Add default section share at judgment level.
authorJulien Moutinho <julm+hjugement@autogeree.net>
Tue, 12 Jun 2018 02:18:20 +0000 (04:18 +0200)
committerJulien Moutinho <julm+hjugement@autogeree.net>
Tue, 12 Jun 2018 02:18:20 +0000 (04:18 +0200)
Hjugement/Section.hs
hjugement.cabal
test/HUnit.hs

index 4559c8c0bc7cb16f0d9259ea7cac1a2e16863def..7749f01f7ec3256fcec60ad9df234d2f52bd4831 100644 (file)
@@ -1,7 +1,7 @@
 {-# 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(..))
@@ -12,7 +12,7 @@ import Data.Hashable (Hashable(..))
 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
@@ -23,25 +23,30 @@ import qualified Data.Map.Strict as Map
 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
@@ -55,40 +60,38 @@ 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
@@ -96,16 +99,18 @@ opinionsBySection cs js = go ((singleGrade <$> js) <$ HS.toMap cs)
                                 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
@@ -114,7 +119,7 @@ opinionsBySection cs js = go ((singleGrade <$> js) <$ HS.toMap cs)
                                 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 ->
@@ -138,10 +143,10 @@ opinionsBySection cs js = go ((singleGrade <$> js) <$ HS.toMap cs)
                   , 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) $
@@ -149,14 +154,14 @@ opinionsBySection cs js = go ((singleGrade <$> js) <$ HS.toMap cs)
                       <$> 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 ->
@@ -168,9 +173,12 @@ opinionsBySection cs js = go ((singleGrade <$> js) <$ HS.toMap cs)
                                -- 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
index cb13364a309d2df4651f9f9ba713ea95a66a7643..b98255ddee4290ffc53fe307345126868288da06 100644 (file)
@@ -2,7 +2,7 @@ name: hjugement
 -- PVP:  +-+------- breaking API changes
 --       | | +----- non-breaking API additions
 --       | | | +--- code changes with no API change
-version: 1.1.0.20180529
+version: 1.2.0.20180612
 category: Politic
 synopsis: Majority Judgment.
 description:
@@ -53,6 +53,7 @@ Library
   default-language: Haskell2010
   default-extensions:
     NoImplicitPrelude
+    NamedFieldPuns
   ghc-options:
     -Wall
     -Wincomplete-uni-patterns
index 349cd2fa087a8753f3100c571e46172ec2569740..2a027cc9f000530c4724b69db5057f9e5d7f2e40 100644 (file)
@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module HUnit where
 
@@ -164,6 +165,50 @@ hunits =
                                         [ 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)]
@@ -623,7 +668,7 @@ testSection ::
  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
@@ -633,3 +678,8 @@ testSection msg cs js ss expect =
 
 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