{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Majority.Merit where
import Data.Eq (Eq(..))
import Data.Function (($), (.))
import Data.Functor (Functor, (<$>), (<$))
import Data.Hashable (Hashable)
import Data.List as List
import Data.Map.Strict (Map)
import Data.Ord (Ord(..))
import Data.Ratio (Rational)
import Data.Semigroup (Semigroup(..))
import Data.Set (Set)
import Data.Tuple (curry)
import GHC.Exts (IsList(..))
import Prelude (Bounded(..), Enum(..), Num(..), Integer, error)
import Text.Show (Show(..))
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
type Choices = HS.HashSet
choices :: (Bounded choice , Enum choice , Eq choice, Hashable choice) => Choices choice
choices = HS.fromList $ enumFrom minBound
type Grades = Set
grades :: [grade] -> Grades (Ranked grade)
grades = Set.fromList . zipRank
newtype Ranked a = Ranked (Integer, a)
deriving (Show,Functor)
instance Eq (Ranked a) where
Ranked (x,_) == Ranked (y,_) = x==y
instance Ord (Ranked a) where
Ranked (x,_) `compare` Ranked (y,_) = x`compare`y
zipRank :: [a] -> [Ranked a]
zipRank = List.zipWith (curry Ranked) [0..]
rankKey :: [(k, a)] -> [(Ranked k, a)]
rankKey = List.zipWith (\i (k,a) -> (Ranked (i,k),a)) [0..]
unRank :: Ranked a -> a
unRank (Ranked (_i, x)) = x
enum :: (Bounded a, Enum a, Ord a) => Set a
enum = Set.fromList $ enumFrom minBound
type Judges = HM.HashMap
judges ::
Eq judge =>
Hashable judge =>
[judge] -> grade -> Judges judge grade
judges js dg = HM.fromList $ (\j -> (j, dg)) <$> js
type Opinions judge grade = HM.HashMap judge (Distribution grade)
opinions ::
Eq judge =>
Hashable judge =>
Judges judge grade ->
Opinions judge grade ->
( Opinions judge grade
, HS.HashSet judge )
opinions js os =
( HM.union os $ singleGrade <$> js
, HS.fromMap $ (() <$) $ os`HM.difference`js )
type Distribution grade = Map grade Share
singleGrade :: grade -> Distribution grade
singleGrade = (`Map.singleton` 1)
type Share = Rational
type OpinionsByChoice choice judge grade = HM.HashMap choice (Opinions judge grade)
opinionsByChoice ::
Eq choice =>
Hashable choice =>
[(choice, Opinions judge grade)] ->
OpinionsByChoice choice judge grade
opinionsByChoice = HM.fromList
newtype Merit grade = Merit { unMerit :: Map grade Share }
deriving (Eq, Show)
instance Ord grade => Semigroup (Merit grade) where
Merit x <> Merit y = Merit (Map.unionWith (+) x y)
instance (Ord grade, Show grade) => IsList (Merit grade) where
type Item (Merit grade) = (grade, Share)
fromList = Merit . Map.fromListWithKey
(\g _x _y -> error $ "duplicate grade in merit: " <> show g)
toList (Merit cs) = toList cs
merit ::
Ord grade =>
Opinions judge grade ->
Merit grade
merit = foldr insertOpinion $ Merit $ Map.empty
where
insertOpinion dist (Merit m) =
Merit $
Map.foldlWithKey
(\acc g s -> Map.insertWith (+) g s acc)
m dist
newtype MeritByChoice choice grade
= MeritByChoice { unMeritByChoice :: HM.HashMap choice (Merit grade) }
deriving (Eq, Show)
instance (Eq choice, Hashable choice, Ord grade) => Semigroup (MeritByChoice choice grade) where
MeritByChoice x <> MeritByChoice y = MeritByChoice (HM.unionWith (<>) x y)
instance (Eq choice, Hashable choice, Show choice) => IsList (MeritByChoice choice grade) where
type Item (MeritByChoice choice grade) = (choice, Merit grade)
fromList = MeritByChoice . HM.fromListWith
(\_x _y -> error $ "duplicate choice in merits")
toList (MeritByChoice cs) = toList cs
meritByChoice ::
(Ord grade, Eq choice, Hashable choice) =>
OpinionsByChoice choice judge grade ->
MeritByChoice choice grade
meritByChoice os = MeritByChoice $ merit <$> os