{-# 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 ((%), numerator, denominator)
import Data.Semigroup (Semigroup(..))
import Data.Tuple (snd)
import Prelude (Num(..), fromIntegral, lcm, div, )
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.
--
-- For using less resources and generalizing to non-integral 'Share's,
-- this 'MajorityValue' is actually encoded as an Abbreviated Majority Value,
-- instead of a big list of 'grade's.
newtype MajorityValue grade = MajorityValue [Middle grade]
 deriving (Eq, Show)
unMajorityValue :: MajorityValue grade -> [Middle grade]
unMajorityValue (MajorityValue ms) = ms
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)
instance Show grade => Show (Middle grade) where
	showsPrec p (Middle s l h) = showsPrec p (s,l,h)

-- | 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 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 :: Ord grade => MajorityValue grade -> Maybe grade
majorityGrade (MajorityValue mv) = lowGrade <$> listToMaybe mv

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

majorityValueByChoice :: 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 :: Ord grade => MeritByChoice choice grade -> MajorityRanking choice grade
majorityRanking = List.sortOn (Down . snd) . HM.toList . majorityValueByChoice

-- | Expand a 'MajorityValue' such that each 'grade' has a 'Share' of '1'.
--
-- WARNING: the resulting list of 'grade's may have a different length
-- than the list of 'grade's used to build the 'Merit'.
expandValue :: Eq grade => MajorityValue grade -> [grade]
expandValue (MajorityValue ms) =
	let lcm' = foldr lcm 1 (denominator . middleShare <$> ms) in
	concat $ (<$> ms) $ \(Middle s l h) ->
		let r = numerator s * (lcm' `div` denominator s) in
		concat (replicate (fromIntegral r) [l, h])
		{-
		case r`divMod`2 of
		 (quo,0) -> concat (replicate (fromIntegral quo) [l, h])
		 (quo,_) -> l:concat (replicate (fromIntegral quo) [l, h])
		-}

-- | @'normalizeMajorityValue' m@ multiply all 'Share's
-- by their least common denominator to get integral 'Share's.
normalizeMajorityValue :: MajorityValue grade -> MajorityValue grade
normalizeMajorityValue (MajorityValue mv) =
	MajorityValue $ (\m -> m{middleShare = lcm' * middleShare m}) <$> mv
	where
	lcm' = foldr lcm 1 (denominator . middleShare <$> mv) % den
	den  = case mv of
	 Middle s _l _h:_ -> denominator s
	 _ -> 1