]> Git — Sourcephile - majurity.git/blob - hjugement-web/src/Voting/Protocol/Arithmetic.purs
83209e6155cb0a09d6aaa48deb820b8db9dc0776
[majurity.git] / 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