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

import Data.Bool
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.Ratio (Rational)
import Data.Ord (Ord(..), Ordering(..), Down(..))
import Data.Semigroup (Semigroup(..))
import Data.Set (Set)
import Data.Tuple (fst, snd, curry)
import Prelude (Bounded(..), Enum(..), Num(..), Integer, error)
import GHC.Exts (IsList(..))
import Text.Show (Show(..))
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 'choice's,
-- i.e. if judges change their grades when 'choice's 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 'choice's does not change
-- the inputs or messages of other 'choice's.
type Grades = Set

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

-- * Type 'Ranked'
-- | Helper type to rank data without a good 'Ord' instance.
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 = HM.HashMap

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

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

-- | '(ok, ko) = opinions 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'.
opinions ::
 Eq judge =>
 Hashable judge =>
 Judges judge grade ->
 Opinions judge grade ->
 ( Opinions judge grade
 , HS.HashSet judge )
opinions js os =
	( HM.union os $ singleGrade <$> js
	, HS.fromMap $ (() <$) $ os`HM.difference`js )

-- ** Type 'Distribution'
-- | Usually, a 'judge' gives a 'singleGrade' to a given 'choice'.
-- However, when applying the Majority Judgment to a 'Tree' of 'Section's,
-- what a 'judge' gives to a parent 'Section'
-- is composed by the 'grade's he or she has given
-- to the sub-'Section's, and those can be different.
-- In that case, each 'grade' given to a sub-'Section' contributes to a 'Share'
-- of the parent 'Section' which therefore is not necessarily a 'singleGrade',
-- but more generally a 'Distribution' of 'grade's.
-- And the sub-'Section's can actually themselves have sub-'Section's,
-- hence not being given a 'grade', but a 'Distribution' of 'grade's too.
type Distribution grade = Map grade Share

singleGrade :: grade -> Distribution grade
singleGrade = (`Map.singleton` 1)

-- *** Type 'Share'
-- | Usually a 'judge' attributes a 'singleGrade' to a given 'choice',
-- and then the 'Share' of this 'grade' is 1.
-- However, when introducing vote colleges (giving more power to some 'judge's),
-- or when introducing 'Section's (decomposing a judgment into several sub-judgments),
-- only a percent of 'grade' can be attributed by a 'judge' to a given 'choice'.
-- This is what a 'Share' is used for.
type Share = Rational
 -- FIXME: newtype checking >= 0

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

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

-- * Type 'Merit'
-- | Profile of merit about a single 'choice'.
newtype Merit grade = Merit (Map grade Share)
 deriving (Eq, Show)
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, Share)
	fromList = Merit . Map.fromListWithKey
		 (\g _x _y -> error $ "duplicate grade in merit: " <> show g)
	toList (Merit cs) = toList cs

-- | @merit os@ returns the 'Merit' given by opinions 'os'
merit ::
 Ord grade =>
 Opinions judge grade ->
 Merit grade
merit = foldr insertOpinion $ Merit $ Map.empty
	-- TODO: maybe count by making g passes
	where
	insertOpinion dist (Merit m) =
		Merit $
		Map.foldlWithKey
		 (\acc g s -> Map.insertWith (+) g s acc)
		 m dist

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

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

-- * Type 'MajorityValue'
-- | A 'MajorityValue' is a compressed list of 'grade's,
-- where each 'grade' is associated with the 'Share'
-- by which it would be replicated in situ if decompressed.
newtype MajorityValue grade = MajorityValue [(grade,Share)]
 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
	mx@(MajorityValue ((x,sx):xs)) `compare` my@(MajorityValue ((y,sy):ys)) =
		case sx`compare`sy of
		 _ | sx == 0 && sy == 0 -> MajorityValue xs`compare`MajorityValue ys
		 _ | sx <= 0 -> MajorityValue xs`compare`my
		 _ | sy <= 0 -> mx`compare`MajorityValue ys
		 EQ -> x`compare`y <> MajorityValue xs`compare`MajorityValue ys
		 LT -> x`compare`y <> MajorityValue xs`compare`MajorityValue((y,sy-sx):ys)
		 GT -> x`compare`y <> MajorityValue((x,sx-sy):xs)`compare`MajorityValue ys

-- | The 'majorityValue' is the list of the 'majorityGrade's
-- of a 'choice', each one replicated their associated 'Share' 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 :: Ord grade => Map grade Share -> [(grade, Share)]
	go gs = case snd (Map.foldlWithKey untilMajGrade (0,[]) gs) of
	         [] -> []
	         gw@(majGrade,_):_ -> gw:go (Map.delete majGrade gs)
		where
		tot = sum gs
		untilMajGrade (t,[]) g s | 2*tc >= tot = (tc,[(g,s)])
		                         | otherwise   = (tc,[])
		                         where tc = t+s
		untilMajGrade acc _g _s = 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 => 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