Majority/Value.hs

   1 {-# OPTIONS_GHC -fno-warn-orphans #-}
   2 module Majority.Value where
   3
   4 import Data.Bool
   5 import Data.Eq (Eq(..))
   6 import Data.Function (($), (.), on)
   7 import Data.Functor ((<$>))
   8 import Data.List as List
   9 import Data.Maybe (Maybe(..), listToMaybe)
  10 import Data.Ord (Ord(..), Ordering(..), Down(..))
  11 import Data.Ratio ((%))
  12 import Data.Semigroup (Semigroup(..))
  13 import Data.Tuple (snd)
  14 import Prelude (Num(..))
  15 import Text.Show (Show(..))
  16 import qualified Data.HashMap.Strict as HM
  17 import qualified Data.Map.Strict as Map
  18
  19 import Majority.Merit
  20
  21 -- * Type 'MajorityValue'
  22 -- | A 'MajorityValue' is a list of 'grade's
  23 -- made from the successive lower middlemosts of a 'Merit',
  24 -- i.e. from the most consensual 'majorityGrade' to the least.
  25 newtype MajorityValue grade = MajorityValue { unMajorityValue :: [Middle grade] }
  26  deriving (Eq, Show)
  27 instance Ord grade => Ord (MajorityValue grade) where
  28         MajorityValue []`compare`MajorityValue [] = EQ
  29         MajorityValue []`compare`MajorityValue ys | all ((==0) . middleShare) ys = EQ
  30                                                   | otherwise                    = LT
  31         MajorityValue xs`compare`MajorityValue [] | all ((==0) . middleShare) xs = EQ
  32                                                   | otherwise                    = GT
  33         mx@(MajorityValue (x:xs)) `compare` my@(MajorityValue (y:ys))
  34          | middleShare x <= 0 && middleShare y <= 0 = MajorityValue xs`compare`MajorityValue ys
  35          | middleShare x <= 0 = MajorityValue xs`compare`my
  36          | middleShare y <= 0 = mx`compare`MajorityValue ys
  37          | otherwise =
  38                 lowGrade x`compare`lowGrade y <>
  39                 highGrade x`compare`highGrade y <>
  40                 case middleShare x`compare`middleShare y of
  41                  LT -> compare (MajorityValue xs) (MajorityValue (y{middleShare = middleShare y - middleShare x} : ys))
  42                  EQ -> compare (MajorityValue xs) (MajorityValue ys)
  43                  GT -> compare (MajorityValue (x{middleShare = middleShare x - middleShare y} : xs)) (MajorityValue ys)
  44
  45 -- ** Type 'Middle'
  46 -- | A centered middle of a 'Merit'.
  47 -- Needed to handle the 'Fractional' capabilities of a 'Share'.
  48 --
  49 -- By construction in 'majorityValue',
  50 -- 'lowGrade' is always lower or equal to 'highGrade'.
  51 data Middle grade = Middle
  52  { middleShare :: Share -- ^ the same 'Share' of 'lowGrade' and 'highGrade'.
  53  , lowGrade    :: grade
  54  , highGrade   :: grade
  55  } deriving (Eq, Ord, Show)
  56
  57 -- | The 'majorityValue' is the list of the 'Middle's of the 'Merit' of a 'choice',
  58 -- from the most consensual to the least.
  59 majorityValue :: Ord grade => Merit grade -> MajorityValue grade
  60 majorityValue (Merit countByGrade) = MajorityValue $ goMiddle 0 [] $ Map.toList countByGrade
  61         where
  62         total = sum countByGrade
  63         middle = (1%2) * total
  64         goMiddle :: Ord grade => Share -> [(grade,Share)] -> [(grade,Share)] -> [Middle grade]
  65         goMiddle prevShare ps next =
  66                 case next of
  67                  [] -> []
  68                  curr@(currGrade,currShare):ns ->
  69                         let nextShare = prevShare + currShare in
  70                         case nextShare`compare`middle of
  71                          LT -> goMiddle nextShare (curr:ps) ns
  72                          EQ -> goBorders (curr:ps) ns
  73                          GT ->
  74                                 let lowShare  = middle - prevShare in
  75                                 let highShare = nextShare - middle in
  76                                 let minShare  = min lowShare highShare in
  77                                 Middle minShare currGrade currGrade :
  78                                 goBorders
  79                                  ((currGrade, lowShare  - minShare) : ps)
  80                                  ((currGrade, highShare - minShare) : ns)
  81         goBorders :: [(grade,Share)] -> [(grade,Share)] -> [Middle grade]
  82         goBorders lows highs =
  83                 case (lows,highs) of
  84                  ((lowGrade,lowShare):ls, (highGrade,highShare):hs)
  85                   | lowShare <= 0  -> goBorders ls highs
  86                   | highShare <= 0 -> goBorders lows hs
  87                   | otherwise ->
  88                                 let minShare = min lowShare highShare in
  89                                 Middle minShare lowGrade highGrade :
  90                                 goBorders
  91                                  ((lowGrade , lowShare  - minShare) : ls)
  92                                  ((highGrade, highShare - minShare) : hs)
  93                  _ -> []
  94 instance (Show grade, Ord grade) => Ord (Merit grade) where
  95         compare = compare `on` majorityValue
  96
  97 -- | The 'majorityGrade' is the lower middlemost
  98 -- (also known as median by experts) of the 'grade's
  99 -- given to a 'choice' by the 'Judges'.
 100 --
 101 -- It is the highest 'grade' approved by an absolute majority of the 'Judges':
 102 -- more than 50% of the 'Judges' give the 'choice' at least a 'grade' of 'majorityGrade',
 103 -- but every 'grade' lower than 'majorityGrade' is rejected by an absolute majority
 104 -- Thus the 'majorityGrade' of a 'choice'
 105 -- is the final 'grade' wished by the majority.
 106 --
 107 -- The 'majorityGrade' is necessarily a word that belongs to 'grades',
 108 -- and it has an absolute meaning.
 109 --
 110 -- When the number of 'Judges' is even, there is a middle-interval
 111 -- (which can, of course, be reduced to a single 'grade'
 112 -- if the two middle 'grade's are the same),
 113 -- then the 'majorityGrade' is the lowest 'grade' of the middle-interval
 114 -- (the “lower middlemost” when there are two in the middle),
 115 -- which is the only one which respects consensus:
 116 -- any other 'choice' whose grades are all within this middle-interval,
 117 -- has a 'majorityGrade' which is greater or equal to this lower middlemost.
 118 majorityGrade :: Show grade => Ord grade => Merit grade -> Maybe grade
 119 majorityGrade m = lowGrade <$> listToMaybe gs where MajorityValue gs = majorityValue m
 120
 121 -- * Type 'MajorityRanking'
 122 type MajorityRanking choice grade = [(choice, MajorityValue grade)]
 123
 124 majorityValueByChoice :: Show grade => Ord grade => MeritByChoice choice grade -> HM.HashMap choice (MajorityValue grade)
 125 majorityValueByChoice (MeritByChoice ms) = majorityValue <$> ms
 126
 127 -- | The 'majorityRanking' ranks all the 'choice's on the basis of their 'grade's.
 128 --
 129 -- Choice A ranks higher than 'choice' B in the 'majorityRanking'
 130 -- if and only if A’s 'majorityValue' is lexicographically above B’s.
 131 -- There can be no tie unless two 'choice's have precisely the same 'majorityValue's.
 132 majorityRanking :: Show grade => Ord grade => MeritByChoice choice grade -> MajorityRanking choice grade
 133 majorityRanking = List.sortOn (Down . snd) . HM.toList . majorityValueByChoice