Htirage/Sequence.hs

   1 -- | Calculs d’arrangements.
   2 module Htirage.Sequence where
   3
   4 import Data.Bool
   5 import Data.Foldable (any, foldr)
   6 import Data.Functor ((<$>))
   7 import Data.List (length)
   8 import Data.Ord (Ord(..))
   9 import Prelude (Integral(..), Num(..), undefined)
  10
  11 -- | @'nAk' n k@ retourne le nombre de combinaisons
  12 -- de longueur 'k' d’un ensemble de longueur 'n'.
  13 nAk :: Integral i => i -> i -> i
  14 n`nAk`k | n<0||k<0||n<k = undefined
  15         | otherwise     = go 1 1
  16         where
  17         go i acc = if k < i then acc else go (i+1) (acc * (n-i+1))
  18
  19 sequenceOfRank :: Integral i => i -> i -> i -> [i]
  20 sequenceOfRank n k rk | rk<0||n`nAk`k<rk = undefined
  21                       | otherwise = shiftPositions (for1K 1 rk (n`nAk`k))
  22         where
  23         for1K i r a =
  24                 if k < i then []
  25                 else q+1 : for1K (i+1) r' a'
  26                 where
  27                 -- Optimized computation of: n-i`nAk`k-i
  28                 a' = a `div` (n-i+1)
  29                 -- Greatest multiple of 'a' lower or equal to the rank 'r',
  30                 -- and the remaining of the rank
  31                 (q, r') = r `divMod` a'
  32         shiftPositions = -- Promote the positions in the good interval.
  33                 foldr (\x acc -> x : ((\x' -> if x' >= x then x'+1 else x') <$> acc)) []
  34
  35 rankOfSequence :: Integral i => i -> [i] -> i
  36 rankOfSequence n ns | any (\x -> x<1||n<x) ns || n<k = undefined
  37                     | otherwise = for0K 1 0 (n`nAk`k) ns
  38         where
  39         k = fromInteger (toInteger (length ns))
  40         for0K _ r _ []     = r
  41         for0K i r a (x:xs) = for0K (i+1) r' a' xs'
  42                 where
  43                 -- Optimized computation of: n-i`nAk`k-i
  44                 a' = a `div` (n-i+1)
  45                 -- Next rank
  46                 r' = r + (x-1) * a'
  47                 xs' = (\x' -> if x < x' then x'-1 else x') <$> xs