hjugement 1.0.0.20170808 → 2.0.0.20180903

raw patch · 13 files changed

+1468/−430 lines, 13 filesdep +hashabledep +randomdep +unordered-containersdep ~containersdep ~tasty-hunitdep ~textPVP ok

version bump matches the API change (PVP)

Dependencies added: hashable, random, unordered-containers

Dependency ranges changed: containers, tasty-hunit, text, transformers

API changes (from Hackage documentation)

Files

• Hjugement.hs +0/−7
• Hjugement/Majority.hs +0/−223
• Majority/Gauge.hs +100/−0
• Majority/Judgment.hs +11/−0
• Majority/Merit.hs +194/−0
• Majority/Section.hs +189/−0
• Majority/Value.hs +133/−0
• README.md +2/−2
• hjugement.cabal +58/−28
• stack.yaml +3/−0
• test/HUnit.hs +679/−128
• test/QuickCheck.hs +88/−38
• test/Types.hs +11/−4

@@ -1,7 +0,0 @@-module Hjugement- ( module Hjugement.Majority- , IsList(..)- ) where--import Hjugement.Majority-import GHC.Exts (IsList(..))

@@ -1,223 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-module Hjugement.Majority where--import Data.Function (on)-import Data.List-import Data.Map.Strict (Map)-import Data.Maybe (fromMaybe)-import Data.Ord (Down(..))-import Data.Semigroup (Semigroup(..))-import Data.Set (Set)-import GHC.Exts (IsList(..))-import qualified Data.Map.Strict as Map-import qualified Data.Set as Set---- * Type 'Choices'-type Choices prop = Set prop---- | Return a set of 'Choices' by enumerating the alternatives of its type. Useful on sum types.-choices :: (Bounded prop , Enum prop , Ord prop) => Choices prop-choices = Set.fromList (enumFrom minBound)---- * Type 'Scale'-data Scale grade- =   Scale- {   scaleGrades :: Set grade-     -- ^ How many 'grade's should be used?-     -- A greater number of 'grade's permits a finer distinction but demands-     -- a higher degree of expertise and discernment.-     -- The optimal number is the highest number of 'grade's that constitutes a common language,-     -- that is, that allows 'judge's to make absolute judgments.-     -- Too little 'grade's may lead too often to ties.-     -- -     -- Note, however, that if the inputs or grades depend on the set of choices,-     -- i.e. if judges change their grades when choices are added or dropped,-     -- then the Arrow paradox cannot be avoided.-     -- To avoid this the scale must be fixed and absolute-     -- so that more or fewer choices does not change-     -- the inputs or messages of other choices.- ,   scaleDefault :: grade-     -- ^ For instance, when a 'judge' gives no 'grade' or has “no opinion”,-     -- 'scaleDefault' could mean that the 'judge' chooses “To Reject” the choice:-     -- the rationale being that a 'judge' having “no opinion”-     -- concerning a choice has not even taken the time to evaluate it-     -- and thus has implicitly rejected it.- } deriving (Eq, Show)---- | Return a 'Scale' by enumerating the alternatives of its type. Useful on sum types.-scale :: (Bounded grade, Enum grade, Ord grade) => Scale grade-scale = Scale { scaleGrades  = Set.fromList (enumFrom minBound)-              , scaleDefault = toEnum 0-              }---- | Return a 'Scale' from a list of 'grade's and a default 'grade'.--- Useful with 'grade's whose type has no 'Ord' instance--- or a different one than the one wanted.-scaleOfList :: Eq a => [a] -> a -> Scale Int-scaleOfList gs dg = Scale is di-	where-	is = fromList $ findIndices (const True) gs-	di = fromMaybe (error "default grade not in the scale") $ dg`elemIndex`gs--gradeOfScale :: [a] -> Int -> a-gradeOfScale = (!!)---- * Type 'Jury'-type Jury judge = Set judge---- | Return a 'Jury' by enumerating the alternatives of its type. Useful on sum types.-jury :: (Bounded judge , Enum judge , Ord judge) => Jury judge-jury = Set.fromList (enumFrom minBound)---- * Type 'Opinion'--- | Profile of opinions of one single 'judge' about some 'prop'ositions.-type Opinion prop grade = Map prop grade---- | Construct the 'Opinion' of a 'judge' about some 'prop'ositions implicit from their type.-opinion :: (Enum prop, Bounded prop, Ord prop) =>-           judge -> [grade] ->-           (judge, Opinion prop grade)-opinion j gs = (j, Map.fromList (zip (enumFrom minBound) gs))---- ** Type 'Opinions'--- | Profile of opinions of some 'judge's about some 'prop'ositions.-newtype Opinions prop grade judge = Opinions (Map judge (Opinion prop grade))- deriving (Eq, Show)-instance (Ord judge, Show judge) => IsList (Opinions prop grade judge) where-	type Item (Opinions prop grade judge) = (judge, Opinion prop grade)-	fromList = Opinions . Map.fromListWithKey-		 (\k _x _y -> error $ "duplicate opinion for judge: " <> show k)-	toList (Opinions os) = toList os---- * Type 'Merit'--- | Profile of merits about a choice.-newtype Merit grade = Merit (Map grade Count)- deriving (Eq, Show)-type Count = Int--instance Ord grade => Semigroup (Merit grade) where-	Merit x <> Merit y = Merit (Map.unionWith (+) x y)-instance Ord grade => Ord (Merit grade) where-	compare = compare `on` majorityValue-instance (Ord grade, Show grade) => IsList (Merit grade) where-	type Item (Merit grade) = (grade, Count)-	fromList = Merit . Map.fromListWithKey-		 (\g _x _y -> error $ "duplicate grade in merit: " <> show g)-	toList (Merit cs) = toList cs---- | @merit grad@ returns the 'Merit'--- of a single 'choice' by some 'judge's.-merit :: (Ord grade, Ord prop) =>-         Scale grade -> prop -> Opinions prop grade judge ->-         Merit grade-merit scal prop (Opinions os) = foldr insertOpinion defaultMerit os-	where-	insertOpinion op (Merit m) = Merit (Map.insertWith (+) g 1 m)-		where g = Map.findWithDefault (scaleDefault scal) prop op-	defaultMerit = Merit (const 0 `Map.fromSet` scaleGrades scal)---- ** Type 'Merits'--- | Profile of merits about some choices.-newtype Merits prop grade = Merits (Map prop (Merit grade))- deriving (Eq, Show)-instance (Ord grade, Ord prop) => Semigroup (Merits prop grade) where-	Merits x <> Merits y = Merits (Map.unionWith (<>) x y)-instance (Ord prop, Show prop) => IsList (Merits prop grade) where-	type Item (Merits prop grade) = (prop, Merit grade)-	fromList = Merits . Map.fromListWithKey-		 (\p _x _y -> error $ "duplicate choice in merits: " <> show p)-	toList (Merits cs) = toList cs---- | @merit scal props opins@ returns the 'Merits'--- of the 'Choices' 'props'--- as judged by the 'Opinions' 'opins'--- on the 'Scale' 'scal'.-merits :: (Ord grade, Ord prop) =>-          Scale grade -> Choices prop -> Opinions prop grade judge ->-          Merits prop grade-merits scal props (Opinions os) = foldr ((<>) . meritsFromOpinion) defaultMerits os-	where-	meritsFromOpinion = Merits . (Merit . (`Map.singleton` 1) <$>) . (<> defaultOpinion)-	defaultOpinion    = const (scaleDefault scal) `Map.fromSet` props-	defaultMerits     = Merits (const defaultMerit `Map.fromSet` props)-	defaultMerit      = Merit (const 0 `Map.fromSet` scaleGrades scal)---- * Type 'Value'--- | A 'Value' is a compressed list of 'grade's,--- where each 'grade' is associated with the 'Count'--- by which it would be replicated in situ if decompressed.-newtype Value grade = Value [(grade,Count)]- deriving (Eq, Show)--- | 'compare' lexicographically as if the 'Value's--- were decompressed.-instance Ord grade => Ord (Value grade) where-	Value []`compare`Value [] = EQ-	Value []`compare`Value ys | all ((==0) . snd) ys = EQ-	                          | otherwise            = LT-	Value xs`compare`Value [] | all ((==0) . snd) xs = EQ-	                          | otherwise            = GT-	sx@(Value ((x,cx):xs)) `compare` sy@(Value ((y,cy):ys)) =-		case cx`compare`cy of-		 _ | cx == 0 && cy == 0 -> Value xs`compare`Value ys-		 _ | cx <= 0 -> Value xs`compare`sy-		 _ | cy <= 0 -> sx`compare`Value ys-		 EQ -> x`compare`y <> Value xs`compare`Value ys-		 LT -> x`compare`y <> Value xs`compare`Value((y,cy-cx):ys)-		 GT -> x`compare`y <> Value((x,cx-cy):xs)`compare`Value ys---- | The 'majorityValue' is the list of the 'majorityGrade's--- of a choice, each one replicated their associated 'Count' times,--- from the most consensual to the least,--- ie. by removing the 'grade' of the previous 'majorityGrade'--- to compute the next.-majorityValue :: Ord grade => Merit grade -> Value grade-majorityValue (Merit m) = Value (go m)-	where-	go gs = case snd (Map.foldlWithKey untilMajGrade (0,[]) gs) of-	         [] -> []-	         gw@(g,_):_ -> gw:go (Map.delete g gs)-		where-		tot = sum gs-		untilMajGrade (t,[]) g c | 2*tc >= tot = (tc,[(g,c)])-		                         | otherwise   = (tc,[])-		                         where tc = t+c-		untilMajGrade acc _g _c = acc---- | The 'majorityGrade' is the lower middlemost--- (also known as median by experts) of the 'grade's--- given to a choice by the 'judge's.--- --- It is the highest 'grade' approved by an absolute majority of the 'judge's:--- more than 50% of the 'judge's give the choice at least a 'grade' of 'majorityGrade',--- but every 'grade' lower than 'majorityGrade' is rejected by an absolute majority--- Thus the 'majorityGrade' of a choice--- is the final 'grade' wished by the majority.------ The 'majorityGrade' is necessarily a word that belongs to 'grades',--- and it has an absolute meaning.------ When the number of 'judge's is even, there is a middle-interval--- (which can, of course, be reduced to a single 'grade'--- if the two middle 'grade's are the same),--- then the 'majorityGrade' is the lowest 'grade' of the middle-interval--- (the “lower middlemost” when there are two in the middle),--- 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 :: Ord grade => Merit grade -> grade-majorityGrade m = fst (head gs) where Value gs = majorityValue m---- * Type 'Ranking'--type Ranking prop = [prop]---- | The 'majorityRanking' ranks all the choices on the basis of their 'grade's.------ 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 choices have precisely the same 'majorityValue's.-majorityRanking :: Ord grade => Merits prop grade -> Ranking prop-majorityRanking = map fst . sortBy (compare `on` Down . snd) . majorityValueByChoice--majorityValueByChoice :: Ord grade => Merits prop grade -> [(prop, Value grade)]-majorityValueByChoice (Merits ms) = Map.toAscList (majorityValue <$> ms)

