{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-} -- NOTE: for IsList
module Majority.Merit where

import Data.Eq (Eq(..))
import Data.Foldable (Foldable, foldr)
import Data.Function (($), (.))
import Data.Functor (Functor, (<$>), (<$))
import Data.Hashable (Hashable)
import Data.List as List
import Data.Map.Strict (Map)
import Data.Ord (Ord(..))
import Data.Ratio ((%), Rational, denominator)
import Data.Semigroup (Semigroup(..))
import Data.Set (Set)
import Data.Tuple (curry)
import GHC.Exts (IsList(..))
import Prelude (Bounded(..), Enum(..), Num(..), Integer, error, lcm)
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 (G, 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..]

-- ** Type 'G'
-- | Rank of a grade.
type G = Integer

rank :: Ranked a -> G
rank (Ranked (r, _x)) = r

unRank :: Ranked a -> a
unRank (Ranked (_r, 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),
-- it becomes possible that only a percentage of 'grade'
-- is 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 { unMerit :: 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, 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 =>
 Foldable opinions =>
 opinions (Distribution 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

meritFromList ::
 Ord grade =>
 Foldable opinions =>
 Functor opinions =>
 opinions grade ->
 Merit grade
meritFromList = merit . (singleGrade <$>)

-- | 'normalizeMerit m' multiply all 'Share's
-- by their least common denominator
-- to get integral 'Share's.
normalizeMerit :: Merit grade -> Merit grade
normalizeMerit (Merit ms) = Merit $ (lcm' *) <$> ms
	where lcm' = foldr lcm 1 (denominator <$> ms) % 1

-- ** Type 'MeritByChoice'
-- | Profile of merit about some 'choice's.
newtype MeritByChoice choice grade
 =      MeritByChoice { unMeritByChoice :: 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