Hjugement/Section.hs

   1 {-# LANGUAGE ScopedTypeVariables #-}
   2 module Hjugement.Section where
   3
   4 import Control.Applicative (Applicative(..))
   5 import Data.Bool
   6 import Data.Either (Either(..))
   7 import Data.Eq (Eq(..))
   8 import Data.Foldable (Foldable(..), any)
   9 import Data.Function (($), (.))
  10 import Data.Traversable (Traversable(..))
  11 import Data.Functor ((<$>), (<$))
  12 import Data.Maybe (Maybe(..), isNothing, maybe, fromMaybe)
  13 import Data.Hashable (Hashable(..))
  14 import Data.Map.Strict (Map)
  15 import Data.Ord (Ord(..))
  16 import Data.Ratio ((%))
  17 import Data.Semigroup (Semigroup(..))
  18 import Prelude (Num(..), Fractional(..), toRational, fromIntegral)
  19 import Data.Tree
  20 import Text.Show (Show(..))
  21 import qualified Data.List as List
  22 import qualified Data.HashMap.Strict as HM
  23 import qualified Data.HashSet as HS
  24 import qualified Data.Map.Strict as Map
  25
  26 import Hjugement.MJ
  27
  28 -- * Type 'Section'
  29 -- | Node of a 'Tree' holding a 'SectionOpinion' per 'judge'.
  30 type Section judge grade = HM.HashMap judge (SectionOpinion grade)
  31
  32 -- ** Type 'SectionOpinion'
  33 data SectionOpinion grade
  34  =   SectionOpinion
  35  {   sectionShare :: Maybe Share
  36      -- ^ A 'Share' within the parent 'Section'
  37      --   (defaulting to a 'Share' computed as the remaining 'Share' to reach 1
  38      --   divided by the number of defaulted 'Share's).
  39  ,   sectionGrade :: Maybe grade
  40      -- ^ A 'grade' attributed to the current 'Section'
  41      --   (defaulting to the 'grade' set on an ancestor 'Section' if any,
  42      --   or the |judge|'s default grade).
  43  } deriving (Eq, Show)
  44
  45 -- | Compute the 'Opinion's from the |Judges|' evaluation on all or some 'Section's.
  46 opinionsBySection ::
  47  forall judge grade.
  48  Show judge =>
  49  Show grade =>
  50  Eq judge =>
  51  Hashable judge =>
  52  Ord grade =>
  53  Judges judge grade ->
  54  Tree (Section judge grade) ->
  55  Either (ErrorSection judge)
  56         (Tree (Opinions judge grade))
  57 opinionsBySection js = go (singleGrade <$> js)
  58         where
  59         go defaultGradeByJudge (Node gradeByJudge opinionByJudgeBySection) =
  60                 let maybeShareBySectionByJudge :: HM.HashMap judge [Maybe Share] =
  61                         foldr (\section -> HM.unionWith (<>) $ pure . sectionShare <$> rootLabel section)
  62                          HM.empty opinionByJudgeBySection in
  63                 let shareBySectionByJudge :: HM.HashMap judge [Share] =
  64                         (<$> maybeShareBySectionByJudge) $ \maybeShareBySection ->
  65                                 let usedShare    = sum $ fromMaybe 0 <$> maybeShareBySection in
  66                                 let unusedShares = toRational $ List.length $ List.filter isNothing maybeShareBySection in
  67                                 let evenShare    = (1 - usedShare) / unusedShares in
  68                                 fromMaybe evenShare <$> maybeShareBySection
  69                 in
  70                 case opinionByJudgeBySection of
  71                  [] | unknownJudges <- gradeByJudge`HM.difference`defaultGradeByJudge
  72                     , not $ null unknownJudges ->
  73                         Left $ ErrorSection_unknown_judges $ HS.fromMap $ (() <$) $ unknownJudges
  74                     | otherwise ->
  75                         -- NOTE: no Section, current Opinions is derived from current Node and default grades.
  76                         let opin :: HM.HashMap judge (Map grade Share) =
  77                                 HM.mapWithKey (\judge -> maybe (defaultGradeByJudge HM.! judge) singleGrade . sectionGrade) gradeByJudge in
  78                         Right $ Node (HM.union opin defaultGradeByJudge) []
  79                  _ | ko <- HM.filter (\ss -> any (< 0) ss || sum ss /= 1) shareBySectionByJudge
  80                          , not (null ko) ->
  81                         Left $ ErrorSection_invalid_shares ko
  82                  _ -> do
  83                         -- NOTE: current Opinions is computed from its sub-'Section's.
  84                         let defaultGradeByJudge' :: HM.HashMap judge (Map grade Share) =
  85                                 -- NOTE: grades set at current node become the new default grades within its 'Section's.
  86                                 HM.union
  87                                  (HM.mapWithKey (\judge ->
  88                                         maybe (defaultGradeByJudge HM.! judge) singleGrade . sectionGrade) gradeByJudge)
  89                                  defaultGradeByJudge
  90                         opins <- traverse (go defaultGradeByJudge') opinionByJudgeBySection
  91                         let distByJudgeBySection :: [HM.HashMap judge (Map grade Share)] = rootLabel <$> opins
  92                         let distBySectionByJudge :: HM.HashMap judge [Map grade Share] =
  93                                 foldr (\distByJudge -> HM.unionWith (<>) (pure <$> distByJudge))
  94                                  HM.empty distByJudgeBySection
  95                         let numSections   = List.length opinionByJudgeBySection
  96                         let defaultShares = List.replicate numSections $ 1 % fromIntegral numSections
  97                         let opin :: HM.HashMap judge (Map grade Share) =
  98                                 HM.intersectionWith -- NOTE: just used to zip actually
  99                                  (\shareBySection distBySection ->
 100                                         Map.unionsWith (+) $ -- NOTE: merge dists
 101                                         List.zipWith (\share dist -> (share *) <$> dist) -- NOTE: shrink dists
 102                                          shareBySection distBySection)
 103                                  (shareBySectionByJudge`HM.union`(defaultShares <$ defaultGradeByJudge))
 104                                  distBySectionByJudge
 105                         Right $ Node opin opins
 106
 107 -- * Type 'ErrorSection'
 108 data ErrorSection judge
 109  =   ErrorSection_invalid_shares (HM.HashMap judge [Share])
 110      -- ^ When at least one of the 'Share's is not positive, or when their sum is not 1.
 111  |   ErrorSection_unknown_judges (HS.HashSet judge)
 112      -- ^ When at least one 'Section'
 113  deriving (Eq,Show)