@@ -0,0 +1,100 @@+-- | WARNING: the 'MajorityGauge' is a simplified 'MajorityValue'+-- which is sufficient to determine the 'MajorityRanking'+-- when the number of judges is large.+-- It is an approximation, it can perfectly lead to a wrong ranking+-- wrt. the 'MajorityRanking' done by using 'majorityValue'.+module Majority.Gauge where++import Data.Bool+import Data.Eq (Eq(..))+import Data.Function (($), (.))+import Data.Functor ((<$>))+import Data.Maybe (Maybe(..), listToMaybe)+import Data.Ord (Ord(..), Ordering(..), Down(..))+import Data.Tuple (snd)+import Prelude (Num(..))+import Text.Show (Show(..), showParen, shows)+import qualified Data.HashMap.Strict as HM+import qualified Data.List as List+import qualified Data.Map.Strict as Map++import Majority.Merit++-- * Type 'MajorityGauge'+-- | The 'MajorityGauge' is a simplification of the 'majorityValue'+-- from which may be deduced the 'majorityRanking'+-- among the propositions in many cases;+-- in particular, when there are many judges.+-- +-- However, when two propositions are tied with the same 'MajorityGauge',+-- 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'.+ ,   mgGrade  :: g     -- ^ 'majorityGrade'.+ ,   mgLower  :: Share -- ^ Number of 'grade's given which are worse than 'mgGrade'.+ } deriving (Eq)+instance Show g => Show (MajorityGauge g) where+	showsPrec p (MajorityGauge b g w) = showParen (p >= 10) $ shows (b,g,w)++-- ** Type 'Sign'+data Sign = Minus | Plus+ deriving (Eq, Show)++-- | If 'mgHigher' is higher than 'mgLower'+-- then the 'majorityGrade' is completed by a 'Plus';+-- otherwise the 'majorityGrade' is completed by a 'Minus'.+mgSign :: MajorityGauge g -> Sign+mgSign g = if mgHigher g > mgLower g then Plus else Minus++-- | The 'MajorityGauge'-ranking, first tries to rank+-- according to the 'majorityGrade' 'mgGrade'.+--+-- If both 'MajorityGauge's have the same 'mgGrade',+-- it tries to rank according to the 'mgSign' of both 'MajorityGauge's:+-- a 'Plus' is ahead of a 'Minus'.+-- +-- If both 'mgSign' are 'Plus',+-- the one having the higher 'mgHigher' is ahead,+-- or if both 'mgSign' are 'Minus',+-- the one having the higher 'mgLower' is behind.+--+-- Otherwise, the 'MajorityGauge'-ranking is a tie.+instance Ord g => Ord (MajorityGauge g) where+	x `compare` y =+		case mgGrade x `compare` mgGrade y of+		 EQ ->+			case (mgSign x, mgSign y) of+			 (Minus, Plus)  -> LT+			 (Plus , Minus) -> GT+			 (Plus , Plus)  -> mgHigher x `compare` mgHigher y+			 (Minus, Minus) -> mgLower  x `compare` mgLower  y+		 o -> o++majorityGauge :: Ord grade => Merit grade -> Maybe (MajorityGauge grade)+majorityGauge = listToMaybe . majorityGauges++majorityGauges :: Ord grade => Merit grade -> [MajorityGauge grade]+majorityGauges (Merit m) = go Map.empty m+	where+	go done gs = case snd (Map.foldlWithKey untilMajGrade (0,[]) gs) of+	              []  -> []+	              (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)+		total = List.sum gs+		untilMajGrade (t,[]) g c | 2*tc >= total = (tc,[(MajorityGauge 0 g t,c)])+		                         | otherwise     = (tc,[])+		                         where tc = t+c+		untilMajGrade (t,(mg,c):_) _g c' = (t,[(mg{mgHigher=mgHigher mg + c'},c)])++-- * Type 'MajorityGaugeRanking'+type MajorityGaugeRanking choice grade = [(choice, [MajorityGauge grade])]++majorityGaugesByChoice :: Ord grade => MeritByChoice choice grade -> HM.HashMap choice [MajorityGauge grade]+majorityGaugesByChoice (MeritByChoice ms) = majorityGauges <$> ms++majorityGaugeRanking :: Ord grade => MeritByChoice choice grade -> MajorityGaugeRanking choice grade+majorityGaugeRanking = List.sortOn (Down . snd) . HM.toList . majorityGaugesByChoice

@@ -0,0 +1,11 @@+module Majority.Judgment+ ( module Majority.Merit+ , module Majority.Value+ , module Majority.Gauge+ , module Majority.Section+ ) where++import Majority.Merit+import Majority.Value+import Majority.Gauge+import Majority.Section

@@ -0,0 +1,194 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-} -- NOTE: for IsList+module Majority.Merit where++import Data.Eq (Eq(..))+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.Semigroup (Semigroup(..))+import Data.Set (Set)+import Data.Tuple (curry)+import GHC.Exts (IsList(..))+import Prelude (Bounded(..), Enum(..), Num(..), Integer, error)+import Text.Show (Show(..))+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set++-- * Type 'Choices'+type Choices = HS.HashSet++-- | Return a set of 'Choices' by enumerating the alternatives of its type. Useful on sum types.+choices :: (Bounded choice , Enum choice , Eq choice, Hashable choice) => Choices choice+choices = HS.fromList $ enumFrom minBound++-- * Type 'Grades'+-- | How many 'grade's should be used?+-- A greater number of 'grade's permits a finer distinction but demands+-- a higher degree of expertise and discernment.+-- The optimal number is the highest number of 'grade's that constitutes a common language,+-- that is, that allows 'Judges' to make absolute judgments.+-- Too little 'grade's may lead too often to ties.+-- +-- Note, however, that if the inputs or grades depend on the set of 'choice's,+-- i.e. if judges change their grades when 'choice's are added or dropped,+-- then the Arrow paradox cannot be avoided.+-- To avoid this the scale of grades must be fixed and absolute+-- so that more or fewer 'choice's does not change+-- the inputs or messages of other 'choice's.+type Grades = Set++grades :: [grade] -> Grades (Ranked grade)+grades = Set.fromList . zipRank++-- * Type 'Ranked'+-- | Helper type to rank data without a good 'Ord' instance.+newtype Ranked a = Ranked (Integer, a)+ deriving (Show,Functor)+instance Eq (Ranked a) where+	Ranked (x,_) == Ranked (y,_) = x==y+instance Ord (Ranked a) where+	Ranked (x,_) `compare` Ranked (y,_) = x`compare`y++-- | @'zipRank' xs@ returns a list with the items of 'xs' wrapped+-- so that they are 'compare'able according to their position into 'xs'.+zipRank :: [a] -> [Ranked a]+zipRank = List.zipWith (curry Ranked) [0..]++rankKey :: [(k, a)] -> [(Ranked k, a)]+rankKey = List.zipWith (\i (k,a) -> (Ranked (i,k),a)) [0..]++unRank :: Ranked a -> a+unRank (Ranked (_i, x)) = x++-- | Return the 'Set' enumerating the alternatives+-- of its type parameter. Useful on sum types.+enum :: (Bounded a, Enum a, Ord a) => Set a+enum = Set.fromList $ enumFrom minBound++-- * Type 'Judges'+-- | Map each 'judge' to its default 'grade'+-- (usually the same for all 'judge's but not necessarily).+--+-- For instance, when a 'judge' gives no 'grade' or has “no opinion”,+-- this default grade could mean that the 'judge' chooses “To Reject” the 'choice':+-- the rationale being that a 'judge' having “no opinion”+-- concerning a 'choice' has not even taken the time to evaluate it+-- and thus has implicitly rejected it.+type Judges = HM.HashMap++judges ::+ Eq judge =>+ Hashable judge =>+ [judge] -> grade -> Judges judge grade+judges js dg = HM.fromList $ (\j -> (j, dg)) <$> js++-- * Type 'Opinions'+-- | Profile of opinions of some 'judge's about a single 'choice'.+type Opinions judge grade = HM.HashMap judge (Distribution grade)++-- | @(ok, ko) = 'opinions' js os@ returns:+--+-- * in 'ok' the opinions of the 'judge's 'js' updated by those in 'os',+-- * in 'ko' the opinions of 'judge's not in 'js'.+opinions ::+ Eq judge =>+ Hashable judge =>+ Judges judge grade ->+ Opinions judge grade ->+ ( Opinions judge grade+ , HS.HashSet judge )+opinions js os =+	( HM.union os $ singleGrade <$> js+	, HS.fromMap $ (() <$) $ os`HM.difference`js )++-- ** Type 'Distribution'+-- | Usually, a 'judge' gives a 'singleGrade' to a given 'choice'.+-- However, when applying the Majority Judgment to a 'Tree' of 'Section's,+-- what a 'judge' gives to a parent 'Section'+-- is composed by the 'grade's he or she has given+-- to the sub-'Section's, and those can be different.+-- In that case, each 'grade' given to a sub-'Section' contributes to a 'Share'+-- of the parent 'Section' which therefore is not necessarily a 'singleGrade',+-- but more generally a 'Distribution' of 'grade's.+-- And the sub-'Section's can actually themselves have sub-'Section's,+-- hence not being given a 'grade', but a 'Distribution' of 'grade's too.+type Distribution grade = Map grade Share++singleGrade :: grade -> Distribution grade+singleGrade = (`Map.singleton` 1)++-- *** Type 'Share'+-- | Usually a 'judge' attributes a 'singleGrade' to a given 'choice',+-- and then the 'Share' of this 'grade' is 1.+-- However, when introducing vote colleges (giving more power to some 'judge's),+-- or when introducing 'Section's (decomposing a judgment into several sub-judgments),+-- it becomes possible that only a percentage of 'grade'+-- is attributed by a 'judge' to a given 'choice'.+-- This is what a 'Share' is used for.+type Share = Rational+ -- FIXME: newtype checking >= 0++-- ** Type 'OpinionsByChoice'+-- | Profile of opinions of some 'Judges' about some 'choice's.+type OpinionsByChoice choice judge grade = HM.HashMap choice (Opinions judge grade)++opinionsByChoice ::+ Eq choice =>+ Hashable choice =>+ [(choice, Opinions judge grade)] ->+ OpinionsByChoice choice judge grade+opinionsByChoice = HM.fromList++-- * Type 'Merit'+-- | Profile of merit about a single 'choice'.+newtype Merit grade = Merit { unMerit :: Map grade Share }+ deriving (Eq, Show)+instance Ord grade => Semigroup (Merit grade) where+	Merit x <> Merit y = Merit (Map.unionWith (+) x y)+instance (Ord grade, Show grade) => IsList (Merit grade) where+	type Item (Merit grade) = (grade, Share)+	fromList = Merit . Map.fromListWithKey+		 (\g _x _y -> error $ "duplicate grade in merit: " <> show g)+	toList (Merit cs) = toList cs++-- | @merit os@ returns the 'Merit' given by opinions 'os'+merit ::+ Ord grade =>+ Opinions judge grade ->+ Merit grade+merit = foldr insertOpinion $ Merit $ Map.empty+	-- TODO: maybe count by making g passes+	where+	insertOpinion dist (Merit m) =+		Merit $+		Map.foldlWithKey+		 (\acc g s -> Map.insertWith (+) g s acc)+		 m dist++-- ** Type 'MeritByChoice'+-- | Profile of merit about some 'choice's.+newtype MeritByChoice choice grade+ =      MeritByChoice { unMeritByChoice :: HM.HashMap choice (Merit grade) }+ deriving (Eq, Show)+instance (Eq choice, Hashable choice, Ord grade) => Semigroup (MeritByChoice choice grade) where+	MeritByChoice x <> MeritByChoice y = MeritByChoice (HM.unionWith (<>) x y)+instance (Eq choice, Hashable choice, Show choice) => IsList (MeritByChoice choice grade) where+	type Item (MeritByChoice choice grade) = (choice, Merit grade)+	fromList = MeritByChoice . HM.fromListWith+		 (\_x _y -> error $ "duplicate choice in merits")+	toList (MeritByChoice cs) = toList cs++-- | @meritByChoice gs cs os@ returns the 'Merit's+-- given to 'choice's 'cs' by opinions 'os' from the 'Judges' 'js' on the 'Grades' 'gs'.+meritByChoice ::+ (Ord grade, Eq choice, Hashable choice) =>+ OpinionsByChoice choice judge grade ->+ MeritByChoice choice grade+meritByChoice os = MeritByChoice $ merit <$> os

@@ -0,0 +1,189 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- | This module implements the composition of a Majority Judgment+-- from a tree of Majority Judgments: for the same question,+-- the same choices, the same judges and the same grades.+-- In that tree, a parent judgment is formed by the aggregation of its children judgments,+-- where a child judgment contributes only for a percentage of the parent judgment.+module Majority.Section where++import Control.Applicative (Applicative(..), Alternative(..))+import Data.Bool+import Data.Either (Either(..))+import Data.Eq (Eq(..))+import Data.Foldable (Foldable(..), any)+import Data.Function (($), (.))+import Data.Functor ((<$>), (<$))+import Data.Hashable (Hashable(..))+import Data.Maybe (Maybe(..), isNothing, maybe, fromMaybe)+import Data.Ord (Ord(..))+import Data.Traversable (Traversable(..))+import Data.Tree as Tree+import Prelude (Num(..), Fractional(..), toRational)+import Text.Show (Show(..))+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import qualified Data.List as List+import qualified Data.Map.Strict as Map++import Majority.Merit++-- * Type 'Section'+-- | An opinion of a 'judge' about a 'choice' at a specific section 'Tree.Node'.+data Section grade+ =   Section+ {   sectionShare :: Maybe Share+     -- ^ A 'Share' within the parent 'Tree.Node'+     --   (defaulting to a 'Share' computed as the remaining 'Share' to reach 1+     --   divided by the number of defaulted 'Share's).+ ,   sectionGrade :: Maybe grade+     -- ^ A 'grade' attributed to the current 'Tree.Node'+     --   (defaulting to the 'grade' set on an ancestor 'Tree.Node' if any,+     --   or the |judge|'s default grade).+ } deriving (Eq,Show)++-- ** Type 'SectionByJudge'+type SectionByJudge judge grade = HM.HashMap judge (Section grade)++-- ** Type 'SectionNode'+-- | Node value of a 'Tree' holding a 'Section', per 'judge', per 'choice'.+data SectionNode choice judge grade+ =   SectionNode+ {   sectionNodeShare       :: Maybe Share+     -- ^ A default 'sectionShare' for judges not specifying their own.+ ,   sectionByJudgeByChoice :: HM.HashMap choice (SectionByJudge judge grade)+ } deriving (Eq,Show)++-- * Type 'ErrorSection'+data ErrorSection choice judge grade+ =   ErrorSection_unknown_choices (HS.HashSet choice)+     -- ^ When some 'choice's are not known.+ |   ErrorSection_unknown_judges (HM.HashMap choice (HS.HashSet judge))+     -- ^ When some 'judge's are not known.+ |   ErrorSection_invalid_shares (HM.HashMap choice (HM.HashMap judge [Share]))+     -- ^ When at least one of the 'Share's is not positive, or when their sum is not 1.+ deriving (Eq,Show)++-- | @'opinionsBySection' cs js ss@ computes the 'Opinions' of the given 'Judges' @js@ about the given 'choice's @cs@,+-- from the 'grade' (specified or omitted) attributed to 'choice's+-- and the 'Share's (specified or omitted) attributed to 'Tree.Node'+-- in given 'Tree' @ss@.+opinionsBySection ::+ forall choice judge grade.+ Eq choice =>+ Eq judge =>+ Hashable choice =>+ Hashable judge =>+ Ord grade =>+ Choices choice ->+ Judges judge grade ->+ Tree (SectionNode choice judge grade) ->+ Either (ErrorSection choice judge grade)+        (Tree (OpinionsByChoice choice judge grade))+opinionsBySection cs js = go ((singleGrade <$> js) <$ HS.toMap cs)+	where+	go :: HM.HashMap choice (HM.HashMap judge (Distribution grade)) ->+	      Tree (SectionNode choice judge grade) ->+	      Either (ErrorSection choice judge grade)+	             (Tree (OpinionsByChoice choice judge grade))+	go defaultDistJC (Tree.Node (SectionNode _sectionNodeShare currOpinJC) childOpinJCS) =+		-- From current |Tree.Node|'s value.+			let currDistJC :: HM.HashMap choice (HM.HashMap judge (Distribution grade)) =+				-- Collect the 'Distribution' of current 'Tree.Node',+				-- and insert default 'Distribution'+				-- for each unspecified 'judge'+				-- of each (specified or unspecified) 'choice'.+				let specifiedDistJC =+					HM.mapWithKey (\choice ->+						let defaultDistJ = defaultDistJC HM.!choice in+						HM.mapWithKey (\judge ->+							maybe (defaultDistJ HM.!judge) singleGrade .+							sectionGrade))+					 currOpinJC+				in+				HM.unionWith HM.union+				 specifiedDistJC+				 defaultDistJC+			in+		-- From children 'Tree.Node's.+			let maybeChildShareSJC :: HM.HashMap choice (HM.HashMap judge [Maybe Share]) =+				-- Collect the (specified or explicitely (with 'Nothing') unspecified) 'Share's by section,+				-- and insert all unspecified 'Share's when a 'choice' or a 'judge' is unspecified.+				foldr (\(Tree.Node SectionNode{sectionNodeShare, sectionByJudgeByChoice} _) ->+					let defaultChildShareSJC = ([sectionNodeShare] <$ js) <$ defaultDistJC in+					let specifiedChildShareSJC =+						(<$> sectionByJudgeByChoice) $+						(pure . (<|> sectionNodeShare) . sectionShare <$>) in+					-- Fusion specified 'choice's into accum.+					HM.unionWith (HM.unionWith (List.++)) $+						-- Add default 'Share' for this 'Tree.Node',+						-- for each unspecified 'judge' of specified and unspecified 'choice'.+						HM.unionWith HM.union+						 specifiedChildShareSJC+						 defaultChildShareSJC)+				 HM.empty+				 childOpinJCS+			in+			let childShareSJC :: HM.HashMap choice (HM.HashMap judge [Share]) =+				-- Replace unspecified shares of each child 'Tree.Node'+				-- by an even default: the total remaining 'Share'+				-- divided by the number of unspecified 'Share's.+				(<$> maybeChildShareSJC) $ \maybeShareSJ ->+					(<$> maybeShareSJ) $ \maybeShareS ->+						let specifiedShare    = sum $ fromMaybe 0 <$> maybeShareS in+						let unspecifiedShares = toRational $ List.length $ List.filter isNothing maybeShareS in+						let defaultShare      = (1 - specifiedShare) / unspecifiedShares in+						fromMaybe defaultShare <$> maybeShareS+			in+		case childOpinJCS of+		-- Test for unknown choices.+		 _ | unknownChoices <- currOpinJC`HM.difference`defaultDistJC+		   , not $ null unknownChoices ->+			Left $ ErrorSection_unknown_choices $+				HS.fromMap $ (() <$) $ unknownChoices+		-- Test for unknown judges.+		 _ | unknownJudgesC <- HM.filter (not . null) $+		                       HM.intersectionWith HM.difference+		                        currOpinJC+		                        defaultDistJC+		   , not $ null unknownJudgesC ->+			Left $ ErrorSection_unknown_judges $+				HS.fromMap . (() <$) <$> unknownJudgesC+		-- Handle no child 'Tree.Node':+		-- current 'Distribution' is computed from current |Tree.Node|'s value ('currOpinJC')+		-- and inherited default 'Distribution' ('defaultDistJC').+		 [] -> Right $ Tree.Node currDistJC []+		-- Test for invalid shares.+		 _ | invalidSharesJC <-+		       HM.filter (not . null) $+		       HM.filter (\ss -> any (< 0) ss || sum ss /= 1)+		       <$> childShareSJC+		   , not $ null invalidSharesJC ->+			Left $ ErrorSection_invalid_shares invalidSharesJC+		-- Handle children 'Tree.Node's:+		-- current 'Opinions' is computed from the 'Opinions' of the children 'Tree.Node's.+		 _ -> do+			distJCS :: [Tree (HM.HashMap choice (HM.HashMap judge (Distribution grade)))] <-+				traverse (go $ currDistJC) childOpinJCS+				-- 'grade's set at current 'Tree.Node' ('currDistJC')+				-- become the new default 'grade's ('defaultDistJC')+				-- within its children 'Tree.Node's.+			let distSJC :: HM.HashMap choice (HM.HashMap judge [Distribution grade]) =+				-- Collect the 'Distribution's by section.+				foldr (\distJC ->+					let newDistSJC = (pure <$>) <$> rootLabel distJC in+					HM.unionWith (HM.unionWith (List.++)) newDistSJC)+				 HM.empty+				 distJCS+			let distJC :: HM.HashMap choice (HM.HashMap judge (Distribution grade)) =+				-- Compute the current 'Distribution' by scaling (share *) and merging (+)+				-- the children 'Distribution's.+				HM.mapWithKey (\choice ->+					let childShareSJ = childShareSJC HM.!choice in+					HM.mapWithKey (\judge ->+						let childShareS = childShareSJ HM.!judge in+						Map.unionsWith (+) .+						List.zipWith+						 (\share dist -> (share *) <$> dist)+						 childShareS))+				 distSJC+			Right $ Tree.Node distJC distJCS

@@ -0,0 +1,133 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Majority.Value where++import Data.Bool+import Data.Eq (Eq(..))+import Data.Function (($), (.), on)+import Data.Functor ((<$>))+import Data.List as List+import Data.Maybe (Maybe(..), listToMaybe)+import Data.Ord (Ord(..), Ordering(..), Down(..))+import Data.Ratio ((%))+import Data.Semigroup (Semigroup(..))+import Data.Tuple (snd)+import Prelude (Num(..))+import Text.Show (Show(..))+import qualified Data.HashMap.Strict as HM+import qualified Data.Map.Strict as Map++import Majority.Merit++-- * Type 'MajorityValue'+-- | 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] }+ deriving (Eq, Show)+instance Ord grade => Ord (MajorityValue grade) where+	MajorityValue []`compare`MajorityValue [] = EQ+	MajorityValue []`compare`MajorityValue ys | all ((==0) . middleShare) ys = EQ+	                                          | otherwise                    = LT+	MajorityValue xs`compare`MajorityValue [] | all ((==0) . middleShare) xs = EQ+	                                          | otherwise                    = GT+	mx@(MajorityValue (x:xs)) `compare` my@(MajorityValue (y:ys))+	 | middleShare x <= 0 && middleShare y <= 0 = MajorityValue xs`compare`MajorityValue ys+	 | middleShare x <= 0 = MajorityValue xs`compare`my+	 | middleShare y <= 0 = mx`compare`MajorityValue ys+	 | otherwise =+		lowGrade x`compare`lowGrade y <>+		highGrade x`compare`highGrade y <>+		case middleShare x`compare`middleShare y of+		 LT -> compare (MajorityValue xs) (MajorityValue (y{middleShare = middleShare y - middleShare x} : ys))+		 EQ -> compare (MajorityValue xs) (MajorityValue ys)+		 GT -> compare (MajorityValue (x{middleShare = middleShare x - middleShare y} : xs)) (MajorityValue ys)++-- ** Type 'Middle'+-- | A centered middle of a 'Merit'.+-- Needed to handle the 'Fractional' capabilities of a 'Share'.+--+-- By construction in 'majorityValue',+-- 'lowGrade' is always lower or equal to 'highGrade'.+data Middle grade = Middle+ { middleShare :: Share -- ^ the same 'Share' of 'lowGrade' and 'highGrade'.+ , lowGrade    :: grade+ , highGrade   :: grade+ } deriving (Eq, Ord, Show)++-- | The 'majorityValue' is the list of the 'Middle's of the 'Merit' of a 'choice',+-- from the most consensual to the least.+majorityValue :: Ord grade => Merit grade -> MajorityValue grade+majorityValue (Merit countByGrade) = MajorityValue $ goMiddle 0 [] $ Map.toList countByGrade+	where+	total = sum countByGrade+	middle = (1%2) * total+	goMiddle :: Ord grade => Share -> [(grade,Share)] -> [(grade,Share)] -> [Middle grade]+	goMiddle prevShare ps next =+		case next of+		 [] -> []+		 curr@(currGrade,currShare):ns ->+			let nextShare = prevShare + currShare in+			case nextShare`compare`middle of+			 LT -> goMiddle nextShare (curr:ps) ns+			 EQ -> goBorders (curr:ps) ns+			 GT ->+				let lowShare  = middle - prevShare in+				let highShare = nextShare - middle in+				let minShare  = min lowShare highShare in+				Middle minShare currGrade currGrade :+				goBorders+				 ((currGrade, lowShare  - minShare) : ps)+				 ((currGrade, highShare - minShare) : ns)+	goBorders :: [(grade,Share)] -> [(grade,Share)] -> [Middle grade]+	goBorders lows highs =+		case (lows,highs) of+		 ((lowGrade,lowShare):ls, (highGrade,highShare):hs)+		  | lowShare <= 0  -> goBorders ls highs+		  | highShare <= 0 -> goBorders lows hs+		  | otherwise ->+				let minShare = min lowShare highShare in+				Middle minShare lowGrade highGrade :+				goBorders+				 ((lowGrade , lowShare  - minShare) : ls)+				 ((highGrade, highShare - minShare) : hs)+		 _ -> []+instance (Show grade, Ord grade) => Ord (Merit grade) where+	compare = compare `on` majorityValue++-- | The 'majorityGrade' is the lower middlemost+-- (also known as median by experts) of the 'grade's+-- given to a 'choice' by the 'Judges'.+--+-- It is the highest 'grade' approved by an absolute majority of the 'Judges':+-- more than 50% of the 'Judges' give the 'choice' at least a 'grade' of 'majorityGrade',+-- but every 'grade' lower than 'majorityGrade' is rejected by an absolute majority+-- Thus the 'majorityGrade' of a 'choice'+-- is the final 'grade' wished by the majority.+--+-- The 'majorityGrade' is necessarily a word that belongs to 'grades',+-- and it has an absolute meaning.+--+-- When the number of 'Judges' is even, there is a middle-interval+-- (which can, of course, be reduced to a single 'grade'+-- if the two middle 'grade's are the same),+-- then the 'majorityGrade' is the lowest 'grade' of the middle-interval+-- (the “lower middlemost” when there are two in the middle),+-- 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++-- * Type 'MajorityRanking'+type MajorityRanking choice grade = [(choice, MajorityValue grade)]++majorityValueByChoice :: Show grade => 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.+--+-- 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 = List.sortOn (Down . snd) . HM.toList . majorityValueByChoice

@@ -43,14 +43,14 @@ If the number of individual judgments is small and even (eg. for 6 judges: [“Insufficient”, “Acceptable”, “Acceptable”, “Good”, “Good”, “Good”]), there is however a probability that two different grades-border the middlemost of this dilated scale (here: [“Acceptable”, “Good”]).+border the middlemost of this dilated scale (here: “Acceptable” and “Good”). But only the lower grade (here: “Acceptable”) rewards consensus, and thus is considered to be the most consensual. Indeed, if any other choice obtains less scattered judgments (eg. [“Acceptable”, “Acceptable”, “Acceptable”, “Acceptable”, “Good”, “Good”]) all enclosed into these two grades, it will obtain a most consensual majoritary grade-greater or egal to the one of this choice (here: “Acceptable”).+greater or egal (here: “Acceptable”) to the one of this choice. Which would not necessarily be the case with the greater grade (here: “Good”).  ## Ranking many choices

@@ -1,7 +1,10 @@-author: Julien Moutinho <julm+hjugement@autogeree.net>-build-type: Simple-cabal-version: >= 1.18-category: Language+name: hjugement+-- PVP:  +-+------- breaking API changes+--       | | +----- non-breaking API additions+--       | | | +--- code changes with no API change+version: 2.0.0.20180903+category: Politic+synopsis: Majority Judgment. description:   A library for the <http://libgen.io/book/index.php?md5=BF67AA4298C1CE7633187546AA53E01D Majority Judgment>.   .@@ -11,10 +14,11 @@   in theory and in practice”.   .   For introductory explanations, you can read:-  the README.md (en) and/or-  Marjolaine Leray's comic: <https://www.lechoixcommun.fr/articles/Vous_reprendrez_bien_un_peu_de_democratie-2.html Vous reprendrez bien un peu de démocratie ?> (fr)   .-  Or watch: Rida Laraki's conference: <https://mixitconf.org/2017/majority-judgment Le Jugement Majoritaire> (fr)+  * the accompanying README.md file (en),+  * Marjolaine Leray's comic: <https://www.lechoixcommun.fr/articles/Vous_reprendrez_bien_un_peu_de_democratie-2.html Vous reprendrez bien un peu de démocratie ?> (fr),+  * the dedicated web sites: <https://mieuxvoter.fr> and <https://lechoixcommun.fr>,+  * or watch: Rida Laraki's conference: <https://mixitconf.org/2017/majority-judgment Le Jugement Majoritaire> (fr).   .   For comprehensive studies, you can read Michel Balinski and Rida Laraki's:   .@@ -22,51 +26,77 @@   * 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)-extra-source-files: extra-doc-files: README.md-extra-tmp-files: license: GPL-3 license-file: COPYING-maintainer: Julien Moutinho <julm+hjugement@autogeree.net>-name: hjugement stability: experimental-synopsis: Majority Judgment.-tested-with: GHC==8.0.2-version: 1.0.0.20170808+author:      Julien Moutinho <julm+hjugement@autogeree.net>+maintainer:  Julien Moutinho <julm+hjugement@autogeree.net>+bug-reports: Julien Moutinho <julm+hjugement@autogeree.net>+-- homepage: +build-type: Simple+cabal-version: 1.24+tested-with: GHC==8.4.3+extra-source-files:+  stack.yaml+extra-tmp-files:+ Source-Repository head  location: git://git.autogeree.net/hjugement  type:     git  Library   exposed-modules:-    Hjugement-    Hjugement.Majority+    Majority.Gauge+    Majority.Judgment+    Majority.Merit+    Majority.Section+    Majority.Value   default-language: Haskell2010   default-extensions:-  ghc-options: -Wall -fno-warn-tabs+    NoImplicitPrelude+    NamedFieldPuns+  ghc-options:+    -Wall+    -Wincomplete-uni-patterns+    -Wincomplete-record-updates+    -fno-warn-tabs+    -- -fhide-source-paths   build-depends:-    base >= 4.6 && < 5-    , containers > 0.5+      base >= 4.6 && < 5+    , containers >= 0.5+    , hashable >= 1.2.6+    -- , transformers >= 0.5.2+    , unordered-containers >= 0.2.8  Test-Suite hjugement-test   type: exitcode-stdio-1.0-  default-language: Haskell2010-  default-extensions:-  ghc-options: -Wall -fno-warn-tabs   hs-source-dirs: test   main-is: Main.hs   other-modules:     HUnit     QuickCheck     Types+  default-language: Haskell2010+  default-extensions:+    ImplicitPrelude+  ghc-options:+    -Wall+    -Wincomplete-uni-patterns+    -Wincomplete-record-updates+    -fno-warn-tabs+    -- -fhide-source-paths   build-depends:-    base >= 4.6 && < 5-    , containers >= 0.5 && < 0.6-    , hjugement+      hjugement+    , base >= 4.6 && < 5+    , containers >= 0.5+    , hashable >= 1.2.6     , QuickCheck >= 2.0+    , random >= 1.1     , tasty >= 0.11-    , tasty-hunit+    , tasty-hunit >= 0.9     , tasty-quickcheck-    , text-    , transformers >= 0.4 && < 0.6+    , text >= 1.2+    , transformers >= 0.5+    , unordered-containers >= 0.2.8

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

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module HUnit where @@ -6,175 +7,725 @@ import Test.Tasty.HUnit  import Control.Arrow (second)-import qualified Data.Map.Strict as Map+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 Hjugement+import Majority.Judgment import Types  hunits :: TestTree hunits = 	testGroup "HUnit"-	 [ testGroup "Value" $+	 [ testGroup "MajorityValue" $ 		 [ testCompareValue-			 [(3,15), (2,7), (1,3), (0::Int,2)]-			 [(3,16), (2,6), (1,2), (0,3)]-		 , testGroup "OfMerits"+			 (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-				testValueOfMerits+				testMajorityValueOfMerits 				 [ (The, m [136,307,251,148,84,74]) 				 ]-				 [ (The, [('C',251),('B',307),('D',148),('E',84),('A',136),('F',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-				testValueOfMerits+				testMajorityValueOfMerits 				 [ (This, m [12,10,21,5,5,5,2]) 				 , (That, m [12,16,22,3,3,3,1]) 				 ]-				 [ (This, [(Acceptable,21),(Insufficient,10),(Good,5),(ToReject,12),(Perfect,5),(VeryGood,5),(TooGood,2)])-				 , (That, [(Acceptable,22),(Insufficient,16),(ToReject,12),(VeryGood,3),(Perfect,3),(Good,3),(TooGood,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 "OfOpinions"-			 [ testValueOfOpinions [No,Yes]-				   [The]-				 [ [No ]-				 , [No ]-				 , [No ]-				 , [No ]-				 , [Yes]-				 , [Yes]-				 ]-				 [ (The, [(No,4),(Yes,2)])-				 ]-			 , testValueOfOpinions [No,Yes]-				   [The]-				 [ [No ]-				 , [No ]-				 , [No ]-				 , [Yes]-				 , [Yes]-				 , [Yes]-				 ]-				 [ (The, [(No,3),(Yes,3)])-				 ]-			 , testValueOfOpinions [No,Yes]-				   [This, That]-				 [ [No  , No ]-				 , [No  , Yes]-				 , [No  , Yes]-				 , [No  , Yes]-				 , [Yes , Yes]-				 , [Yes , Yes]+		 , 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, [(No,4),(Yes,2)])-				 , (That, [(Yes,5),(No,1)])+				 [ (This, [ Middle (1 % 1) No No+				          , Middle (2 % 1) No Yes+				          ])+				 , (That, [ Middle (2 % 1) Yes Yes+				          , Middle (1 % 1) No  Yes+				          ]) 				 ]-			 , testValueOfOpinions [No,Yes]-				   [This, That]-				 [ [No  , No ]-				 , [No  , No ]-				 , [No  , No ]-				 , [No  , Yes]-				 , [No  , Yes]-				 , [No  , Yes]+			 , testMajorityValueOfOpinions+				 [ (This, [No,No,No,No,No,No])+				 , (That, [No,No,No,Yes,Yes,Yes]) 				 ]-				 [ (This, [(No,6),(Yes,0)])-				 , (That, [(No,3),(Yes,3)])+				 [ (This, [Middle (3 % 1) No No])+				 , (That, [Middle (3 % 1) No Yes]) 				 ]-			 , testValueOfOpinions [No,Yes]-				   [This, That]-				 [ [Yes , No ]-				 , [Yes , No ]-				 , [Yes , No ]-				 , [Yes , Yes]-				 , [Yes , Yes]-				 , [Yes , Yes]+			 , testMajorityValueOfOpinions+				 [ (This, [Yes,Yes,Yes,Yes,Yes,Yes])+				 , (That, [No,No,No,Yes,Yes,Yes]) 				 ]-				 [ (This, [(Yes,6),(No,0)])-				 , (That, [(No,3),(Yes,3)])+				 [ (This, [Middle (3 % 1) Yes Yes])+				 , (That, [Middle (3 % 1) No  Yes]) 				 ]-			 , testValueOfOpinions [No,Yes]-				   [This, That]-				 [ [No  , No ]-				 , [No  , No ]-				 , [Yes , No ]-				 , [Yes , Yes]-				 , [Yes , Yes]-				 , [Yes , Yes]+			 , testMajorityValueOfOpinions+				 [ (This, [No,No,Yes,Yes,Yes,Yes])+				 , (That, [No,No,No,Yes,Yes,Yes]) 				 ]-				 [ (This, [(Yes,4),(No,2)])-				 , (That, [(No,3),(Yes,3)])+				 [ (This, [ Middle (1 % 1) Yes Yes+				          , Middle (2 % 1) No  Yes+				          ])+				 , (That, [ Middle (3 % 1) No Yes ]) 				 ]-			 , testValueOfOpinions [ToReject,Insufficient,Acceptable,Good,VeryGood,Perfect]-				   [1::Int ..6]-				 [ [Perfect,Perfect,Acceptable,VeryGood,Good,VeryGood]-				 , [Perfect,VeryGood,Perfect,Good,Acceptable,Acceptable]-				 , [VeryGood,VeryGood,Good,Acceptable,VeryGood,Insufficient]-				 , [Perfect,VeryGood,VeryGood,Good,Good,Acceptable]-				 , [Perfect,Good,VeryGood,Good,Good,Acceptable]-				 , [Perfect,VeryGood,Perfect,Good,Good,Good]+			 , 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, [(Perfect,5),(VeryGood,1),(ToReject,0),(Insufficient,0),(Acceptable,0),(Good,0)])-				 , (2, [(VeryGood,4),(Good,1),(Perfect,1),(ToReject,0),(Insufficient,0),(Acceptable,0)])-				 , (3, [(VeryGood,2),(Good,1),(Perfect,2),(Acceptable,1),(ToReject,0),(Insufficient,0)])-				 , (4, [(Good,4),(Acceptable,1),(VeryGood,1),(ToReject,0),(Insufficient,0),(Perfect,0)])-				 , (5, [(Good,4),(Acceptable,1),(VeryGood,1),(ToReject,0),(Insufficient,0),(Perfect,0)])-				 , (6, [(Acceptable,3),(Good,1),(Insufficient,1),(VeryGood,1),(ToReject,0),(Perfect,0)])+				 [ (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 -mkOpinion :: Ord prop =>-             Choices prop -> judge -> [grade] ->-             (judge, Opinion prop grade)-mkOpinion props j gs = (j, Map.fromList $ toList props `zip` gs)--mkMerit :: (Ord grade, Show grade) => [grade] -> [Count] -> Merit grade-mkMerit scal = fromList . (scal`zip`)--mkMerits :: (Ord prop, Ord grade) =>-            [grade] -> Choices prop -> [[grade]] ->-            Merits prop grade-mkMerits scal props opins =-	merits (Scale (fromList scal) (head scal)) props $ fromList $-	zipWith (mkOpinion props) [1::Int ..] opins+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) =>-                    [(grade, Count)] -> [(grade, Count)] -> TestTree+                    MajorityValue grade -> MajorityValue grade -> TestTree testCompareValue x y =-	testGroup (elide $ show (x,y))-	 [ testCase "x == x" $ Value x`compare`Value x @?= EQ-	 , testCase "y == y" $ Value y`compare`Value y @?= EQ-	 , testCase "x <  y" $ Value x`compare`Value y @?= LT-	 , testCase "y >  x" $ Value y`compare`Value x @?= GT+	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 	 ] -testRanking :: (Ord prop, Ord grade, Show grade, Show prop) =>-               [grade] -> Choices prop -> [[grade]] ->-               Ranking prop -> TestTree-testRanking scal props opins expect =-	testCase (elide $ show (toList props,opins)) $-		majorityRanking (mkMerits scal props opins) @?= expect+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 -testValueOfOpinions :: (Show grade, Show prop, Ord grade, Ord prop) =>-             [grade] -> Choices prop -> [[grade]] ->-             [(prop, [(grade,Count)])] -> TestTree-testValueOfOpinions scal props opins expect =-	testCase (elide $ show (toList props,opins)) $-		majorityValueByChoice (mkMerits scal props opins)-		 @?= ((Value`second`)<$>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) -testValueOfMerits :: (Show grade, Show prop, Ord grade, Ord prop) =>-             Merits prop grade ->-             [(prop, [(grade,Count)])] -> TestTree-testValueOfMerits ms expect =-	testCase (elide $ show ms) $+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-		 @?= ((Value`second`)<$>expect)+		 @?= (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

@@ -7,21 +7,27 @@ 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 Hjugement+import Majority.Judgment import Types  quickchecks :: TestTree quickchecks = 	testGroup "QuickCheck"-	 [ testProperty "arbitraryJudgments" $ \(SameLength (x::[(G6,Count)],y)) ->-		let (gx, cx) = unzip x in-		let (gy, cy) = unzip y in-		gx == gy && sum cx == sum cy-	 , testGroup "Value"-		 [ testProperty "compare" $ \(SameLength (x::Value G6,y)) ->+	 [ 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 		 ] 	 {-@@ -35,24 +41,28 @@ 	 -} 	 ] --- | Decompress a 'Value'.-expandValue :: Value a -> [a]-expandValue (Value []) = []-expandValue (Value ((x,c):xs)) = replicate c x ++ expandValue (Value xs)+-- | 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 --- | @arbitraryJudgments n@ arbitrarily generates 'n' lists of pairs of grade and 'Count'+-- | @arbitraryMerits n@ arbitrarily generates 'n' lists of 'Merit' -- for the same arbitrary grades,--- and with the same total 'Count' of individual judgments.-arbitraryJudgments :: forall g. (Bounded g, Enum g) => Int -> Gen [[(g, Count)]]-arbitraryJudgments n = sized $ \s -> do+-- 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 lg = maxG - minG + 1+	let lenGrades = maxG - minG + 1 	replicateM n $ do-		cs  <- resize s $ arbitrarySizedNaturalSum lg-		cs' <- arbitraryPad (lg - length cs) (return 0) cs-		return $ zip gs cs'+		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',@@ -68,11 +78,43 @@ 		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 :: Int -> Gen a -> [a] -> Gen [a]-arbitraryPad n pad [] = replicateM n pad+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@@ -97,38 +139,46 @@ instance Arbitrary G6 where 	arbitrary = arbitraryBoundedEnum instance (Arbitrary g, Bounded g, Enum g, Ord g, Show g) => Arbitrary (Merit g) where-	arbitrary = fromList . head <$> arbitraryJudgments 1+	arbitrary = head <$> arbitraryMerits 1 	shrink (Merit m) = Merit <$> shrink m instance- ( Arbitrary p, Bounded p, Enum p, Ord p, Show p+ ( Arbitrary c, Bounded c, Enum c, Eq c, Hashable c, Show c  , Arbitrary g, Bounded g, Enum g, Ord g, Show g- ) => Arbitrary (Merits p g) where+ ) => Arbitrary (MeritByChoice c g) where 	arbitrary = do-		minP <- choose (fromEnum(minBound::p), fromEnum(maxBound::p))-		maxP <- choose (minP, fromEnum(maxBound::p))+		minP <- choose (fromEnum(minBound::c), fromEnum(maxBound::c))+		maxP <- choose (minP, fromEnum(maxBound::c)) 		let ps = toEnum minP`enumFromTo`toEnum maxP-		let ms = (fromList <$>) <$> arbitraryJudgments (maxP - minP + 1)+		let ms = arbitraryMerits (maxP - minP + 1) 		fromList . zip ps <$> ms-instance (Bounded g, Eq g, Integral g, Arbitrary g) => Arbitrary (Value g) where-	arbitrary = head . (Value <$>) <$> arbitraryJudgments 1-	shrink (Value vs) = Value <$> shrink vs+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) => Arbitrary (SameLength (Value g, Value g)) where-	arbitrary = do-		SameLength (x,y) <- arbitrary-		return $ SameLength (Value x, Value y)-instance (Arbitrary g, Bounded g, Enum g, Ord g, Show g) => Arbitrary (SameLength (Merit g, Merit g)) where+instance (Arbitrary g, Bounded g, Enum g, Ord g) => Arbitrary (SameLength (MajorityValue g, MajorityValue g)) where 	arbitrary = do 		SameLength (x,y) <- arbitrary-		return $ SameLength (fromList x, fromList y)-instance (Arbitrary g, Bounded g, Enum g) => Arbitrary (SameLength ([(g,Count)], [(g,Count)])) where+		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 <- arbitraryJudgments 2+		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 )

@@ -1,13 +1,20 @@+{-# LANGUAGE DeriveGeneric #-} module Types where +import Data.Hashable+import GHC.Generics (Generic)+import Prelude+ data G2 = No | Yes  deriving (Eq, Ord, Show) -data P1 = The- deriving (Eq, Ord, Show)+data C1 = The+ deriving (Eq, Ord, Show, Generic)+instance Hashable C1 -data P2 = This | That- deriving (Eq, Ord, Show)+data C2 = This | That+ deriving (Eq, Ord, Show, Generic)+instance Hashable C2  data G6 = ToReject | Insufficient | Acceptable | Good | VeryGood | Perfect | TooGood  deriving (Bounded, Enum, Eq, Ord, Show)