-- PVP: +-+------- breaking API changes
-- | | +----- non-breaking API additions
-- | | | +--- code changes with no API change
-version: 0.0.0.20190501
+version: 0.0.0.20190511
category: Politic
synopsis: A cryptographic protocol for the Majority Judgment.
description:
and that the tallying authorities did their job properly (/universal verifiability/).
.
* /private/: the identities of the voters who cast a vote are not publicly revealed.
- .
- More specifically, in this protocol :
- .
- * Ballots are encrypted using public-key cryptography
- secured by the /Discrete Logarithm problem/:
- finding @x@ in @g^x `mod` p@, where @p@ is a large prime
- and @g@ a generator of @Gq@, the multiplicative subgroup of order @q@,
- in @Fp@ (the finite prime field whose characteristic is @p@).
- Here, @p@ is 2048-bit and @q@ is 256-bit.
- The signing (Schnorr-like), the encrypting (ElGamal-like)
- and the /Decisional Diffe Hellman/ (DDH) assumption,
- all rely on the hardness of that problem.
- * Ballots are added without being decrypted
- because adding (multiplying actually) ciphertexts then decrypting,
- is like decrypting then adding plaintexts (/additive homomorphism/).
- Which requires to solve the /Discrete Logarithm Problem/
- for numbers in the order of the number of voters,
- which is not hard for small numbers (with a lookup table as here,
- or with Pollard’s rho algorithm for logarithms).
- * The /Schnorr protocol/ is used to prove that a voter has knowledge
- of the secret key used to sign their votes.
- A voter's credentials is a secret key (the signing key)
- that has a public part (the verification key).
- The association between the public part and the corresponding voter’s identity
- does not need to be known, and actually should not be disclosed to satisfy
- e.g. the French requirements regarding voting systems.
- Using credentials prevent the submission of duplicated ballots
- (because they are added as an additional input to the random oracle
- in the /non-interactive zero-knowledge/ (NIZK) proofs for ciphertext well-formedness).
- This allows a testing of duplicates which depends only on the size of the number of voters,
- and thus enables Helios-C to scale for larger elections while attaining correctness.
- * The /Chaum-Pedersen protocol/ (proving that equality of discrete logarithms)
- is used to prove that ciphertexts are well-formed
- (encrypting a 0 or a 1… or any expected natural) without decrypting them.
- Which is known as a /Disjunctive Chaum-Pedersen/ proof of partial knowledge.
- * A /strong Fiat-Shamir transformation/ is used
- to transform the /interactive zero-knowledge/ (IZK) /Chaum-Pedersen protocol/
- into a /non-interactive zero-knowledge/ (NIZK) proof, using a SHA256 hash.
- * (TODO) A Pedersen's /distributed key generation/ (DKG) protocol
- coupled with ElGamal keys (under the DDH assumption),
- is used to have a fully distributed semantically secure encryption.
-extra-doc-files:
+extra-doc-files: README.md
license: GPL-3
license-file: COPYING
stability: experimental
type: git
Library
+ hs-source-dirs: src
exposed-modules:
- Protocol.Arithmetic
- Protocol.Credential
- Protocol.Election
- Protocol.Utils
+ Voting.Protocol
+ Voting.Protocol.Arithmetic
+ Voting.Protocol.Credential
+ Voting.Protocol.Election
+ Voting.Protocol.Utils
default-language: Haskell2010
default-extensions:
AllowAmbiguousTypes
, memory >= 0.14
-- , mmorph >= 1.1
-- , monad-classes >= 0.3
+ , deepseq >= 1.4
, random >= 1.1
-- , reflection >= 2.1
, text >= 1.2
Test-Suite hjugement-protocol-test
type: exitcode-stdio-1.0
- hs-source-dirs: test
+ hs-source-dirs: tests
main-is: Main.hs
other-modules:
HUnit
hjugement-protocol
, base >= 4.6 && < 5
, containers >= 0.5
- , hashable >= 1.2.6
+ -- , hashable >= 1.2.6
, QuickCheck >= 2.0
-- , monad-classes >= 0.3
, random >= 1.1
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+module Voting.Protocol
+ ( module Voting.Protocol.Arithmetic
+ , module Voting.Protocol.Credential
+ , module Voting.Protocol.Election
+ , module Voting.Protocol.Trustees
+ ) where
+
+import Voting.Protocol.Arithmetic
+import Voting.Protocol.Credential
+import Voting.Protocol.Election
+import Voting.Protocol.Trustees
{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Protocol.Arithmetic
- ( module Protocol.Arithmetic
+module Voting.Protocol.Arithmetic
+ ( module Voting.Protocol.Arithmetic
, Natural
, Random.RandomGen
) where
import Control.Arrow (first)
+import Control.DeepSeq (NFData)
import Control.Monad (Monad(..))
import Data.Bits
import Data.Bool
import Data.Maybe (Maybe(..))
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
-import Data.String (IsString(..))
+import Data.String (String, IsString(..))
import Numeric.Natural (Natural)
import Prelude (Integer, Integral(..), fromIntegral, Enum(..))
import Text.Show (Show(..))
--
-- The 'Natural' is always within @[0..'fieldCharac'-1]@.
newtype F p = F { unF :: Natural }
- deriving (Eq,Ord,Show)
+ deriving (Eq,Ord,Show,NFData)
instance PrimeField p => FromNatural (F p) where
fromNatural i = F (abs (i `mod` fieldCharac @p))
-- * Type 'G'
-- | The type of the elements of a 'Multiplicative' 'SubGroup' of a 'PrimeField'.
newtype G q = G { unG :: F (P q) }
- deriving (Eq,Ord,Show)
+ deriving (Eq,Ord,Show,NFData)
instance PrimeField (P q) => FromNatural (G q) where
fromNatural = G . fromNatural
go g = g : go (g * invGen)
invGen = inv groupGen
+groupGenPowers :: SubGroup q => [G q]
+groupGenPowers = go one
+ where go g = g : go (g * groupGen)
+
-- | @('hash' bs gs)@ returns as a number in 'E'
-- the SHA256 of the given 'BS.ByteString' 'bs'
-- prefixing the decimal representation of given 'SubGroup' elements 'gs',
-- | An exponent of a (necessarily cyclic) 'SubGroup' of a 'PrimeField'.
-- The value is always in @[0..'groupOrder'-1]@.
newtype E q = E { unE :: F (P q) }
- deriving (Eq,Ord,Show)
+ deriving (Eq,Ord,Show,NFData)
instance SubGroup q => FromNatural (E q) where
fromNatural i = E (F (abs (i `mod` unF (groupOrder @q))))
-- * Groups
+-- * Type 'Params'
+class SubGroup q => Params q where
+ paramsName :: String
+instance Params WeakParams where
+ paramsName = "WeakParams"
+instance Params BeleniosParams where
+ paramsName = "BeleniosParams"
+
-- ** Type 'WeakParams'
-- | Weak parameters for debugging purposes only.
data WeakParams
-module Protocol.Credential where
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+module Voting.Protocol.Credential where
+import Control.DeepSeq (NFData)
import Control.Monad (Monad(..), replicateM)
import Data.Bits
import Data.Bool
import Data.Maybe (maybe)
import Data.Ord (Ord(..))
import Data.Text (Text)
+import GHC.Generics (Generic)
import Numeric.Natural (Natural)
import Prelude (Integral(..), fromIntegral, div)
import Text.Show (Show)
import qualified Data.Text.Encoding as Text
import qualified System.Random as Random
-import Protocol.Arithmetic
+import Voting.Protocol.Arithmetic
-- * Type 'Credential'
-- | A 'Credential' is a word of @('tokenLength'+1 '==' 15)@-characters
-- The last character is a checksum.
-- The entropy is: @('tokenLength' * log 'tokenBase' / log 2) '==' 82.01… bits@.
newtype Credential = Credential Text
- deriving (Eq, Show)
+ deriving (Eq,Show,Generic,NFData)
credentialAlphabet :: [Char] -- TODO: make this an array
credentialAlphabet = "123456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz"
= CredentialError_BadChar Char.Char
| CredentialError_Checksum
| CredentialError_Length
- deriving (Eq, Show)
+ deriving (Eq,Show,Generic,NFData)
-- ** Type 'UUID'
newtype UUID = UUID Text
- deriving (Eq,Ord,Show)
+ deriving (Eq,Ord,Show,Generic,NFData)
-- | @'randomUUID'@ generates a random 'UUID'.
randomUUID ::
-- ** Type 'SecretKey'
type SecretKey = E
--- | @('secretKey' uuid cred)@ returns the 'SecretKey'
+-- | @('credentialSecretKey' uuid cred)@ returns the 'SecretKey'
-- derived from given 'uuid' and 'cred'
-- using 'Crypto.fastPBKDF2_SHA256'.
-secretKey :: SubGroup q => UUID -> Credential -> SecretKey q
-secretKey (UUID uuid) (Credential cred) =
+credentialSecretKey :: SubGroup q => UUID -> Credential -> SecretKey q
+credentialSecretKey (UUID uuid) (Credential cred) =
fromNatural $ BS.foldl'
(\acc b -> acc`shiftL`3 + fromIntegral b)
(0::Natural)
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
-module Protocol.Election where
+module Voting.Protocol.Election where
import Control.Applicative (Applicative(..))
+import Control.DeepSeq (NFData)
import Control.Monad (Monad(..), join, mapM, replicateM, unless, zipWithM)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Except (ExceptT, runExcept, throwE, withExceptT)
import Data.Function (($), (.), id, const)
import Data.Functor (Functor, (<$>))
import Data.Functor.Identity (Identity(..))
-import Data.Functor.Compose (Compose(..))
-import Data.Maybe (Maybe(..), fromMaybe)
+import Data.Maybe (Maybe(..), fromMaybe, maybe)
import Data.Ord (Ord(..))
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import Data.Traversable (Traversable(..))
import Data.Tuple (fst, snd, uncurry)
import GHC.Natural (minusNaturalMaybe)
+import GHC.Generics (Generic)
import Numeric.Natural (Natural)
import Prelude (fromIntegral)
import Text.Show (Show(..))
import qualified Control.Monad.Trans.State.Strict as S
import qualified Data.ByteString as BS
import qualified Data.List as List
+import qualified Data.Map.Strict as Map
-import Protocol.Utils
-import Protocol.Arithmetic
-import Protocol.Credential
+import Voting.Protocol.Utils
+import Voting.Protocol.Arithmetic
+import Voting.Protocol.Credential
-- * Type 'Encryption'
-- | ElGamal-like encryption.
, encryption_vault :: G q
-- ^ Encrypted 'clear' text,
-- equal to @('pubKey' '^'encNone '*' 'groupGen' '^'clear)@
- } deriving (Eq,Show)
+ } deriving (Eq,Show,Generic,NFData)
-- | Additive homomorphism.
-- Using the fact that: @'groupGen' '^'x '*' 'groupGen' '^'y '==' 'groupGen' '^'(x'+'y)@.
-- that is to say: @('proof_response' '==' logBase base 'commitment' '-' sec '*' 'proof_challenge')@,
-- therefore the prover knows 'sec'.
--
- -- The prover choses 'commitment' to be a random power of @base@,
- -- to ensure that each 'prove' does not reveal any information about its secret.
- } deriving (Eq,Show)
+ -- The prover choses 'commitment' to be a random power of @base@,
+ -- to ensure that each 'prove' does not reveal any information
+ -- about its secret.
+ } deriving (Eq,Show,Generic,NFData)
-- ** Type 'ZKP'
-- | Zero-knowledge proof.
-- when composing the 'proof_challenge' and 'proof_response' together
-- (with 'commit').
--
--- NOTE: @sec@ is @secKey@ in 'signature_proof' or @encNonce@ in 'proveEncryption'.
---
-- WARNING: for 'prove' to be a so-called /strong Fiat-Shamir transformation/ (not a weak):
--- the statement must be included in the 'hash' (not only the commitments).
+-- the statement must be included in the 'hash' (along with the commitments).
--
-- NOTE: a 'random' @nonce@ is used to ensure each 'prove'
-- does not reveal any information regarding the secret @sec@,
-- is indexing a 'Disjunction' within a list of them,
-- without revealing which 'Opinion' it is.
newtype DisjProof q = DisjProof [Proof q]
- deriving (Eq,Show)
+ deriving (Eq,Show,Generic,NFData)
-- | @('proveEncryption' elecPubKey voterZKP (prevDisjs,nextDisjs) (encNonce,enc))@
-- returns a 'DisjProof' that 'enc' 'encrypt's
, question_mini :: Opinion q
, question_maxi :: Opinion q
-- , question_blank :: Maybe Bool
- } deriving (Eq, Show)
+ } deriving (Eq,Show,Generic,NFData)
-- * Type 'Answer'
data Answer q = Answer
-- ^ Proofs that the sum of the 'Opinon's encrypted in 'answer_opinions'
-- is an element of @[mini..maxi]@.
-- , answer_blankProof ::
- } deriving (Eq,Show)
+ } deriving (Eq,Show,Generic,NFData)
-- | @('encryptAnswer' elecPubKey zkp quest opinions)@
-- returns an 'Answer' validable by 'verifyAnswer',
| ErrorAnswer_WrongSumOfOpinions Natural Natural Natural
-- ^ When the sum of opinions is not within the bounds
-- of 'question_mini' and 'question_maxi'.
- deriving (Eq,Show)
+ deriving (Eq,Show,Generic,NFData)
-- * Type 'Election'
data Election q = Election
, election_questions :: [Question q]
, election_uuid :: UUID
, election_hash :: Hash -- TODO: serialize to JSON to calculate this
- } deriving (Eq,Show)
+ } deriving (Eq,Show,Generic,NFData)
-- ** Type 'Hash'
newtype Hash = Hash Text
- deriving (Eq,Ord,Show)
+ deriving (Eq,Ord,Show,Generic,NFData)
-- * Type 'Ballot'
data Ballot q = Ballot
, ballot_signature :: Maybe (Signature q)
, ballot_election_uuid :: UUID
, ballot_election_hash :: Hash
- }
+ } deriving (Generic,NFData)
--- | @('encryptBallot' elec ('Just' secKey) opinionsByQuest)@
+-- | @('encryptBallot' elec ('Just' ballotSecKey) opinionsByQuest)@
-- returns a 'Ballot' signed by 'secKey' (the voter's secret key)
-- where 'opinionsByQuest' is a list of 'Opinion's
-- on each 'question_choices' of each 'election_questions'.
Monad m => RandomGen r => SubGroup q =>
Election q -> Maybe (SecretKey q) -> [[Bool]] ->
S.StateT r (ExceptT ErrorBallot m) (Ballot q)
-encryptBallot Election{..} secKeyMay opinionsByQuest
+encryptBallot Election{..} ballotSecKeyMay opinionsByQuest
| List.length election_questions /= List.length opinionsByQuest =
lift $ throwE $
ErrorBallot_WrongNumberOfAnswers
(fromIntegral $ List.length election_questions)
| otherwise = do
let (voterKeys, voterZKP) =
- case secKeyMay of
+ case ballotSecKeyMay of
Nothing -> (Nothing, ZKP "")
- Just secKey ->
- ( Just (secKey, pubKey)
- , ZKP (bytesNat pubKey) )
- where pubKey = publicKey secKey
+ Just ballotSecKey ->
+ ( Just (ballotSecKey, ballotPubKey)
+ , ZKP (bytesNat ballotPubKey) )
+ where ballotPubKey = publicKey ballotSecKey
ballot_answers <-
S.mapStateT (withExceptT ErrorBallot_Answer) $
zipWithM (encryptAnswer election_publicKey voterZKP)
election_questions opinionsByQuest
ballot_signature <- case voterKeys of
Nothing -> return Nothing
- Just (secKey, signature_publicKey) -> do
+ Just (ballotSecKey, signature_publicKey) -> do
signature_proof <-
- prove secKey (Identity groupGen) $
+ prove ballotSecKey (Identity groupGen) $
\(Identity commitment) ->
hash
-- NOTE: the order is unusual, the commitments are first
{ signature_publicKey :: PublicKey q
-- ^ Verification key.
, signature_proof :: Proof q
- }
+ } deriving (Generic,NFData)
-- *** Hashing
-- | @('signatureCommitments' voterZKP commitment)@
signatureCommitments :: SubGroup q => ZKP -> Commitment q -> BS.ByteString
signatureCommitments (ZKP voterZKP) commitment =
- "sig|"<>voterZKP<>"|"<>bytesNat commitment<>"|"
+ "sig|"<>voterZKP<>"|" -- NOTE: this is actually part of the statement
+ <> bytesNat commitment<>"|"
-- ** Type 'ErrorBallot'
-- | Error raised by 'encryptBallot'.
-- is different than the number of questions.
| ErrorBallot_Answer ErrorAnswer
-- ^ When 'encryptAnswer' raised an 'ErrorAnswer'.
- deriving (Eq,Show)
+ deriving (Eq,Show,Generic,NFData)
--- /dev/null
+../HLint.hs
\ No newline at end of file
-module Protocol.Utils where
+module Voting.Protocol.Utils where
+
import Control.Applicative (Applicative(..), Alternative(..))
import Control.Monad (Monad(..), join, mapM, unless, zipWithM)
import Control.Monad.Trans.Class (MonadTrans(..))
import Data.Function (($), id, const)
import Data.Functor (Functor, (<$>), (<$))
import Data.Functor.Identity (Identity(..))
-import Data.Functor.Compose (Compose(..))
-import Data.Maybe (Maybe(..), maybe, fromMaybe)
-import Data.Ord (Ord(..))
-import Data.Semigroup (Semigroup(..))
-import Data.Text (Text)
+import Data.Maybe (Maybe(..), maybe)
import Data.Traversable (Traversable(..))
-import Data.Tuple (fst, snd, uncurry)
-import GHC.Natural (minusNaturalMaybe)
-import Numeric.Natural (Natural)
-import Prelude (fromIntegral)
-import Text.Show (Show(..))
-import Control.Monad.Trans.Maybe (MaybeT(..))
-import qualified Control.Monad.Trans.Except as Exn
-import qualified Control.Monad.Trans.State.Strict as S
-import qualified Data.ByteString as BS
import qualified Data.List as List
-- | NOTE: check the lengths before applying @f@.
maybe ([] <$ err) sequenceA $
isoZipWith f as bs
+isoZipWithM_ ::
+ Applicative m =>
+ m () ->
+ (a -> b -> m c) ->
+ [a] -> [b] -> m ()
+isoZipWithM_ err f as bs =
+ maybe err sequenceA_ $
+ isoZipWith f as bs
+
isoZipWith3M ::
Applicative m =>
m () ->
+++ /dev/null
-module HUnit.Utils
- ( module Test.Tasty
- , module Test.Tasty.HUnit
- , Monad(..), replicateM, when
- , module Data.Bool
- , Eq(..)
- , Either(..)
- , ($), (.)
- , (<$>)
- , Int
- , Maybe(..)
- , Monoid(..)
- , Ord(..)
- , String
- , Text
- , Word8
- , Num, Fractional(..), Integral(..), Integer, undefined, fromIntegral
- , Show(..)
- ) where
-
-import Control.Monad (Monad(..), replicateM, when)
-import Data.Bool
-import Data.Either (Either(..))
-import Data.Eq (Eq(..))
-import Data.Function (($), (.))
-import Data.Functor ((<$>))
-import Data.Int (Int)
-import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..))
-import Data.Ord (Ord(..))
-import Data.String (String)
-import Data.Text (Text)
-import Data.Word (Word8)
-import Prelude (Num, Fractional(..), Integral(..), Integer, undefined, fromIntegral)
-import Test.Tasty
-import Test.Tasty.HUnit
-import Text.Show (Show(..))
--- /dev/null
+../HLint.hs
\ No newline at end of file
{-# LANGUAGE OverloadedStrings #-}
module HUnit.Arithmetic where
+import Test.Tasty.HUnit
import Protocol.Arithmetic
-import HUnit.Utils
+import Utils
hunit :: TestTree
hunit = testGroup "Arithmetic"
module HUnit.Credential where
import Control.Applicative (Applicative(..))
+import Test.Tasty.HUnit
import qualified Control.Monad.Trans.State.Strict as S
import qualified System.Random as Random
import Protocol.Arithmetic
import Protocol.Credential
-import HUnit.Utils
+import Utils
hunit :: TestTree
hunit = testGroup "Credential"
, "xLcs7ev6Jy6FHHF" ==> Left CredentialError_Checksum
, "xLcs7ev6Jy6FHHE" ==> Right (Credential "xLcs7ev6Jy6FHHE")
]
- , testGroup "secretKey" $
+ , testGroup "credentialSecretKey" $
[ testSecretKey @WeakParams 0 $ E (F 122)
, testSecretKey @WeakParams 1 $ E (F 35)
, testSecretKey @BeleniosParams 0 $ E (F 2317630607062989137269685509390)
(`S.evalState` Random.mkStdGen seed) $
(,) <$> randomUUID <*> randomCredential in
testCase (show (u,c)) $
- secretKey @q uuid cred @?= exp
+ credentialSecretKey @q uuid cred @?= exp
{-# LANGUAGE PatternSynonyms #-}
module HUnit.Election where
--- import Control.Applicative (Applicative(..))
-import qualified Control.Monad.Trans.Except as Exn
-import qualified Control.Monad.Trans.State.Strict as S
+import Test.Tasty.HUnit
import qualified Data.List as List
import qualified System.Random as Random
import Protocol.Arithmetic
import Protocol.Credential
import Protocol.Election
-import HUnit.Utils
+import Protocol.Trustees.Simple
--- * Type 'Params'
-class SubGroup q => Params q where
- paramsName :: String
-instance Params WeakParams where
- paramsName = "WeakParams"
-instance Params BeleniosParams where
- paramsName = "BeleniosParams"
+import Utils
hunit :: TestTree
hunit = testGroup "Election"
[ testsEncryptBallot @WeakParams
, testsEncryptBallot @BeleniosParams
]
+ , testGroup "trustee" $
+ [ testsTrustee @WeakParams
+ ]
]
testsEncryptBallot :: forall q. Params q => TestTree
TestTree
testEncryptBallot seed quests opins exp =
let verify =
- Exn.runExcept $
- (`S.evalStateT` Random.mkStdGen seed) $ do
+ runExcept $
+ (`evalStateT` Random.mkStdGen seed) $ do
uuid <- randomUUID
cred <- randomCredential
- let secKey = secretKey @q uuid cred
- let pubKey = publicKey secKey
+ let ballotSecKey = credentialSecretKey @q uuid cred
+ let elecPubKey = publicKey ballotSecKey -- FIXME: wrong key
let elec = Election
{ election_name = "election"
, election_description = "description"
- , election_publicKey = pubKey
+ , election_publicKey = elecPubKey
, election_questions = quests
, election_uuid = uuid
- , election_hash = Hash ""
+ , election_hash = Hash "" -- FIXME: when implemented
}
verifyBallot elec
- <$> encryptBallot elec (Just secKey) opins
+ <$> encryptBallot elec (Just ballotSecKey) opins
in
testCase (show opins) $
verify @?= exp
+
+testsTrustee :: forall q. Params q => TestTree
+testsTrustee =
+ testGroup (paramsName @q)
+ [ testTrustee @q 0 (Right ())
+ ]
+
+testTrustee ::
+ forall q. SubGroup q =>
+ Int -> Either ErrorTrusteePublicKey () -> TestTree
+testTrustee seed exp =
+ let verify =
+ runExcept $
+ (`evalStateT` Random.mkStdGen seed) $ do
+ trustSecKey <- randomSecretKey @_ @_ @q
+ trustPubKey <- proveTrusteePublicKey trustSecKey
+ lift $ verifyTrusteePublicKey trustPubKey
+ in
+ testCase (show seed) $
+ verify @?= exp
--- /dev/null
+../HLint.hs
\ No newline at end of file
--- /dev/null
+module Main where
+
+import System.IO (IO)
+import Data.Function (($))
+import Test.Tasty
+import HUnit
+
+main :: IO ()
+main =
+ defaultMain $
+ testGroup "Protocol"
+ [ hunits
+ ]
--- /dev/null
+module Utils
+ ( module Test.Tasty
+ , module Data.Bool
+ , Applicative(..)
+ , Monad(..), forM, replicateM, unless, when
+ , Eq(..)
+ , Either(..), either, isLeft, isRight
+ , ($), (.), id, const, flip
+ , (<$>)
+ , Int
+ , Maybe(..)
+ , Monoid(..), Semigroup(..)
+ , Ord(..)
+ , String
+ , Text
+ , Word8
+ , Num, Fractional(..), Integral(..), Integer, fromIntegral
+ , Show(..)
+ , MonadTrans(..)
+ , ExceptT
+ , runExcept
+ , throwE
+ , StateT
+ , evalStateT
+ , mkStdGen
+ , debug
+ , nCk
+ , combinOfRank
+ ) where
+
+import Control.Applicative (Applicative(..))
+import Control.Monad
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
+import Control.Monad.Trans.State.Strict
+import Data.Bool
+import Data.Either (Either(..), either, isLeft, isRight)
+import Data.Eq (Eq(..))
+import Data.Function
+import Data.Functor ((<$>))
+import Data.Int (Int)
+import Data.Maybe (Maybe(..))
+import Data.Monoid (Monoid(..))
+import Data.Ord (Ord(..))
+import Data.Semigroup (Semigroup(..))
+import Data.String (String)
+import Data.Text (Text)
+import Data.Word (Word8)
+import Debug.Trace
+import Prelude (Num(..), Fractional(..), Integral(..), Integer, undefined, fromIntegral)
+import System.Random (mkStdGen)
+import Test.Tasty
+import Text.Show (Show(..))
+
+debug msg x = trace (msg<>": "<>show x) x
+
+-- | @'nCk' n k@ returns the number of combinations
+-- of size 'k' from a set of size 'n'.
+--
+-- Computed using the formula:
+-- @'nCk' n (k+1) == 'nCk' n (k-1) * (n-k+1) / k@
+nCk :: Integral i => i -> i -> i
+n`nCk`k | n<0||k<0||n<k = undefined
+ | otherwise = go 1 1
+ where
+ go i acc = if k' < i then acc else go (i+1) (acc * (n-i+1) `div` i)
+ -- Use a symmetry to compute over smaller numbers,
+ -- which is more efficient and safer
+ k' = if n`div`2 < k then n-k else k
+
+-- | @'combinOfRank' n k r@ returns the @r@-th combination
+-- of @k@ elements from a set of @n@ elements.
+-- DOC: <http://www.site.uottawa.ca/~lucia/courses/5165-09/GenCombObj.pdf>, p.26
+combinOfRank :: Integral i => i -> i -> i -> [i]
+combinOfRank n k rk | rk<0||n`nCk`k<rk = undefined
+ | otherwise = for1K 1 1 rk
+ where
+ for1K i j r | i < k = uptoRank i j r
+ | i == k = [j+r] -- because when i == k, nbCombs is always 1
+ | otherwise = []
+ uptoRank i j r | nbCombs <- (n-j)`nCk`(k-i)
+ , nbCombs <= r = uptoRank i (j+1) (r-nbCombs)
+ | otherwise = j : for1K (i+1) (j+1) r
sourcephile / git / majurity.git / commitdiff