{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TupleSections #-}
module Hjugement.MJ where

import Data.Eq (Eq(..))
import Data.Function (on)
import Data.Functor (Functor)
import Data.Hashable (Hashable)
import Data.List as List
import Data.Map.Strict (Map)
import Data.Ord (Ord(..), Down(..))
import Data.Semigroup (Semigroup(..))
import Data.Set (Set)
import Data.Tuple (fst)
import GHC.Exts (IsList(..))
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set

-- * Type 'Choices'
type Choices = HS.HashSet

-- | Return a set of 'Choices' by enumerating the alternatives of its type. Useful on sum types.
choices :: (Bounded choice , Enum choice , Eq choice, Hashable choice) => Choices choice
choices = HS.fromList $ enumFrom minBound

-- * Type 'Grades'
-- | 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 'Judges' 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 of grades must be fixed and absolute
-- so that more or fewer choices does not change
-- the inputs or messages of other choices.
type Grades = Set

grades :: [grade] -> Grades (Ranked grade)
grades = Set.fromList . zipRank

-- * Type 'Ranked'
newtype Ranked a = Ranked (Integer, a)
 deriving (Show,Functor)
instance Eq (Ranked a) where
	Ranked (x,_) == Ranked (y,_) = x==y
instance Ord (Ranked a) where
	Ranked (x,_) `compare` Ranked (y,_) = x`compare`y

-- | 'zipRank xs' returns a list with the items of 'xs' wrapped
-- so that they are 'compare'able according to their position into 'xs'.
zipRank :: [a] -> [Ranked a]
zipRank = List.zipWith (curry Ranked) [0..]

rankKey :: [(k, a)] -> [(Ranked k, a)]
rankKey = List.zipWith (\i (k,a) -> (Ranked (i,k),a)) [0..]

unRank :: Ranked a -> a
unRank (Ranked (_i, x)) = x

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

-- * Type 'Judges'
-- | Map each 'judge' to its default 'grade'
-- (usually the same for all 'judge's but not necessarily).
--
-- For instance, when a 'judge' gives no 'grade' or has “no opinion”,
-- this default grade 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.
type Judges judge grade = HM.HashMap judge grade

judges ::
 Eq judge =>
 Hashable judge =>
 [judge] -> grade -> Judges judge grade
judges js dg = HM.fromList $ ((,dg) <$>) js

-- * Type 'Opinion'
-- | Profile of opinions of some 'judge's about a single 'choice'.
type Opinion = HM.HashMap

-- | '(ok, ko) = opinion js os' returns:
--
-- * in 'ok' the opinions of the 'judge's 'js' updated by those in 'os',
-- * in 'ko' the opinions of 'judge's not in 'js'.
opinion ::
 Eq judge =>
 Hashable judge =>
 Judges judge grade ->
 Opinion judge grade ->
 ( Opinion judge grade
 , Opinion judge grade )
opinion js os = (os`HM.union`js, os`HM.difference`js)

-- ** Type 'Opinions'
-- | Profile of opinions of some 'Judges' about some 'choice's.
type Opinions choice judge grade = HM.HashMap choice (Opinion judge grade)

opinions ::
 Eq choice =>
 Hashable choice =>
 [(choice, Opinion judge grade)] ->
 Opinions choice judge grade
opinions = HM.fromList

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

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 gs os@ returns the 'Merit' given by opinions 'os'
merit ::
 Ord grade =>
 Grades grade ->
 Opinion judge grade ->
 Merit grade
merit gs = foldr insertOpinion defaultMerit
	where
	insertOpinion g (Merit m) = Merit $ Map.insertWith (+) g 1 m
	defaultMerit              = Merit $ const 0 `Map.fromSet` gs

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

-- | @merits gs cs os@ returns the 'Merits'
-- given to 'choice's 'cs' by opinions 'os' from the 'Judges' 'js' on the 'Grades' 'gs'.
merits ::
 (Ord grade, Eq choice, Hashable choice) =>
 Grades grade ->
 Opinions choice judge grade ->
 Merits choice grade
merits gs os = Merits $ merit gs <$> os

-- * Type 'MajorityValue'
-- | A 'MajorityValue' 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 MajorityValue grade = MajorityValue [(grade,Count)]
 deriving (Eq, Show)
-- | 'compare' lexicographically as if the 'MajorityValue's
-- were decompressed.
instance Ord grade => Ord (MajorityValue grade) where
	MajorityValue []`compare`MajorityValue [] = EQ
	MajorityValue []`compare`MajorityValue ys | all ((==0) . snd) ys = EQ
	                                          | otherwise            = LT
	MajorityValue xs`compare`MajorityValue [] | all ((==0) . snd) xs = EQ
	                                          | otherwise            = GT
	sx@(MajorityValue ((x,cx):xs)) `compare` sy@(MajorityValue ((y,cy):ys)) =
		case cx`compare`cy of
		 _ | cx == 0 && cy == 0 -> MajorityValue xs`compare`MajorityValue ys
		 _ | cx <= 0 -> MajorityValue xs`compare`sy
		 _ | cy <= 0 -> sx`compare`MajorityValue ys
		 EQ -> x`compare`y <> MajorityValue xs`compare`MajorityValue ys
		 LT -> x`compare`y <> MajorityValue xs`compare`MajorityValue((y,cy-cx):ys)
		 GT -> x`compare`y <> MajorityValue((x,cx-cy):xs)`compare`MajorityValue 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 -> MajorityValue grade
majorityValue (Merit m) = MajorityValue (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 '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 => Merit grade -> grade
majorityGrade m = fst (List.head gs) where MajorityValue gs = majorityValue m

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

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

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