hjugement-2.0.0.20180903: Majority/Value.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}
module Majority.Value where

import Data.Bool
import Data.Eq (Eq(..))
import Data.Function (($), (.), on)
import Data.Functor ((<$>))
import Data.List as List
import Data.Maybe (Maybe(..), listToMaybe)
import Data.Ord (Ord(..), Ordering(..), Down(..))
import Data.Ratio ((%))
import Data.Semigroup (Semigroup(..))
import Data.Tuple (snd)
import Prelude (Num(..))
import Text.Show (Show(..))
import qualified Data.HashMap.Strict as HM
import qualified Data.Map.Strict as Map

import Majority.Merit

-- * Type 'MajorityValue'
-- | A 'MajorityValue' is a list of 'grade's
-- made from the successive lower middlemosts of a 'Merit',
-- i.e. from the most consensual 'majorityGrade' to the least.
newtype MajorityValue grade = MajorityValue { unMajorityValue :: [Middle grade] }
 deriving (Eq, Show)
instance Ord grade => Ord (MajorityValue grade) where
	MajorityValue []`compare`MajorityValue [] = EQ
	MajorityValue []`compare`MajorityValue ys | all ((==0) . middleShare) ys = EQ
	                                          | otherwise                    = LT
	MajorityValue xs`compare`MajorityValue [] | all ((==0) . middleShare) xs = EQ
	                                          | otherwise                    = GT
	mx@(MajorityValue (x:xs)) `compare` my@(MajorityValue (y:ys))
	 | middleShare x <= 0 && middleShare y <= 0 = MajorityValue xs`compare`MajorityValue ys
	 | middleShare x <= 0 = MajorityValue xs`compare`my
	 | middleShare y <= 0 = mx`compare`MajorityValue ys
	 | otherwise =
		lowGrade x`compare`lowGrade y <>
		highGrade x`compare`highGrade y <>
		case middleShare x`compare`middleShare y of
		 LT -> compare (MajorityValue xs) (MajorityValue (y{middleShare = middleShare y - middleShare x} : ys))
		 EQ -> compare (MajorityValue xs) (MajorityValue ys)
		 GT -> compare (MajorityValue (x{middleShare = middleShare x - middleShare y} : xs)) (MajorityValue ys)

-- ** Type 'Middle'
-- | A centered middle of a 'Merit'.
-- Needed to handle the 'Fractional' capabilities of a 'Share'.
--
-- By construction in 'majorityValue',
-- 'lowGrade' is always lower or equal to 'highGrade'.
data Middle grade = Middle
 { middleShare :: Share -- ^ the same 'Share' of 'lowGrade' and 'highGrade'.
 , lowGrade    :: grade
 , highGrade   :: grade
 } deriving (Eq, Ord, Show)

-- | The 'majorityValue' is the list of the 'Middle's of the 'Merit' of a 'choice',
-- from the most consensual to the least.
majorityValue :: Ord grade => Merit grade -> MajorityValue grade
majorityValue (Merit countByGrade) = MajorityValue $ goMiddle 0 [] $ Map.toList countByGrade
	where
	total = sum countByGrade
	middle = (1%2) * total
	goMiddle :: Ord grade => Share -> [(grade,Share)] -> [(grade,Share)] -> [Middle grade]
	goMiddle prevShare ps next =
		case next of
		 [] -> []
		 curr@(currGrade,currShare):ns ->
			let nextShare = prevShare + currShare in
			case nextShare`compare`middle of
			 LT -> goMiddle nextShare (curr:ps) ns
			 EQ -> goBorders (curr:ps) ns
			 GT ->
				let lowShare  = middle - prevShare in
				let highShare = nextShare - middle in
				let minShare  = min lowShare highShare in
				Middle minShare currGrade currGrade :
				goBorders
				 ((currGrade, lowShare  - minShare) : ps)
				 ((currGrade, highShare - minShare) : ns)
	goBorders :: [(grade,Share)] -> [(grade,Share)] -> [Middle grade]
	goBorders lows highs =
		case (lows,highs) of
		 ((lowGrade,lowShare):ls, (highGrade,highShare):hs)
		  | lowShare <= 0  -> goBorders ls highs
		  | highShare <= 0 -> goBorders lows hs
		  | otherwise ->
				let minShare = min lowShare highShare in
				Middle minShare lowGrade highGrade :
				goBorders
				 ((lowGrade , lowShare  - minShare) : ls)
				 ((highGrade, highShare - minShare) : hs)
		 _ -> []
instance (Show grade, Ord grade) => Ord (Merit grade) where
	compare = compare `on` majorityValue

-- | The 'majorityGrade' is the lower middlemost
-- (also known as median by experts) of the 'grade's
-- given to a 'choice' by the 'Judges'.
--
-- It is the highest 'grade' approved by an absolute majority of the 'Judges':
-- more than 50% of the 'Judges' give the 'choice' at least a 'grade' of 'majorityGrade',
-- but every 'grade' lower than 'majorityGrade' is rejected by an absolute majority
-- Thus the 'majorityGrade' of a 'choice'
-- is the final 'grade' wished by the majority.
--
-- The 'majorityGrade' is necessarily a word that belongs to 'grades',
-- and it has an absolute meaning.
--
-- When the number of 'Judges' is even, there is a middle-interval
-- (which can, of course, be reduced to a single 'grade'
-- if the two middle 'grade's are the same),
-- then the 'majorityGrade' is the lowest 'grade' of the middle-interval
-- (the “lower middlemost” when there are two in the middle),
-- which is the only one which respects consensus:
-- any other 'choice' whose grades are all within this middle-interval,
-- has a 'majorityGrade' which is greater or equal to this lower middlemost.
majorityGrade :: Show grade => Ord grade => Merit grade -> Maybe grade
majorityGrade m = lowGrade <$> listToMaybe gs where MajorityValue gs = majorityValue m

-- * Type 'MajorityRanking'
type MajorityRanking choice grade = [(choice, MajorityValue grade)]

majorityValueByChoice :: Show grade => Ord grade => MeritByChoice choice grade -> HM.HashMap choice (MajorityValue grade)
majorityValueByChoice (MeritByChoice ms) = majorityValue <$> ms

-- | The 'majorityRanking' ranks all the 'choice's on the basis of their 'grade's.
--
-- Choice A ranks higher than 'choice' B in the 'majorityRanking'
-- if and only if A’s 'majorityValue' is lexicographically above B’s.
-- There can be no tie unless two 'choice's have precisely the same 'majorityValue's.
majorityRanking :: Show grade => Ord grade => MeritByChoice choice grade -> MajorityRanking choice grade
majorityRanking = List.sortOn (Down . snd) . HM.toList . majorityValueByChoice