Htirage.hs

   1 -- | Tirage au sort par aléa équiprobable publiquement vérifiable.
   2 -- GPL-3, (c) 2017-07-19 Julien Moutinho \<julm+htirage@autogeree.net>
   3 module Htirage where
   4
   5 import Data.Bits
   6 import Data.List
   7
   8 -- * Sélection de choix
   9
  10 -- | @select1 bs cs@ retourne un choix de la liste de choix 'cs'
  11 -- déterminé par le premier nombre binaire formé par l’entropie 'bs'
  12 -- qui a le potentiel d’atteindre tous les choix, et qui en atteint effectivement un.
  13 select1 :: [Bool] -> [a] -> a
  14 select1 bs cs
  15  | given < enough = error (show (enough - given) ++ " missing bits")
  16  | i > iMax       = select1 (tail bits ++ bs') cs
  17  | otherwise      = cs !! i
  18         where (bits, bs') = splitAt enough bs
  19               i           = intOfBits bits
  20               iMax        = length cs - 1
  21               enough      = nbBits iMax
  22               given       = length bs
  23
  24 -- | @selectKCombN k cs ns@ retourne les 'k' choix parmi 'cs', déterminés par les bits 'bs'.
  25 selectKCombN :: Int -> [a] -> [Bool] -> [a]
  26 selectKCombN k cs bs = select1 bs (k`combs`cs)
  27
  28 -- * Dénombrement
  29
  30 -- ** Arrangements
  31
  32 -- | @nbArrs k n@ retourne le nombre d’arrangements de longueur 'k' d’une liste de longueur 'n'.
  33 nbArrs :: Int -> Int -> Int
  34 k `nbArrs` n = product [n-k+1 .. n]
  35
  36 -- ** Combinaisons
  37
  38 -- | @nbCombs k n@ retourne le nombre de combinaisons de longueur 'k' d’une liste de longueur 'n'.
  39 nbCombs :: Int -> Int -> Int
  40 k `nbCombs` n = (k `nbArrs` n) `div` product [1..k]
  41
  42 -- | @combs k n@ retourne les combinaisons de longueur 'k' d’une liste 'n'.
  43 combs :: Int -> [a] -> [[a]]
  44 combs k n = combsK n !! k
  45
  46 -- | @combsK n@ retourne les combinaisons de longueur inférieure ou égale à 'n' d’une liste 'n'.
  47 --
  48 -- Algorithme dynamique permettant un calcul de 'combs'
  49 -- relativement rapide du fait du partage de 'combsKmoins1'.
  50 combsK :: [a] -> [[[a]]]
  51 combsK [] = [[[]]]
  52 combsK (x : xs) =
  53         zipWith (++) (combsKmoins1 ++ [[]])
  54                      ([] : map (map (x :)) combsKmoins1)
  55         where combsKmoins1 = combsK xs
  56
  57 -- * Manipulation de bits
  58
  59 -- | @nbBits n@ retourne le nombre de bits servant à encoder 'n'.
  60 nbBits :: Int -> Int
  61 nbBits n = finiteBitSize n - countLeadingZeros n
  62
  63 -- | @intOfBits bs@ retourne le nombre encodé par les bits 'bs'.
  64 intOfBits :: [Bool] -> Int
  65 intOfBits bs = foldr (.|.) 0 (zipWith (\i b -> if b then bit i else 0) [0..] bs)
  66
  67 -- | @bitsOfInt m n@ retourne les 'm' premiers bits de poids faible encodant le nombre 'n'.
  68 bitsOfInt :: Int -> Int -> [Bool]
  69 bitsOfInt m n = [testBit n i | i <- [0..m-1]]
  70
  71 -- * Extraction d’entropie publique
  72
  73 -- | @equiProbableBitsKCombN k n c@ retourne les bits équiprobables donnés
  74 -- par la combinaison 'c' obtenue par tirage équiprobable
  75 -- d’une combinaison de 'k' éléments parmi 'n'.
  76 --
  77 -- Pour que les bits retournés aient chacun
  78 -- la même probabilité d’être à 'True' ou à 'False',
  79 -- seulement 2 puissance 'equiProbableBits'
  80 -- de ces combinaisons sont considérées comme valides ;
  81 -- les autres donnant des doublons quand on ne considère
  82 -- que les 'equiProbableBits' bits de poids faible
  83 -- de leur position dans la liste des combinaisons retournée par 'combs'.
  84 --
  85 -- Dans le cas où survient une combinaison invalide,
  86 -- aucun bit n’est extrait du tirage 'c'.
  87 equiProbableBitsKCombN :: Int -> Int -> [Int] -> [Bool]
  88 equiProbableBitsKCombN k n c =
  89         case elemIndex (sort c) (k`combs`[1..n]) of
  90          Just i | nbBits i <= equiProbableBits -> equiProbableBits `bitsOfInt` i
  91          _ -> []
  92         where equiProbableBits = nbBits (k`nbCombs`n) - 1
  93
  94 -- | @equiProbableBitsLOTO nums numComplementaire@ retourne les bits équiprobables donnés
  95 -- par un tirage du <https://www.fdj.fr/jeux/jeux-de-tirage/loto/resultats/ LOTO Français>.
  96 equiProbableBitsLOTO :: (Int,Int,Int,Int,Int) -> Int -> [Bool]
  97 equiProbableBitsLOTO (n1,n2,n3,n4,n5) nc =
  98         equiProbableBitsKCombN 5 49 [n1,n2,n3,n4,n5] ++
  99         equiProbableBitsKCombN 1 10 [nc]
 100
 101 -- | @equiProbableBitsSwissLOTO nums numComplementaire@ retourne les bits équiprobables donnés
 102 -- par un tirage du <https://jeux.loro.ch/FR/1/SwissLoto#action=game-history SwissLOTO>.
 103 equiProbableBitsSwissLOTO :: (Int,Int,Int,Int,Int,Int) -> Int -> [Bool]
 104 equiProbableBitsSwissLOTO (n1,n2,n3,n4,n5,n6) nc =
 105         equiProbableBitsKCombN 6 42 [n1,n2,n3,n4,n5,n6] ++
 106         equiProbableBitsKCombN 1 6 [nc]
 107
 108 -- | @equiProbableBitsSwissLOTO nums numComplementaires@ retourne les bits équiprobables donnés
 109 -- par un tirage de l’<https://www.fdj.fr/jeux/jeux-de-tirage/euromillions/resultats EuroMillions>.
 110 equiProbableBitsEuroMillions :: (Int,Int,Int,Int,Int) -> (Int,Int) -> [Bool]
 111 equiProbableBitsEuroMillions (n1,n2,n3,n4,n5) (nc1,nc2) =
 112         equiProbableBitsKCombN 5 50 [n1,n2,n3,n4,n5] ++
 113         equiProbableBitsKCombN 2 11 [nc1,nc2]
 114
 115 -- | @equiProbableBits6aus49 nums numComplementaire@ retourne les bits équiprobables donnés
 116 -- par un tirage du <https://www.lotto.de/de/ergebnisse/lotto-6aus49/archiv.html 6aus49>.
 117 equiProbableBits6aus49 :: (Int,Int,Int,Int,Int,Int) -> Int -> [Bool]
 118 equiProbableBits6aus49 (n1,n2,n3,n4,n5,n6) nc =
 119         equiProbableBitsKCombN 6 49 [n1,n2,n3,n4,n5,n6] ++
 120         equiProbableBitsKCombN 1 10 [nc]