hjugement-web/src/Voting/Protocol/Arithmetic.purs

   1 module Voting.Protocol.Arithmetic where
   2
   3 import Control.Monad (bind)
   4 import Data.Argonaut.Core as JSON
   5 import Data.Argonaut.Decode (class DecodeJson, decodeJson)
   6 import Data.Argonaut.Encode (class EncodeJson, encodeJson)
   7 import Data.Argonaut.Parser as JSON
   8 import Data.BigInt (BigInt)
   9 import Data.BigInt as BigInt
  10 import Data.Boolean (otherwise)
  11 import Data.Bounded (class Bounded, top)
  12 import Data.Either (Either(..))
  13 import Data.Eq (class Eq, (==), (/=))
  14 import Data.EuclideanRing (class EuclideanRing, (/), mod)
  15 import Data.Foldable (all)
  16 import Data.Function (($), identity, (<<<))
  17 import Data.Functor ((<$>))
  18 import Data.HeytingAlgebra ((&&))
  19 import Data.List (List, (:))
  20 import Data.List.Lazy as LL
  21 import Data.Maybe (Maybe(..), maybe)
  22 import Data.Monoid (class Monoid, mempty, (<>))
  23 import Data.Newtype (class Newtype, wrap, unwrap)
  24 import Data.Ord (class Ord, (<))
  25 import Data.Reflection (class Reifies, reflect)
  26 import Data.Ring (class Ring, (-), negate)
  27 import Data.Semiring (class Semiring, zero, (+), one, (*))
  28 import Data.Show (class Show, show)
  29 import Data.String.CodeUnits as String
  30 import Type.Proxy (Proxy(..))
  31
  32 -- * Type 'Natural'
  33 newtype Natural = Natural BigInt
  34 instance newtypeNatural :: Newtype Natural BigInt where
  35   wrap = Natural
  36   unwrap (Natural x) = x
  37 derive newtype instance eqNatural            :: Eq Natural
  38 derive newtype instance ordNatural           :: Ord Natural
  39 derive newtype instance showNatural          :: Show Natural
  40 derive newtype instance semiringNatural      :: Semiring Natural
  41 derive newtype instance euclideanRingNatural :: EuclideanRing Natural
  42
  43 -- * Class 'FromNatural'
  44 class FromNatural a where
  45   fromNatural :: Natural -> a
  46
  47 -- * Class 'ToNatural'
  48 class ToNatural a where
  49   nat :: a -> Natural
  50 instance toNaturalBigInt :: ToNatural Natural where
  51   nat = identity
  52
  53
  54 -- * Class 'Additive'
  55 -- | An additive semigroup.
  56 class Additive a where
  57   gzero :: a
  58   gadd  :: a -> a -> a
  59 instance additiveBigInt :: Additive BigInt where
  60   gzero = zero
  61   gadd  = (+)
  62 instance additiveNatural :: Additive Natural where
  63   gzero = zero
  64   gadd  = (+)
  65
  66 -- | `('power' b e)` returns the modular exponentiation of base `b` by exponent `e`.
  67 power :: forall crypto c a. Semiring a => a -> E crypto c -> a
  68 power x = go <<< unwrap
  69   where
  70   two :: Natural
  71   two = one + one
  72   go :: Natural -> a
  73   go p
  74     | p == zero = one
  75     | p == one  = x
  76     | p `mod` two == zero = let x' = go (p / two) in x' * x'
  77     | otherwise           = let x' = go (p / two) in x' * x' * x
  78 infixr 8 power as ^
  79
  80 -- * Class 'CryptoParams' where
  81 class
  82  ( EuclideanRing (G crypto c)
  83  , FromNatural   (G crypto c)
  84  , ToNatural     (G crypto c)
  85  , Eq            (G crypto c)
  86  , Ord           (G crypto c)
  87  , Show          (G crypto c)
  88  , DecodeJson    (G crypto c)
  89  , EncodeJson    (G crypto c)
  90  , Reifies c crypto
  91  ) <= CryptoParams crypto c where
  92   -- | A generator of the subgroup.
  93   groupGen   :: G crypto c
  94   -- | The order of the subgroup.
  95   groupOrder :: Proxy crypto -> Proxy c -> Natural
  96
  97 -- | 'groupGenPowers' returns the infinite list
  98 -- of powers of 'groupGen'.
  99 groupGenPowers :: forall crypto c. CryptoParams crypto c => LL.List (G crypto c)
 100 groupGenPowers = go one
 101   where go g = g LL.: go (g * groupGen)
 102
 103 -- | 'groupGenInverses' returns the infinite list
 104 -- of 'inverse' powers of 'groupGen':
 105 -- @['groupGen' '^' 'negate' i | i <- [0..]]@,
 106 -- but by computing each value from the previous one.
 107 --
 108 -- Used by 'intervalDisjunctions'.
 109 groupGenInverses :: forall crypto c. CryptoParams crypto c => LL.List (G crypto c)
 110 groupGenInverses = go one
 111   where
 112   invGen = inverse groupGen
 113   go g = g LL.: go (g * invGen)
 114
 115 inverse :: forall a. EuclideanRing a => a -> a
 116 inverse a = one / a
 117
 118 -- ** Class 'ReifyCrypto'
 119 class ReifyCrypto crypto where
 120   -- | Like 'reify' but augmented with the 'CryptoParams' constraint.
 121   reifyCrypto :: forall r. crypto -> (forall c. Reifies c crypto => CryptoParams crypto c => Proxy c -> r) -> r
 122
 123 -- ** Type 'G'
 124 -- | The type of the elements of a subgroup of a field.
 125 newtype G crypto c = G Natural
 126
 127 -- ** Type 'E'
 128 -- | An exponent of a (cyclic) subgroup of a field.
 129 -- The value is always in @[0..'groupOrder'-1]@.
 130 newtype E crypto c = E Natural
 131  -- deriving (Eq,Ord,Show)
 132  -- deriving newtype NFData
 133 derive newtype instance eqE   :: Eq   (E crypto c)
 134 derive newtype instance ordE  :: Ord  (E crypto c)
 135 derive newtype instance showE :: Show (E crypto c)
 136 instance newtypeE :: Newtype (E crypto c) Natural where
 137   wrap = E
 138   unwrap (E x) = x
 139 instance additiveE :: CryptoParams crypto c => Additive (E crypto c) where
 140   gzero = zero
 141   gadd  = (+)
 142 instance semiringE :: CryptoParams crypto c => Semiring (E crypto c) where
 143   zero = E zero
 144   add (E x) (E y) = E ((x + y) `mod` groupOrder (Proxy::Proxy crypto) (Proxy::Proxy c))
 145   one = E one
 146   mul (E x) (E y) = E ((x * y) `mod` groupOrder (Proxy::Proxy crypto) (Proxy::Proxy c))
 147 instance ringE :: CryptoParams crypto c => Ring (E crypto c) where
 148   sub (E x) (E y) = E (x + wrap (unwrap (groupOrder (Proxy::Proxy crypto) (Proxy::Proxy c)) - unwrap y))
 149 instance fromNaturalE :: CryptoParams crypto c => FromNatural (E crypto c) where
 150   fromNatural n = E (n `mod` groupOrder (Proxy::Proxy crypto) (Proxy::Proxy c))
 151 instance toNaturalE :: ToNatural (E crypto c) where
 152   nat (E x) = x
 153 instance boundedE :: CryptoParams crypto c => Bounded (E crypto c) where
 154   bottom = E zero
 155   top    = E $ wrap (unwrap (groupOrder (Proxy::Proxy crypto) (Proxy::Proxy c)) - one)
 156 {-
 157 instance enumE :: Reifies c crypto => Enum (E crypto c) where
 158   succ z = let z' = z + one in if z' > z then Just z' else Nothing
 159   pred z = let z' = z - one in if z' < z then Just z' else Nothing
 160 instance boundedEnumE :: Reifies c crypto => BoundedEnum (E crypto c) where
 161   cardinality = Cardinality (toInt (undefined :: m) - 1)
 162   toEnum x = let z = mkE x in if runE z == x then Just z else Nothing
 163   fromEnum = runE
 164 -}
 165 instance encodeJsonE :: EncodeJson (E crypto c) where
 166   encodeJson (E n) = encodeJson (show n)
 167 instance decodeJsonE :: CryptoParams crypto c => DecodeJson (E crypto c) where
 168   decodeJson = JSON.caseJsonString (Left "String") $ \s ->
 169     maybe (Left "Exponent") Right $ do
 170       {head:c0} <- String.uncons s
 171       if c0 /= '0' && all isDigit (String.toCharArray s)
 172       then do
 173         n <- Natural <$> BigInt.fromString s
 174         if n < groupOrder (Proxy::Proxy crypto) (Proxy::Proxy c)
 175         then Just (E n)
 176         else Nothing
 177       else Nothing
 178
 179 isDigit :: Char -> Boolean
 180 isDigit c = case c of
 181  '0' -> true
 182  '1' -> true
 183  '2' -> true
 184  '3' -> true
 185  '4' -> true
 186  '5' -> true
 187  '6' -> true
 188  '7' -> true
 189  '8' -> true
 190  '9' -> true
 191  _ -> false