{-# LANGUAGE ScopedTypeVariables #-}
module Majority.Section where
import Control.Applicative (Applicative(..), Alternative(..))
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..), any)
import Data.Function (($), (.))
import Data.Functor ((<$>), (<$))
import Data.Hashable (Hashable(..))
import Data.Maybe (Maybe(..), isNothing, maybe, fromMaybe)
import Data.Ord (Ord(..))
import Data.Traversable (Traversable(..))
import Data.Tree as Tree
import Prelude (Num(..), Fractional(..), toRational)
import Text.Show (Show(..))
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import Majority.Merit
data Section grade
= Section
{ sectionShare :: Maybe Share
, sectionGrade :: Maybe grade
} deriving (Eq,Show)
type SectionByJudge judge grade = HM.HashMap judge (Section grade)
data SectionNode choice judge grade
= SectionNode
{ sectionNodeShare :: Maybe Share
, sectionByJudgeByChoice :: HM.HashMap choice (SectionByJudge judge grade)
} deriving (Eq,Show)
data ErrorSection choice judge grade
= ErrorSection_unknown_choices (HS.HashSet choice)
| ErrorSection_unknown_judges (HM.HashMap choice (HS.HashSet judge))
| ErrorSection_invalid_shares (HM.HashMap choice (HM.HashMap judge [Share]))
deriving (Eq,Show)
opinionsBySection ::
forall choice judge grade.
Eq choice =>
Eq judge =>
Hashable choice =>
Hashable judge =>
Ord grade =>
Choices choice ->
Judges judge grade ->
Tree (SectionNode choice judge grade) ->
Either (ErrorSection choice judge grade)
(Tree (OpinionsByChoice choice judge grade))
opinionsBySection cs js = go ((singleGrade <$> js) <$ HS.toMap cs)
where
go :: HM.HashMap choice (HM.HashMap judge (Distribution grade)) ->
Tree (SectionNode choice judge grade) ->
Either (ErrorSection choice judge grade)
(Tree (OpinionsByChoice choice judge grade))
go defaultDistJC (Tree.Node (SectionNode _sectionNodeShare currOpinJC) childOpinJCS) =
let currDistJC :: HM.HashMap choice (HM.HashMap judge (Distribution grade)) =
let specifiedDistJC =
HM.mapWithKey (\choice ->
let defaultDistJ = defaultDistJC HM.!choice in
HM.mapWithKey (\judge ->
maybe (defaultDistJ HM.!judge) singleGrade .
sectionGrade))
currOpinJC
in
HM.unionWith HM.union
specifiedDistJC
defaultDistJC
in
let maybeChildShareSJC :: HM.HashMap choice (HM.HashMap judge [Maybe Share]) =
foldr (\(Tree.Node SectionNode{sectionNodeShare, sectionByJudgeByChoice} _) ->
let defaultChildShareSJC = ([sectionNodeShare] <$ js) <$ defaultDistJC in
let specifiedChildShareSJC =
(<$> sectionByJudgeByChoice) $
(pure . (<|> sectionNodeShare) . sectionShare <$>) in
HM.unionWith (HM.unionWith (List.++)) $
HM.unionWith HM.union
specifiedChildShareSJC
defaultChildShareSJC)
HM.empty
childOpinJCS
in
let childShareSJC :: HM.HashMap choice (HM.HashMap judge [Share]) =
(<$> maybeChildShareSJC) $ \maybeShareSJ ->
(<$> maybeShareSJ) $ \maybeShareS ->
let specifiedShare = sum $ fromMaybe 0 <$> maybeShareS in
let unspecifiedShares = toRational $ List.length $ List.filter isNothing maybeShareS in
let defaultShare = (1 - specifiedShare) / unspecifiedShares in
fromMaybe defaultShare <$> maybeShareS
in
case childOpinJCS of
_ | unknownChoices <- currOpinJC`HM.difference`defaultDistJC
, not $ null unknownChoices ->
Left $ ErrorSection_unknown_choices $
HS.fromMap $ (() <$) $ unknownChoices
_ | unknownJudgesC <- HM.filter (not . null) $
HM.intersectionWith HM.difference
currOpinJC
defaultDistJC
, not $ null unknownJudgesC ->
Left $ ErrorSection_unknown_judges $
HS.fromMap . (() <$) <$> unknownJudgesC
[] -> Right $ Tree.Node currDistJC []
_ | invalidSharesJC <-
HM.filter (not . null) $
HM.filter (\ss -> any (< 0) ss || sum ss /= 1)
<$> childShareSJC
, not $ null invalidSharesJC ->
Left $ ErrorSection_invalid_shares invalidSharesJC
_ -> do
distJCS :: [Tree (HM.HashMap choice (HM.HashMap judge (Distribution grade)))] <-
traverse (go $ currDistJC) childOpinJCS
let distSJC :: HM.HashMap choice (HM.HashMap judge [Distribution grade]) =
foldr (\distJC ->
let newDistSJC = (pure <$>) <$> rootLabel distJC in
HM.unionWith (HM.unionWith (List.++)) newDistSJC)
HM.empty
distJCS
let distJC :: HM.HashMap choice (HM.HashMap judge (Distribution grade)) =
HM.mapWithKey (\choice ->
let childShareSJ = childShareSJC HM.!choice in
HM.mapWithKey (\judge ->
let childShareS = childShareSJ HM.!judge in
Map.unionsWith (+) .
List.zipWith
(\share dist -> (share *) <$> dist)
childShareS))
distSJC
Right $ Tree.Node distJC distJCS