{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-} -- for ReifyCrypto
module Voting.Protocol.Arithmetic where

import Control.Arrow (first)
import Control.DeepSeq (NFData)
import Control.Monad (Monad(..))
import Data.Aeson (ToJSON(..),FromJSON(..))
import Data.Bits
import Data.Bool
import Data.Eq (Eq(..))
import Data.Foldable (Foldable, foldl')
import Data.Function (($), (.), id)
import Data.Int (Int)
import Data.Maybe (Maybe(..), fromJust)
import Data.Ord (Ord(..))
import Data.Proxy (Proxy(..))
import Data.Reflection (Reifies(..))
import Data.String (IsString(..))
import GHC.Natural (minusNaturalMaybe)
import Numeric.Natural (Natural)
import Prelude (Integer, Bounded(..), Integral(..), fromIntegral)
import Text.Read (readMaybe)
import Text.Show (Show(..))
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON
import qualified Data.ByteString as BS
import qualified Data.Char as Char
import qualified Data.Text as Text
import qualified Prelude as Num
import qualified System.Random as Random

-- * Class 'CryptoParams' where
class
 ( EuclideanRing (G crypto c)
 , FromNatural   (G crypto c)
 , ToNatural     (G crypto c)
 , Eq            (G crypto c)
 , Ord           (G crypto c)
 , Show          (G crypto c)
 , NFData        (G crypto c)
 , FromJSON      (G crypto c)
 , ToJSON        (G crypto c)
 , Reifies c crypto
 ) => CryptoParams crypto c where
	-- | A generator of the subgroup.
	groupGen   :: G crypto c
	-- | The order of the subgroup.
	groupOrder :: Proxy c -> Natural
	
	-- | 'groupGenPowers' returns the infinite list
	-- of powers of 'groupGen'.
	--
	-- NOTE: In the 'CryptoParams' class to keep
	-- computed values in memory across calls to 'groupGenPowers'.
	groupGenPowers :: [G crypto c]
	groupGenPowers = G crypto c -> [G crypto c]
forall crypto c.
CryptoParams crypto c =>
G crypto c -> [G crypto c]
go G crypto c
forall a. Semiring a => a
one
		where go :: G crypto c -> [G crypto c]
go G crypto c
g = G crypto c
g G crypto c -> [G crypto c] -> [G crypto c]
forall a. a -> [a] -> [a]
: G crypto c -> [G crypto c]
go (G crypto c
g G crypto c -> G crypto c -> G crypto c
forall a. Semiring a => a -> a -> a
* G crypto c
forall crypto c. CryptoParams crypto c => G crypto c
groupGen)
	
	-- | 'groupGenInverses' returns the infinite list
	-- of 'inverse' powers of 'groupGen':
	-- @['groupGen' '^' 'negate' i | i <- [0..]]@,
	-- but by computing each value from the previous one.
	--
	-- NOTE: In the 'CryptoParams' class to keep
	-- computed values in memory across calls to 'groupGenInverses'.
	--
	-- Used by 'intervalDisjunctions'.
	groupGenInverses :: [G crypto c]
	groupGenInverses = G crypto c -> [G crypto c]
forall crypto c.
CryptoParams crypto c =>
G crypto c -> [G crypto c]
go G crypto c
forall a. Semiring a => a
one
		where
		invGen :: G crypto c
invGen = G crypto c -> G crypto c
forall a. EuclideanRing a => a -> a
inverse G crypto c
forall crypto c. CryptoParams crypto c => G crypto c
groupGen
		go :: G crypto c -> [G crypto c]
go G crypto c
g = G crypto c
g G crypto c -> [G crypto c] -> [G crypto c]
forall a. a -> [a] -> [a]
: G crypto c -> [G crypto c]
go (G crypto c
g G crypto c -> G crypto c -> G crypto c
forall a. Semiring a => a -> a -> a
* G crypto c
forall crypto c. CryptoParams crypto c => G crypto c
invGen)

-- ** Class 'ReifyCrypto'
class ReifyCrypto crypto where
	-- | Like 'reify' but augmented with the 'CryptoParams' constraint.
	reifyCrypto :: crypto -> (forall c. Reifies c crypto => CryptoParams crypto c => Proxy c -> r) -> r

-- * Class 'Additive'
-- | An additive semigroup.
class Additive a where
	zero :: a
	(+) :: a -> a -> a; infixl 6 +
	sum :: Foldable f => f a -> a
	sum = (a -> a -> a) -> a -> f a -> a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' a -> a -> a
forall a. Additive a => a -> a -> a
(+) a
forall a. Additive a => a
zero
instance Additive Natural where
	zero :: Natural
zero = Natural
0
	+ :: Natural -> Natural -> Natural
(+)  = Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
(Num.+)
instance Additive Integer where
	zero :: Integer
zero = Integer
0
	+ :: Integer -> Integer -> Integer
(+)  = Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(Num.+)
instance Additive Int where
	zero :: Int
zero = Int
0
	+ :: Int -> Int -> Int
(+)  = Int -> Int -> Int
forall a. Num a => a -> a -> a
(Num.+)

-- * Class 'Semiring'
-- | A multiplicative semigroup, with an additive semigroup (aka. a semiring).
class Additive a => Semiring a where
	one :: a
	(*) :: a -> a -> a; infixl 7 *
instance Semiring Natural where
	one :: Natural
one = Natural
1
	* :: Natural -> Natural -> Natural
(*) = Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
(Num.*)
instance Semiring Integer where
	one :: Integer
one = Integer
1
	* :: Integer -> Integer -> Integer
(*) = Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
(Num.*)
instance Semiring Int where
	one :: Int
one = Int
1
	* :: Int -> Int -> Int
(*) = Int -> Int -> Int
forall a. Num a => a -> a -> a
(Num.*)

-- | @(b '^' e)@ returns the modular exponentiation of base 'b' by exponent 'e'.
(^) ::
 forall crypto c.
 Reifies c crypto =>
 Semiring (G crypto c) =>
 G crypto c -> E crypto c -> G crypto c
^ :: G crypto c -> E crypto c -> G crypto c
(^) G crypto c
b (E Natural
e)
 | Natural
e Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
0 = G crypto c
forall a. Semiring a => a
one
 | Bool
otherwise = G crypto c
t G crypto c -> G crypto c -> G crypto c
forall a. Semiring a => a -> a -> a
* (G crypto c
bG crypto c -> G crypto c -> G crypto c
forall a. Semiring a => a -> a -> a
*G crypto c
b) G crypto c -> E crypto c -> G crypto c
forall crypto c.
(Reifies c crypto, Semiring (G crypto c)) =>
G crypto c -> E crypto c -> G crypto c
^ Natural -> E crypto c
forall crypto c. Natural -> E crypto c
E (Natural
eNatural -> Int -> Natural
forall a. Bits a => a -> Int -> a
`shiftR`Int
1)
	where t :: G crypto c
t | Natural -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Natural
e Int
0 = G crypto c
b
	        | Bool
otherwise   = G crypto c
forall a. Semiring a => a
one
infixr 8 ^

-- ** Class 'Ring'
-- | A semiring that support substraction (aka. a ring).
class Semiring a => Ring a where
	negate :: a -> a
	(-) :: a -> a -> a; infixl 6 -
	a
x-a
y = a
x a -> a -> a
forall a. Additive a => a -> a -> a
+ a -> a
forall a. Ring a => a -> a
negate a
y
instance Ring Integer where
	negate :: Integer -> Integer
negate  = Integer -> Integer
forall a. Num a => a -> a
Num.negate
instance Ring Int where
	negate :: Int -> Int
negate  = Int -> Int
forall a. Num a => a -> a
Num.negate

-- ** Class 'EuclideanRing'
-- | A commutative ring that support division (aka. an euclidean ring).
class Ring a => EuclideanRing a where
	inverse :: a -> a
	(/) :: a -> a -> a; infixl 7 /
	a
x/a
y = a
x a -> a -> a
forall a. Semiring a => a -> a -> a
* a -> a
forall a. EuclideanRing a => a -> a
inverse a
y

-- ** Type 'G'
-- | The type of the elements of a subgroup of a field.
newtype G crypto c = G { G crypto c -> FieldElement crypto
unG :: FieldElement crypto }

-- *** Type family 'FieldElement'
type family FieldElement crypto :: *

-- ** Type 'E'
-- | An exponent of a (cyclic) subgroup of a field.
-- The value is always in @[0..'groupOrder'-1]@.
newtype E crypto c = E { E crypto c -> Natural
unE :: Natural }
 deriving (E crypto c -> E crypto c -> Bool
(E crypto c -> E crypto c -> Bool)
-> (E crypto c -> E crypto c -> Bool) -> Eq (E crypto c)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall crypto c. E crypto c -> E crypto c -> Bool
/= :: E crypto c -> E crypto c -> Bool
$c/= :: forall crypto c. E crypto c -> E crypto c -> Bool
== :: E crypto c -> E crypto c -> Bool
$c== :: forall crypto c. E crypto c -> E crypto c -> Bool
Eq,Eq (E crypto c)
Eq (E crypto c)
-> (E crypto c -> E crypto c -> Ordering)
-> (E crypto c -> E crypto c -> Bool)
-> (E crypto c -> E crypto c -> Bool)
-> (E crypto c -> E crypto c -> Bool)
-> (E crypto c -> E crypto c -> Bool)
-> (E crypto c -> E crypto c -> E crypto c)
-> (E crypto c -> E crypto c -> E crypto c)
-> Ord (E crypto c)
E crypto c -> E crypto c -> Bool
E crypto c -> E crypto c -> Ordering
E crypto c -> E crypto c -> E crypto c
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall crypto c. Eq (E crypto c)
forall crypto c. E crypto c -> E crypto c -> Bool
forall crypto c. E crypto c -> E crypto c -> Ordering
forall crypto c. E crypto c -> E crypto c -> E crypto c
min :: E crypto c -> E crypto c -> E crypto c
$cmin :: forall crypto c. E crypto c -> E crypto c -> E crypto c
max :: E crypto c -> E crypto c -> E crypto c
$cmax :: forall crypto c. E crypto c -> E crypto c -> E crypto c
>= :: E crypto c -> E crypto c -> Bool
$c>= :: forall crypto c. E crypto c -> E crypto c -> Bool
> :: E crypto c -> E crypto c -> Bool
$c> :: forall crypto c. E crypto c -> E crypto c -> Bool
<= :: E crypto c -> E crypto c -> Bool
$c<= :: forall crypto c. E crypto c -> E crypto c -> Bool
< :: E crypto c -> E crypto c -> Bool
$c< :: forall crypto c. E crypto c -> E crypto c -> Bool
compare :: E crypto c -> E crypto c -> Ordering
$ccompare :: forall crypto c. E crypto c -> E crypto c -> Ordering
$cp1Ord :: forall crypto c. Eq (E crypto c)
Ord,Int -> E crypto c -> ShowS
[E crypto c] -> ShowS
E crypto c -> String
(Int -> E crypto c -> ShowS)
-> (E crypto c -> String)
-> ([E crypto c] -> ShowS)
-> Show (E crypto c)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall crypto c. Int -> E crypto c -> ShowS
forall crypto c. [E crypto c] -> ShowS
forall crypto c. E crypto c -> String
showList :: [E crypto c] -> ShowS
$cshowList :: forall crypto c. [E crypto c] -> ShowS
show :: E crypto c -> String
$cshow :: forall crypto c. E crypto c -> String
showsPrec :: Int -> E crypto c -> ShowS
$cshowsPrec :: forall crypto c. Int -> E crypto c -> ShowS
Show)
 deriving newtype E crypto c -> ()
(E crypto c -> ()) -> NFData (E crypto c)
forall a. (a -> ()) -> NFData a
forall crypto c. E crypto c -> ()
rnf :: E crypto c -> ()
$crnf :: forall crypto c. E crypto c -> ()
NFData
instance ToJSON (E crypto c) where
	toJSON :: E crypto c -> Value
toJSON = String -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON (String -> Value) -> (E crypto c -> String) -> E crypto c -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> String
forall a. Show a => a -> String
show (Natural -> String)
-> (E crypto c -> Natural) -> E crypto c -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. E crypto c -> Natural
forall crypto c. E crypto c -> Natural
unE
instance CryptoParams crypto c => FromJSON (E crypto c) where
	parseJSON :: Value -> Parser (E crypto c)
parseJSON (JSON.String Text
s)
	 | Just (Char
c0,Text
_) <- Text -> Maybe (Char, Text)
Text.uncons Text
s
	 , Char
c0 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'0'
	 , (Char -> Bool) -> Text -> Bool
Text.all Char -> Bool
Char.isDigit Text
s
	 , Just Natural
x <- String -> Maybe Natural
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
s)
	 , Natural
x Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
< Proxy c -> Natural
forall crypto c. CryptoParams crypto c => Proxy c -> Natural
groupOrder (Proxy c
forall k (t :: k). Proxy t
Proxy @c)
	 = E crypto c -> Parser (E crypto c)
forall (m :: * -> *) a. Monad m => a -> m a
return (Natural -> E crypto c
forall crypto c. Natural -> E crypto c
E Natural
x)
	parseJSON Value
json = String -> Value -> Parser (E crypto c)
forall a. String -> Value -> Parser a
JSON.typeMismatch String
"Exponent" Value
json
instance CryptoParams crypto c => FromNatural (E crypto c) where
	fromNatural :: Natural -> E crypto c
fromNatural Natural
n = Natural -> E crypto c
forall crypto c. Natural -> E crypto c
E (Natural -> E crypto c) -> Natural -> E crypto c
forall a b. (a -> b) -> a -> b
$ Natural
n Natural -> Natural -> Natural
forall a. Integral a => a -> a -> a
`mod` Proxy c -> Natural
forall crypto c. CryptoParams crypto c => Proxy c -> Natural
groupOrder (Proxy c
forall k (t :: k). Proxy t
Proxy @c)
instance ToNatural (E crypto c) where
	nat :: E crypto c -> Natural
nat = E crypto c -> Natural
forall crypto c. E crypto c -> Natural
unE
instance CryptoParams crypto c => Additive (E crypto c) where
	zero :: E crypto c
