-- | WARNING: the 'MajorityGauge' is a simplified 'MajorityValue'
-- which is sufficient to determine the 'MajorityRanking'
-- when the number of judges is large.
module Majurity.Judgment.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(..))
import qualified Data.HashMap.Strict as HM
import qualified Data.List as List
import qualified Data.Map.Strict as Map

import Majurity.Judgment.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
 {   MajorityGauge g -> Share
mgLower  :: Share -- ^ Number of 'grade's given which are worse than 'mgGrade'.
 ,   MajorityGauge g -> g
mgGrade  :: g     -- ^ 'majorityGrade'.
 ,   MajorityGauge g -> Share
mgHigher :: Share -- ^ Number of 'grade's given which are better than 'mgGrade'.
 } deriving (MajorityGauge g -> MajorityGauge g -> Bool
(MajorityGauge g -> MajorityGauge g -> Bool)
-> (MajorityGauge g -> MajorityGauge g -> Bool)
-> Eq (MajorityGauge g)
forall g. Eq g => MajorityGauge g -> MajorityGauge g -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MajorityGauge g -> MajorityGauge g -> Bool
$c/= :: forall g. Eq g => MajorityGauge g -> MajorityGauge g -> Bool
== :: MajorityGauge g -> MajorityGauge g -> Bool
$c== :: forall g. Eq g => MajorityGauge g -> MajorityGauge g -> Bool
Eq)
instance Show g => Show (MajorityGauge g) where
	showsPrec :: Int -> MajorityGauge g -> ShowS
showsPrec Int
p (MajorityGauge Share
w g
g Share
b) = Int -> (Share, g, Share) -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p (Share
w,g
g,Share
b)

-- ** Type 'Sign'
data Sign = Minus | Plus
 deriving (Sign -> Sign -> Bool
(Sign -> Sign -> Bool) -> (Sign -> Sign -> Bool) -> Eq Sign
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Sign -> Sign -> Bool
$c/= :: Sign -> Sign -> Bool
== :: Sign -> Sign -> Bool
$c== :: Sign -> Sign -> Bool
Eq, Int -> Sign -> ShowS
[Sign] -> ShowS
Sign -> String
(Int -> Sign -> ShowS)
-> (Sign -> String) -> ([Sign] -> ShowS) -> Show Sign
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Sign] -> ShowS
$cshowList :: [Sign] -> ShowS
show :: Sign -> String
$cshow :: Sign -> String
showsPrec :: Int -> Sign -> ShowS
$cshowsPrec :: Int -> Sign -> ShowS
Show)

-- | If 'mgHigher' is higher than 'mgLower'
-- then the 'majorityGrade' is completed by a 'Plus';
-- otherwise the 'majorityGrade' is completed by a 'Minus'.
--
-- This indicates the side of the next 'majorityGrade'
-- which is different than the current one:
-- 'Minus' when it is lower and 'Plus' otherwise.
mgSign :: MajorityGauge g -> Sign
mgSign :: MajorityGauge g -> Sign
mgSign MajorityGauge g
g = if MajorityGauge g -> Share
forall g. MajorityGauge g -> Share
mgHigher MajorityGauge g
g Share -> Share -> Bool
forall a. Ord a => a -> a -> Bool
> MajorityGauge g -> Share
forall g. MajorityGauge g -> Share
mgLower MajorityGauge g
g then Sign
Plus else Sign
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
	MajorityGauge g
x compare :: MajorityGauge g -> MajorityGauge g -> Ordering
`compare` MajorityGauge g
y =
		case MajorityGauge g -> g
