diff --git a/Majority/Gauge.hs b/Majority/Gauge.hs --- a/Majority/Gauge.hs +++ b/Majority/Gauge.hs @@ -13,7 +13,7 @@ import Data.Ord (Ord(..), Ordering(..), Down(..)) import Data.Tuple (snd) import Prelude (Num(..)) -import Text.Show (Show(..), showParen, shows) +import Text.Show (Show(..)) import qualified Data.HashMap.Strict as HM import qualified Data.List as List import qualified Data.Map.Strict as Map @@ -30,12 +30,12 @@ -- they are not necessarily tied according to their 'majorityValue's. data MajorityGauge g = MajorityGauge - { mgHigher :: Share -- ^ Number of 'grade's given which are better than 'mgGrade'. + { mgLower :: Share -- ^ Number of 'grade's given which are worse than 'mgGrade'. , mgGrade :: g -- ^ 'majorityGrade'. - , mgLower :: Share -- ^ Number of 'grade's given which are worse than 'mgGrade'. + , mgHigher :: Share -- ^ Number of 'grade's given which are better than 'mgGrade'. } deriving (Eq) instance Show g => Show (MajorityGauge g) where - showsPrec p (MajorityGauge b g w) = showParen (p >= 10) $ shows (b,g,w) + showsPrec p (MajorityGauge w g b) = showsPrec p (w,g,b) -- ** Type 'Sign' data Sign = Minus | Plus @@ -44,6 +44,10 @@ -- | If 'mgHigher' is higher than 'mgLower' -- then the 'majorityGrade' is completed by a 'Plus'; -- otherwise the 'majorityGrade' is completed by a 'Minus'. +-- +-- This indicates the side of the next 'majorityGrade' +-- which is different than the current one: +-- 'Minus' when it is lower and 'Plus' otherwise. mgSign :: MajorityGauge g -> Sign mgSign g = if mgHigher g > mgLower g then Plus else Minus @@ -68,7 +72,7 @@ (Minus, Plus) -> LT (Plus , Minus) -> GT (Plus , Plus) -> mgHigher x `compare` mgHigher y - (Minus, Minus) -> mgLower x `compare` mgLower y + (Minus, Minus) -> mgLower y `compare` mgLower x o -> o majorityGauge :: Ord grade => Merit grade -> Maybe (MajorityGauge grade) @@ -81,11 +85,11 @@ [] -> [] (mg,c):_ -> add mg done:go (Map.insert (mgGrade mg) c done) (Map.delete (mgGrade mg) gs) where - add = Map.foldrWithKey $ \g c (MajorityGauge b mg w) -> - if g >= mg then MajorityGauge (b+c) mg w - else MajorityGauge b mg (w+c) + add = Map.foldrWithKey $ \g c (MajorityGauge w mg b) -> + if g >= mg then MajorityGauge w mg (b+c) + else MajorityGauge (w+c) mg b total = List.sum gs - untilMajGrade (t,[]) g c | 2*tc >= total = (tc,[(MajorityGauge 0 g t,c)]) + untilMajGrade (t,[]) g c | 2*tc >= total = (tc,[(MajorityGauge t g 0,c)]) | otherwise = (tc,[]) where tc = t+c untilMajGrade (t,(mg,c):_) _g c' = (t,[(mg{mgHigher=mgHigher mg + c'},c)]) diff --git a/Majority/Judgment.hs b/Majority/Judgment.hs --- a/Majority/Judgment.hs +++ b/Majority/Judgment.hs @@ -2,10 +2,12 @@ ( module Majority.Merit , module Majority.Value , module Majority.Gauge + , module Majority.Rank , module Majority.Section ) where import Majority.Merit import Majority.Value import Majority.Gauge +import Majority.Rank import Majority.Section diff --git a/Majority/Merit.hs b/Majority/Merit.hs --- a/Majority/Merit.hs +++ b/Majority/Merit.hs @@ -3,18 +3,19 @@ module Majority.Merit where import Data.Eq (Eq(..)) +import Data.Foldable (Foldable, foldr) import Data.Function (($), (.)) import Data.Functor (Functor, (<$>), (<$)) import Data.Hashable (Hashable) import Data.List as List import Data.Map.Strict (Map) import Data.Ord (Ord(..)) -import Data.Ratio (Rational) +import Data.Ratio ((%), Rational, denominator) import Data.Semigroup (Semigroup(..)) import Data.Set (Set) import Data.Tuple (curry) import GHC.Exts (IsList(..)) -import Prelude (Bounded(..), Enum(..), Num(..), Integer, error) +import Prelude (Bounded(..), Enum(..), Num(..), Integer, error, lcm) import Text.Show (Show(..)) import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS @@ -64,8 +65,11 @@ rankKey :: [(k, a)] -> [(Ranked k, a)] rankKey = List.zipWith (\i (k,a) -> (Ranked (i,k),a)) [0..] +rank :: Ranked a -> Integer +rank (Ranked (r, _x)) = r + unRank :: Ranked a -> a -unRank (Ranked (_i, x)) = x +unRank (Ranked (_r, x)) = x -- | Return the 'Set' enumerating the alternatives -- of its type parameter. Useful on sum types. @@ -161,9 +165,10 @@ -- | @merit os@ returns the 'Merit' given by opinions 'os' merit :: Ord grade => - Opinions judge grade -> + Foldable opinions => + opinions (Distribution grade) -> Merit grade -merit = foldr insertOpinion $ Merit $ Map.empty +merit = foldr insertOpinion (Merit Map.empty) -- TODO: maybe count by making g passes where insertOpinion dist (Merit m) = @@ -171,6 +176,21 @@ Map.foldlWithKey (\acc g s -> Map.insertWith (+) g s acc) m dist + +meritFromList :: + Ord grade => + Foldable opinions => + Functor opinions => + opinions grade -> + Merit grade +meritFromList = merit . (singleGrade <$>) + +-- | 'normalizeMerit m' multiply all 'Share's +-- by their least common denominator +-- to get integral 'Share's. +normalizeMerit :: Merit grade -> Merit grade +normalizeMerit (Merit ms) = Merit $ (lcm' *) <$> ms + where lcm' = foldr lcm 1 (denominator <$> ms) % 1 -- ** Type 'MeritByChoice' -- | Profile of merit about some 'choice's. diff --git a/Majority/Rank.hs b/Majority/Rank.hs new file mode 100644 --- /dev/null +++ b/Majority/Rank.hs @@ -0,0 +1,110 @@ +{-# OPTIONS -fno-warn-tabs #-} +module Majority.Rank where +import Data.Bool +import Data.Eq (Eq(..)) +import Data.Foldable (Foldable(..)) +import Data.Function (($)) +import Data.Functor ((<$>)) +import Data.Ord (Ord(..)) +import Data.Ratio +import Data.Semigroup (Semigroup(..)) +import Prelude (Integer, Integral(..), Num(..), RealFrac(..), undefined) + +import Majority.Merit hiding (merit) +import Majority.Value + +-- | Number of judges. +type JS = Integer +-- | Number of grades. +type GS = Integer +-- | Rank of grade. +type G = Integer + +-- | 'rankOfMajorityValue gs mv' returns +-- the number of 'MajorityValue' lower than given 'mv'. +rankOfMajorityValue :: GS -> MajorityValue (Ranked grade) -> Integer +rankOfMajorityValue gs mv = + go ((2 *) $ sum $ middleShare <$> mvN) (0,0) mvN + where + MajorityValue mvN = normalizeMajorityValue mv + go :: Rational -> (G,G) -> [Middle (Ranked grade)] -> Integer + go _n _0 [] = 0 + go n (l0,h0) (Middle s low high : ms) + | s <= 0 = go n (l0,h0) ms + | otherwise = + countMiddleFrom (numerator $ n) gs (l0,h0) (rank low, rank high) + + go (n - dn) (0, rank high) (Middle (s - dn * (1%2)) low high : ms) + where dn = if denominator s == 1 then 2 else 1 + +positionOfMajorityValue :: GS -> MajorityValue (Ranked grade) -> Rational +positionOfMajorityValue gs mv = + rankOfMajorityValue gs mv % + countMerits (2 * numerator js) gs + where js = sum $ middleShare <$> unMajorityValue mv + +countMiddleFrom :: JS -> GS -> (G,G) -> (G,G) -> Integer +countMiddleFrom js gs (l0,h0) (l1,h1) = + sum $ countMiddle js gs <$> + if js`mod`2 == 0 then even else odd + where + even = even1 <> even2 <> even3 + odd = [ (l,l) | l<-[l0..l1-1] ] + even1 = + [ (l,h) | l<-[l0] + , h<-[h0..(if l0 GS -> (G,G) -> Integer +countMiddle js gs (l,h) = + -- debug ("countMiddle: js="<>show js<>" gs="<>show gs<>" (l,h)="<>show (l,h)) $ + countMerits side (l+1) * -- NOTE: +1 because 'l' starts at 0 + countMerits side (gs-h) + where side = floor ((js-1)%2) + +-- | (probaMajorityGrades js gs' compute the probability +-- of each grade to be a 'MajorityGrade' given 'js' judges and 'gs' grades. +probaMajorityGrades :: JS -> GS -> [Rational] +probaMajorityGrades js gs = + [ countMiddle js gs (l,l) % d + | l <- [0..gs-1] + ] where d = countMerits js gs + +-- | 'countMerits js gs' +-- returns the number of 'Merit's of size 'js' possible using grades 'gs'. +-- That is the number of ways to divide a segment of length 'js' +-- into at most 'gs' segments whose size is between '0' and 'js'. +countMerits :: JS -> GS -> Integer +countMerits js gs = + -- debug ("countMerits: js="<>show js<>" gs="<>show gs) $ + (js+gs-1)`nCk`(gs-1) + +lastRank :: JS -> GS -> Integer +lastRank js gs = countMerits js gs - 1 + +-- | @'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 [Middle grade] +unMajorityValue (MajorityValue ms) = ms instance Ord grade => Ord (MajorityValue grade) where MajorityValue []`compare`MajorityValue [] = EQ MajorityValue []`compare`MajorityValue ys | all ((==0) . middleShare) ys = EQ @@ -52,7 +58,9 @@ { middleShare :: Share -- ^ the same 'Share' of 'lowGrade' and 'highGrade'. , lowGrade :: grade , highGrade :: grade - } deriving (Eq, Ord, Show) + } deriving (Eq, Ord) +instance Show grade => Show (Middle grade) where + showsPrec p (Middle s l h) = showsPrec p (s,l,h) -- | The 'majorityValue' is the list of the 'Middle's of the 'Merit' of a 'choice', -- from the most consensual to the least. @@ -82,7 +90,7 @@ goBorders lows highs = case (lows,highs) of ((lowGrade,lowShare):ls, (highGrade,highShare):hs) - | lowShare <= 0 -> goBorders ls highs + | lowShare <= 0 -> goBorders ls highs | highShare <= 0 -> goBorders lows hs | otherwise -> let minShare = min lowShare highShare in @@ -91,7 +99,7 @@ ((lowGrade , lowShare - minShare) : ls) ((highGrade, highShare - minShare) : hs) _ -> [] -instance (Show grade, Ord grade) => Ord (Merit grade) where +instance Ord grade => Ord (Merit grade) where compare = compare `on` majorityValue -- | The 'majorityGrade' is the lower middlemost @@ -115,13 +123,13 @@ -- which is the only one which respects consensus: -- any other 'choice' whose grades are all within this middle-interval, -- has a 'majorityGrade' which is greater or equal to this lower middlemost. -majorityGrade :: Show grade => Ord grade => Merit grade -> Maybe grade -majorityGrade m = lowGrade <$> listToMaybe gs where MajorityValue gs = majorityValue m +majorityGrade :: Ord grade => MajorityValue grade -> Maybe grade +majorityGrade (MajorityValue mv) = lowGrade <$> listToMaybe mv -- * Type 'MajorityRanking' type MajorityRanking choice grade = [(choice, MajorityValue grade)] -majorityValueByChoice :: Show grade => Ord grade => MeritByChoice choice grade -> HM.HashMap choice (MajorityValue grade) +majorityValueByChoice :: Ord grade => MeritByChoice choice grade -> HM.HashMap choice (MajorityValue grade) majorityValueByChoice (MeritByChoice ms) = majorityValue <$> ms -- | The 'majorityRanking' ranks all the 'choice's on the basis of their 'grade's. @@ -129,5 +137,32 @@ -- Choice A ranks higher than 'choice' B in the 'majorityRanking' -- if and only if A’s 'majorityValue' is lexicographically above B’s. -- There can be no tie unless two 'choice's have precisely the same 'majorityValue's. -majorityRanking :: Show grade => Ord grade => MeritByChoice choice grade -> MajorityRanking choice grade +majorityRanking :: Ord grade => MeritByChoice choice grade -> MajorityRanking choice grade majorityRanking = List.sortOn (Down . snd) . HM.toList . majorityValueByChoice + +-- | Expand a 'MajorityValue' such that each 'grade' has a 'Share' of '1'. +-- +-- WARNING: the resulting list of 'grade's may have a different length +-- than the list of 'grade's used to build the 'Merit'. +expandValue :: Eq grade => MajorityValue grade -> [grade] +expandValue (MajorityValue ms) = + let lcm' = foldr lcm 1 (denominator . middleShare <$> ms) in + concat $ (<$> ms) $ \(Middle s l h) -> + let r = numerator s * (lcm' `div` denominator s) in + concat (replicate (fromIntegral r) [l, h]) + {- + case r`divMod`2 of + (quo,0) -> concat (replicate (fromIntegral quo) [l, h]) + (quo,_) -> l:concat (replicate (fromIntegral quo) [l, h]) + -} + +-- | 'normalizeMajorityValue m' multiply all 'Share's +-- by their least common denominator to get integral 'Share's. +normalizeMajorityValue :: MajorityValue grade -> MajorityValue grade +normalizeMajorityValue (MajorityValue mv) = + MajorityValue $ (\m -> m{middleShare = lcm' * middleShare m}) <$> mv + where + lcm' = foldr lcm 1 (denominator . middleShare <$> mv) % den + den = case mv of + Middle s _l _h:_ -> denominator s + _ -> 1 diff --git a/hjugement.cabal b/hjugement.cabal --- a/hjugement.cabal +++ b/hjugement.cabal @@ -2,7 +2,7 @@ -- PVP: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 2.0.0.20181030 +version: 2.0.1.20190208 category: Politic synopsis: Majority Judgment. description: @@ -27,11 +27,6 @@ * cahier: (en) * paper: (en) * article: (fr). - . - And, if you do not mind to dive into a quick and poorly documented code, - you can also play around with a Python macro to Libre Office - that I've written and embedded into this spreadsheet: - . extra-doc-files: README.md license: GPL-3 license-file: COPYING @@ -57,6 +52,7 @@ Majority.Gauge Majority.Judgment Majority.Merit + Majority.Rank Majority.Section Majority.Value default-language: Haskell2010 @@ -82,11 +78,23 @@ main-is: Main.hs other-modules: HUnit + HUnit.Merit + HUnit.Rank + HUnit.Section + HUnit.Utils + HUnit.Value QuickCheck + QuickCheck.Gauge + QuickCheck.Merit + QuickCheck.Utils + QuickCheck.Value Types default-language: Haskell2010 default-extensions: - ImplicitPrelude + NoImplicitPrelude + FlexibleInstances + ScopedTypeVariables + TypeFamilies ghc-options: -Wall -Wincomplete-uni-patterns diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,3 @@ -resolver: lts-12.8 +resolver: lts-12.25 packages: - '.' diff --git a/test/HUnit.hs b/test/HUnit.hs --- a/test/HUnit.hs +++ b/test/HUnit.hs @@ -1,731 +1,15 @@ -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module HUnit where - import Test.Tasty -import Test.Tasty.HUnit - -import Control.Arrow (second) -import Data.Hashable (Hashable) -import Data.Ratio ((%)) -import Data.Tree (Tree(..)) -import GHC.Exts (IsList(..)) -import Prelude -import qualified Data.HashMap.Strict as HM - -import Majority.Judgment -import Types +import qualified HUnit.Rank +import qualified HUnit.Merit +import qualified HUnit.Value +import qualified HUnit.Section hunits :: TestTree hunits = testGroup "HUnit" - [ testGroup "MajorityValue" $ - [ testCompareValue - (majorityValue $ Merit [(3,15), (2,7), (1,3), (0::Int,2)]) - (majorityValue $ Merit [(3,16), (2,6), (1,2), (0,3)]) - , testGroup "Merit" - [ let m = mkMerit ['A'..'F'] in - testMajorityValueOfMerits - [ (The, m [136,307,251,148,84,74]) - ] - [ (The, - [ Middle ( 57 % 1) 'C' 'C' - , Middle (137 % 1) 'B' 'C' - , Middle (148 % 1) 'B' 'D' - , Middle ( 22 % 1) 'B' 'E' - , Middle ( 62 % 1) 'A' 'E' - , Middle ( 74 % 1) 'A' 'F' - ]) - ] - , let m = mkMerit [ToReject .. TooGood] in - testMajorityValueOfMerits - [ (This, m [12,10,21,5,5,5,2]) - , (That, m [12,16,22,3,3,3,1]) - ] - [ (This, [ Middle (8 % 1) Acceptable Acceptable - , Middle (5 % 1) Insufficient Acceptable - , Middle (5 % 1) Insufficient Good - , Middle (5 % 1) ToReject VeryGood - , Middle (5 % 1) ToReject Perfect - , Middle (2 % 1) ToReject TooGood - ]) - , (That, [ Middle ( 2 % 1) Acceptable Acceptable - , Middle (16 % 1) Insufficient Acceptable - , Middle ( 2 % 1) ToReject Acceptable - , Middle ( 3 % 1) ToReject Good - , Middle ( 3 % 1) ToReject VeryGood - , Middle ( 3 % 1) ToReject Perfect - , Middle ( 1 % 1) ToReject TooGood - ]) - ] - ] - , testGroup "MajorityRanking" - [ testMajorityValueOfOpinions - [ (The, [No,No,No,No,Yes,Yes]) ] - [ (The, [ Middle (1 % 1) No No - , Middle (2 % 1) No Yes - ]) ] - , testMajorityValueOfOpinions - [ (The, [No,No,No,Yes,Yes,Yes]) ] - [ (The, [ Middle (3 % 1) No Yes ]) ] - , testMajorityValueOfOpinions - [ (The, [No,No,No,No,Yes,Yes,Yes]) ] - [ (The, [ Middle (1 % 2) No No - , Middle (3 % 1) No Yes ]) ] - , testMajorityValueOfOpinions - [ (This, [No,No,No,No,Yes,Yes]) - , (That, [No,Yes,Yes,Yes,Yes,Yes]) - ] - [ (This, [ Middle (1 % 1) No No - , Middle (2 % 1) No Yes - ]) - , (That, [ Middle (2 % 1) Yes Yes - , Middle (1 % 1) No Yes - ]) - ] - , testMajorityValueOfOpinions - [ (This, [No,No,No,No,No,No]) - , (That, [No,No,No,Yes,Yes,Yes]) - ] - [ (This, [Middle (3 % 1) No No]) - , (That, [Middle (3 % 1) No Yes]) - ] - , testMajorityValueOfOpinions - [ (This, [Yes,Yes,Yes,Yes,Yes,Yes]) - , (That, [No,No,No,Yes,Yes,Yes]) - ] - [ (This, [Middle (3 % 1) Yes Yes]) - , (That, [Middle (3 % 1) No Yes]) - ] - , testMajorityValueOfOpinions - [ (This, [No,No,Yes,Yes,Yes,Yes]) - , (That, [No,No,No,Yes,Yes,Yes]) - ] - [ (This, [ Middle (1 % 1) Yes Yes - , Middle (2 % 1) No Yes - ]) - , (That, [ Middle (3 % 1) No Yes ]) - ] - , testMajorityValueOfOpinions - [ (1::Int, [Perfect,Perfect,VeryGood,Perfect,Perfect,Perfect]) - , (2, [Perfect,VeryGood,VeryGood,VeryGood,Good,VeryGood]) - , (3, [Acceptable,Perfect,Good,VeryGood,VeryGood,Perfect]) - , (4, [VeryGood,Good,Acceptable,Good,Good,Good]) - , (5, [Good,Acceptable,VeryGood,Good,Good,Good]) - , (6, [VeryGood,Acceptable,Insufficient,Acceptable,Acceptable,Good]) - ] - [ (1, [ Middle (2 % 1) Perfect Perfect - , Middle (1 % 1) VeryGood Perfect - ]) - , (2, [ Middle (2 % 1) VeryGood VeryGood - , Middle (1 % 1) Good Perfect - ]) - , (3, [ Middle (1 % 1) VeryGood VeryGood - , Middle (1 % 1) Good Perfect - , Middle (1 % 1) Acceptable Perfect - ]) - , (4, [ Middle (2 % 1) Good Good - , Middle (1 % 1) Acceptable VeryGood - ]) - , (5, [ Middle (2 % 1) Good Good - , Middle (1 % 1) Acceptable VeryGood - ]) - , (6, [ Middle (1 % 1) Acceptable Acceptable - , Middle (1 % 1) Acceptable Good - , Middle (1 % 1) Insufficient VeryGood - ]) - ] - ] - , testGroup "Section" - [ testSection "0 judge" - ([]::Choices C2) - ([]::Judges Int G6) - (node0 []) - (Right $ node0 []) - , testSection "1 judge, default grade" - [This] - [(1::Int,ToReject)] - (node0 []) - (Right $ node0 [(This, [(1,[(ToReject,1%1)])])]) - , testSection "1 judge, default grade, 2 choices" - [This, That] - [(1::Int,ToReject)] - (node0 []) - (Right $ node0 [ (This, [(1,[(ToReject,1%1)])]) - , (That, [(1,[(ToReject,1%1)])]) - ]) - , testSection "1 judge, default grade" - [This] - [(1::Int,ToReject)] - (node0 [(This,[(1,Section Nothing Nothing)])]) - (Right $ node0 [(This,[(1,[(ToReject,1%1)])])]) - , testSection "2 judges, default grade" - [This] - [(1::Int,ToReject), (2::Int,ToReject)] - (node0 - [ (This, [(1,Section Nothing Nothing)]) - ]) - (Right $ node0 - [ (This, [ (1,[(ToReject,1%1)]) - , (2,[(ToReject,1%1)]) - ]) - ]) - , testSection "ErrorSection_unknown_choices" - [] - [(1::Int,ToReject)] - (node0 [(This,[])]) - (Left $ ErrorSection_unknown_choices [This]) - , testSection "ErrorSection_unknown_choices" - [] - [(1::Int,ToReject)] - (node0 [(This,[(2,Section Nothing Nothing)])]) - (Left $ ErrorSection_unknown_choices [This]) - , testSection "ErrorSection_unknown_choices" - [This] - [(1::Int,ToReject)] - (node0 [ (This,[(1,Section Nothing Nothing)]) - , (That,[(2,Section Nothing Nothing)]) - ]) - (Left $ ErrorSection_unknown_choices [That]) - , testSection "ErrorSection_unknown_judges" - [This] - [(1::Int,ToReject)] - (node0 [(This,[(2,Section Nothing Nothing)])]) - (Left $ ErrorSection_unknown_judges [(This,[2])]) - , testSection "1 judge, 1 grade" - [This] - [(1::Int,ToReject)] - (node0 [(This,[(1,Section Nothing (Just Acceptable))])]) - (Right $ node0 [(This,[(1,[(Acceptable,1%1)])])]) - , testSection "1 judge, 1 grade, 2 sections" - [This] - [(1::Int,ToReject)] - (Node - [ (This, [(1,Section Nothing (Just Acceptable))]) ] - [ node0 [(This, [(1,Section (Just $ 1%2) Nothing)])] - , node0 [(This, [(1,Section (Just $ 1%2) Nothing)])] - ]) - (Right $ Node - [ (This, [(1,[(Acceptable,1%1)])]) ] - [ node0 [(This, [(1,[(Acceptable,1%1)])])] - , node0 [(This, [(1,[(Acceptable,1%1)])])] - ]) - , testSection "sectionNodeShare with judge" - [This] - [(1::Int,ToReject), (2,Insufficient)] - (Node - [(This, [(1,Section Nothing (Just Acceptable))])] - [ node0 $ SectionNode (Just $ 1%3) [(This, [ (1,Section (Just $ 1%2) Nothing) - , (2,Section Nothing Nothing) - ])] - , node0 [(This, [ (1,Section (Just $ 1%2) Nothing) - , (2,Section Nothing (Just Good)) - ])] - ]) - (Right $ Node - [ (This, [ (1,[(Acceptable,1%2 + 1%2)]) - , (2,[(Insufficient,1%3), (Good,2%3)]) - ]) ] - [ node0 [(This, [ (1,[(Acceptable,1%1)]) - , (2,[(Insufficient,1%1)]) - ])] - , node0 [(This, [ (1,[(Acceptable,1%1)]) - , (2,[(Good,1%1)]) - ])] - ]) - , testSection "sectionNodeShare without judge" - [This] - [(1::Int,ToReject), (2,Insufficient)] - (Node - [(This, [(1,Section Nothing (Just Acceptable))])] - [ node0 $ SectionNode (Just $ 1%3) [(This, [ (1,Section (Just $ 1%2) Nothing) ])] - , node0 [(This, [ (1,Section (Just $ 1%2) Nothing) - , (2,Section Nothing (Just Good)) - ])] - ]) - (Right $ Node - [ (This, [ (1,[(Acceptable,1%2 + 1%2)]) - , (2,[(Insufficient,1%3), (Good,2%3)]) - ]) ] - [ node0 [(This, [ (1,[(Acceptable,1%1)]) - , (2,[(Insufficient,1%1)]) - ])] - , node0 [(This, [ (1,[(Acceptable,1%1)]) - , (2,[(Good,1%1)]) - ])] - ]) - , testSection "1 judge, 2 grades, 2 sections" - [This] - [(1::Int,ToReject)] - (Node - [ (This, [(1,Section Nothing (Just Acceptable))]) ] - [ node0 [(This, [(1,Section (Just $ 1%2) Nothing)])] - , node0 [(This, [(1,Section (Just $ 1%2) (Just Good))])] - ]) - (Right $ Node - [(This, [(1,[(Acceptable,1%2), (Good,1%2)])])] - [ node0 [(This, [(1,[(Acceptable,1%1)])])] - , node0 [(This, [(1,[(Good,1%1)])])] - ]) - , testSection "1 judge, 2 grades, 2 sections (1 default)" - [This] - [(1::Int,ToReject)] - (Node - [ (This, [(1,Section Nothing (Just Acceptable))]) ] - [ node0 [(This, [(1,Section Nothing Nothing)])] - , node0 [(This, [(1,Section (Just $ 1%2) (Just Good))])] - ]) - (Right $ Node - [(This, [(1,[(Acceptable,1%2), (Good,1%2)])])] - [ node0 [(This, [(1,[(Acceptable,1%1)])])] - , node0 [(This, [(1,[(Good,1%1)])])] - ]) - , testSection "1 judge, 3 grades, 3 sections (2 default)" - [This] - [(1::Int,ToReject)] - (Node - [ (This, [(1,Section Nothing (Just Acceptable))]) ] - [ node0 [(This, [(1,Section Nothing Nothing)])] - , node0 [(This, [(1,Section (Just $ 1%2) (Just Good))])] - , node0 [(This, [(1,Section Nothing (Just VeryGood))])] - ]) - (Right $ Node - [(This, [(1,[(Acceptable,1%4), (Good,1%2), (VeryGood,1%4)])])] - [ node0 [(This, [(1,[(Acceptable,1%1)])])] - , node0 [(This, [(1,[(Good,1%1)])])] - , node0 [(This, [(1,[(VeryGood,1%1)])])] - ]) - , testSection "ErrorSection_invalid_shares sum not 1" - [This] - [(1::Int,ToReject)] - (Node - [ (This, [(1,Section Nothing (Just Acceptable))]) ] - [ node0 [(This, [(1,Section (Just $ 1%2) Nothing)])] - , node0 [(This, [(1,Section (Just $ 1%3) (Just Good))])] - ]) - (Left $ ErrorSection_invalid_shares [(This, [(1,[1%2,1%3])])]) - , testSection "ErrorSection_invalid_shares negative share" - [This] - [(1::Int,ToReject)] - (Node - [ (This, [(1,Section Nothing (Just Acceptable))]) ] - [ node0 [(This, [(1,Section (Just $ 1%2) Nothing)])] - , node0 [(This, [(1,Section (Just $ -1%2) (Just Good))])] - ]) - (Left $ ErrorSection_invalid_shares [(This, [(1,[1%2,-1%2])])]) - , testSection "2 judges, 3 grade, 3 sections (1 default)" - [This] - [(1::Int,ToReject), (2::Int,ToReject)] - (Node - [ (This, [(1,Section Nothing (Just Acceptable))]) - ] - [ node0 - [ (This, [(1,Section Nothing Nothing)]) - ] - , node0 - [ (This, [(1,Section (Just $ 1%2) (Just Good))]) - ] - ]) - (Right $ Node - [ (This, [ (1,[(Acceptable,1%2), (Good,1%2)]) - , (2,[(ToReject,1%1)]) - ]) - ] - [ node0 - [ (This, [ (1,[(Acceptable,1%1)]) - , (2,[(ToReject,1%1)]) - ]) - ] - , node0 - [ (This, [ (1,[(Good,1%1)]) - , (2,[(ToReject,1%1)]) - ]) - ] - ]) - , testSection "2 judges, 4 grades, 5 sections (2 defaults)" - [This] - [(1::Int,ToReject), (2::Int,ToReject)] - (Node - [ (This, [(1,Section Nothing (Just Acceptable))]) - ] - [ node0 - [ (This, [(1,Section Nothing Nothing)]) - ] - , node0 - [ (This, [(1,Section (Just $ 1%2) (Just Good))]) - ] - , Node - [ (This, [(1,Section Nothing (Just Good))]) - ] - [ node0 - [ (This, [ (1,Section Nothing (Just VeryGood)) - , (2,Section Nothing (Just Insufficient)) - ]) - ] - ] - ]) - (Right $ Node - [ (This, [ (1,[(Acceptable,1%4), (Good,1%2), (VeryGood,1%4)]) - , (2,[(ToReject,2%3), (Insufficient,1%3)]) - ]) - ] - [ node0 - [ (This, [ (1,[(Acceptable,1%1)]) - , (2,[(ToReject,1%1)]) - ]) - ] - , node0 - [ (This, [ (1,[(Good,1%1)]) - , (2,[(ToReject,1%1)]) - ]) - ] - , Node - [ (This, [ (1,[(VeryGood,1%1)]) - , (2,[(Insufficient,1%1)]) - ]) - ] - [ node0 - [ (This, [ (1,[(VeryGood,1%1)]) - , (2,[(Insufficient,1%1)]) - ]) - ] - ] - ]) - , testSection "1 judge, default grade, 2 choices" - [This, That] - [(1::Int,ToReject)] - (node0 []) - (Right $ node0 [ (This,[(1,[(ToReject,1%1)])]) - , (That,[(1,[(ToReject,1%1)])]) - ]) - , testSection "2 judges, 2 choices" - [This, That] - [(1::Int,ToReject), (2::Int,ToReject)] - (Node - [ ] - [ node0 - [ (This, [(1,Section Nothing (Just Good))]) - , (That, [(2,Section Nothing (Just Insufficient))]) - ] - , node0 - [ (This, [(1,Section Nothing (Just Acceptable))]) - , (That, [(2,Section Nothing (Just VeryGood))]) - ] - ]) - (Right $ Node - [ (This, [ (1,[(Good,1%2), (Acceptable,1%2)]) - , (2,[(ToReject,1%1)]) - ]) - , (That, [ (1,[(ToReject,1%1)]) - , (2,[(Insufficient,1%2), (VeryGood,1%2)]) - ]) - ] - [ node0 [ (This, [ (1,[(Good,1%1)]) - , (2,[(ToReject,1%1)]) - ]) - , (That, [ (1,[(ToReject,1%1)]) - , (2,[(Insufficient,1%1)]) - ]) - ] - , node0 [ (This, [ (1,[(Acceptable,1%1)]) - , (2,[(ToReject,1%1)]) - ]) - , (That, [ (1,[(ToReject,1%1)]) - , (2,[(VeryGood,1%1)]) - ]) - ] - ]) - , testSection "1 judge, 1 choice" - [This] - [(1::Int,ToReject)] - (Node [] - [ node0 [ (This, [(1,Section (Just $ 1%8) (Just Acceptable))]) - ] - , node0 [ (This, [(1,Section Nothing Nothing)]) - ] - ]) - (Right $ Node - [ (This, [(1,[(Acceptable,1%8), (ToReject,7%8)])]) - ] - [ node0 [ (This, [(1,[(Acceptable, 1%1)])]) - ] - , node0 [ (This, [(1,[(ToReject, 1%1)])]) - ] - ]) - , testSection "1 judge, 1 choice (missing judge)" - [This] - [(1::Int,ToReject)] - (Node [] - [ node0 [ (This, [(1,Section (Just $ 1%8) (Just Acceptable))]) - ] - , node0 [ (This, []) - ] - ]) - (Right $ Node - [ (This, [(1,[(Acceptable,1%8), (ToReject,7%8)])]) - ] - [ node0 [ (This, [(1,[(Acceptable, 1%1)])]) - ] - , node0 [ (This, [(1,[(ToReject, 1%1)])]) - ] - ]) - , testSection "1 judge, 1 choice (missing judge)" - [This] - [(1::Int,ToReject)] - (Node [] - [ node0 [ (This, []) - ] - , node0 [ (This, [(1,Section (Just $ 1%8) (Just Acceptable))]) - ] - ]) - (Right $ Node - [ (This, [(1,[(Acceptable,1%8), (ToReject,7%8)])]) - ] - [ node0 [ (This, [(1,[(ToReject, 1%1)])]) - ] - , node0 [ (This, [(1,[(Acceptable, 1%1)])]) - ] - ]) - , testSection "1 judge, 1 choice (missing choice)" - [This] - [(1::Int,ToReject)] - (Node [] - [ node0 [ (This, [(1,Section (Just $ 1%8) (Just Acceptable))]) - ] - , node0 [ - ] - ]) - (Right $ Node - [ (This, [(1,[(Acceptable,1%8), (ToReject,7%8)])]) - ] - [ node0 [ (This, [(1,[(Acceptable, 1%1)])]) - ] - , node0 [ (This, [(1,[(ToReject, 1%1)])]) - ] - ]) - , testSection "1 judge, 1 choice (missing choice)" - [This] - [(1::Int,ToReject)] - (Node [] - [ node0 [ - ] - , node0 [ (This, [(1,Section (Just $ 1%8) (Just Acceptable))]) - ] - ]) - (Right $ Node - [ (This, [(1,[(Acceptable,1%8), (ToReject,7%8)])]) - ] - [ node0 [ (This, [(1,[(ToReject, 1%1)])]) - ] - , node0 [ (This, [(1,[(Acceptable, 1%1)])]) - ] - ]) - , testSection "2 judges, 2 choices" - [This, That] - [(1::Int,ToReject), (2::Int,ToReject)] - (node0 - [ (This, [(1,Section Nothing (Just Acceptable))]) - , (That, [(2,Section (Just $ 1%8) (Just VeryGood))]) - ]) - (Right $ node0 - [ (This, [ (1,[(Acceptable,1%1)]) - , (2,[(ToReject,1%1)]) - ]) - , (That, [ (1,[(ToReject,1%1)]) - , (2,[(VeryGood,1%1)]) - ]) - ]) - , testSection "2 judges, 2 choices" - [This, That] - [(1::Int,ToReject), (2::Int,ToReject)] - (Node - [ ] - [ node0 - [ (This, [(1,Section Nothing (Just Good))]) - , (That, [(2,Section Nothing (Just Insufficient))]) - ] - , node0 - [ (This, [(1,Section Nothing (Just Acceptable))]) - , (That, [(2,Section (Just $ 1%8) (Just VeryGood))]) - ] - ]) - (Right $ Node - [ (This, [ (1,[(Good,1%2), (Acceptable,1%2)]) - , (2,[(ToReject,1%1)]) - ]) - , (That, [ (1,[(ToReject,1%1)]) - , (2,[(Insufficient,7%8), (VeryGood,1%8)]) - ]) - ] - [ node0 [ (This, [ (1,[(Good,1%1)]) - , (2,[(ToReject,1%1)]) - ]) - , (That, [ (1,[(ToReject,1%1)]) - , (2,[(Insufficient,1%1)]) - ]) - ] - , node0 [ (This, [ (1,[(Acceptable,1%1)]) - , (2,[(ToReject,1%1)]) - ]) - , (That, [ (1,[(ToReject,1%1)]) - , (2,[(VeryGood,1%1)]) - ]) - ] - ]) - , testSection "2 judges, 2 choices" - [This, That] - [(1::Int,ToReject), (2::Int,ToReject)] - (Node [ (This, [(1,Section Nothing (Just Acceptable))]) - ] - [ node0 [ (This, [(1,Section Nothing Nothing)]) - ] - , node0 [ (This, [ (1,Section (Just $ 1%2) (Just Good)) ]) - , (That, [ (1,Section (Just $ 1%3) Nothing) - , (2,Section (Just $ 1%5) (Just Insufficient)) - ]) - ] - , Node [ (This, [(1,Section Nothing (Just Good))]) - , (That, [(2,Section Nothing (Just VeryGood))]) - ] - [ node0 [ (This, [ (1,Section Nothing (Just VeryGood)) - , (2,Section Nothing (Just Insufficient)) - ]) - , (That, [ (1,Section Nothing (Just Acceptable)) ]) - ] - , node0 [ (This, [ (1,Section Nothing (Just Acceptable)) - ]) - , (That, [ (1,Section Nothing (Just VeryGood)) - , (2,Section Nothing (Just Good)) - ]) - ] - ] - ]) - (Right $ - Node [ (This, [ (1,[(Acceptable,1%4 + 1%8), (Good,1%2), (VeryGood,1%8)]) - , (2,[(ToReject,1%3 + 1%3 + 1%6), (Insufficient,1%6)]) - ]) - , (That, [ (1,[(ToReject,1%3 + 1%3), (Acceptable,1%6), (VeryGood,1%6)]) - , (2,[(ToReject,4%10), (Insufficient,1%5), (VeryGood,4%20), (Good,4%20)]) - ]) - ] - [ node0 [ (This, [ (1,[(Acceptable,1%1)]) -- 1%4 - , (2,[(ToReject,1%1)]) -- 1%3 - ]) - , (That, [ (1,[(ToReject,1%1)]) -- 1%3 - , (2,[(ToReject,1%1)]) -- 4%10 - ]) - ] - , node0 [ (This, [ (1,[(Good,1%1)]) -- 1%2 - , (2,[(ToReject,1%1)]) -- 1%3 - ]) - , (That, [ (1,[(ToReject,1%1)]) -- 1%3 - , (2,[(Insufficient,1%1)]) -- 1%5 - ]) - ] - , Node [ (This, [ (1,[(VeryGood,1%2), (Acceptable,1%2)]) -- 1%4 - , (2,[(Insufficient,1%2), (ToReject,1%2)]) -- 1%3 - ]) - , (That, [ (1,[(Acceptable,1%2), (VeryGood,1%2)]) -- 1%3 - , (2,[(VeryGood,1%2), (Good,1%2)]) -- 4%10 - ]) - ] - [ node0 [ (This, [ (1,[(VeryGood,1%1)]) - , (2,[(Insufficient,1%1)]) - ]) - , (That, [ (1,[(Acceptable,1%1)]) - , (2,[(VeryGood,1%1)]) - ]) - ] - , node0 [ (This, [ (1,[(Acceptable,1%1)]) - , (2,[(ToReject,1%1)]) - ]) - , (That, [ (1,[(VeryGood,1%1)]) - , (2,[(Good,1%1)]) - ]) - ] - ] - ] - ) - ] - ] - ] - -elide :: String -> String -elide s | length s > 42 = take 42 s ++ ['…'] - | otherwise = s - -mkMerit :: (Ord grade, Show grade) => [grade] -> [Share] -> Merit grade -mkMerit gs = fromList . (gs`zip`) - -mkMeritByChoice :: - (Eq choice, Hashable choice, Ord grade) => - [(choice,[grade])] -> - MeritByChoice choice grade -mkMeritByChoice os = - meritByChoice $ fromList $ - second (fromList . zip [1::Int ..] . (singleGrade <$>)) <$> os - -testCompareValue :: (Ord grade, Show grade) => - MajorityValue grade -> MajorityValue grade -> TestTree -testCompareValue x y = - testGroup (elide $ show (unMajorityValue x, unMajorityValue y)) - [ testCase "x == x" $ x`compare`x @?= EQ - , testCase "y == y" $ y`compare`y @?= EQ - , testCase "x < y" $ x`compare`y @?= LT - , testCase "y > x" $ y`compare`x @?= GT + [ HUnit.Merit.hunit + , HUnit.Value.hunit + , HUnit.Rank.hunit + , HUnit.Section.hunit ] - -testMajorityRanking :: - (Eq choice, Hashable choice, Ord grade, Show grade, Show choice) => - [(choice, [grade])] -> - MajorityRanking choice grade -> TestTree -testMajorityRanking os expect = - testCase (elide $ show os) $ - majorityRanking (mkMeritByChoice os) @?= expect - -testMajorityValueOfOpinions :: - (Show grade, Show choice, Ord grade, Eq choice, Hashable choice) => - [(choice, [grade])] -> - [(choice, [Middle grade])] -> TestTree -testMajorityValueOfOpinions os expect = - testCase (elide $ show os) $ - majorityValueByChoice (mkMeritByChoice os) - @?= (MajorityValue<$>HM.fromList expect) - -testMajorityValueOfMerits :: - (Show grade, Show choice, Ord grade, Eq choice, Hashable choice) => - MeritByChoice choice grade -> - [(choice, [Middle grade])] -> TestTree -testMajorityValueOfMerits ms expect = - testCase (elide $ show $ unMeritByChoice ms) $ - majorityValueByChoice ms - @?= (MajorityValue<$>HM.fromList expect) - -testSection :: - Eq choice => - Hashable choice => - Eq judge => - Hashable judge => - Ord grade => - Show choice => - Show judge => - Show grade => - String -> - Choices choice -> - Judges judge grade -> - Tree (SectionNode choice judge grade) -> - Either (ErrorSection choice judge grade) - (Tree (OpinionsByChoice choice judge grade)) -> - TestTree -testSection msg cs js ss expect = - testCase (elide msg) $ - opinionsBySection cs js ss @?= expect - -node0 :: a -> Tree a -node0 = (`Node`[]) - -instance (Eq choice, Hashable choice) => IsList (SectionNode choice judge grade) where - type Item (SectionNode choice judge grade) = (choice, SectionByJudge judge grade) - fromList = SectionNode Nothing . fromList - toList = GHC.Exts.toList . sectionByJudgeByChoice diff --git a/test/HUnit/Merit.hs b/test/HUnit/Merit.hs new file mode 100644 --- /dev/null +++ b/test/HUnit/Merit.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedLists #-} +module HUnit.Merit where +import Control.Arrow (second) +import Data.Int (Int) +import Data.Eq (Eq(..)) +import Data.Function (($), (.)) +import Data.Functor ((<$>)) +import Data.Hashable (Hashable) +import Data.List (zip) +import Data.Ord (Ord(..)) +import Data.Ratio ((%)) +import GHC.Exts (IsList(..)) +import Text.Show (Show(..)) +import qualified Data.HashMap.Strict as HM + +import Test.Tasty +import Test.Tasty.HUnit +import Majority.Judgment +import HUnit.Utils +import Types + +hunit :: TestTree +hunit = testGroup "Merit" + [ let m = mkMerit ['A'..'F'] in + testMajorityValueOfMerits + [ (The, m [136,307,251,148,84,74]) + ] + [ (The, + [ Middle ( 57 % 1) 'C' 'C' + , Middle (137 % 1) 'B' 'C' + , Middle (148 % 1) 'B' 'D' + , Middle ( 22 % 1) 'B' 'E' + , Middle ( 62 % 1) 'A' 'E' + , Middle ( 74 % 1) 'A' 'F' + ]) + ] + , let m = mkMerit [ToReject .. TooGood] in + testMajorityValueOfMerits + [ (This, m [12,10,21,5,5,5,2]) + , (That, m [12,16,22,3,3,3,1]) + ] + [ (This, [ Middle (8 % 1) Acceptable Acceptable + , Middle (5 % 1) Insufficient Acceptable + , Middle (5 % 1) Insufficient Good + , Middle (5 % 1) ToReject VeryGood + , Middle (5 % 1) ToReject Perfect + , Middle (2 % 1) ToReject TooGood + ]) + , (That, [ Middle ( 2 % 1) Acceptable Acceptable + , Middle (16 % 1) Insufficient Acceptable + , Middle ( 2 % 1) ToReject Acceptable + , Middle ( 3 % 1) ToReject Good + , Middle ( 3 % 1) ToReject VeryGood + , Middle ( 3 % 1) ToReject Perfect + , Middle ( 1 % 1) ToReject TooGood + ]) + ] + ] +mkMerit :: (Ord grade, Show grade) => [grade] -> [Share] -> Merit grade +mkMerit gs = fromList . (gs`zip`) + +mkMeritByChoice :: + (Eq choice, Hashable choice, Ord grade) => + [(choice,[grade])] -> + MeritByChoice choice grade +mkMeritByChoice os = + meritByChoice $ fromList $ + second (fromList . zip [1::Int ..] . (singleGrade <$>)) <$> os + +testMajorityValueOfMerits :: + (Show grade, Show choice, Ord grade, Eq choice, Hashable choice) => + MeritByChoice choice grade -> + [(choice, [Middle grade])] -> TestTree +testMajorityValueOfMerits ms expect = + testCase (elide $ show $ unMeritByChoice ms) $ + majorityValueByChoice ms + @?= (MajorityValue<$>HM.fromList expect) + diff --git a/test/HUnit/Rank.hs b/test/HUnit/Rank.hs new file mode 100644 --- /dev/null +++ b/test/HUnit/Rank.hs @@ -0,0 +1,116 @@ +module HUnit.Rank where +import Data.Bool +import Data.Eq (Eq(..)) +import Data.Foldable (Foldable(..)) +import Data.Function (($), (.)) +import Data.Functor ((<$>)) +import Data.List +import Data.Ord (Ord(..)) +import Data.Semigroup (Semigroup(..)) +import Data.Ratio +import GHC.Exts (IsList(..)) +import Majority.Judgment +import Prelude (Integer, Num(..), fromIntegral) +import Test.Tasty +import Test.Tasty.HUnit +import Text.Show (Show(..)) + +import QuickCheck.Merit () +import QuickCheck.Value () + +hunit :: TestTree +hunit = testGroup "Rank" + [ testGroup "lexicographic" + [ testLexRank 1 1 + , testLexRank 5 4 + , testLexRank 5 5 + , testLexRank 10 5 + , testLexRank 15 5 + ] + , testGroup "majority" + [ testMajRank 1 1 + , testMajRank 5 4 + , testMajRank 5 5 + , testMajRank 10 5 + , testMajRank 15 5 + , testMajRank 25 4 + ] + ] + +testLexRank :: JS -> GS -> TestTree +testLexRank js gs = + testGroup ("js="<>show js<>" gs="<>show gs) + [ testCase "rankOfMerit" $ + rankOfMerit gs <$> merits js gs + @?= [0..lastRank js gs] + , testCase "Rank -> Merit -> Rank" $ + let ranks = [0..lastRank js gs] in + rankOfMerit gs . + meritOfRank js gs + <$> ranks @?= ranks + , testCase "Merit -> Rank -> Merit" $ + let dists = merits js gs in + meritOfRank js gs . + rankOfMerit gs + <$> dists @?= dists + ] + +testMajRank :: JS -> GS -> TestTree +testMajRank js gs = + testGroup ("js="<>show js<>" gs="<>show gs) + [ testCase "rankOfMajorityValue" $ + rankOfMajorityValue gs <$> majorityValues js gs + @?= [0..lastRank js gs] + ] + +-- | Generate all distributions possible, in lexicographic order. +merits :: JS -> GS -> [[G]] +merits js0 gs = go 0 js0 + where + go g js + | g == gs - 1 = [replicate (fromIntegral js) g] + | otherwise = concat + [ (replicate (fromIntegral r) g <>) <$> go (g+1) (js-r) + | r <- reverse [0..js] + ] + +-- | Generate all distributions possible, in majority order. +majorityValues :: JS -> GS -> [MajorityValue (Ranked ())] +majorityValues js0 gs = sort $ majorityValue . fromList <$> go 0 js0 + where + go g js + | g == gs - 1 = [[(Ranked (g, ()), js%1)]] + | otherwise = concat + [ ((Ranked (g, ()), r%1) :) <$> go (g+1) (js-r) + | r <- reverse [0..js] + ] + +rankOfMerit :: GS -> [Integer] -> Integer +rankOfMerit gsI dist = go 0 ranks dist + where + js = fromIntegral $ length dist + gs = fromIntegral gsI + ranks = reverse $ reverse . take gs <$> take js pascalDiagonals + go g0 (p:ps) (d:ds) = + sum (take dI p) + + go d (drop dI <$> ps) ds + where dI = fromIntegral (d - g0) + go _ _ _ = 0 + +meritOfRank :: JS -> GS -> Integer -> [Integer] +meritOfRank jsI gsI = go 0 ranks + where + js = fromIntegral jsI + gs = fromIntegral gsI + ranks = reverse $ reverse . take gs <$> take js pascalDiagonals + go _g0 [] _r = [] + go g0 (p:ps) r = g : go g (drop s <$> ps) (r-dr) + where + skip = takeWhile (<= r) $ scanl1 (+) p + s = length skip + g = g0 + fromIntegral s + dr = if null skip then 0 else last skip + +-- | Diagonals of Pascal's triangle. +pascalDiagonals :: [[Integer]] +pascalDiagonals = repeat 1 : (scanl1 (+) <$> pascalDiagonals) diff --git a/test/HUnit/Section.hs b/test/HUnit/Section.hs new file mode 100644 --- /dev/null +++ b/test/HUnit/Section.hs @@ -0,0 +1,565 @@ +{-# LANGUAGE OverloadedLists #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module HUnit.Section where +import Data.Either (Either(..)) +import Data.Eq (Eq(..)) +import Data.Function (($), (.)) +import Data.Hashable (Hashable) +import Data.Int (Int) +import Data.Maybe (Maybe(..)) +import Data.Ord (Ord(..)) +import Data.Ratio ((%)) +import Data.String (String) +import Data.Tree (Tree(..)) +import GHC.Exts (IsList(..)) +import Prelude (Num(..)) +import Test.Tasty +import Test.Tasty.HUnit +import Text.Show (Show(..)) + +import Majority.Judgment +import HUnit.Utils +import Types + +hunit :: TestTree +hunit = testGroup "Section" + [ testSection "0 judge" + ([]::Choices C2) + ([]::Judges Int G6) + (node0 []) + (Right $ node0 []) + , testSection "1 judge, default grade" + [This] + [(1::Int,ToReject)] + (node0 []) + (Right $ node0 [(This, [(1,[(ToReject,1%1)])])]) + , testSection "1 judge, default grade, 2 choices" + [This, That] + [(1::Int,ToReject)] + (node0 []) + (Right $ node0 [ (This, [(1,[(ToReject,1%1)])]) + , (That, [(1,[(ToReject,1%1)])]) + ]) + , testSection "1 judge, default grade" + [This] + [(1::Int,ToReject)] + (node0 [(This,[(1,Section Nothing Nothing)])]) + (Right $ node0 [(This,[(1,[(ToReject,1%1)])])]) + , testSection "2 judges, default grade" + [This] + [(1::Int,ToReject), (2::Int,ToReject)] + (node0 + [ (This, [(1,Section Nothing Nothing)]) + ]) + (Right $ node0 + [ (This, [ (1,[(ToReject,1%1)]) + , (2,[(ToReject,1%1)]) + ]) + ]) + , testSection "ErrorSection_unknown_choices" + [] + [(1::Int,ToReject)] + (node0 [(This,[])]) + (Left $ ErrorSection_unknown_choices [This]) + , testSection "ErrorSection_unknown_choices" + [] + [(1::Int,ToReject)] + (node0 [(This,[(2,Section Nothing Nothing)])]) + (Left $ ErrorSection_unknown_choices [This]) + , testSection "ErrorSection_unknown_choices" + [This] + [(1::Int,ToReject)] + (node0 [ (This,[(1,Section Nothing Nothing)]) + , (That,[(2,Section Nothing Nothing)]) + ]) + (Left $ ErrorSection_unknown_choices [That]) + , testSection "ErrorSection_unknown_judges" + [This] + [(1::Int,ToReject)] + (node0 [(This,[(2,Section Nothing Nothing)])]) + (Left $ ErrorSection_unknown_judges [(This,[2])]) + , testSection "1 judge, 1 grade" + [This] + [(1::Int,ToReject)] + (node0 [(This,[(1,Section Nothing (Just Acceptable))])]) + (Right $ node0 [(This,[(1,[(Acceptable,1%1)])])]) + , testSection "1 judge, 1 grade, 2 sections" + [This] + [(1::Int,ToReject)] + (Node + [ (This, [(1,Section Nothing (Just Acceptable))]) ] + [ node0 [(This, [(1,Section (Just $ 1%2) Nothing)])] + , node0 [(This, [(1,Section (Just $ 1%2) Nothing)])] + ]) + (Right $ Node + [ (This, [(1,[(Acceptable,1%1)])]) ] + [ node0 [(This, [(1,[(Acceptable,1%1)])])] + , node0 [(This, [(1,[(Acceptable,1%1)])])] + ]) + , testSection "sectionNodeShare with judge" + [This] + [(1::Int,ToReject), (2,Insufficient)] + (Node + [(This, [(1,Section Nothing (Just Acceptable))])] + [ node0 $ SectionNode (Just $ 1%3) [(This, [ (1,Section (Just $ 1%2) Nothing) + , (2,Section Nothing Nothing) + ])] + , node0 [(This, [ (1,Section (Just $ 1%2) Nothing) + , (2,Section Nothing (Just Good)) + ])] + ]) + (Right $ Node + [ (This, [ (1,[(Acceptable,1%2 + 1%2)]) + , (2,[(Insufficient,1%3), (Good,2%3)]) + ]) ] + [ node0 [(This, [ (1,[(Acceptable,1%1)]) + , (2,[(Insufficient,1%1)]) + ])] + , node0 [(This, [ (1,[(Acceptable,1%1)]) + , (2,[(Good,1%1)]) + ])] + ]) + , testSection "sectionNodeShare without judge" + [This] + [(1::Int,ToReject), (2,Insufficient)] + (Node + [(This, [(1,Section Nothing (Just Acceptable))])] + [ node0 $ SectionNode (Just $ 1%3) [(This, [ (1,Section (Just $ 1%2) Nothing) ])] + , node0 [(This, [ (1,Section (Just $ 1%2) Nothing) + , (2,Section Nothing (Just Good)) + ])] + ]) + (Right $ Node + [ (This, [ (1,[(Acceptable,1%2 + 1%2)]) + , (2,[(Insufficient,1%3), (Good,2%3)]) + ]) ] + [ node0 [(This, [ (1,[(Acceptable,1%1)]) + , (2,[(Insufficient,1%1)]) + ])] + , node0 [(This, [ (1,[(Acceptable,1%1)]) + , (2,[(Good,1%1)]) + ])] + ]) + , testSection "1 judge, 2 grades, 2 sections" + [This] + [(1::Int,ToReject)] + (Node + [ (This, [(1,Section Nothing (Just Acceptable))]) ] + [ node0 [(This, [(1,Section (Just $ 1%2) Nothing)])] + , node0 [(This, [(1,Section (Just $ 1%2) (Just Good))])] + ]) + (Right $ Node + [(This, [(1,[(Acceptable,1%2), (Good,1%2)])])] + [ node0 [(This, [(1,[(Acceptable,1%1)])])] + , node0 [(This, [(1,[(Good,1%1)])])] + ]) + , testSection "1 judge, 2 grades, 2 sections (1 default)" + [This] + [(1::Int,ToReject)] + (Node + [ (This, [(1,Section Nothing (Just Acceptable))]) ] + [ node0 [(This, [(1,Section Nothing Nothing)])] + , node0 [(This, [(1,Section (Just $ 1%2) (Just Good))])] + ]) + (Right $ Node + [(This, [(1,[(Acceptable,1%2), (Good,1%2)])])] + [ node0 [(This, [(1,[(Acceptable,1%1)])])] + , node0 [(This, [(1,[(Good,1%1)])])] + ]) + , testSection "1 judge, 3 grades, 3 sections (2 default)" + [This] + [(1::Int,ToReject)] + (Node + [ (This, [(1,Section Nothing (Just Acceptable))]) ] + [ node0 [(This, [(1,Section Nothing Nothing)])] + , node0 [(This, [(1,Section (Just $ 1%2) (Just Good))])] + , node0 [(This, [(1,Section Nothing (Just VeryGood))])] + ]) + (Right $ Node + [(This, [(1,[(Acceptable,1%4), (Good,1%2), (VeryGood,1%4)])])] + [ node0 [(This, [(1,[(Acceptable,1%1)])])] + , node0 [(This, [(1,[(Good,1%1)])])] + , node0 [(This, [(1,[(VeryGood,1%1)])])] + ]) + , testSection "ErrorSection_invalid_shares sum not 1" + [This] + [(1::Int,ToReject)] + (Node + [ (This, [(1,Section Nothing (Just Acceptable))]) ] + [ node0 [(This, [(1,Section (Just $ 1%2) Nothing)])] + , node0 [(This, [(1,Section (Just $ 1%3) (Just Good))])] + ]) + (Left $ ErrorSection_invalid_shares [(This, [(1,[1%2,1%3])])]) + , testSection "ErrorSection_invalid_shares negative share" + [This] + [(1::Int,ToReject)] + (Node + [ (This, [(1,Section Nothing (Just Acceptable))]) ] + [ node0 [(This, [(1,Section (Just $ 1%2) Nothing)])] + , node0 [(This, [(1,Section (Just $ -1%2) (Just Good))])] + ]) + (Left $ ErrorSection_invalid_shares [(This, [(1,[1%2,-1%2])])]) + , testSection "2 judges, 3 grade, 3 sections (1 default)" + [This] + [(1::Int,ToReject), (2::Int,ToReject)] + (Node + [ (This, [(1,Section Nothing (Just Acceptable))]) + ] + [ node0 + [ (This, [(1,Section Nothing Nothing)]) + ] + , node0 + [ (This, [(1,Section (Just $ 1%2) (Just Good))]) + ] + ]) + (Right $ Node + [ (This, [ (1,[(Acceptable,1%2), (Good,1%2)]) + , (2,[(ToReject,1%1)]) + ]) + ] + [ node0 + [ (This, [ (1,[(Acceptable,1%1)]) + , (2,[(ToReject,1%1)]) + ]) + ] + , node0 + [ (This, [ (1,[(Good,1%1)]) + , (2,[(ToReject,1%1)]) + ]) + ] + ]) + , testSection "2 judges, 4 grades, 5 sections (2 defaults)" + [This] + [(1::Int,ToReject), (2::Int,ToReject)] + (Node + [ (This, [(1,Section Nothing (Just Acceptable))]) + ] + [ node0 + [ (This, [(1,Section Nothing Nothing)]) + ] + , node0 + [ (This, [(1,Section (Just $ 1%2) (Just Good))]) + ] + , Node + [ (This, [(1,Section Nothing (Just Good))]) + ] + [ node0 + [ (This, [ (1,Section Nothing (Just VeryGood)) + , (2,Section Nothing (Just Insufficient)) + ]) + ] + ] + ]) + (Right $ Node + [ (This, [ (1,[(Acceptable,1%4), (Good,1%2), (VeryGood,1%4)]) + , (2,[(ToReject,2%3), (Insufficient,1%3)]) + ]) + ] + [ node0 + [ (This, [ (1,[(Acceptable,1%1)]) + , (2,[(ToReject,1%1)]) + ]) + ] + , node0 + [ (This, [ (1,[(Good,1%1)]) + , (2,[(ToReject,1%1)]) + ]) + ] + , Node + [ (This, [ (1,[(VeryGood,1%1)]) + , (2,[(Insufficient,1%1)]) + ]) + ] + [ node0 + [ (This, [ (1,[(VeryGood,1%1)]) + , (2,[(Insufficient,1%1)]) + ]) + ] + ] + ]) + , testSection "1 judge, default grade, 2 choices" + [This, That] + [(1::Int,ToReject)] + (node0 []) + (Right $ node0 [ (This,[(1,[(ToReject,1%1)])]) + , (That,[(1,[(ToReject,1%1)])]) + ]) + , testSection "2 judges, 2 choices" + [This, That] + [(1::Int,ToReject), (2::Int,ToReject)] + (Node + [ ] + [ node0 + [ (This, [(1,Section Nothing (Just Good))]) + , (That, [(2,Section Nothing (Just Insufficient))]) + ] + , node0 + [ (This, [(1,Section Nothing (Just Acceptable))]) + , (That, [(2,Section Nothing (Just VeryGood))]) + ] + ]) + (Right $ Node + [ (This, [ (1,[(Good,1%2), (Acceptable,1%2)]) + , (2,[(ToReject,1%1)]) + ]) + , (That, [ (1,[(ToReject,1%1)]) + , (2,[(Insufficient,1%2), (VeryGood,1%2)]) + ]) + ] + [ node0 [ (This, [ (1,[(Good,1%1)]) + , (2,[(ToReject,1%1)]) + ]) + , (That, [ (1,[(ToReject,1%1)]) + , (2,[(Insufficient,1%1)]) + ]) + ] + , node0 [ (This, [ (1,[(Acceptable,1%1)]) + , (2,[(ToReject,1%1)]) + ]) + , (That, [ (1,[(ToReject,1%1)]) + , (2,[(VeryGood,1%1)]) + ]) + ] + ]) + , testSection "1 judge, 1 choice" + [This] + [(1::Int,ToReject)] + (Node [] + [ node0 [ (This, [(1,Section (Just $ 1%8) (Just Acceptable))]) + ] + , node0 [ (This, [(1,Section Nothing Nothing)]) + ] + ]) + (Right $ Node + [ (This, [(1,[(Acceptable,1%8), (ToReject,7%8)])]) + ] + [ node0 [ (This, [(1,[(Acceptable, 1%1)])]) + ] + , node0 [ (This, [(1,[(ToReject, 1%1)])]) + ] + ]) + , testSection "1 judge, 1 choice (missing judge)" + [This] + [(1::Int,ToReject)] + (Node [] + [ node0 [ (This, [(1,Section (Just $ 1%8) (Just Acceptable))]) + ] + , node0 [ (This, []) + ] + ]) + (Right $ Node + [ (This, [(1,[(Acceptable,1%8), (ToReject,7%8)])]) + ] + [ node0 [ (This, [(1,[(Acceptable, 1%1)])]) + ] + , node0 [ (This, [(1,[(ToReject, 1%1)])]) + ] + ]) + , testSection "1 judge, 1 choice (missing judge)" + [This] + [(1::Int,ToReject)] + (Node [] + [ node0 [ (This, []) + ] + , node0 [ (This, [(1,Section (Just $ 1%8) (Just Acceptable))]) + ] + ]) + (Right $ Node + [ (This, [(1,[(Acceptable,1%8), (ToReject,7%8)])]) + ] + [ node0 [ (This, [(1,[(ToReject, 1%1)])]) + ] + , node0 [ (This, [(1,[(Acceptable, 1%1)])]) + ] + ]) + , testSection "1 judge, 1 choice (missing choice)" + [This] + [(1::Int,ToReject)] + (Node [] + [ node0 [ (This, [(1,Section (Just $ 1%8) (Just Acceptable))]) + ] + , node0 [ + ] + ]) + (Right $ Node + [ (This, [(1,[(Acceptable,1%8), (ToReject,7%8)])]) + ] + [ node0 [ (This, [(1,[(Acceptable, 1%1)])]) + ] + , node0 [ (This, [(1,[(ToReject, 1%1)])]) + ] + ]) + , testSection "1 judge, 1 choice (missing choice)" + [This] + [(1::Int,ToReject)] + (Node [] + [ node0 [ + ] + , node0 [ (This, [(1,Section (Just $ 1%8) (Just Acceptable))]) + ] + ]) + (Right $ Node + [ (This, [(1,[(Acceptable,1%8), (ToReject,7%8)])]) + ] + [ node0 [ (This, [(1,[(ToReject, 1%1)])]) + ] + , node0 [ (This, [(1,[(Acceptable, 1%1)])]) + ] + ]) + , testSection "2 judges, 2 choices" + [This, That] + [(1::Int,ToReject), (2::Int,ToReject)] + (node0 + [ (This, [(1,Section Nothing (Just Acceptable))]) + , (That, [(2,Section (Just $ 1%8) (Just VeryGood))]) + ]) + (Right $ node0 + [ (This, [ (1,[(Acceptable,1%1)]) + , (2,[(ToReject,1%1)]) + ]) + , (That, [ (1,[(ToReject,1%1)]) + , (2,[(VeryGood,1%1)]) + ]) + ]) + , testSection "2 judges, 2 choices" + [This, That] + [(1::Int,ToReject), (2::Int,ToReject)] + (Node + [ ] + [ node0 + [ (This, [(1,Section Nothing (Just Good))]) + , (That, [(2,Section Nothing (Just Insufficient))]) + ] + , node0 + [ (This, [(1,Section Nothing (Just Acceptable))]) + , (That, [(2,Section (Just $ 1%8) (Just VeryGood))]) + ] + ]) + (Right $ Node + [ (This, [ (1,[(Good,1%2), (Acceptable,1%2)]) + , (2,[(ToReject,1%1)]) + ]) + , (That, [ (1,[(ToReject,1%1)]) + , (2,[(Insufficient,7%8), (VeryGood,1%8)]) + ]) + ] + [ node0 [ (This, [ (1,[(Good,1%1)]) + , (2,[(ToReject,1%1)]) + ]) + , (That, [ (1,[(ToReject,1%1)]) + , (2,[(Insufficient,1%1)]) + ]) + ] + , node0 [ (This, [ (1,[(Acceptable,1%1)]) + , (2,[(ToReject,1%1)]) + ]) + , (That, [ (1,[(ToReject,1%1)]) + , (2,[(VeryGood,1%1)]) + ]) + ] + ]) + , testSection "2 judges, 2 choices" + [This, That] + [(1::Int,ToReject), (2::Int,ToReject)] + (Node [ (This, [(1,Section Nothing (Just Acceptable))]) + ] + [ node0 [ (This, [(1,Section Nothing Nothing)]) + ] + , node0 [ (This, [ (1,Section (Just $ 1%2) (Just Good)) ]) + , (That, [ (1,Section (Just $ 1%3) Nothing) + , (2,Section (Just $ 1%5) (Just Insufficient)) + ]) + ] + , Node [ (This, [(1,Section Nothing (Just Good))]) + , (That, [(2,Section Nothing (Just VeryGood))]) + ] + [ node0 [ (This, [ (1,Section Nothing (Just VeryGood)) + , (2,Section Nothing (Just Insufficient)) + ]) + , (That, [ (1,Section Nothing (Just Acceptable)) ]) + ] + , node0 [ (This, [ (1,Section Nothing (Just Acceptable)) + ]) + , (That, [ (1,Section Nothing (Just VeryGood)) + , (2,Section Nothing (Just Good)) + ]) + ] + ] + ]) + (Right $ + Node [ (This, [ (1,[(Acceptable,1%4 + 1%8), (Good,1%2), (VeryGood,1%8)]) + , (2,[(ToReject,1%3 + 1%3 + 1%6), (Insufficient,1%6)]) + ]) + , (That, [ (1,[(ToReject,1%3 + 1%3), (Acceptable,1%6), (VeryGood,1%6)]) + , (2,[(ToReject,4%10), (Insufficient,1%5), (VeryGood,4%20), (Good,4%20)]) + ]) + ] + [ node0 [ (This, [ (1,[(Acceptable,1%1)]) -- 1%4 + , (2,[(ToReject,1%1)]) -- 1%3 + ]) + , (That, [ (1,[(ToReject,1%1)]) -- 1%3 + , (2,[(ToReject,1%1)]) -- 4%10 + ]) + ] + , node0 [ (This, [ (1,[(Good,1%1)]) -- 1%2 + , (2,[(ToReject,1%1)]) -- 1%3 + ]) + , (That, [ (1,[(ToReject,1%1)]) -- 1%3 + , (2,[(Insufficient,1%1)]) -- 1%5 + ]) + ] + , Node [ (This, [ (1,[(VeryGood,1%2), (Acceptable,1%2)]) -- 1%4 + , (2,[(Insufficient,1%2), (ToReject,1%2)]) -- 1%3 + ]) + , (That, [ (1,[(Acceptable,1%2), (VeryGood,1%2)]) -- 1%3 + , (2,[(VeryGood,1%2), (Good,1%2)]) -- 4%10 + ]) + ] + [ node0 [ (This, [ (1,[(VeryGood,1%1)]) + , (2,[(Insufficient,1%1)]) + ]) + , (That, [ (1,[(Acceptable,1%1)]) + , (2,[(VeryGood,1%1)]) + ]) + ] + , node0 [ (This, [ (1,[(Acceptable,1%1)]) + , (2,[(ToReject,1%1)]) + ]) + , (That, [ (1,[(VeryGood,1%1)]) + , (2,[(Good,1%1)]) + ]) + ] + ] + ] + ) + ] + +testSection :: + Eq choice => + Hashable choice => + Eq judge => + Hashable judge => + Ord grade => + Show choice => + Show judge => + Show grade => + String -> + Choices choice -> + Judges judge grade -> + Tree (SectionNode choice judge grade) -> + Either (ErrorSection choice judge grade) + (Tree (OpinionsByChoice choice judge grade)) -> + TestTree +testSection msg cs js ss expect = + testCase (elide msg) $ + opinionsBySection cs js ss @?= expect + +node0 :: a -> Tree a +node0 = (`Node`[]) + +instance + (Eq choice, Hashable choice) => + IsList (SectionNode choice judge grade) where + type Item (SectionNode choice judge grade) = (choice, SectionByJudge judge grade) + fromList = SectionNode Nothing . fromList + toList = GHC.Exts.toList . sectionByJudgeByChoice diff --git a/test/HUnit/Utils.hs b/test/HUnit/Utils.hs new file mode 100644 --- /dev/null +++ b/test/HUnit/Utils.hs @@ -0,0 +1,9 @@ +module HUnit.Utils where +import Data.Bool +import Data.List +import Data.String (String) +import Data.Ord (Ord(..)) + +elide :: String -> String +elide s | length s > 42 = take 42 s ++ ['…'] + | otherwise = s diff --git a/test/HUnit/Value.hs b/test/HUnit/Value.hs new file mode 100644 --- /dev/null +++ b/test/HUnit/Value.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE OverloadedLists #-} +module HUnit.Value where +import Data.Function (($)) +import Data.Int (Int) +import Data.Hashable (Hashable) +import Data.Eq (Eq(..)) +import Data.Functor ((<$>)) +import Data.Ord (Ord(..), Ordering(..)) +import Data.Ratio ((%)) +import Text.Show (Show(..)) +import qualified Data.HashMap.Strict as HM + +import Test.Tasty +import Test.Tasty.HUnit +import Majority.Judgment +import HUnit.Merit +import HUnit.Utils +import Types + +hunit :: TestTree +hunit = testGroup "Value" + [ testGroup "MajorityValue" + [ testCompareValue + (majorityValue $ Merit [(3,15), (2,7), (1,3), (0::Int,2)]) + (majorityValue $ Merit [(3,16), (2,6), (1,2), (0,3)]) + ] + , testGroup "MajorityRanking" + [ testMajorityValueOfOpinions + [ (The, [No,No,No,No,Yes,Yes]) ] + [ (The, [ Middle (1 % 1) No No + , Middle (2 % 1) No Yes + ]) ] + , testMajorityValueOfOpinions + [ (The, [No,No,No,Yes,Yes,Yes]) ] + [ (The, [ Middle (3 % 1) No Yes ]) ] + , testMajorityValueOfOpinions + [ (The, [No,No,No,No,Yes,Yes,Yes]) ] + [ (The, [ Middle (1 % 2) No No + , Middle (3 % 1) No Yes ]) ] + , testMajorityValueOfOpinions + [ (This, [No,No,No,No,Yes,Yes]) + , (That, [No,Yes,Yes,Yes,Yes,Yes]) + ] + [ (This, [ Middle (1 % 1) No No + , Middle (2 % 1) No Yes + ]) + , (That, [ Middle (2 % 1) Yes Yes + , Middle (1 % 1) No Yes + ]) + ] + , testMajorityValueOfOpinions + [ (This, [No,No,No,No,No,No]) + , (That, [No,No,No,Yes,Yes,Yes]) + ] + [ (This, [Middle (3 % 1) No No]) + , (That, [Middle (3 % 1) No Yes]) + ] + , testMajorityValueOfOpinions + [ (This, [Yes,Yes,Yes,Yes,Yes,Yes]) + , (That, [No,No,No,Yes,Yes,Yes]) + ] + [ (This, [Middle (3 % 1) Yes Yes]) + , (That, [Middle (3 % 1) No Yes]) + ] + , testMajorityValueOfOpinions + [ (This, [No,No,Yes,Yes,Yes,Yes]) + , (That, [No,No,No,Yes,Yes,Yes]) + ] + [ (This, [ Middle (1 % 1) Yes Yes + , Middle (2 % 1) No Yes + ]) + , (That, [ Middle (3 % 1) No Yes ]) + ] + , testMajorityValueOfOpinions + [ (1::Int, [Perfect,Perfect,VeryGood,Perfect,Perfect,Perfect]) + , (2, [Perfect,VeryGood,VeryGood,VeryGood,Good,VeryGood]) + , (3, [Acceptable,Perfect,Good,VeryGood,VeryGood,Perfect]) + , (4, [VeryGood,Good,Acceptable,Good,Good,Good]) + , (5, [Good,Acceptable,VeryGood,Good,Good,Good]) + , (6, [VeryGood,Acceptable,Insufficient,Acceptable,Acceptable,Good]) + ] + [ (1, [ Middle (2 % 1) Perfect Perfect + , Middle (1 % 1) VeryGood Perfect + ]) + , (2, [ Middle (2 % 1) VeryGood VeryGood + , Middle (1 % 1) Good Perfect + ]) + , (3, [ Middle (1 % 1) VeryGood VeryGood + , Middle (1 % 1) Good Perfect + , Middle (1 % 1) Acceptable Perfect + ]) + , (4, [ Middle (2 % 1) Good Good + , Middle (1 % 1) Acceptable VeryGood + ]) + , (5, [ Middle (2 % 1) Good Good + , Middle (1 % 1) Acceptable VeryGood + ]) + , (6, [ Middle (1 % 1) Acceptable Acceptable + , Middle (1 % 1) Acceptable Good + , Middle (1 % 1) Insufficient VeryGood + ]) + ] + ] + ] + +testCompareValue :: + (Ord grade, Show grade) => + MajorityValue grade -> MajorityValue grade -> TestTree +testCompareValue x y = + testGroup (elide $ show (unMajorityValue x, unMajorityValue y)) + [ testCase "x == x" $ x`compare`x @?= EQ + , testCase "y == y" $ y`compare`y @?= EQ + , testCase "x < y" $ x`compare`y @?= LT + , testCase "y > x" $ y`compare`x @?= GT + ] + +testMajorityRanking :: + (Eq choice, Hashable choice, Ord grade, Show grade, Show choice) => + [(choice, [grade])] -> + MajorityRanking choice grade -> TestTree +testMajorityRanking os expect = + testCase (elide $ show os) $ + majorityRanking (mkMeritByChoice os) @?= expect + +testMajorityValueOfOpinions :: + (Show grade, Show choice, Ord grade, Eq choice, Hashable choice) => + [(choice, [grade])] -> + [(choice, [Middle grade])] -> TestTree +testMajorityValueOfOpinions os expect = + testCase (elide $ show os) $ + majorityValueByChoice (mkMeritByChoice os) + @?= (MajorityValue<$>HM.fromList expect) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,5 +1,7 @@ module Main where +import System.IO (IO) +import Data.Function (($)) import Test.Tasty import QuickCheck import HUnit diff --git a/test/QuickCheck.hs b/test/QuickCheck.hs --- a/test/QuickCheck.hs +++ b/test/QuickCheck.hs @@ -1,184 +1,14 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module QuickCheck where - -import Test.QuickCheck import Test.Tasty -import Test.Tasty.QuickCheck -import Control.Arrow (first) -import Control.Monad (replicateM) -import Data.Hashable (Hashable) -import qualified Data.Map.Strict as Map -import Data.Ratio -import GHC.Exts (IsList(..)) -import Prelude -import System.Random (Random(..)) -import qualified Data.Set as Set - -import Majority.Judgment -import Types +import qualified QuickCheck.Gauge +import qualified QuickCheck.Merit +import qualified QuickCheck.Value quickchecks :: TestTree quickchecks = testGroup "QuickCheck" - [ testProperty "arbitraryMerits" $ \(SameLength (Merit x::Merit G6,Merit y::Merit G6)) -> - Map.keys x == Map.keys y && - sum x == sum y - , testGroup "MajorityValue" - [ testProperty "compare" $ \(SameLength (x::MajorityValue G6,y)) -> - expandValue x`compare` expandValue y == x`compare`y - ] - {- - , testProperty "majorityGauge and majorityValue consistency" $ - \(SameLength (x@(Merit xs)::Merit G6,y@(Merit ys))) -> - not (all (==0) xs || all (==0) ys) ==> - case majorityGauge x`compare`majorityGauge y of - LT -> majorityValue x < majorityValue y - GT -> majorityValue x > majorityValue y - EQ -> True - -} + [ QuickCheck.Merit.quickcheck + , QuickCheck.Value.quickcheck + , QuickCheck.Gauge.quickcheck ] - --- | Decompress a 'MajorityValue'. -expandValue :: MajorityValue a -> [a] -expandValue (MajorityValue ms) = - let d = foldr lcm 1 (denominator . middleShare <$> ms) in - go $ (\m -> (numerator (middleShare m) * d, lowGrade m, highGrade m)) <$> ms - where - go [] = [] - go ((s,l,h):xs) = concat (replicate (fromIntegral s) [l, h]) ++ go xs - --- | @arbitraryMerits n@ arbitrarily generates 'n' lists of 'Merit' --- for the same arbitrary grades, --- and with the same total 'Share' of individual judgments. -arbitraryMerits :: forall g. (Bounded g, Enum g, Ord g) => Int -> Gen [Merit g] -arbitraryMerits n = sized $ \shareSum -> do - minG <- choose (fromEnum(minBound::g), fromEnum(maxBound::g)) - maxG <- choose (minG, fromEnum(maxBound::g)) - let gs::[g] = toEnum minG`enumFromTo`toEnum maxG - let lenGrades = maxG - minG + 1 - replicateM n $ do - shares <- resize shareSum $ arbitrarySizedPositiveRationalSum lenGrades - shares' :: [Share] <- arbitraryPad (lenGrades - length shares) (return 0) shares - return $ Merit $ fromList $ zip gs shares' - --- | @arbitrarySizedNaturalSum maxLen@ --- arbitrarily chooses a list of 'length' at most 'maxLen', --- containing 'Int's summing up to 'sized'. -arbitrarySizedNaturalSum :: Int -> Gen [Int] -arbitrarySizedNaturalSum maxLen = sized (go maxLen) - where - go :: Int -> Int -> Gen [Int] - go len tot | len <= 0 = return [] - | len == 1 = return [tot] - | tot <= 0 = return [tot] - go len tot = do - d <- choose (0, tot) - (d:) <$> go (len-1) (tot - d) - --- | @arbitrarySizedPositiveRationalSum maxLen@ --- arbitrarily chooses a list of 'length' at most 'maxLen', --- containing positive 'Rational's summing up to 'sized'. -arbitrarySizedPositiveRationalSum :: Int -> Gen [Rational] -arbitrarySizedPositiveRationalSum maxLen = sized (go maxLen . fromIntegral) - where - go :: Int -> Rational -> Gen [Rational] - go len tot | len <= 0 = return [] - | len == 1 = return [tot] - | tot <= 0 = return [tot] - go len tot = do - d <- choose (0, tot) - (d:) <$> go (len-1) (tot - d) - -instance Random Rational where - randomR (minR, maxR) g = - if d - b == 0 - then first (% b) $ randomR (a, c) g - else first (bd2ac . nat2bd) $ randomR (0, toInteger (maxBound::Int)) g - where - a = numerator minR - b = denominator minR - c = numerator maxR - d = denominator maxR - nat2bd x = ((d - b) % toInteger (maxBound::Int)) * (x%1) + (b%1) - bd2ac x = alpha * x + beta - where - alpha = (c-a) % (d-b) - beta = (a%1) - alpha * (b%1) - - random = randomR (toInteger (minBound::Int)%1, toInteger (maxBound::Int)%1) - --- | @arbitraryPad n pad xs@ --- arbitrarily grows list 'xs' with 'pad' elements --- up to length 'n'. -arbitraryPad :: (Num i, Integral i) => i -> Gen a -> [a] -> Gen [a] -arbitraryPad n pad [] = replicateM (fromIntegral n) pad -arbitraryPad n pad xs = do - (r, xs') <- go n xs - if r > 0 - then arbitraryPad r pad xs' - else return xs' - where - go r xs' | r <= 0 = return (0,xs') - go r [] = arbitrary >>= \b -> - if b then pad >>= \p -> ((p:)<$>) <$> go (r-1) [] - else return (r,[]) - go r (x:xs') = arbitrary >>= \b -> - if b then pad >>= \p -> (([p,x]++)<$>) <$> go (r-1) xs' - else ((x:)<$>) <$> go r xs' - --- | Like 'nub', but O(n * log n). -nubList :: Ord a => [a] -> [a] -nubList = go Set.empty where - go _ [] = [] - go s (x:xs) | x`Set.member`s = go s xs - | otherwise = x:go (Set.insert x s) xs - -instance Arbitrary G6 where - arbitrary = arbitraryBoundedEnum -instance (Arbitrary g, Bounded g, Enum g, Ord g, Show g) => Arbitrary (Merit g) where - arbitrary = head <$> arbitraryMerits 1 - shrink (Merit m) = Merit <$> shrink m -instance - ( Arbitrary c, Bounded c, Enum c, Eq c, Hashable c, Show c - , Arbitrary g, Bounded g, Enum g, Ord g, Show g - ) => Arbitrary (MeritByChoice c g) where - arbitrary = do - minP <- choose (fromEnum(minBound::c), fromEnum(maxBound::c)) - maxP <- choose (minP, fromEnum(maxBound::c)) - let ps = toEnum minP`enumFromTo`toEnum maxP - let ms = arbitraryMerits (maxP - minP + 1) - fromList . zip ps <$> ms -instance (Bounded g, Eq g, Integral g, Arbitrary g) => Arbitrary (MajorityValue g) where - arbitrary = head . (majorityValue <$>) <$> arbitraryMerits 1 - shrink (MajorityValue vs) = MajorityValue <$> shrink vs -instance (Bounded g, Enum g) => Arbitrary (Middle g) where - arbitrary = do - lowG <- choose (fromEnum(minBound::g), fromEnum(maxBound::g)) - highG <- choose (lowG, fromEnum(maxBound::g)) - share <- choose (0, 1) - return $ Middle share (toEnum lowG) (toEnum highG) - --- * Type 'SameLength' -newtype SameLength a = SameLength a - deriving (Eq, Show) -instance Functor SameLength where - fmap f (SameLength x) = SameLength (f x) -instance (Arbitrary g, Bounded g, Enum g, Ord g) => Arbitrary (SameLength (MajorityValue g, MajorityValue g)) where - arbitrary = do - SameLength (x,y) <- arbitrary - return $ SameLength (MajorityValue x, MajorityValue y) -instance (Arbitrary g, Bounded g, Enum g, Ord g) => Arbitrary (SameLength (Merit g, Merit g)) where - arbitrary = do - vs <- arbitraryMerits 2 - case vs of - [x,y] -> return $ SameLength (x,y) - _ -> undefined -instance (Arbitrary g, Bounded g, Enum g, Ord g) => Arbitrary (SameLength ([Middle g], [Middle g])) where - arbitrary = do - SameLength (m0, m1) <- arbitrary - return $ SameLength - ( unMajorityValue $ majorityValue m0 - , unMajorityValue $ majorityValue m1 ) diff --git a/test/QuickCheck/Gauge.hs b/test/QuickCheck/Gauge.hs new file mode 100644 --- /dev/null +++ b/test/QuickCheck/Gauge.hs @@ -0,0 +1,23 @@ +module QuickCheck.Gauge where +import Data.Bool +import Data.Function (($)) +import Data.Ord (Ord(..), Ordering(..)) +import Majority.Merit +import Test.Tasty +import Test.Tasty.QuickCheck + +import Majority.Judgment +import QuickCheck.Merit () +import QuickCheck.Utils +import Types + +quickcheck :: TestTree +quickcheck = + testGroup "Gauge" + [ testProperty "majorityGauge and majorityValue consistency" $ + \(SameLength (x::Merit G6, y)) -> + case majorityGauge x`compare`majorityGauge y of + LT -> majorityValue x < majorityValue y + GT -> majorityValue y < majorityValue x + EQ -> True + ] diff --git a/test/QuickCheck/Merit.hs b/test/QuickCheck/Merit.hs new file mode 100644 --- /dev/null +++ b/test/QuickCheck/Merit.hs @@ -0,0 +1,117 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module QuickCheck.Merit where +import Control.Monad (Monad(..), replicateM) +import Data.Bool +import Data.Eq (Eq(..)) +import Data.Foldable (Foldable(..)) +import Data.Function (($), (.)) +import Data.Functor ((<$>)) +import Data.Hashable (Hashable) +import Data.Int (Int) +import Data.List ((++), head, zip) +import Data.Ord (Ord(..)) +import Data.Ratio (Rational) +import GHC.Exts (IsList(..)) +import Majority.Merit +import Prelude (Enum(..), Num(..), Integral(..), Bounded(..), fromIntegral, undefined) +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.QuickCheck +import Text.Show (Show(..)) +import qualified Data.Map.Strict as Map + +import QuickCheck.Utils +import Types + +quickcheck :: TestTree +quickcheck = + testGroup "Merit" + [ testProperty "arbitraryMerits" $ \(SameLength (Merit x::Merit G6,Merit y::Merit G6)) -> + Map.keys x == Map.keys y && + sum x == sum y + ] + +-- | @arbitraryMerits n@ arbitrarily generates 'n' lists of 'Merit' +-- for the same arbitrary grades, +-- and with the same total 'Share' of individual judgments. +arbitraryMerits :: forall g. (Bounded g, Enum g, Ord g) => Int -> Gen [Merit g] +arbitraryMerits n = sized $ \shareSum -> do + minG <- choose (fromEnum(minBound::g), fromEnum(maxBound::g)) + maxG <- choose (minG, fromEnum(maxBound::g)) + let gs::[g] = toEnum minG`enumFromTo`toEnum maxG + let lenGrades = maxG - minG + 1 + replicateM n $ do + shares <- resize shareSum $ arbitrarySizedPositiveRationalSum lenGrades + shares' :: [Share] <- arbitraryPad (lenGrades - length shares) (return 0) shares + return $ Merit $ fromList $ zip gs shares' + +-- | @arbitrarySizedPositiveRationalSum maxLen@ +-- arbitrarily chooses a list of 'length' at most 'maxLen', +-- containing positive 'Rational's summing up to 'sized'. +arbitrarySizedPositiveRationalSum :: Int -> Gen [Rational] +arbitrarySizedPositiveRationalSum maxLen = sized (go maxLen . fromIntegral) + where + go :: Int -> Rational -> Gen [Rational] + go len tot | len <= 0 = return [] + | len == 1 = return [tot] + | tot <= 0 = return [tot] + go len tot = do + d <- choose (0, tot) + (d:) <$> go (len-1) (tot - d) + +-- | @arbitrarySizedNaturalSum maxLen@ +-- arbitrarily chooses a list of 'length' at most 'maxLen', +-- containing 'Int's summing up to 'sized'. +arbitrarySizedNaturalSum :: Int -> Gen [Int] +arbitrarySizedNaturalSum maxLen = sized (go maxLen) + where + go :: Int -> Int -> Gen [Int] + go len tot | len <= 0 = return [] + | len == 1 = return [tot] + | tot <= 0 = return [tot] + go len tot = do + d <- choose (0, tot) + (d:) <$> go (len-1) (tot - d) + +-- | @arbitraryPad n pad xs@ +-- arbitrarily grows list 'xs' with 'pad' elements +-- up to length 'n'. +arbitraryPad :: (Num i, Integral i) => i -> Gen a -> [a] -> Gen [a] +arbitraryPad n pad [] = replicateM (fromIntegral n) pad +arbitraryPad n pad xs = do + (r, xs') <- go n xs + if r > 0 + then arbitraryPad r pad xs' + else return xs' + where + go r xs' | r <= 0 = return (0,xs') + go r [] = arbitrary >>= \b -> + if b then pad >>= \p -> ((p:)<$>) <$> go (r-1) [] + else return (r,[]) + go r (x:xs') = arbitrary >>= \b -> + if b then pad >>= \p -> (([p,x] ++)<$>) <$> go (r-1) xs' + else ((x:)<$>) <$> go r xs' + +instance + (Arbitrary g, Bounded g, Enum g, Ord g, Show g) => + Arbitrary (Merit g) where + arbitrary = head <$> arbitraryMerits 1 + shrink (Merit m) = Merit <$> shrink m +instance + ( Arbitrary c, Bounded c, Enum c, Eq c, Hashable c, Show c + , Arbitrary g, Bounded g, Enum g, Ord g, Show g + ) => Arbitrary (MeritByChoice c g) where + arbitrary = do + minP <- choose (fromEnum(minBound::c), fromEnum(maxBound::c)) + maxP <- choose (minP, fromEnum(maxBound::c)) + let ps = toEnum minP`enumFromTo`toEnum maxP + let ms = arbitraryMerits (maxP - minP + 1) + fromList . zip ps <$> ms +instance + (Arbitrary g, Bounded g, Enum g, Ord g) => + Arbitrary (SameLength (Merit g, Merit g)) where + arbitrary = do + vs <- arbitraryMerits 2 + case vs of + [x,y] -> return $ SameLength (x,y) + _ -> undefined diff --git a/test/QuickCheck/Utils.hs b/test/QuickCheck/Utils.hs new file mode 100644 --- /dev/null +++ b/test/QuickCheck/Utils.hs @@ -0,0 +1,51 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module QuickCheck.Utils where +import Control.Arrow (first) +import Data.Bool +import Data.Eq (Eq(..)) +import Data.Function (($), (.)) +import Data.Functor (Functor(..)) +import Data.Int (Int) +import Data.Ord (Ord(..)) +import Data.Ratio ((%), Rational, numerator, denominator) +import Prelude (Num(..), Integral(..), Bounded(..)) +import System.Random (Random(..)) + +import Test.QuickCheck +import Text.Show (Show(..)) +import Types +import qualified Data.Set as Set + +-- | Like 'nub', but O(n * log n). +nubList :: Ord a => [a] -> [a] +nubList = go Set.empty where + go _ [] = [] + go s (x:xs) | x`Set.member`s = go s xs + | otherwise = x:go (Set.insert x s) xs + +instance Random Rational where + random = randomR (toInteger (minBound::Int)%1, toInteger (maxBound::Int)%1) + randomR (minR, maxR) g = + if d - b == 0 + then first (% b) $ randomR (a, c) g + else first (bd2ac . nat2bd) $ randomR (0, toInteger (maxBound::Int)) g + where + a = numerator minR + b = denominator minR + c = numerator maxR + d = denominator maxR + nat2bd x = ((d - b) % toInteger (maxBound::Int)) * (x%1) + (b%1) + bd2ac x = alpha * x + beta + where + alpha = (c-a) % (d-b) + beta = (a%1) - alpha * (b%1) +instance Arbitrary G6 where + arbitrary = arbitraryBoundedEnum +instance Arbitrary DanishSchoolGrade where + arbitrary = arbitraryBoundedEnum + +-- * Type 'SameLength' +newtype SameLength a = SameLength a + deriving (Eq, Show) +instance Functor SameLength where + fmap f (SameLength x) = SameLength (f x) diff --git a/test/QuickCheck/Value.hs b/test/QuickCheck/Value.hs new file mode 100644 --- /dev/null +++ b/test/QuickCheck/Value.hs @@ -0,0 +1,52 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module QuickCheck.Value where +import Majority.Value +import Types +import Data.List (head) + +import QuickCheck.Merit +import QuickCheck.Utils + +import Control.Monad (Monad(..)) +import Data.Function (($), (.)) +import Data.Functor ((<$>)) +import Test.Tasty +import Test.Tasty.QuickCheck +import Data.Eq (Eq(..)) +import Data.Ord (Ord(..)) +import Prelude (Enum(..), Integral(..), Bounded(..)) + +quickcheck :: TestTree +quickcheck = + testGroup "Value" + [ testGroup "MajorityValue" + [ testProperty "compare" $ \(SameLength (x::MajorityValue G6,y)) -> + expandValue x`compare` expandValue y == x`compare`y + ] + ] + +instance + (Bounded g, Eq g, Integral g, Arbitrary g) => + Arbitrary (MajorityValue g) where + arbitrary = head . (majorityValue <$>) <$> arbitraryMerits 1 + shrink (MajorityValue vs) = MajorityValue <$> shrink vs +instance (Bounded g, Enum g) => Arbitrary (Middle g) where + arbitrary = do + lowG <- choose (fromEnum(minBound::g), fromEnum(maxBound::g)) + highG <- choose (lowG, fromEnum(maxBound::g)) + share <- choose (0, 1) + return $ Middle share (toEnum lowG) (toEnum highG) +instance + (Arbitrary g, Bounded g, Enum g, Ord g) => + Arbitrary (SameLength (MajorityValue g, MajorityValue g)) where + arbitrary = do + SameLength (x,y) <- arbitrary + return $ SameLength (MajorityValue x, MajorityValue y) +instance + (Arbitrary g, Bounded g, Enum g, Ord g) => + Arbitrary (SameLength ([Middle g], [Middle g])) where + arbitrary = do + SameLength (m0, m1) <- arbitrary + return $ SameLength + ( unMajorityValue $ majorityValue m0 + , unMajorityValue $ majorityValue m1 )