Hjugement/Section.hs

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