hjugement 2.0.0.20181030 → 2.0.1.20190208

raw patch · 19 files changed

+1370/−932 lines, 19 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Majority/Gauge.hs +13/−9
• Majority/Judgment.hs +2/−0
• Majority/Merit.hs +25/−5
• Majority/Rank.hs +110/−0
• Majority/Value.hs +45/−10
• hjugement.cabal +15/−7
• stack.yaml +1/−1
• test/HUnit.hs +8/−724
• test/HUnit/Merit.hs +78/−0
• test/HUnit/Rank.hs +116/−0
• test/HUnit/Section.hs +565/−0
• test/HUnit/Utils.hs +9/−0
• test/HUnit/Value.hs +132/−0
• test/Main.hs +2/−0
• test/QuickCheck.hs +6/−176
• test/QuickCheck/Gauge.hs +23/−0
• test/QuickCheck/Merit.hs +117/−0
• test/QuickCheck/Utils.hs +51/−0
• test/QuickCheck/Value.hs +52/−0

@@ -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)])

@@ -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

@@ -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.

@@ -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<l1 then gs-1 else h1-1)]+	 ]+	even2 =+	 [ (l,h) | l<-[l0+1..l1-1]+	 , h<-[max l h0..gs-1]+	 ]+	even3 =+	 [ (l,h) | l<-[l1 | l0 < l1]+	 , h<-[max l h0..h1-1]+	 ]++-- | 'countMiddle js gs (l,h)'+-- returns the number of 'MajorityValue's of length 'js' and using grades 'gs',+-- which have '(l,h)' as lower and upper majority grade.+-- This is done by multiplying together+-- the 'countMerits' to the left of 'l'+-- and the 'countMerits' to the right of 'h'+countMiddle :: JS -> 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<k = undefined+        | otherwise     = go 1 1+        where+        go i acc = if k' < i then acc else go (i+1) (acc * (n-i+1) `div` i)+        -- Use a symmetry to compute over smaller numbers,+        -- which is more efficient and safer+        k' = if n`div`2 < k then n-k else k+infix 7 `nCk`

@@ -8,10 +8,10 @@ import Data.List as List import Data.Maybe (Maybe(..), listToMaybe) import Data.Ord (Ord(..), Ordering(..), Down(..))-import Data.Ratio ((%))+import Data.Ratio ((%), numerator, denominator) import Data.Semigroup (Semigroup(..)) import Data.Tuple (snd)-import Prelude (Num(..))+import Prelude (Num(..), fromIntegral, lcm, div, ) import Text.Show (Show(..)) import qualified Data.HashMap.Strict as HM import qualified Data.Map.Strict as Map@@ -22,8 +22,14 @@ -- | A 'MajorityValue' is a list of 'grade's -- made from the successive lower middlemosts of a 'Merit', -- i.e. from the most consensual 'majorityGrade' to the least.-newtype MajorityValue grade = MajorityValue { unMajorityValue :: [Middle grade] }+--+-- For using less resources and generalizing to non-integral 'Share's,+-- this 'MajorityValue' is actually encoded as an Abbreviated Majority Value,+-- instead of a big list of 'grade's.+newtype MajorityValue grade = MajorityValue [Middle grade]  deriving (Eq, Show)+unMajorityValue :: MajorityValue grade -> [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

@@ -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: <http://www.lamsade.dauphine.fr/sites/default/IMG/pdf/cahier_377.pdf Majority Judgment vs. Majority Rule> (en)   * paper: <https://1007421605497013616-a-1802744773732722657-s-sites.googlegroups.com/site/ridalaraki/xfiles/BalinskiLarakiJudgeDontVotecahierderecherche2010-27.pdf Judge : Don't Vote!> (en)   * article: <https://www.cairn.info/revue-francaise-d-economie-2012-4-page-11.htm Jugement majoritaire versus vote majoritaire (via les présidentielles 2011-2012)> (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:-  <http://autogeree.net/~julm/txt/jugements.ods>. 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

@@ -1,3 +1,3 @@-resolver: lts-12.8+resolver: lts-12.25 packages: - '.'

@@ -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

@@ -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)+

@@ -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)

@@ -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

@@ -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

@@ -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)

@@ -1,5 +1,7 @@ module Main where +import System.IO (IO)+import Data.Function (($)) import Test.Tasty import QuickCheck import HUnit

@@ -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 )

@@ -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+	 ]

@@ -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

@@ -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)

@@ -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 )