{-# 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 ((%), numerator, denominator)
import Data.Semigroup (Semigroup(..))
import Data.Tuple (snd)
import Prelude (Num(..), fromIntegral, lcm, div, )
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 [Middle grade]
deriving (Eq, Show)
unMajorityValue :: MajorityValue grade -> [Middle grade]
unMajorityValue (MajorityValue ms) = ms
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)
instance Show grade => Show (Middle grade) where
showsPrec p (Middle s l h) = showsPrec p (s,l,h)
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 Ord grade => Ord (Merit grade) where
compare = compare `on` majorityValue
majorityGrade :: Ord grade => MajorityValue grade -> Maybe grade
majorityGrade (MajorityValue mv) = lowGrade <$> listToMaybe mv
type MajorityRanking choice grade = [(choice, MajorityValue grade)]
majorityValueByChoice :: Ord grade => MeritByChoice choice grade -> HM.HashMap choice (MajorityValue grade)
majorityValueByChoice (MeritByChoice ms) = majorityValue <$> ms
majorityRanking :: Ord grade => MeritByChoice choice grade -> MajorityRanking choice grade
majorityRanking = List.sortOn (Down . snd) . HM.toList . majorityValueByChoice
expandValue :: Eq grade => MajorityValue grade -> [grade]
expandValue (MajorityValue ms) =
let lcm' = foldr lcm 1 (denominator . middleShare <$> ms) in
concat $ (<$> ms) $ \(Middle s l h) ->
let r = numerator s * (lcm' `div` denominator s) in
concat (replicate (fromIntegral r) [l, h])
normalizeMajorityValue :: MajorityValue grade -> MajorityValue grade
normalizeMajorityValue (MajorityValue mv) =
MajorityValue $ (\m -> m{middleShare = lcm' * middleShare m}) <$> mv
where
lcm' = foldr lcm 1 (denominator . middleShare <$> mv) % den
den = case mv of
Middle s _l _h:_ -> denominator s
_ -> 1