forall g. MajorityGauge g -> g
mgGrade MajorityGauge g
x g -> g -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` MajorityGauge g -> g
forall g. MajorityGauge g -> g
mgGrade MajorityGauge g
y of
		 Ordering
EQ ->
			case (MajorityGauge g -> Sign
forall g. MajorityGauge g -> Sign
mgSign MajorityGauge g
x, MajorityGauge g -> Sign
forall g. MajorityGauge g -> Sign
mgSign MajorityGauge g
y) of
			 (Sign
Minus, Sign
Plus)  -> Ordering
LT
			 (Sign
Plus , Sign
Minus) -> Ordering
GT
			 (Sign
Plus , Sign
Plus)  -> MajorityGauge g -> Share
forall g. MajorityGauge g -> Share
mgHigher MajorityGauge g
x Share -> Share -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` MajorityGauge g -> Share
forall g. MajorityGauge g -> Share
mgHigher MajorityGauge g
y
			 (Sign
Minus, Sign
Minus) -> MajorityGauge g -> Share
forall g. MajorityGauge g -> Share
mgLower  MajorityGauge g
y Share -> Share -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` MajorityGauge g -> Share
forall g. MajorityGauge g -> Share
mgLower  MajorityGauge g
x
		 Ordering
o -> Ordering
o

majorityGauge :: Ord grade => Merit grade -> Maybe (MajorityGauge grade)
majorityGauge :: Merit grade -> Maybe (MajorityGauge grade)
majorityGauge = [MajorityGauge grade] -> Maybe (MajorityGauge grade)
forall a. [a] -> Maybe a
listToMaybe ([MajorityGauge grade] -> Maybe (MajorityGauge grade))
-> (Merit grade -> [MajorityGauge grade])
-> Merit grade
-> Maybe (MajorityGauge grade)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Merit grade -> [MajorityGauge grade]
forall grade. Ord grade => Merit grade -> [MajorityGauge grade]
majorityGauges

majorityGauges :: Ord grade => Merit grade -> [MajorityGauge grade]
majorityGauges :: Merit grade -> [MajorityGauge grade]
majorityGauges (Merit Map grade Share
m) = Map grade Share -> Map grade Share -> [MajorityGauge grade]
forall k. Ord k => Map k Share -> Map k Share -> [MajorityGauge k]
go Map grade Share
forall k a. Map k a
Map.empty Map grade Share
m
	where
	go :: Map k Share -> Map k Share -> [MajorityGauge k]
go Map k Share
done Map k Share
gs = case (Share, [(MajorityGauge k, Share)]) -> [(MajorityGauge k, Share)]
forall a b. (a, b) -> b
snd (((Share, [(MajorityGauge k, Share)])
 -> k -> Share -> (Share, [(MajorityGauge k, Share)]))
-> (Share, [(MajorityGauge k, Share)])
-> Map k Share
-> (Share, [(MajorityGauge k, Share)])
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey (Share, [(MajorityGauge k, Share)])
-> k -> Share -> (Share, [(MajorityGauge k, Share)])
forall g.
(Share, [(MajorityGauge g, Share)])
-> g -> Share -> (Share, [(MajorityGauge g, Share)])
untilMajGrade (Share
0,[]) Map k Share
gs) of
	              []  -> []
	              (MajorityGauge k
mg,Share
c):[(MajorityGauge k, Share)]
_ -> MajorityGauge k -> Map k Share -> MajorityGauge k
add MajorityGauge k
mg Map k Share
doneMajorityGauge k -> [MajorityGauge k] -> [MajorityGauge k]
forall a. a -> [a] -> [a]
:Map k Share -> Map k Share -> [MajorityGauge k]
go (k -> Share -> Map k Share -> Map k Share
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (MajorityGauge k -> k
forall g. MajorityGauge g -> g
mgGrade MajorityGauge k
mg) Share
c Map k Share
done) (k -> Map k Share -> Map k Share
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (MajorityGauge k -> k
forall g. MajorityGauge g -> g
mgGrade MajorityGauge k
mg) Map k Share
gs)
		where
		add :: MajorityGauge k -> Map k Share -> MajorityGauge k
add = (k -> Share -> MajorityGauge k -> MajorityGauge k)
-> MajorityGauge k -> Map k Share -> MajorityGauge k
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey ((k -> Share -> MajorityGauge k -> MajorityGauge k)
 -> MajorityGauge k -> Map k Share -> MajorityGauge k)
-> (k -> Share -> MajorityGauge k -> MajorityGauge k)
-> MajorityGauge k
-> Map k Share
-> MajorityGauge k
forall a b. (a -> b) -> a -> b
$ \k
g Share
c (MajorityGauge Share
w k
mg Share
b) ->
			if k
g k -> k -> Bool
forall a. Ord a => a -> a -> Bool
>= k
mg then Share -> k -> Share -> MajorityGauge k
forall g. Share -> g -> Share -> MajorityGauge g
MajorityGauge Share
w k
mg (Share
bShare -> Share -> Share
forall a. Num a => a -> a -> a
+Share
c)
			           else Share -> k -> Share -> MajorityGauge k
forall g. Share -> g -> Share -> MajorityGauge g
MajorityGauge (Share
wShare -> Share -> Share
forall a. Num a => a -> a -> a
+Share
c) k
mg Share
b
		total :: Share
total = Map k Share -> Share
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
List.sum Map k Share
gs
		untilMajGrade :: (Share, [(MajorityGauge g, Share)])
-> g -> Share -> (Share, [(MajorityGauge g, Share)])
untilMajGrade (Share
t,[]) g
g Share
c | Share
2Share -> Share -> Share
forall a. Num a => a -> a -> a
*Share
tc Share -> Share -> Bool
forall a. Ord a => a -> a -> Bool
>= Share
total = (Share
tc,[(Share -> g -> Share -> MajorityGauge g
forall g. Share -> g -> Share -> MajorityGauge g
MajorityGauge Share
t g
g Share
0,Share
c)])
		                         | Bool
otherwise     = (Share
tc,[])
		                         where tc :: Share
tc = Share
tShare -> Share -> Share
forall a. Num a => a -> a -> a
+Share
c
		untilMajGrade (Share
t,(MajorityGauge g
mg,Share
c):[(MajorityGauge g, Share)]
_) g
_g Share
c' = (Share
t,[(MajorityGauge g
mg{mgHigher :: Share
mgHigher=MajorityGauge g -> Share
forall g. MajorityGauge g -> Share
mgHigher MajorityGauge g
mg Share -> Share -> Share
forall a. Num a => a -> a -> a
+ Share
c'},Share
c)])

-- * Type 'MajorityGaugeRanking'
type MajorityGaugeRanking choice grade = [(choice, [MajorityGauge grade])]

majorityGaugesByChoice :: Ord grade => MeritByChoice choice grade -> HM.HashMap choice [MajorityGauge grade]
majorityGaugesByChoice :: MeritByChoice choice grade -> HashMap choice [MajorityGauge grade]
majorityGaugesByChoice (MeritByChoice HashMap choice (Merit grade)
ms) = Merit grade -> [MajorityGauge grade]
forall grade. Ord grade => Merit grade -> [MajorityGauge grade]
majorityGauges (Merit grade -> [MajorityGauge grade])
-> HashMap choice (Merit grade)
-> HashMap choice [MajorityGauge grade]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap choice (Merit grade)
ms

majorityGaugeRanking :: Ord grade => MeritByChoice choice grade -> MajorityGaugeRanking choice grade
majorityGaugeRanking :: MeritByChoice choice grade -> MajorityGaugeRanking choice grade
majorityGaugeRanking = ((choice, [MajorityGauge grade]) -> Down [MajorityGauge grade])
-> MajorityGaugeRanking choice grade
-> MajorityGaugeRanking choice grade
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn ([MajorityGauge grade] -> Down [MajorityGauge grade]
forall a. a -> Down a
Down ([MajorityGauge grade] -> Down [MajorityGauge grade])
-> ((choice, [MajorityGauge grade]) -> [MajorityGauge grade])
-> (choice, [MajorityGauge grade])
-> Down [MajorityGauge grade]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (choice, [MajorityGauge grade]) -> [MajorityGauge grade]
forall a b. (a, b) -> b
snd) (MajorityGaugeRanking choice grade
 -> MajorityGaugeRanking choice grade)
-> (MeritByChoice choice grade
    -> MajorityGaugeRanking choice grade)
-> MeritByChoice choice grade
-> MajorityGaugeRanking choice grade
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap choice [MajorityGauge grade]
-> MajorityGaugeRanking choice grade
forall k v. HashMap k v -> [(k, v)]
HM.toList (HashMap choice [MajorityGauge grade]
 -> MajorityGaugeRanking choice grade)
-> (MeritByChoice choice grade
    -> HashMap choice [MajorityGauge grade])
-> MeritByChoice choice grade
-> MajorityGaugeRanking choice grade
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MeritByChoice choice grade -> HashMap choice [MajorityGauge grade]
forall grade choice.
Ord grade =>
MeritByChoice choice grade -> HashMap choice [MajorityGauge grade]
majorityGaugesByChoice