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.Maybe (Maybe(..), maybe)
  21 import Data.Monoid (class Monoid, mempty, (<>))
  22 import Data.Newtype (class Newtype, wrap, unwrap)
  23 import Data.Ord (class Ord, (<))
  24 import Data.Reflection (class Reifies, reflect)
  25 import Data.Ring (class Ring, (-), negate)
  26 import Data.Semiring (class Semiring, zero, (+), one, (*))
  27 import Data.Show (class Show, show)
  28 import Data.String.CodeUnits as String
  29 import Type.Proxy (Proxy(..))
  30
  31 -- * Type 'Natural'
  32 newtype Natural = Natural BigInt
  33 instance newtypeNatural :: Newtype Natural BigInt where
  34   wrap = Natural
  35   unwrap (Natural x) = x
  36 derive newtype instance eqNatural            :: Eq Natural
  37 derive newtype instance ordNatural           :: Ord Natural
  38 derive newtype instance showNatural          :: Show Natural
  39 derive newtype instance semiringNatural      :: Semiring Natural
  40 derive newtype instance euclideanRingNatural :: EuclideanRing Natural
  41
  42 -- * Class 'FromNatural'
  43 class FromNatural a where
  44   fromNatural :: Natural -> a
  45
  46 -- * Class 'ToNatural'
  47 class ToNatural a where
  48   nat :: a -> Natural
  49 instance toNaturalBigInt :: ToNatural Natural where
  50   nat = identity
  51
  52
  53 -- * Class 'Additive'
  54 -- | An additive semigroup.
  55 class Additive a where
  56   gzero :: a
  57   gadd  :: a -> a -> a
  58 instance additiveBigInt :: Additive BigInt where
  59   gzero = zero
  60   gadd  = (+)
  61 instance additiveNatural :: Additive Natural where
  62   gzero = zero
  63   gadd  = (+)
  64
  65 -- | `('power' b e)` returns the modular exponentiation of base `b` by exponent `e`.
  66 power :: forall m. Monoid m => m -> Natural -> m
  67 power x = go
  68   where
  69   two :: Natural
  70   two = one + one
  71   go :: Natural -> m
  72   go p
  73     | p == zero = mempty
  74     | p == one  = x
  75     | p `mod` two == zero = let x' = go (p / two) in x' <> x'
  76     | otherwise           = let x' = go (p / two) in x' <> x' <> x
  77 infixr 8 power as ^
  78
  79 -- * Class 'CryptoParams' where
  80 class
  81  ( EuclideanRing (G crypto c)
  82  , FromNatural    (G crypto c)
  83  , ToNatural      (G crypto c)
  84  , Eq             (G crypto c)
  85  , Ord            (G crypto c)
  86  , Show           (G crypto c)
  87  -- , NFData         (G crypto c)
  88  -- , FromJSON       (G crypto c)
  89  -- , ToJSON         (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 => List (G crypto c)
 100 groupGenPowers = go one
 101   where go g = g : 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 => List (G crypto c)
 110 groupGenInverses = go one
 111   where
 112   invGen = inverse groupGen
 113   go g = g : 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 additiveE :: CryptoParams crypto c => Additive (E crypto c) where
 137   gzero = zero
 138   gadd  = (+)
 139 instance semiringE :: CryptoParams crypto c => Semiring (E crypto c) where
 140   zero = E zero
 141   add (E x) (E y) = E ((x + y) `mod` groupOrder (Proxy::Proxy crypto) (Proxy::Proxy c))
 142   one = E one
 143   mul (E x) (E y) = E ((x * y) `mod` groupOrder (Proxy::Proxy crypto) (Proxy::Proxy c))
 144 instance ringE :: CryptoParams crypto c => Ring (E crypto c) where
 145   sub (E x) (E y) = E (x + wrap (unwrap (groupOrder (Proxy::Proxy crypto) (Proxy::Proxy c)) - unwrap y))
 146 instance fromNaturalE :: CryptoParams crypto c => FromNatural (E crypto c) where
 147   fromNatural n = E (n `mod` groupOrder (Proxy::Proxy crypto) (Proxy::Proxy c))
 148 instance toNaturalE :: ToNatural (E crypto c) where
 149   nat (E x) = x
 150 instance boundedE :: CryptoParams crypto c => Bounded (E crypto c) where
 151   bottom = E zero
 152   top    = E $ wrap (unwrap (groupOrder (Proxy::Proxy crypto) (Proxy::Proxy c)) - one)
 153 {-
 154 instance enumE :: Reifies c crypto => Enum (E crypto c) where
 155   succ z = let z' = z + one in if z' > z then Just z' else Nothing
 156   pred z = let z' = z - one in if z' < z then Just z' else Nothing
 157 instance boundedEnumE :: Reifies c crypto => BoundedEnum (E crypto c) where
 158   cardinality = Cardinality (toInt (undefined :: m) - 1)
 159   toEnum x = let z = mkE x in if runE z == x then Just z else Nothing
 160   fromEnum = runE
 161 -}
 162 instance encodeJsonE :: EncodeJson (E crypto c) where
 163   encodeJson (E n) = encodeJson (show n)
 164 instance decodeJsonE :: CryptoParams crypto c => DecodeJson (E crypto c) where
 165   decodeJson = JSON.caseJsonString (Left "String") $ \s ->
 166     maybe (Left "Exponent") Right $ do
 167       {head:c0} <- String.uncons s
 168       if c0 /= '0' && all isDigit (String.toCharArray s)
 169       then do
 170         n <- Natural <$> BigInt.fromString s
 171         if n < groupOrder (Proxy::Proxy crypto) (Proxy::Proxy c)
 172         then Just (E n)
 173         else Nothing
 174       else Nothing
 175
 176 isDigit :: Char -> Boolean
 177 isDigit c = case c of
 178  '0' -> true
 179  '1' -> true
 180  '2' -> true
 181  '3' -> true
 182  '4' -> true
 183  '5' -> true
 184  '6' -> true
 185  '7' -> true
 186  '8' -> true
 187  '9' -> true
 188  _ -> false