{-# 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
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)
data Middle grade = Middle
{ middleShare :: Share
, lowGrade :: grade
, highGrade :: grade
} deriving (Eq, Ord, Show)
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
majorityGrade :: Show grade => Ord grade => Merit grade -> Maybe grade
majorityGrade m = lowGrade <$> listToMaybe gs where MajorityValue gs = majorityValue m
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
majorityRanking :: Show grade => Ord grade => MeritByChoice choice grade -> MajorityRanking choice grade
majorityRanking = List.sortOn (Down . snd) . HM.toList . majorityValueByChoice