test/HUnit/Rank.hs

   1 module HUnit.Rank where
   2 import Data.Bool
   3 import Data.Eq (Eq(..))
   4 import Data.Foldable (Foldable(..))
   5 import Data.Function (($), (.))
   6 import Data.Functor ((<$>))
   7 import Data.List
   8 import Data.Ord (Ord(..))
   9 import Data.Semigroup (Semigroup(..))
  10 import Data.Ratio
  11 import GHC.Exts (IsList(..))
  12 import Majority.Judgment
  13 import Prelude (Integer, Num(..), fromIntegral)
  14 import Test.Tasty
  15 import Test.Tasty.HUnit
  16 import Text.Show (Show(..))
  17
  18 import QuickCheck.Merit ()
  19 import QuickCheck.Value ()
  20
  21 hunit :: TestTree
  22 hunit = testGroup "Rank"
  23  [ testGroup "lexicographic"
  24          [ testLexRank 1 1
  25          , testLexRank 5 4
  26          , testLexRank 5 5
  27          , testLexRank 10 5
  28          , testLexRank 15 5
  29          ]
  30  , testGroup "majority"
  31          [ testMajRank 1 1
  32          , testMajRank 5 4
  33          , testMajRank 5 5
  34          , testMajRank 10 5
  35          , testMajRank 15 5
  36          , testMajRank 25 4
  37          ]
  38  ]
  39
  40 testLexRank :: JS -> GS -> TestTree
  41 testLexRank js gs =
  42         testGroup ("js="<>show js<>" gs="<>show gs)
  43          [ testCase "rankOfMerit" $
  44                 rankOfMerit gs <$> merits js gs
  45                  @?= [0..lastRank js gs]
  46          , testCase "Rank -> Merit -> Rank" $
  47                 let ranks = [0..lastRank js gs] in
  48                 rankOfMerit gs .
  49                 meritOfRank js gs
  50                  <$> ranks @?= ranks
  51          , testCase "Merit -> Rank -> Merit" $
  52                 let dists = merits js gs in
  53                 meritOfRank js gs .
  54                 rankOfMerit gs
  55                  <$> dists @?= dists
  56          ]
  57
  58 testMajRank :: JS -> GS -> TestTree
  59 testMajRank js gs =
  60         testGroup ("js="<>show js<>" gs="<>show gs)
  61          [ testCase "rankOfMajorityValue" $
  62                 rankOfMajorityValue gs <$> majorityValues js gs
  63                  @?= [0..lastRank js gs]
  64          ]
  65
  66 -- | Generate all distributions possible, in lexicographic order.
  67 merits :: JS -> GS -> [[G]]
  68 merits js0 gs = go 0 js0
  69         where
  70         go g js
  71          | g == gs - 1 = [replicate (fromIntegral js) g]
  72          | otherwise = concat
  73                  [ (replicate (fromIntegral r) g <>) <$> go (g+1) (js-r)
  74                  | r <- reverse [0..js]
  75                  ]
  76
  77 -- | Generate all distributions possible, in majority order.
  78 majorityValues :: JS -> GS -> [MajorityValue (Ranked ())]
  79 majorityValues js0 gs = sort $ majorityValue . fromList <$> go 0 js0
  80         where
  81         go g js
  82          | g == gs - 1 = [[(Ranked (g, ()), js%1)]]
  83          | otherwise = concat
  84                  [ ((Ranked (g, ()), r%1) :) <$> go (g+1) (js-r)
  85                  | r <- reverse [0..js]
  86                  ]
  87
  88 rankOfMerit :: GS -> [Integer] -> Integer
  89 rankOfMerit gsI dist = go 0 ranks dist
  90         where
  91         js  = fromIntegral $ length dist
  92         gs  = fromIntegral gsI
  93         ranks = reverse $ reverse . take gs <$> take js pascalDiagonals
  94         go g0 (p:ps) (d:ds) =
  95                 sum (take dI p) +
  96                 go d (drop dI <$> ps) ds
  97                 where dI = fromIntegral (d - g0)
  98         go _ _ _ = 0
  99
 100 meritOfRank :: JS -> GS -> Integer -> [Integer]
 101 meritOfRank jsI gsI = go 0 ranks
 102         where
 103         js = fromIntegral jsI
 104         gs = fromIntegral gsI
 105         ranks = reverse $ reverse . take gs <$> take js pascalDiagonals
 106         go _g0 [] _r = []
 107         go g0 (p:ps) r = g : go g (drop s <$> ps) (r-dr)
 108                 where
 109                 skip = takeWhile (<= r) $ scanl1 (+) p
 110                 s    = length skip
 111                 g    = g0 + fromIntegral s
 112                 dr   = if null skip then 0 else last skip
 113
 114 -- | Diagonals of Pascal's triangle.
 115 pascalDiagonals :: [[Integer]]
 116 pascalDiagonals = repeat 1 : (scanl1 (+) <$> pascalDiagonals)