{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module Majurity.Judgment.Merit where
import Data.Eq (Eq(..))
import Data.Foldable (Foldable)
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, denominator)
import Data.Semigroup (Semigroup(..))
import Data.Set (Set)
import Data.Tuple (curry)
import GHC.Exts (IsList(..))
import Prelude (Bounded(..), Enum(..), Num(..), Integer, error, lcm)
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 :: Choices choice
choices = [choice] -> Choices choice
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList ([choice] -> Choices choice) -> [choice] -> Choices choice
forall a b. (a -> b) -> a -> b
$ choice -> [choice]
forall a. Enum a => a -> [a]
enumFrom choice
forall a. Bounded a => a
minBound
type Grades = Set
grades :: [grade] -> Grades (Ranked grade)
grades :: [grade] -> Grades (Ranked grade)
grades = [Ranked grade] -> Grades (Ranked grade)
forall a. Ord a => [a] -> Set a
Set.fromList ([Ranked grade] -> Grades (Ranked grade))
-> ([grade] -> [Ranked grade]) -> [grade] -> Grades (Ranked grade)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [grade] -> [Ranked grade]
forall a. [a] -> [Ranked a]
zipRank
newtype Ranked a = Ranked (G, a)
deriving (Int -> Ranked a -> ShowS
[Ranked a] -> ShowS
Ranked a -> String
(Int -> Ranked a -> ShowS)
-> (Ranked a -> String) -> ([Ranked a] -> ShowS) -> Show (Ranked a)
forall a. Show a => Int -> Ranked a -> ShowS
forall a. Show a => [Ranked a] -> ShowS
forall a. Show a => Ranked a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Ranked a] -> ShowS
$cshowList :: forall a. Show a => [Ranked a] -> ShowS
show :: Ranked a -> String
$cshow :: forall a. Show a => Ranked a -> String
showsPrec :: Int -> Ranked a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Ranked a -> ShowS
Show,a -> Ranked b -> Ranked a
(a -> b) -> Ranked a -> Ranked b
(forall a b. (a -> b) -> Ranked a -> Ranked b)
-> (forall a b. a -> Ranked b -> Ranked a) -> Functor Ranked
forall a b. a -> Ranked b -> Ranked a
forall a b. (a -> b) -> Ranked a -> Ranked b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Ranked b -> Ranked a
$c<$ :: forall a b. a -> Ranked b -> Ranked a
fmap :: (a -> b) -> Ranked a -> Ranked b
$cfmap :: forall a b. (a -> b) -> Ranked a -> Ranked b
Functor)
instance Eq (Ranked a) where
Ranked (G
x,a
_) == :: Ranked a -> Ranked a -> Bool
== Ranked (G
y,a
_) = G
xG -> G -> Bool
forall a. Eq a => a -> a -> Bool
==G
y
instance Ord (Ranked a) where
Ranked (G
x,a
_) compare :: Ranked a -> Ranked a -> Ordering
`compare` Ranked (G
y,a
_) = G
xG -> G -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare`G
y
zipRank :: [a] -> [Ranked a]
zipRank :: [a] -> [Ranked a]
zipRank = (G -> a -> Ranked a) -> [G] -> [a] -> [Ranked a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
List.zipWith (((G, a) -> Ranked a) -> G -> a -> Ranked a
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (G, a) -> Ranked a
forall a. (G, a) -> Ranked a
Ranked) [G
0..]
rankKey :: [(k, a)] -> [(Ranked k, a)]
rankKey :: [(k, a)] -> [(Ranked k, a)]
rankKey = (G -> (k, a) -> (Ranked k, a))
-> [G] -> [(k, a)] -> [(Ranked k, a)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
List.zipWith (\G
i (k
k,a
a) -> ((G, k) -> Ranked k
forall a. (G, a) -> Ranked a
Ranked (G
i,k
k),a
a)) [G
0..]
type G = Integer
rank :: Ranked a -> G
rank :: Ranked a -> G
rank (Ranked (G
r, a
_x)) = G
r
unRank :: Ranked a -> a
unRank :: Ranked a -> a
unRank (Ranked (G
_r, a
x)) = a
x
enum :: (Bounded a, Enum a, Ord a) => Set a
enum :: Set a
enum = [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList ([a] -> Set a) -> [a] -> Set a
forall a b. (a -> b) -> a -> b
$ a -> [a]
forall a. Enum a => a -> [a]
enumFrom a
forall a. Bounded a => a
minBound
type Judges = HM.HashMap
judges ::
Eq judge =>
Hashable judge =>
[judge] -> grade -> Judges judge grade
judges :: [judge] -> grade -> Judges judge grade
judges [judge]
js grade
dg = [(judge, grade)] -> Judges judge grade
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(judge, grade)] -> Judges judge grade)
-> [(judge, grade)] -> Judges judge grade
forall a b. (a -> b) -> a -> b
$ (\judge
j -> (judge
j, grade
dg)) (judge -> (judge, grade)) -> [judge] -> [(judge, grade)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [judge]
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 :: Judges judge grade
-> Opinions judge grade -> (Opinions judge grade, HashSet judge)
opinions Judges judge grade
js Opinions judge grade
os =
( Opinions judge grade
-> Opinions judge grade -> Opinions judge grade
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
HM.union Opinions judge grade
os (Opinions judge grade -> Opinions judge grade)
-> Opinions judge grade -> Opinions judge grade
forall a b. (a -> b) -> a -> b
$ grade -> Distribution grade
forall grade. grade -> Distribution grade
singleGrade (grade -> Distribution grade)
-> Judges judge grade -> Opinions judge grade
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Judges judge grade
js
, HashMap judge () -> HashSet judge
forall a. HashMap a () -> HashSet a
HS.fromMap (HashMap judge () -> HashSet judge)
-> HashMap judge () -> HashSet judge
forall a b. (a -> b) -> a -> b
$ (() () -> Opinions judge grade -> HashMap judge ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (Opinions judge grade -> HashMap judge ())
-> Opinions judge grade -> HashMap judge ()
forall a b. (a -> b) -> a -> b
$ Opinions judge grade
osOpinions judge grade -> Judges judge grade -> Opinions judge grade
forall k v w.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k w -> HashMap k v
`HM.difference`Judges judge grade
js )
type Distribution grade = Map grade Share
singleGrade :: grade -> Distribution grade
singleGrade :: grade -> Distribution grade
singleGrade = (grade -> Share -> Distribution grade
forall k a. k -> a -> Map k a
`Map.singleton` Share
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 :: [(choice, Opinions judge grade)]
-> OpinionsByChoice choice judge grade
opinionsByChoice = [(choice, Opinions judge grade)]
-> OpinionsByChoice choice judge grade
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList
newtype Merit grade = Merit { Merit grade -> Map grade Share
unMerit :: Map grade Share }
deriving (Merit grade -> Merit grade -> Bool
(Merit grade -> Merit grade -> Bool)
-> (Merit grade -> Merit grade -> Bool) -> Eq (Merit grade)
forall grade. Eq grade => Merit grade -> Merit grade -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Merit grade -> Merit grade -> Bool
$c/= :: forall grade. Eq grade => Merit grade -> Merit grade -> Bool
== :: Merit grade -> Merit grade -> Bool
$c== :: forall grade. Eq grade => Merit grade -> Merit grade -> Bool
Eq, Int -> Merit grade -> ShowS
[Merit grade] -> ShowS
Merit grade -> String
(Int -> Merit grade -> ShowS)
-> (Merit grade -> String)
-> ([Merit grade] -> ShowS)
-> Show (Merit grade)
forall grade. Show grade => Int -> Merit grade -> ShowS
forall grade. Show grade => [Merit grade] -> ShowS
forall grade. Show grade => Merit grade -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Merit grade] -> ShowS
$cshowList :: forall grade. Show grade => [Merit grade] -> ShowS
show :: Merit grade -> String
$cshow :: forall grade. Show grade => Merit grade -> String
showsPrec :: Int -> Merit grade -> ShowS
$cshowsPrec :: forall grade. Show grade => Int -> Merit grade -> ShowS
Show)
instance Ord grade => Semigroup (Merit grade) where
Merit Map grade Share
x <> :: Merit grade -> Merit grade -> Merit grade
<> Merit Map grade Share
y = Map grade Share -> Merit grade
forall grade. Map grade Share -> Merit grade
Merit ((Share -> Share -> Share)
-> Map grade Share -> Map grade Share -> Map grade Share
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Share -> Share -> Share
forall a. Num a => a -> a -> a
(+) Map grade Share
x Map grade Share
y)
instance (Ord grade, Show grade) => IsList (Merit grade) where
type Item (Merit grade) = (grade, Share)
fromList :: [Item (Merit grade)] -> Merit grade
fromList = Map grade Share -> Merit grade
forall grade. Map grade Share -> Merit grade
Merit (Map grade Share -> Merit grade)
-> ([(grade, Share)] -> Map grade Share)
-> [(grade, Share)]
-> Merit grade
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (grade -> Share -> Share -> Share)
-> [(grade, Share)] -> Map grade Share
forall k a. Ord k => (k -> a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWithKey
(\grade
g Share
_x Share
_y -> String -> Share
forall a. HasCallStack => String -> a
error (String -> Share) -> String -> Share
forall a b. (a -> b) -> a -> b
$ String
"duplicate grade in merit: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> grade -> String
forall a. Show a => a -> String
show grade
g)
toList :: Merit grade -> [Item (Merit grade)]
toList (Merit Map grade Share
cs) = Map grade Share -> [Item (Map grade Share)]
forall l. IsList l => l -> [Item l]
toList Map grade Share
cs
merit ::
Ord grade =>
Foldable opinions =>
opinions (Distribution grade) ->
Merit grade
merit :: opinions (Distribution grade) -> Merit grade
merit = (Distribution grade -> Merit grade -> Merit grade)
-> Merit grade -> opinions (Distribution grade) -> Merit grade
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Distribution grade -> Merit grade -> Merit grade
forall grade.
Ord grade =>
Map grade Share -> Merit grade -> Merit grade
insertOpinion (Distribution grade -> Merit grade
forall grade. Map grade Share -> Merit grade
Merit Distribution grade
forall k a. Map k a
Map.empty)
where
insertOpinion :: Map grade Share -> Merit grade -> Merit grade
insertOpinion Map grade Share
dist (Merit Map grade Share
m) =
Map grade Share -> Merit grade
forall grade. Map grade Share -> Merit grade
Merit (Map grade Share -> Merit grade) -> Map grade Share -> Merit grade
forall a b. (a -> b) -> a -> b
$
(Map grade Share -> grade -> Share -> Map grade Share)
-> Map grade Share -> Map grade Share -> Map grade Share
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey
(\Map grade Share
acc grade
g Share
s -> (Share -> Share -> Share)
-> grade -> Share -> Map grade Share -> Map grade Share
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Share -> Share -> Share
forall a. Num a => a -> a -> a
(+) grade
g Share
s Map grade Share
acc)
Map grade Share
m Map grade Share
dist
meritFromList ::
Ord grade =>
Foldable opinions =>
Functor opinions =>
opinions grade ->
Merit grade
meritFromList :: opinions grade -> Merit grade
meritFromList = opinions (Distribution grade) -> Merit grade
forall grade (opinions :: * -> *).
(Ord grade, Foldable opinions) =>
opinions (Distribution grade) -> Merit grade
merit (opinions (Distribution grade) -> Merit grade)
-> (opinions grade -> opinions (Distribution grade))
-> opinions grade
-> Merit grade
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (grade -> Distribution grade
forall grade. grade -> Distribution grade
singleGrade (grade -> Distribution grade)
-> opinions grade -> opinions (Distribution grade)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
normalizeMerit :: Merit grade -> Merit grade
normalizeMerit :: Merit grade -> Merit grade
normalizeMerit (Merit Map grade Share
ms) = Map grade Share -> Merit grade
forall grade. Map grade Share -> Merit grade
Merit (Map grade Share -> Merit grade) -> Map grade Share -> Merit grade
forall a b. (a -> b) -> a -> b
$ (Share
lcm' Share -> Share -> Share
forall a. Num a => a -> a -> a
*) (Share -> Share) -> Map grade Share -> Map grade Share
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map grade Share
ms
where lcm' :: Share
lcm' = (G -> G -> G) -> G -> Map grade G -> G
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr G -> G -> G
forall a. Integral a => a -> a -> a
lcm G
1 (Share -> G
forall a. Ratio a -> a
denominator (Share -> G) -> Map grade Share -> Map grade G
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map grade Share
ms) G -> G -> Share
forall a. Integral a => a -> a -> Ratio a
% G
1
newtype MeritByChoice choice grade
= MeritByChoice { MeritByChoice choice grade -> HashMap choice (Merit grade)
unMeritByChoice :: HM.HashMap choice (Merit grade) }
deriving (MeritByChoice choice grade -> MeritByChoice choice grade -> Bool
(MeritByChoice choice grade -> MeritByChoice choice grade -> Bool)
-> (MeritByChoice choice grade
-> MeritByChoice choice grade -> Bool)
-> Eq (MeritByChoice choice grade)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall choice grade.
(Eq choice, Eq grade) =>
MeritByChoice choice grade -> MeritByChoice choice grade -> Bool
/= :: MeritByChoice choice grade -> MeritByChoice choice grade -> Bool
$c/= :: forall choice grade.
(Eq choice, Eq grade) =>
MeritByChoice choice grade -> MeritByChoice choice grade -> Bool
== :: MeritByChoice choice grade -> MeritByChoice choice grade -> Bool
$c== :: forall choice grade.
(Eq choice, Eq grade) =>
MeritByChoice choice grade -> MeritByChoice choice grade -> Bool
Eq, Int -> MeritByChoice choice grade -> ShowS
[MeritByChoice choice grade] -> ShowS
MeritByChoice choice grade -> String
(Int -> MeritByChoice choice grade -> ShowS)
-> (MeritByChoice choice grade -> String)
-> ([MeritByChoice choice grade] -> ShowS)
-> Show (MeritByChoice choice grade)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall choice grade.
(Show choice, Show grade) =>
Int -> MeritByChoice choice grade -> ShowS
forall choice grade.
(Show choice, Show grade) =>
[MeritByChoice choice grade] -> ShowS
forall choice grade.
(Show choice, Show grade) =>
MeritByChoice choice grade -> String
showList :: [MeritByChoice choice grade] -> ShowS
$cshowList :: forall choice grade.
(Show choice, Show grade) =>
[MeritByChoice choice grade] -> ShowS
show :: MeritByChoice choice grade -> String
$cshow :: forall choice grade.
(Show choice, Show grade) =>
MeritByChoice choice grade -> String
showsPrec :: Int -> MeritByChoice choice grade -> ShowS
$cshowsPrec :: forall choice grade.
(Show choice, Show grade) =>
Int -> MeritByChoice choice grade -> ShowS
Show)
instance (Eq choice, Hashable choice, Ord grade) => Semigroup (MeritByChoice choice grade) where
MeritByChoice HashMap choice (Merit grade)
x <> :: MeritByChoice choice grade
-> MeritByChoice choice grade -> MeritByChoice choice grade
<> MeritByChoice HashMap choice (Merit grade)
y = HashMap choice (Merit grade) -> MeritByChoice choice grade
forall choice grade.
HashMap choice (Merit grade) -> MeritByChoice choice grade
MeritByChoice ((Merit grade -> Merit grade -> Merit grade)
-> HashMap choice (Merit grade)
-> HashMap choice (Merit grade)
-> HashMap choice (Merit grade)
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
HM.unionWith Merit grade -> Merit grade -> Merit grade
forall a. Semigroup a => a -> a -> a
(<>) HashMap choice (Merit grade)
x HashMap choice (Merit grade)
y)
instance (Eq choice, Hashable choice, Show choice) => IsList (MeritByChoice choice grade) where
type Item (MeritByChoice choice grade) = (choice, Merit grade)
fromList :: [Item (MeritByChoice choice grade)] -> MeritByChoice choice grade
fromList = HashMap choice (Merit grade) -> MeritByChoice choice grade
forall choice grade.
HashMap choice (Merit grade) -> MeritByChoice choice grade
MeritByChoice (HashMap choice (Merit grade) -> MeritByChoice choice grade)
-> ([(choice, Merit grade)] -> HashMap choice (Merit grade))
-> [(choice, Merit grade)]
-> MeritByChoice choice grade
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Merit grade -> Merit grade -> Merit grade)
-> [(choice, Merit grade)] -> HashMap choice (Merit grade)
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
HM.fromListWith
(\Merit grade
_x Merit grade
_y -> String -> Merit grade
forall a. HasCallStack => String -> a
error (String -> Merit grade) -> String -> Merit grade
forall a b. (a -> b) -> a -> b
$ String
"duplicate choice in merits")
toList :: MeritByChoice choice grade -> [Item (MeritByChoice choice grade)]
toList (MeritByChoice HashMap choice (Merit grade)
cs) = HashMap choice (Merit grade)
-> [Item (HashMap choice (Merit grade))]
forall l. IsList l => l -> [Item l]
toList HashMap choice (Merit grade)
cs
meritByChoice ::
(Ord grade, Eq choice, Hashable choice) =>
OpinionsByChoice choice judge grade ->
MeritByChoice choice grade
meritByChoice :: OpinionsByChoice choice judge grade -> MeritByChoice choice grade
meritByChoice OpinionsByChoice choice judge grade
os = HashMap choice (Merit grade) -> MeritByChoice choice grade
forall choice grade.
HashMap choice (Merit grade) -> MeritByChoice choice grade
MeritByChoice (HashMap choice (Merit grade) -> MeritByChoice choice grade)
-> HashMap choice (Merit grade) -> MeritByChoice choice grade
forall a b. (a -> b) -> a -> b
$ HashMap judge (Distribution grade) -> Merit grade
forall grade (opinions :: * -> *).
(Ord grade, Foldable opinions) =>
opinions (Distribution grade) -> Merit grade
merit (HashMap judge (Distribution grade) -> Merit grade)
-> OpinionsByChoice choice judge grade
-> HashMap choice (Merit grade)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OpinionsByChoice choice judge grade
os