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.Functor ((<$>), (<$))
  11 import Data.Hashable (Hashable(..))
  12 import Data.Maybe (Maybe(..), isNothing, maybe, fromMaybe)
  13 import Data.Ord (Ord(..))
  14 import Data.Traversable (Traversable(..))
  15 import Data.Tree
  16 import Prelude (Num(..), Fractional(..), toRational)
  17 import Text.Show (Show(..))
  18 import qualified Data.HashMap.Strict as HM
  19 import qualified Data.HashSet as HS
  20 import qualified Data.List as List
  21 import qualified Data.Map.Strict as Map
  22
  23 import Hjugement.MJ
  24
  25 -- * Type 'Section'
  26 -- | An opinion of a 'judge' about a 'choice' at a specific section 'Node'.
  27 data Section grade
  28  =   Section
  29  {   sectionShare :: Maybe Share
  30      -- ^ A 'Share' within the parent 'Node'
  31      --   (defaulting to a 'Share' computed as the remaining 'Share' to reach 1
  32      --   divided by the number of defaulted 'Share's).
  33  ,   sectionGrade :: Maybe grade
  34      -- ^ A 'grade' attributed to the current 'Node'
  35      --   (defaulting to the 'grade' set on an ancestor 'Node' if any,
  36      --   or the |judge|'s default grade).
  37  } deriving (Eq, Show)
  38
  39 -- ** Type 'SectionByJudge'
  40 type SectionByJudge judge grade = HM.HashMap judge (Section grade)
  41
  42 -- ** Type 'SectionByJudgeByChoice'
  43 -- | Node value of a 'Tree' holding a 'Section', per 'judge', per choice.
  44 type SectionByJudgeByChoice choice judge grade = HM.HashMap choice (SectionByJudge judge grade)
  45
  46 -- * Type 'ErrorSection'
  47 data ErrorSection choice judge grade
  48  =   ErrorSection_unknown_choices (HS.HashSet choice)
  49      -- ^ When some 'choice's are not known.
  50  |   ErrorSection_unknown_judges (HM.HashMap choice (HS.HashSet judge))
  51      -- ^ When some 'judge's are not known.
  52  |   ErrorSection_invalid_shares (HM.HashMap choice (HM.HashMap judge [Share]))
  53      -- ^ When at least one of the 'Share's is not positive, or when their sum is not 1.
  54  deriving (Eq,Show)
  55
  56 -- | Compute the 'Opinions' of the given |Judges| about the given 'Choices',
  57 -- from the 'grade' (specified or omitted) attributed to 'Choice's
  58 -- and the 'Share's (specified or omitted) attributed to 'Node'
  59 -- in given 'Tree'.
  60 opinionsBySection ::
  61  forall choice judge grade.
  62  Show choice =>
  63  Show judge =>
  64  Show grade =>
  65  Eq choice =>
  66  Hashable choice =>
  67  Eq judge =>
  68  Hashable judge =>
  69  Ord grade =>
  70  Choices choice ->
  71  Judges judge grade ->
  72  Tree (SectionByJudgeByChoice choice judge grade) ->
  73  Either (ErrorSection choice judge grade)
  74         (Tree (OpinionsByChoice choice judge grade))
  75 opinionsBySection cs js = go ((singleGrade <$> js) <$ HS.toMap cs)
  76         where
  77         go :: HM.HashMap choice (HM.HashMap judge (Distribution grade)) ->
  78               Tree (SectionByJudgeByChoice choice judge grade) ->
  79               Either (ErrorSection choice judge grade)
  80                      (Tree (OpinionsByChoice choice judge grade))
  81         go defaultDistJC (Node currOpinJC childOpinJCS) =
  82                 -- From current |Node|'s value.
  83                         let currDistJC :: HM.HashMap choice (HM.HashMap judge (Distribution grade)) =
  84                                 -- Collect the 'Distribution' of current 'Node',
  85                                 -- and insert default 'Distribution'
  86                                 -- for each unspecified 'judge'
  87                                 -- of each (specified or unspecified) 'choice'.
  88                                 let specifiedDistJC =
  89                                         HM.mapWithKey (\choice ->
  90                                                 HM.mapWithKey (\judge ->
  91                                                         maybe (defaultDistJC HM.!choice HM.!judge) singleGrade .
  92                                                         sectionGrade))
  93                                          currOpinJC
  94                                 in
  95                                 HM.unionWith HM.union
  96                                  specifiedDistJC
  97                                  defaultDistJC
  98                         in
  99                 -- From children 'Node's.
 100                         let defaultChildShareSJC = ([Nothing] <$ js) <$ defaultDistJC in
 101                         let maybeChildShareSJC :: HM.HashMap choice (HM.HashMap judge [Maybe Share]) =
 102                                 -- Collect the (specified or explicitely (with 'Nothing') unspecified) 'Share's by section,
 103                                 -- and insert all unspecified 'Share's when a 'choice' or a 'judge' is unspecified.
 104                                 foldr (\childOpinJC ->
 105                                         let specifiedChildShareSJC = (pure . sectionShare <$>) <$> rootLabel childOpinJC in
 106                                         -- Fusion specified 'choice's into accum.
 107                                         HM.unionWith (HM.unionWith (List.++)) $
 108                                                 -- Add default 'Share' for this 'Node',
 109                                                 -- for each unspecified 'judge' of specified and unspecified 'choice'.
 110                                                 HM.unionWith HM.union
 111                                                  specifiedChildShareSJC
 112                                                  defaultChildShareSJC)
 113                                  HM.empty
 114                                  childOpinJCS
 115                         in
 116                         let childShareSJC :: HM.HashMap choice (HM.HashMap judge [Share]) =
 117                                 -- Replace unspecified shares of each child 'Node'
 118                                 -- by an even default: the total remaining 'Share'
 119                                 -- divided by the number of unspecified 'Share's.
 120                                 (<$> maybeChildShareSJC) $ \maybeShareSJ ->
 121                                         (<$> maybeShareSJ) $ \maybeShareS ->
 122                                                 let specifiedShare    = sum $ fromMaybe 0 <$> maybeShareS in
 123                                                 let unspecifiedShares = toRational $ List.length $ List.filter isNothing maybeShareS in
 124                                                 let defaultShare      = (1 - specifiedShare) / unspecifiedShares in
 125                                                 fromMaybe defaultShare <$> maybeShareS
 126                         in
 127                 case childOpinJCS of
 128                 -- Test for unknown choices.
 129                  _ | unknownChoices <- currOpinJC`HM.difference`defaultDistJC
 130                    , not $ null unknownChoices ->
 131                         Left $ ErrorSection_unknown_choices $
 132                                 HS.fromMap $ (() <$) $ unknownChoices
 133                 -- Test for unknown judges.
 134                  _ | unknownJudgesC <- HM.filter (not . null) $
 135                                        HM.intersectionWith HM.difference
 136                                         currOpinJC
 137                                         defaultDistJC
 138                    , not $ null unknownJudgesC ->
 139                         Left $ ErrorSection_unknown_judges $
 140                                 HS.fromMap . (() <$) <$> unknownJudgesC
 141                 -- Handle no child 'Node':
 142                 -- current 'Distribution' is computed from current |Node|'s value ('currOpinJC')
 143                 -- and inherited default 'Distribution' ('defaultDistJC').
 144                  [] -> Right $ Node currDistJC []
 145                 -- Test for invalid shares.
 146                  _ | invalidSharesJC <-
 147                        HM.filter (not . null) $
 148                        HM.filter (\ss -> any (< 0) ss || sum ss /= 1)
 149                        <$> childShareSJC
 150                    , not $ null invalidSharesJC ->
 151                         Left $ ErrorSection_invalid_shares invalidSharesJC
 152                 -- Handle children 'Node's:
 153                 -- current 'Opinions' is computed from the 'Opinions' of the children 'Node's.
 154                  _ -> do
 155                         distJCS :: [Tree (HM.HashMap choice (HM.HashMap judge (Distribution grade)))] <-
 156                                 traverse (go $ currDistJC) childOpinJCS
 157                                 -- 'grade's set at current 'Node' ('currDistJC')
 158                                 -- become the new default 'grade's ('defaultDistJC')
 159                                 -- within its children 'Node's.
 160                         let distSJC :: HM.HashMap choice (HM.HashMap judge [Distribution grade]) =
 161                                 -- Collect the 'Distribution's by section.
 162                                 foldr (\distJC ->
 163                                         let newDistSJC = (pure <$>) <$> rootLabel distJC in
 164                                         HM.unionWith (HM.unionWith (List.++)) newDistSJC)
 165                                  HM.empty
 166                                  distJCS
 167                         let distJC :: HM.HashMap choice (HM.HashMap judge (Distribution grade)) =
 168                                 -- Compute the current 'Distribution' by scaling (share *) and merging (+)
 169                                 -- the children 'Distribution's.
 170                                 HM.mapWithKey (\choice ->
 171                                         HM.mapWithKey (\judge ->
 172                                                 Map.unionsWith (+) .
 173                                                 List.zipWith (\share dist -> (share *) <$> dist)
 174                                                  (childShareSJC HM.!choice HM.!judge)))
 175                                  distSJC
 176                         Right $ Node distJC distJCS