zero = Natural -> E crypto c
forall crypto c. Natural -> E crypto c
E Natural
forall a. Additive a => a
zero
	E Natural
x + :: E crypto c -> E crypto c -> E crypto c
+ E Natural
y = Natural -> E crypto c
forall crypto c. Natural -> E crypto c
E (Natural -> E crypto c) -> Natural -> E crypto c
forall a b. (a -> b) -> a -> b
$ (Natural
x Natural -> Natural -> Natural
forall a. Additive a => a -> a -> a
+ Natural
y) Natural -> Natural -> Natural
forall a. Integral a => a -> a -> a
`mod` Proxy c -> Natural
forall crypto c. CryptoParams crypto c => Proxy c -> Natural
groupOrder (Proxy c
forall k (t :: k). Proxy t
Proxy @c)
instance CryptoParams crypto c => Semiring (E crypto c) where
	one :: E crypto c
one = Natural -> E crypto c
forall crypto c. Natural -> E crypto c
E Natural
forall a. Semiring a => a
one
	E Natural
x * :: E crypto c -> E crypto c -> E crypto c
* E Natural
y = Natural -> E crypto c
forall crypto c. Natural -> E crypto c
E (Natural -> E crypto c) -> Natural -> E crypto c
forall a b. (a -> b) -> a -> b
$ (Natural
x Natural -> Natural -> Natural
forall a. Semiring a => a -> a -> a
* Natural
y) Natural -> Natural -> Natural
forall a. Integral a => a -> a -> a
`mod` Proxy c -> Natural
forall crypto c. CryptoParams crypto c => Proxy c -> Natural
groupOrder (Proxy c
forall k (t :: k). Proxy t
Proxy @c)
instance CryptoParams crypto c => Ring (E crypto c) where
	negate :: E crypto c -> E crypto c
