Add MajorityGauge (old code though).

diff --git a/Majority/Gauge.hs b/Majority/Gauge.hs
new file mode 100644 (file)
index 0000000..6aa90e1
--- /dev/null
+++ b/Majority/Gauge.hs
@@ -0,0 +1,100 @@
+-- | WARNING: the 'MajorityGauge' is a simplified 'MajorityValue'
+-- which is sufficient to determine the 'MajorityRanking'
+-- when the number of judges is large.
+-- It is an approximation, it can perfectly lead to a wrong ranking
+-- wrt. the 'MajorityRanking' done by using 'majorityValue'.
+module Majority.Gauge where
+
+import Data.Bool
+import Data.Eq (Eq(..))
+import Data.Function (($), (.))
+import Data.Functor ((<$>))
+import Data.Maybe (Maybe(..), listToMaybe)
+import Data.Ord (Ord(..), Ordering(..), Down(..))
+import Data.Tuple (snd)
+import Prelude (Num(..))
+import Text.Show (Show(..), showParen, shows)
+import qualified Data.HashMap.Strict as HM
+import qualified Data.List as List
+import qualified Data.Map.Strict as Map
+
+import Majority.Merit
+
+-- * Type 'MajorityGauge'
+-- | The 'MajorityGauge' is a simplification of the 'majorityValue'
+-- from which may be deduced the 'majorityRanking'
+-- among the propositions in many cases;
+-- in particular, when there are many judges.
+-- 
+-- However, when two propositions are tied with the same 'MajorityGauge',
+-- they are not necessarily tied according to their 'majorityValue's.
+data MajorityGauge g
+ =   MajorityGauge
+ {   mgHigher :: Share -- ^ Number of 'grade's given which are better than 'mgGrade'.
+ ,   mgGrade  :: g     -- ^ 'majorityGrade'.
+ ,   mgLower  :: Share -- ^ Number of 'grade's given which are worse than 'mgGrade'.
+ } deriving (Eq)
+instance Show g => Show (MajorityGauge g) where
+       showsPrec p (MajorityGauge b g w) = showParen (p >= 10) $ shows (b,g,w)
+
+-- ** Type 'Sign'
+data Sign = Minus | Plus
+ deriving (Eq, Show)
+
+-- | If 'mgHigher' is higher than 'mgLower'
+-- then the 'majorityGrade' is completed by a 'Plus';
+-- otherwise the 'majorityGrade' is completed by a 'Minus'.
+mgSign :: MajorityGauge g -> Sign
+mgSign g = if mgHigher g > mgLower g then Plus else Minus
+
+-- | The 'MajorityGauge'-ranking, first tries to rank
+-- according to the 'majorityGrade' 'mgGrade'.
+--
+-- If both 'MajorityGauge's have the same 'mgGrade',
+-- it tries to rank according to the 'mgSign' of both 'MajorityGauge's:
+-- a 'Plus' is ahead of a 'Minus'.
+-- 
+-- If both 'mgSign' are 'Plus',
+-- the one having the higher 'mgHigher' is ahead,
+-- or if both 'mgSign' are 'Minus',
+-- the one having the higher 'mgLower' is behind.
+--
+-- Otherwise, the 'MajorityGauge'-ranking is a tie.
+instance Ord g => Ord (MajorityGauge g) where
+       x `compare` y =
+               case mgGrade x `compare` mgGrade y of
+                EQ ->
+                       case (mgSign x, mgSign y) of
+                        (Minus, Plus)  -> LT
+                        (Plus , Minus) -> GT
+                        (Plus , Plus)  -> mgHigher x `compare` mgHigher y
+                        (Minus, Minus) -> mgLower  x `compare` mgLower  y
+                o -> o
+
+majorityGauge :: Ord grade => Merit grade -> Maybe (MajorityGauge grade)
+majorityGauge = listToMaybe . majorityGauges
+
+majorityGauges :: Ord grade => Merit grade -> [MajorityGauge grade]
+majorityGauges (Merit m) = go Map.empty m
+       where
+       go done gs = case snd (Map.foldlWithKey untilMajGrade (0,[]) gs) of
+                     []  -> []
+                     (mg,c):_ -> add mg done:go (Map.insert (mgGrade mg) c done) (Map.delete (mgGrade mg) gs)
+               where
+               add = Map.foldrWithKey $ \g c (MajorityGauge b mg w) ->
+                       if g >= mg then MajorityGauge (b+c) mg w
+                                  else MajorityGauge b mg (w+c)
+               total = List.sum gs
+               untilMajGrade (t,[]) g c | 2*tc >= total = (tc,[(MajorityGauge 0 g t,c)])
+                                        | otherwise     = (tc,[])
+                                        where tc = t+c
+               untilMajGrade (t,(mg,c):_) _g c' = (t,[(mg{mgHigher=mgHigher mg + c'},c)])
+
+-- * Type 'MajorityGaugeRanking'
+type MajorityGaugeRanking choice grade = [(choice, [MajorityGauge grade])]
+
+majorityGaugesByChoice :: Ord grade => MeritByChoice choice grade -> HM.HashMap choice [MajorityGauge grade]
+majorityGaugesByChoice (MeritByChoice ms) = majorityGauges <$> ms
+
+majorityGaugeRanking :: Ord grade => MeritByChoice choice grade -> MajorityGaugeRanking choice grade
+majorityGaugeRanking = List.sortOn (Down . snd) . HM.toList . majorityGaugesByChoice

diff --git a/Majority/Judgment.hs b/Majority/Judgment.hs
index d29e7074cbc35a34cd32b5ebca35ece7b16e20a4..be9ee5c454b0d82ca40d235f0df2db4375d8e080 100644 (file)
--- a/Majority/Judgment.hs
+++ b/Majority/Judgment.hs
@@ -1,9 +1,11 @@
 module Majority.Judgment
  ( module Majority.Merit
  , module Majority.Value
+ , module Majority.Gauge
  , module Majority.Section
  ) where
 
 import Majority.Merit
 import Majority.Value
+import Majority.Gauge
 import Majority.Section

diff --git a/hjugement.cabal b/hjugement.cabal
index 43ad3ed2f9b160ecb6869391a254da024973179d..8e0b524c780dcbfc7115bf7263c35d630c8f649b 100644 (file)
--- a/hjugement.cabal
+++ b/hjugement.cabal
@@ -48,6 +48,7 @@ Source-Repository head
 
 Library
   exposed-modules:
+    Majority.Gauge
     Majority.Judgment
     Majority.Merit
     Majority.Section