{-# 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