hjugement/test/HUnit/Rank.hs

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