negate (E Natural
x) = Natural -> E crypto c
forall crypto c. Natural -> E crypto c
E (Natural -> E crypto c) -> Natural -> E crypto c
forall a b. (a -> b) -> a -> b
$ Maybe Natural -> Natural
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Natural -> Natural) -> Maybe Natural -> Natural
forall a b. (a -> b) -> a -> b
$ Proxy c -> Natural
forall crypto c. CryptoParams crypto c => Proxy c -> Natural
groupOrder (Proxy c
forall k (t :: k). Proxy t
Proxy @c)Natural -> Natural -> Maybe Natural
`minusNaturalMaybe`Natural
x
instance CryptoParams crypto c => Random.Random (E crypto c) where
	randomR :: (E crypto c, E crypto c) -> g -> (E crypto c, g)
randomR (E Natural
lo, E Natural
hi) =
		(Integer -> E crypto c) -> (Integer, g) -> (E crypto c, g)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Natural -> E crypto c
forall crypto c. Natural -> E crypto c
E (Natural -> E crypto c)
-> (Integer -> Natural) -> Integer -> E crypto c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ((Integer, g) -> (E crypto c, g))
-> (g -> (Integer, g)) -> g -> (E crypto c, g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
		(Integer, Integer) -> g -> (Integer, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
Random.randomR
		 ( Integer
0Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
`max`Natural -> Integer
forall a. Integral a => a -> Integer
toInteger Natural
lo
		 , Natural -> Integer
forall a. Integral a => a -> Integer
toInteger Natural
hiInteger -> Integer -> Integer
forall a. Ord a => a -> a -> a
`min`(Natural -> Integer
forall a. Integral a => a -> Integer
toInteger (Proxy c -> Natural
forall crypto c. CryptoParams crypto c => Proxy c -> Natural
groupOrder (Proxy c
forall k (t :: k). Proxy t
Proxy @c)) Integer -> Integer -> Integer
forall a. Ring a => a -> a -> a
- Integer
1) )
	random :: g -> (E crypto c, g)
random =
		(Integer -> E crypto c) -> (Integer, g) -> (E crypto c, g)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Natural -> E crypto c
forall crypto c. Natural -> E crypto c
E (Natural -> E crypto c)
-> (Integer -> Natural) -> Integer -> E crypto c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ((Integer, g) -> (E crypto c, g))
-> (g -> (Integer, g)) -> g -> (E crypto c, g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
		(Integer, Integer) -> g -> (Integer, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
Random.randomR (Integer
0, Natural -> Integer
forall a. Integral a => a -> Integer
toInteger (Proxy c -> Natural
forall crypto c. CryptoParams crypto c => Proxy c -> Natural
groupOrder (Proxy c
forall k (t :: k). Proxy t
Proxy @c)) Integer -> Integer -> Integer
forall a. Ring a => a -> a -> a
- Integer
1)
instance CryptoParams crypto c => Bounded (E crypto c) where
	minBound :: E crypto c
minBound = E crypto c
forall a. Additive a => a
zero
	maxBound :: E crypto c
maxBound = Natural -> E crypto c
forall crypto c. Natural -> E crypto c
E (Natural -> E crypto c) -> Natural -> E crypto c
forall a b. (a -> b) -> a -> b
$ Maybe Natural -> Natural
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Natural -> Natural) -> Maybe Natural -> Natural
forall a b. (a -> b) -> a -> b
$ Proxy c -> Natural
forall crypto c. CryptoParams crypto c => Proxy c -> Natural
groupOrder (Proxy c
forall k (t :: k). Proxy t
Proxy @c)Natural -> Natural -> Maybe Natural
`minusNaturalMaybe`Natural
1
{-
instance CryptoParams crypto c => Enum (E crypto c) where
	toEnum = fromNatural . fromIntegral
	fromEnum = fromIntegral . nat
	enumFromTo lo hi = List.unfoldr
	 (\i -> if i<=hi then Just (i, i+one) else Nothing) lo
-}

-- * Class 'FromNatural'
class FromNatural a where
	fromNatural :: Natural -> a
instance FromNatural Natural where
	fromNatural :: Natural -> Natural
fromNatural = Natural -> Natural
forall a. a -> a
id

-- * Class 'ToNatural'
class ToNatural a where
	nat :: a -> Natural
instance ToNatural Natural where
	nat :: Natural -> Natural
nat = Natural -> Natural
forall a. a -> a
id

-- | @('bytesNat' x)@ returns the serialization of 'x'.
bytesNat :: ToNatural n => n -> BS.ByteString
bytesNat :: n -> ByteString
bytesNat = String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> (n -> String) -> n -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> String
forall a. Show a => a -> String
show (Natural -> String) -> (n -> Natural) -> n -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> Natural
forall a. ToNatural a => a -> Natural
nat