hjugement/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 ((%), numerator, denominator)
  12 import Data.Semigroup (Semigroup(..))
  13 import Data.Tuple (snd)
  14 import Prelude (Num(..), fromIntegral, lcm, div, )
  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 --
  26 -- For using less resources and generalizing to non-integral 'Share's,
  27 -- this 'MajorityValue' is actually encoded as an Abbreviated Majority Value,
  28 -- instead of a big list of 'grade's.
  29 newtype MajorityValue grade = MajorityValue [Middle grade]
  30  deriving (Eq, Show)
  31 unMajorityValue :: MajorityValue grade -> [Middle grade]
  32 unMajorityValue (MajorityValue ms) = ms
  33 instance Ord grade => Ord (MajorityValue grade) where
  34         MajorityValue []`compare`MajorityValue [] = EQ
  35         MajorityValue []`compare`MajorityValue ys | all ((==0) . middleShare) ys = EQ
  36                                                   | otherwise                    = LT
  37         MajorityValue xs`compare`MajorityValue [] | all ((==0) . middleShare) xs = EQ
  38                                                   | otherwise                    = GT
  39         mx@(MajorityValue (x:xs)) `compare` my@(MajorityValue (y:ys))
  40          | middleShare x <= 0 && middleShare y <= 0 = MajorityValue xs`compare`MajorityValue ys
  41          | middleShare x <= 0 = MajorityValue xs`compare`my
  42          | middleShare y <= 0 = mx`compare`MajorityValue ys
  43          | otherwise =
  44                 lowGrade x`compare`lowGrade y <>
  45                 highGrade x`compare`highGrade y <>
  46                 case middleShare x`compare`middleShare y of
  47                  LT -> compare (MajorityValue xs) (MajorityValue (y{middleShare = middleShare y - middleShare x} : ys))
  48                  EQ -> compare (MajorityValue xs) (MajorityValue ys)
  49                  GT -> compare (MajorityValue (x{middleShare = middleShare x - middleShare y} : xs)) (MajorityValue ys)
  50
  51 -- ** Type 'Middle'
  52 -- | A centered middle of a 'Merit'.
  53 -- Needed to handle the 'Fractional' capabilities of a 'Share'.
  54 --
  55 -- By construction in 'majorityValue',
  56 -- 'lowGrade' is always lower or equal to 'highGrade'.
  57 data Middle grade = Middle
  58  { middleShare :: Share -- ^ the same 'Share' of 'lowGrade' and 'highGrade'.
  59  , lowGrade    :: grade
  60  , highGrade   :: grade
  61  } deriving (Eq, Ord)
  62 instance Show grade => Show (Middle grade) where
  63         showsPrec p (Middle s l h) = showsPrec p (s,l,h)
  64
  65 -- | The 'majorityValue' is the list of the 'Middle's of the 'Merit' of a 'choice',
  66 -- from the most consensual to the least.
  67 majorityValue :: Ord grade => Merit grade -> MajorityValue grade
  68 majorityValue (Merit countByGrade) = MajorityValue $ goMiddle 0 [] $ Map.toList countByGrade
  69         where
  70         total = sum countByGrade
  71         middle = (1%2) * total
  72         goMiddle :: Ord grade => Share -> [(grade,Share)] -> [(grade,Share)] -> [Middle grade]
  73         goMiddle prevShare ps next =
  74                 case next of
  75                  [] -> []
  76                  curr@(currGrade,currShare):ns ->
  77                         let nextShare = prevShare + currShare in
  78                         case nextShare`compare`middle of
  79                          LT -> goMiddle nextShare (curr:ps) ns
  80                          EQ -> goBorders (curr:ps) ns
  81                          GT ->
  82                                 let lowShare  = middle - prevShare in
  83                                 let highShare = nextShare - middle in
  84                                 let minShare  = min lowShare highShare in
  85                                 Middle minShare currGrade currGrade :
  86                                 goBorders
  87                                  ((currGrade, lowShare  - minShare) : ps)
  88                                  ((currGrade, highShare - minShare) : ns)
  89         goBorders :: [(grade,Share)] -> [(grade,Share)] -> [Middle grade]
  90         goBorders lows highs =
  91                 case (lows,highs) of
  92                  ((lowGrade,lowShare):ls, (highGrade,highShare):hs)
  93                   | lowShare  <= 0 -> goBorders ls highs
  94                   | highShare <= 0 -> goBorders lows hs
  95                   | otherwise ->
  96                                 let minShare = min lowShare highShare in
  97                                 Middle minShare lowGrade highGrade :
  98                                 goBorders
  99                                  ((lowGrade , lowShare  - minShare) : ls)
 100                                  ((highGrade, highShare - minShare) : hs)
 101                  _ -> []
 102 instance Ord grade => Ord (Merit grade) where
 103         compare = compare `on` majorityValue
 104
 105 -- | The 'majorityGrade' is the lower middlemost
 106 -- (also known as median by experts) of the 'grade's
 107 -- given to a 'choice' by the 'Judges'.
 108 --
 109 -- It is the highest 'grade' approved by an absolute majority of the 'Judges':
 110 -- more than 50% of the 'Judges' give the 'choice' at least a 'grade' of 'majorityGrade',
 111 -- but every 'grade' lower than 'majorityGrade' is rejected by an absolute majority
 112 -- Thus the 'majorityGrade' of a 'choice'
 113 -- is the final 'grade' wished by the majority.
 114 --
 115 -- The 'majorityGrade' is necessarily a word that belongs to 'grades',
 116 -- and it has an absolute meaning.
 117 --
 118 -- When the number of 'Judges' is even, there is a middle-interval
 119 -- (which can, of course, be reduced to a single 'grade'
 120 -- if the two middle 'grade's are the same),
 121 -- then the 'majorityGrade' is the lowest 'grade' of the middle-interval
 122 -- (the “lower middlemost” when there are two in the middle),
 123 -- which is the only one which respects consensus:
 124 -- any other 'choice' whose grades are all within this middle-interval,
 125 -- has a 'majorityGrade' which is greater or equal to this lower middlemost.
 126 majorityGrade :: Ord grade => MajorityValue grade -> Maybe grade
 127 majorityGrade (MajorityValue mv) = lowGrade <$> listToMaybe mv
 128
 129 -- * Type 'MajorityRanking'
 130 type MajorityRanking choice grade = [(choice, MajorityValue grade)]
 131
 132 majorityValueByChoice :: Ord grade => MeritByChoice choice grade -> HM.HashMap choice (MajorityValue grade)
 133 majorityValueByChoice (MeritByChoice ms) = majorityValue <$> ms
 134
 135 -- | The 'majorityRanking' ranks all the 'choice's on the basis of their 'grade's.
 136 --
 137 -- Choice A ranks higher than 'choice' B in the 'majorityRanking'
 138 -- if and only if A’s 'majorityValue' is lexicographically above B’s.
 139 -- There can be no tie unless two 'choice's have precisely the same 'majorityValue's.
 140 majorityRanking :: Ord grade => MeritByChoice choice grade -> MajorityRanking choice grade
 141 majorityRanking = List.sortOn (Down . snd) . HM.toList . majorityValueByChoice
 142
 143 -- | Expand a 'MajorityValue' such that each 'grade' has a 'Share' of '1'.
 144 --
 145 -- WARNING: the resulting list of 'grade's may have a different length
 146 -- than the list of 'grade's used to build the 'Merit'.
 147 expandValue :: Eq grade => MajorityValue grade -> [grade]
 148 expandValue (MajorityValue ms) =
 149         let lcm' = foldr lcm 1 (denominator . middleShare <$> ms) in
 150         concat $ (<$> ms) $ \(Middle s l h) ->
 151                 let r = numerator s * (lcm' `div` denominator s) in
 152                 concat (replicate (fromIntegral r) [l, h])
 153                 {-
 154                 case r`divMod`2 of
 155                  (quo,0) -> concat (replicate (fromIntegral quo) [l, h])
 156                  (quo,_) -> l:concat (replicate (fromIntegral quo) [l, h])
 157                 -}
 158
 159 -- | @'normalizeMajorityValue' m@ multiply all 'Share's
 160 -- by their least common denominator to get integral 'Share's.
 161 normalizeMajorityValue :: MajorityValue grade -> MajorityValue grade
 162 normalizeMajorityValue (MajorityValue mv) =
 163         MajorityValue $ (\m -> m{middleShare = lcm' * middleShare m}) <$> mv
 164         where
 165         lcm' = foldr lcm 1 (denominator . middleShare <$> mv) % den
 166         den  = case mv of
 167          Middle s _l _h:_ -> denominator s
 168          _ -> 1