{-# LANGUAGE ScopedTypeVariables #-}
module Hjugement.Section where
-import Control.Applicative (Applicative(..))
+import Control.Applicative (Applicative(..), Alternative(..))
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Maybe (Maybe(..), isNothing, maybe, fromMaybe)
import Data.Ord (Ord(..))
import Data.Traversable (Traversable(..))
-import Data.Tree
+import Data.Tree as Tree
import Prelude (Num(..), Fractional(..), toRational)
import Text.Show (Show(..))
import qualified Data.HashMap.Strict as HM
import Hjugement.MJ
-- * Type 'Section'
--- | An opinion of a 'judge' about a 'choice' at a specific section 'Node'.
+-- | An opinion of a 'judge' about a 'choice' at a specific section 'Tree.Node'.
data Section grade
= Section
{ sectionShare :: Maybe Share
- -- ^ A 'Share' within the parent 'Node'
+ -- ^ A 'Share' within the parent 'Tree.Node'
-- (defaulting to a 'Share' computed as the remaining 'Share' to reach 1
-- divided by the number of defaulted 'Share's).
, sectionGrade :: Maybe grade
- -- ^ A 'grade' attributed to the current 'Node'
- -- (defaulting to the 'grade' set on an ancestor 'Node' if any,
+ -- ^ A 'grade' attributed to the current 'Tree.Node'
+ -- (defaulting to the 'grade' set on an ancestor 'Tree.Node' if any,
-- or the |judge|'s default grade).
- } deriving (Eq, Show)
+ } deriving (Eq,Show)
-- ** Type 'SectionByJudge'
type SectionByJudge judge grade = HM.HashMap judge (Section grade)
--- ** Type 'SectionByJudgeByChoice'
--- | Node value of a 'Tree' holding a 'Section', per 'judge', per choice.
-type SectionByJudgeByChoice choice judge grade = HM.HashMap choice (SectionByJudge judge grade)
+-- ** Type 'SectionNode'
+-- | Node value of a 'Tree' holding a 'Section', per 'judge', per 'choice'.
+data SectionNode choice judge grade
+ = SectionNode
+ { sectionNodeShare :: Maybe Share
+ -- ^ A default 'sectionShare' for judges not specifying their own.
+ , sectionByJudgeByChoice :: HM.HashMap choice (SectionByJudge judge grade)
+ } deriving (Eq,Show)
-- * Type 'ErrorSection'
data ErrorSection choice judge grade
-- | Compute the 'Opinions' of the given |Judges| about the given 'Choices',
-- from the 'grade' (specified or omitted) attributed to 'Choice's
--- and the 'Share's (specified or omitted) attributed to 'Node'
+-- and the 'Share's (specified or omitted) attributed to 'Tree.Node'
-- in given 'Tree'.
opinionsBySection ::
forall choice judge grade.
- Show choice =>
- Show judge =>
- Show grade =>
Eq choice =>
- Hashable choice =>
Eq judge =>
+ Hashable choice =>
Hashable judge =>
Ord grade =>
Choices choice ->
Judges judge grade ->
- Tree (SectionByJudgeByChoice choice 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 (SectionByJudgeByChoice choice judge grade) ->
+ Tree (SectionNode choice judge grade) ->
Either (ErrorSection choice judge grade)
(Tree (OpinionsByChoice choice judge grade))
- go defaultDistJC (Node currOpinJC childOpinJCS) =
- -- From current |Node|'s value.
+ go defaultDistJC (Tree.Node (SectionNode _sectionNodeShare currOpinJC) childOpinJCS) =
+ -- From current |Tree.Node|'s value.
let currDistJC :: HM.HashMap choice (HM.HashMap judge (Distribution grade)) =
- -- Collect the 'Distribution' of current 'Node',
+ -- Collect the 'Distribution' of current 'Tree.Node',
-- and insert default 'Distribution'
-- for each unspecified 'judge'
-- of each (specified or unspecified) 'choice'.
let specifiedDistJC =
HM.mapWithKey (\choice ->
+ let defaultDistJ = defaultDistJC HM.!choice in
HM.mapWithKey (\judge ->
- maybe (defaultDistJC HM.!choice HM.!judge) singleGrade .
+ maybe (defaultDistJ HM.!judge) singleGrade .
sectionGrade))
currOpinJC
in
specifiedDistJC
defaultDistJC
in
- -- From children 'Node's.
- let defaultChildShareSJC = ([Nothing] <$ js) <$ defaultDistJC in
+ -- From children 'Tree.Node's.
let maybeChildShareSJC :: HM.HashMap choice (HM.HashMap judge [Maybe Share]) =
-- Collect the (specified or explicitely (with 'Nothing') unspecified) 'Share's by section,
-- and insert all unspecified 'Share's when a 'choice' or a 'judge' is unspecified.
- foldr (\childOpinJC ->
- let specifiedChildShareSJC = (pure . sectionShare <$>) <$> rootLabel childOpinJC in
+ foldr (\(Tree.Node SectionNode{sectionNodeShare, sectionByJudgeByChoice} _) ->
+ let defaultChildShareSJC = ([sectionNodeShare] <$ js) <$ defaultDistJC in
+ let specifiedChildShareSJC =
+ (<$> sectionByJudgeByChoice) $
+ (pure . (<|> sectionNodeShare) . sectionShare <$>) in
-- Fusion specified 'choice's into accum.
HM.unionWith (HM.unionWith (List.++)) $
- -- Add default 'Share' for this 'Node',
+ -- Add default 'Share' for this 'Tree.Node',
-- for each unspecified 'judge' of specified and unspecified 'choice'.
HM.unionWith HM.union
specifiedChildShareSJC
childOpinJCS
in
let childShareSJC :: HM.HashMap choice (HM.HashMap judge [Share]) =
- -- Replace unspecified shares of each child 'Node'
+ -- Replace unspecified shares of each child 'Tree.Node'
-- by an even default: the total remaining 'Share'
-- divided by the number of unspecified 'Share's.
(<$> maybeChildShareSJC) $ \maybeShareSJ ->
, not $ null unknownJudgesC ->
Left $ ErrorSection_unknown_judges $
HS.fromMap . (() <$) <$> unknownJudgesC
- -- Handle no child 'Node':
- -- current 'Distribution' is computed from current |Node|'s value ('currOpinJC')
+ -- Handle no child 'Tree.Node':
+ -- current 'Distribution' is computed from current |Tree.Node|'s value ('currOpinJC')
-- and inherited default 'Distribution' ('defaultDistJC').
- [] -> Right $ Node currDistJC []
+ [] -> Right $ Tree.Node currDistJC []
-- Test for invalid shares.
_ | invalidSharesJC <-
HM.filter (not . null) $
<$> childShareSJC
, not $ null invalidSharesJC ->
Left $ ErrorSection_invalid_shares invalidSharesJC
- -- Handle children 'Node's:
- -- current 'Opinions' is computed from the 'Opinions' of the children 'Node's.
+ -- Handle children 'Tree.Node's:
+ -- current 'Opinions' is computed from the 'Opinions' of the children 'Tree.Node's.
_ -> do
distJCS :: [Tree (HM.HashMap choice (HM.HashMap judge (Distribution grade)))] <-
traverse (go $ currDistJC) childOpinJCS
- -- 'grade's set at current 'Node' ('currDistJC')
+ -- 'grade's set at current 'Tree.Node' ('currDistJC')
-- become the new default 'grade's ('defaultDistJC')
- -- within its children 'Node's.
+ -- within its children 'Tree.Node's.
let distSJC :: HM.HashMap choice (HM.HashMap judge [Distribution grade]) =
-- Collect the 'Distribution's by section.
foldr (\distJC ->
-- Compute the current 'Distribution' by scaling (share *) and merging (+)
-- the children 'Distribution's.
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)
- (childShareSJC HM.!choice HM.!judge)))
+ List.zipWith
+ (\share dist -> (share *) <$> dist)
+ childShareS))
distSJC
- Right $ Node distJC distJCS
+ Right $ Tree.Node distJC distJCS
{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module HUnit where
[ node0 [(This, [(1,[(Acceptable,1%1)])])]
, node0 [(This, [(1,[(Acceptable,1%1)])])]
])
+ , testSection "sectionNodeShare with judge"
+ [This]
+ [(1::Int,ToReject), (2,Insufficient)]
+ (Node
+ [(This, [(1,Section Nothing (Just Acceptable))])]
+ [ node0 $ SectionNode (Just $ 1%3) [(This, [ (1,Section (Just $ 1%2) Nothing)
+ , (2,Section Nothing Nothing)
+ ])]
+ , node0 [(This, [ (1,Section (Just $ 1%2) Nothing)
+ , (2,Section Nothing (Just Good))
+ ])]
+ ])
+ (Right $ Node
+ [ (This, [ (1,[(Acceptable,1%2 + 1%2)])
+ , (2,[(Insufficient,1%3), (Good,2%3)])
+ ]) ]
+ [ node0 [(This, [ (1,[(Acceptable,1%1)])
+ , (2,[(Insufficient,1%1)])
+ ])]
+ , node0 [(This, [ (1,[(Acceptable,1%1)])
+ , (2,[(Good,1%1)])
+ ])]
+ ])
+ , testSection "sectionNodeShare without judge"
+ [This]
+ [(1::Int,ToReject), (2,Insufficient)]
+ (Node
+ [(This, [(1,Section Nothing (Just Acceptable))])]
+ [ node0 $ SectionNode (Just $ 1%3) [(This, [ (1,Section (Just $ 1%2) Nothing) ])]
+ , node0 [(This, [ (1,Section (Just $ 1%2) Nothing)
+ , (2,Section Nothing (Just Good))
+ ])]
+ ])
+ (Right $ Node
+ [ (This, [ (1,[(Acceptable,1%2 + 1%2)])
+ , (2,[(Insufficient,1%3), (Good,2%3)])
+ ]) ]
+ [ node0 [(This, [ (1,[(Acceptable,1%1)])
+ , (2,[(Insufficient,1%1)])
+ ])]
+ , node0 [(This, [ (1,[(Acceptable,1%1)])
+ , (2,[(Good,1%1)])
+ ])]
+ ])
, testSection "1 judge, 2 grades, 2 sections"
[This]
[(1::Int,ToReject)]
String ->
Choices choice ->
Judges judge grade ->
- Tree (SectionByJudgeByChoice choice judge grade) ->
+ Tree (SectionNode choice judge grade) ->
Either (ErrorSection choice judge grade)
(Tree (OpinionsByChoice choice judge grade)) ->
TestTree
node0 :: a -> Tree a
node0 = (`Node`[])
+
+instance (Eq choice, Hashable choice) => IsList (SectionNode choice judge grade) where
+ type Item (SectionNode choice judge grade) = (choice, SectionByJudge judge grade)
+ fromList = SectionNode Nothing . fromList
+ toList = GHC.Exts.toList . sectionByJudgeByChoice