hjugement-protocol/src/Voting/Protocol/Arithmetic.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE DerivingStrategies #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE Rank2Types #-} -- for ReifyCrypto
   6 module Voting.Protocol.Arithmetic where
   7
   8 import Control.Arrow (first)
   9 import Control.DeepSeq (NFData)
  10 import Control.Monad (Monad(..))
  11 import Data.Aeson (ToJSON(..),FromJSON(..))
  12 import Data.Bits
  13 import Data.Bool
  14 import Data.Eq (Eq(..))
  15 import Data.Foldable (Foldable, foldl')
  16 import Data.Function (($), (.), id)
  17 import Data.Int (Int)
  18 import Data.Maybe (Maybe(..), fromJust)
  19 import Data.Ord (Ord(..))
  20 import Data.Proxy (Proxy(..))
  21 import Data.Reflection (Reifies(..))
  22 import Data.String (IsString(..))
  23 import GHC.Natural (minusNaturalMaybe)
  24 import Numeric.Natural (Natural)
  25 import Prelude (Integer, Bounded(..), Integral(..), fromIntegral)
  26 import Text.Read (readMaybe)
  27 import Text.Show (Show(..))
  28 import qualified Data.Aeson as JSON
  29 import qualified Data.Aeson.Types as JSON
  30 import qualified Data.ByteString as BS
  31 import qualified Data.Char as Char
  32 import qualified Data.Text as Text
  33 import qualified Prelude as Num
  34 import qualified System.Random as Random
  35
  36 -- * Class 'CryptoParams' where
  37 class
  38  ( EuclideanRing (G crypto c)
  39  , FromNatural   (G crypto c)
  40  , ToNatural     (G crypto c)
  41  , Eq            (G crypto c)
  42  , Ord           (G crypto c)
  43  , Show          (G crypto c)
  44  , NFData        (G crypto c)
  45  , FromJSON      (G crypto c)
  46  , ToJSON        (G crypto c)
  47  , Reifies c crypto
  48  ) => CryptoParams crypto c where
  49         -- | A generator of the subgroup.
  50         groupGen   :: G crypto c
  51         -- | The order of the subgroup.
  52         groupOrder :: Proxy c -> Natural
  53
  54         -- | 'groupGenPowers' returns the infinite list
  55         -- of powers of 'groupGen'.
  56         --
  57         -- NOTE: In the 'CryptoParams' class to keep
  58         -- computed values in memory across calls to 'groupGenPowers'.
  59         groupGenPowers :: [G crypto c]
  60         groupGenPowers = go one
  61                 where go g = g : go (g * groupGen)
  62
  63         -- | 'groupGenInverses' returns the infinite list
  64         -- of 'inverse' powers of 'groupGen':
  65         -- @['groupGen' '^' 'negate' i | i <- [0..]]@,
  66         -- but by computing each value from the previous one.
  67         --
  68         -- NOTE: In the 'CryptoParams' class to keep
  69         -- computed values in memory across calls to 'groupGenInverses'.
  70         --
  71         -- Used by 'intervalDisjunctions'.
  72         groupGenInverses :: [G crypto c]
  73         groupGenInverses = go one
  74                 where
  75                 invGen = inverse groupGen
  76                 go g = g : go (g * invGen)
  77
  78 -- ** Class 'ReifyCrypto'
  79 class ReifyCrypto crypto where
  80         -- | Like 'reify' but augmented with the 'CryptoParams' constraint.
  81         reifyCrypto :: crypto -> (forall c. Reifies c crypto => CryptoParams crypto c => Proxy c -> r) -> r
  82
  83 -- * Class 'Additive'
  84 -- | An additive semigroup.
  85 class Additive a where
  86         zero :: a
  87         (+) :: a -> a -> a; infixl 6 +
  88         sum :: Foldable f => f a -> a
  89         sum = foldl' (+) zero
  90 instance Additive Natural where
  91         zero = 0
  92         (+)  = (Num.+)
  93 instance Additive Integer where
  94         zero = 0
  95         (+)  = (Num.+)
  96 instance Additive Int where
  97         zero = 0
  98         (+)  = (Num.+)
  99
 100 -- * Class 'Semiring'
 101 -- | A multiplicative semigroup, with an additive semigroup (aka. a semiring).
 102 class Additive a => Semiring a where
 103         one :: a
 104         (*) :: a -> a -> a; infixl 7 *
 105 instance Semiring Natural where
 106         one = 1
 107         (*) = (Num.*)
 108 instance Semiring Integer where
 109         one = 1
 110         (*) = (Num.*)
 111 instance Semiring Int where
 112         one = 1
 113         (*) = (Num.*)
 114
 115 -- | @(b '^' e)@ returns the modular exponentiation of base 'b' by exponent 'e'.
 116 (^) ::
 117  forall crypto c.
 118  Reifies c crypto =>
 119  Semiring (G crypto c) =>
 120  G crypto c -> E crypto c -> G crypto c
 121 (^) b (E e)
 122  | e == 0 = one
 123  | otherwise = t * (b*b) ^ E (e`shiftR`1)
 124         where t | testBit e 0 = b
 125                 | otherwise   = one
 126 infixr 8 ^
 127
 128 -- ** Class 'Ring'
 129 -- | A semiring that support substraction (aka. a ring).
 130 class Semiring a => Ring a where
 131         negate :: a -> a
 132         (-) :: a -> a -> a; infixl 6 -
 133         x-y = x + negate y
 134 instance Ring Integer where
 135         negate  = Num.negate
 136 instance Ring Int where
 137         negate  = Num.negate
 138
 139 -- ** Class 'EuclideanRing'
 140 -- | A commutative ring that support division (aka. an euclidean ring).
 141 class Ring a => EuclideanRing a where
 142         inverse :: a -> a
 143         (/) :: a -> a -> a; infixl 7 /
 144         x/y = x * inverse y
 145
 146 -- ** Type 'G'
 147 -- | The type of the elements of a subgroup of a field.
 148 newtype G crypto c = G { unG :: FieldElement crypto }
 149
 150 -- *** Type family 'FieldElement'
 151 type family FieldElement crypto :: *
 152
 153 -- ** Type 'E'
 154 -- | An exponent of a (cyclic) subgroup of a field.
 155 -- The value is always in @[0..'groupOrder'-1]@.
 156 newtype E crypto c = E { unE :: Natural }
 157  deriving (Eq,Ord,Show)
 158  deriving newtype NFData
 159 instance ToJSON (E crypto c) where
 160         toJSON = JSON.toJSON . show . unE
 161 instance CryptoParams crypto c => FromJSON (E crypto c) where
 162         parseJSON (JSON.String s)
 163          | Just (c0,_) <- Text.uncons s
 164          , c0 /= '0'
 165          , Text.all Char.isDigit s
 166          , Just x <- readMaybe (Text.unpack s)
 167          , x < groupOrder (Proxy @c)
 168          = return (E x)
 169         parseJSON json = JSON.typeMismatch "Exponent" json
 170 instance CryptoParams crypto c => FromNatural (E crypto c) where
 171         fromNatural n = E $ n `mod` groupOrder (Proxy @c)
 172 instance ToNatural (E crypto c) where
 173         nat = unE
 174 instance CryptoParams crypto c => Additive (E crypto c) where
 175         zero = E zero
 176         E x + E y = E $ (x + y) `mod` groupOrder (Proxy @c)
 177 instance CryptoParams crypto c => Semiring (E crypto c) where
 178         one = E one
 179         E x * E y = E $ (x * y) `mod` groupOrder (Proxy @c)
 180 instance CryptoParams crypto c => Ring (E crypto c) where
 181         negate (E x) = E $ fromJust $ groupOrder (Proxy @c)`minusNaturalMaybe`x
 182 instance CryptoParams crypto c => Random.Random (E crypto c) where
 183         randomR (E lo, E hi) =
 184                 first (E . fromIntegral) .
 185                 Random.randomR
 186                  ( 0`max`toInteger lo
 187                  , toInteger hi`min`(toInteger (groupOrder (Proxy @c)) - 1) )
 188         random =
 189                 first (E . fromIntegral) .
 190                 Random.randomR (0, toInteger (groupOrder (Proxy @c)) - 1)
 191 instance CryptoParams crypto c => Bounded (E crypto c) where
 192         minBound = zero
 193         maxBound = E $ fromJust $ groupOrder (Proxy @c)`minusNaturalMaybe`1
 194 {-
 195 instance CryptoParams crypto c => Enum (E crypto c) where
 196         toEnum = fromNatural . fromIntegral
 197         fromEnum = fromIntegral . nat
 198         enumFromTo lo hi = List.unfoldr
 199          (\i -> if i<=hi then Just (i, i+one) else Nothing) lo
 200 -}
 201
 202 -- * Class 'FromNatural'
 203 class FromNatural a where
 204         fromNatural :: Natural -> a
 205 instance FromNatural Natural where
 206         fromNatural = id
 207
 208 -- * Class 'ToNatural'
 209 class ToNatural a where
 210         nat :: a -> Natural
 211 instance ToNatural Natural where
 212         nat = id
 213
 214 -- | @('bytesNat' x)@ returns the serialization of 'x'.
 215 bytesNat :: ToNatural n => n -> BS.ByteString
 216 bytesNat = fromString . show . nat