{-# LANGUAGE TypeFamilies #-}
module Hjugement.Majority where

import Data.Function (on)
import Data.List
import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
import Data.Ord (Down(..))
import Data.Semigroup (Semigroup(..))
import Data.Set (Set)
import GHC.Exts (IsList(..))
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set

-- * Type 'Choices'
type Choices prop = Set prop

-- | Return a set of 'Choices' by enumerating the alternatives of its type. Useful on sum types.
choices :: (Bounded prop , Enum prop , Ord prop) => Choices prop
choices = Set.fromList (enumFrom minBound)

-- * Type 'Scale'
data Scale grade
 =   Scale
 {   scaleGrades :: Set grade
     -- ^ How many 'grade's should be used?
     -- A greater number of 'grade's permits a finer distinction but demands
     -- a higher degree of expertise and discernment.
     -- The optimal number is the highest number of 'grade's that constitutes a common language,
     -- that is, that allows 'judge's to make absolute judgments.
     -- Too little 'grade's may lead too often to ties.
     -- 
     -- Note, however, that if the inputs or grades depend on the set of choices,
     -- i.e. if judges change their grades when choices are added or dropped,
     -- then the Arrow paradox cannot be avoided.
     -- To avoid this the scale must be fixed and absolute
     -- so that more or fewer choices does not change
     -- the inputs or messages of other choices.
 ,   scaleDefault :: grade
     -- ^ For instance, when a 'judge' gives no 'grade' or has “no opinion”,
     -- 'scaleDefault' could mean that the 'judge' chooses “To Reject” the choice:
     -- the rationale being that a 'judge' having “no opinion”
     -- concerning a choice has not even taken the time to evaluate it
     -- and thus has implicitly rejected it.
 } deriving (Eq, Show)

-- | Return a 'Scale' by enumerating the alternatives of its type. Useful on sum types.
scale :: (Bounded grade, Enum grade, Ord grade) => Scale grade
scale = Scale { scaleGrades  = Set.fromList (enumFrom minBound)
              , scaleDefault = toEnum 0
              }

-- | Return a 'Scale' from a list of 'grade's and a default 'grade'.
-- Useful with 'grade's whose type has no 'Ord' instance
-- or a different one than the one wanted.
scaleOfList :: Eq a => [a] -> a -> Scale Int
scaleOfList gs dg = Scale is di
	where
	is = fromList $ findIndices (const True) gs
	di = fromMaybe (error "default grade not in the scale") $ dg`elemIndex`gs

gradeOfScale :: [a] -> Int -> a
gradeOfScale = (!!)

-- * Type 'Jury'
type Jury judge = Set judge

-- | Return a 'Jury' by enumerating the alternatives of its type. Useful on sum types.
jury :: (Bounded judge , Enum judge , Ord judge) => Jury judge
jury = Set.fromList (enumFrom minBound)

-- * Type 'Opinion'
-- | Profile of opinions of one single 'judge' about some 'prop'ositions.
type Opinion prop grade = Map prop grade

-- | Construct the 'Opinion' of a 'judge' about some 'prop'ositions implicit from their type.
opinion :: (Enum prop, Bounded prop, Ord prop) =>
           judge -> [grade] ->
           (judge, Opinion prop grade)
opinion j gs = (j, Map.fromList (zip (enumFrom minBound) gs))

-- ** Type 'Opinions'
-- | Profile of opinions of some 'judge's about some 'prop'ositions.
newtype Opinions prop grade judge = Opinions (Map judge (Opinion prop grade))
 deriving (Eq, Show)
instance (Ord judge, Show judge) => IsList (Opinions prop grade judge) where
	type Item (Opinions prop grade judge) = (judge, Opinion prop grade)
	fromList = Opinions . Map.fromListWithKey
		 (\k _x _y -> error $ "duplicate opinion for judge: " <> show k)
	toList (Opinions os) = toList os

-- * Type 'Merit'
-- | Profile of merits about a choice.
newtype Merit grade = Merit (Map grade Count)
 deriving (Eq, Show)
type Count = Int

instance Ord grade => Semigroup (Merit grade) where
	Merit x <> Merit y = Merit (Map.unionWith (+) x y)
instance Ord grade => Ord (Merit grade) where
	compare = compare `on` majorityValue
instance (Ord grade, Show grade) => IsList (Merit grade) where
	type Item (Merit grade) = (grade, Count)
	fromList = Merit . Map.fromListWithKey
		 (\g _x _y -> error $ "duplicate grade in merit: " <> show g)
	toList (Merit cs) = toList cs

-- | @merit grad@ returns the 'Merit'
-- of a single 'choice' by some 'judge's.
merit :: (Ord grade, Ord prop) =>
         Scale grade -> prop -> Opinions prop grade judge ->
         Merit grade
merit scal prop (Opinions os) = foldr insertOpinion defaultMerit os
	where
	insertOpinion op (Merit m) = Merit (Map.insertWith (+) g 1 m)
		where g = Map.findWithDefault (scaleDefault scal) prop op
	defaultMerit = Merit (const 0 `Map.fromSet` scaleGrades scal)

-- ** Type 'Merits'
-- | Profile of merits about some choices.
newtype Merits prop grade = Merits (Map prop (Merit grade))
 deriving (Eq, Show)
instance (Ord grade, Ord prop) => Semigroup (Merits prop grade) where
	Merits x <> Merits y = Merits (Map.unionWith (<>) x y)
instance (Ord prop, Show prop) => IsList (Merits prop grade) where
	type Item (Merits prop grade) = (prop, Merit grade)
	fromList = Merits . Map.fromListWithKey
		 (\p _x _y -> error $ "duplicate choice in merits: " <> show p)
	toList (Merits cs) = toList cs

-- | @merit scal props opins@ returns the 'Merits'
-- of the 'Choices' 'props'
-- as judged by the 'Opinions' 'opins'
-- on the 'Scale' 'scal'.
merits :: (Ord grade, Ord prop) =>
          Scale grade -> Choices prop -> Opinions prop grade judge ->
          Merits prop grade
merits scal props (Opinions os) = foldr ((<>) . meritsFromOpinion) defaultMerits os
	where
	meritsFromOpinion = Merits . (Merit . (`Map.singleton` 1) <$>) . (<> defaultOpinion)
	defaultOpinion    = const (scaleDefault scal) `Map.fromSet` props
	defaultMerits     = Merits (const defaultMerit `Map.fromSet` props)
	defaultMerit      = Merit (const 0 `Map.fromSet` scaleGrades scal)

-- * Type 'Value'
-- | A 'Value' is a compressed list of 'grade's,
-- where each 'grade' is associated with the 'Count'
-- by which it would be replicated in situ if decompressed.
newtype Value grade = Value [(grade,Count)]
 deriving (Eq, Show)
-- | 'compare' lexicographically as if the 'Value's
-- were decompressed.
instance Ord grade => Ord (Value grade) where
	Value []`compare`Value [] = EQ
	Value []`compare`Value ys | all ((==0) . snd) ys = EQ
	                          | otherwise            = LT
	Value xs`compare`Value [] | all ((==0) . snd) xs = EQ
	                          | otherwise            = GT
	sx@(Value ((x,cx):xs)) `compare` sy@(Value ((y,cy):ys)) =
		case cx`compare`cy of
		 _ | cx == 0 && cy == 0 -> Value xs`compare`Value ys
		 _ | cx <= 0 -> Value xs`compare`sy
		 _ | cy <= 0 -> sx`compare`Value ys
		 EQ -> x`compare`y <> Value xs`compare`Value ys
		 LT -> x`compare`y <> Value xs`compare`Value((y,cy-cx):ys)
		 GT -> x`compare`y <> Value((x,cx-cy):xs)`compare`Value ys

-- | The 'majorityValue' is the list of the 'majorityGrade's
-- of a choice, each one replicated their associated 'Count' times,
-- from the most consensual to the least,
-- ie. by removing the 'grade' of the previous 'majorityGrade'
-- to compute the next.
majorityValue :: Ord grade => Merit grade -> Value grade
majorityValue (Merit m) = Value (go m)
	where
	go gs = case snd (Map.foldlWithKey untilMajGrade (0,[]) gs) of
	         [] -> []
	         gw@(g,_):_ -> gw:go (Map.delete g gs)
		where
		tot = sum gs
		untilMajGrade (t,[]) g c | 2*tc >= tot = (tc,[(g,c)])
		                         | otherwise   = (tc,[])
		                         where tc = t+c
		untilMajGrade acc _g _c = acc

-- | The 'majorityGrade' is the lower middlemost
-- (also known as median by experts) of the 'grade's
-- given to a choice by the 'judge's.
-- 
-- It is the highest 'grade' approved by an absolute majority of the 'judge's:
-- more than 50% of the 'judge's 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 'judge's 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 => Merit grade -> grade
majorityGrade m = fst (head gs) where Value gs = majorityValue m

-- * Type 'Ranking'

type Ranking prop = [prop]

-- | The 'majorityRanking' ranks all the choices 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 choices have precisely the same 'majorityValue's.
majorityRanking :: Ord grade => Merits prop grade -> Ranking prop
majorityRanking = map fst . sortBy (compare `on` Down . snd) . majorityValueByChoice

majorityValueByChoice :: Ord grade => Merits prop grade -> [(prop, Value grade)]
majorityValueByChoice (Merits ms) = Map.toAscList (majorityValue <$> ms)