diff --git a/Hjugement.hs b/Hjugement.hs deleted file mode 100644 --- a/Hjugement.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Hjugement - ( module Hjugement.Majority - , IsList(..) - ) where - -import Hjugement.Majority -import GHC.Exts (IsList(..)) diff --git a/Hjugement/Majority.hs b/Hjugement/Majority.hs deleted file mode 100644 --- a/Hjugement/Majority.hs +++ /dev/null @@ -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) diff --git a/Majority/Gauge.hs b/Majority/Gauge.hs new file mode 100644 --- /dev/null +++ b/Majority/Gauge.hs @@ -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 diff --git a/Majority/Judgment.hs b/Majority/Judgment.hs new file mode 100644 --- /dev/null +++ b/Majority/Judgment.hs @@ -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 diff --git a/Majority/Merit.hs b/Majority/Merit.hs new file mode 100644 --- /dev/null +++ b/Majority/Merit.hs @@ -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 diff --git a/Majority/Section.hs b/Majority/Section.hs new file mode 100644 --- /dev/null +++ b/Majority/Section.hs @@ -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 diff --git a/Majority/Value.hs b/Majority/Value.hs new file mode 100644 --- /dev/null +++ b/Majority/Value.hs @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/hjugement.cabal b/hjugement.cabal --- a/hjugement.cabal +++ b/hjugement.cabal @@ -1,7 +1,10 @@ -author: Julien Moutinho -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 . . @@ -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: (fr) . - Or watch: Rida Laraki's conference: (fr) + * the accompanying README.md file (en), + * Marjolaine Leray's comic: (fr), + * the dedicated web sites: and , + * or watch: Rida Laraki's conference: (fr). . For comprehensive studies, you can read Michel Balinski and Rida Laraki's: . @@ -22,51 +26,77 @@ * cahier: (en) * paper: (en) * article: (fr) -extra-source-files: extra-doc-files: README.md -extra-tmp-files: license: GPL-3 license-file: COPYING -maintainer: Julien Moutinho -name: hjugement stability: experimental -synopsis: Majority Judgment. -tested-with: GHC==8.0.2 -version: 1.0.0.20170808 +author: Julien Moutinho +maintainer: Julien Moutinho +bug-reports: Julien Moutinho +-- 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 diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,3 @@ +resolver: lts-12.8 +packages: +- '.' diff --git a/test/HUnit.hs b/test/HUnit.hs --- a/test/HUnit.hs +++ b/test/HUnit.hs @@ -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 diff --git a/test/QuickCheck.hs b/test/QuickCheck.hs --- a/test/QuickCheck.hs +++ b/test/QuickCheck.hs @@ -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 ) diff --git a/test/Types.hs b/test/Types.hs --- a/test/Types.hs +++ b/test/Types.hs @@ -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)