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(..))
import qualified Data.HashMap.Strict as HM
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import Majority.Merit
data MajorityGauge g
= MajorityGauge
{ mgLower :: Share
, mgGrade :: g
, mgHigher :: Share
} deriving (Eq)
instance Show g => Show (MajorityGauge g) where
showsPrec p (MajorityGauge w g b) = showsPrec p (w,g,b)
data Sign = Minus | Plus
deriving (Eq, Show)
mgSign :: MajorityGauge g -> Sign
mgSign g = if mgHigher g > mgLower g then Plus else Minus
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 y `compare` mgLower x
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 w mg b) ->
if g >= mg then MajorityGauge w mg (b+c)
else MajorityGauge (w+c) mg b
total = List.sum gs
untilMajGrade (t,[]) g c | 2*tc >= total = (tc,[(MajorityGauge t g 0,c)])
| otherwise = (tc,[])
where tc = t+c
untilMajGrade (t,(mg,c):_) _g c' = (t,[(mg{mgHigher=mgHigher mg + c'},c)])
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