{-# LANGUAGE ScopedTypeVariables #-}
module Hjugement.Section where

import Control.Applicative (Applicative(..))
import Data.Bool
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Foldable (Foldable(..), any)
import Data.Function (($), (.))
import Data.Traversable (Traversable(..))
import Data.Functor ((<$>), (<$))
import Data.Maybe (Maybe(..), isNothing, maybe, fromMaybe)
import Data.Hashable (Hashable(..))
import Data.Map.Strict (Map)
import Data.Ord (Ord(..))
import Data.Ratio ((%))
import Data.Semigroup (Semigroup(..))
import Prelude (Num(..), Fractional(..), toRational, fromIntegral)
import Data.Tree
import Text.Show (Show(..))
import qualified Data.List as List
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import qualified Data.Map.Strict as Map

import Hjugement.MJ

-- * Type 'Section'
-- | Node of a 'Tree' holding a 'SectionOpinion' per 'judge'.
type Section judge grade = HM.HashMap judge (SectionOpinion grade)

-- ** Type 'SectionOpinion'
data SectionOpinion grade
 =   SectionOpinion
 {   sectionShare :: Maybe Share
     -- ^ A 'Share' within the parent 'Section'
     --   (defaulting to a 'Share' computed as the remaining 'Share' to reach 1
     --   divided by the number of defaulted 'Share's).
 ,   sectionGrade :: Maybe grade
     -- ^ A 'grade' attributed to the current 'Section'
     --   (defaulting to the 'grade' set on an ancestor 'Section' if any,
     --   or the |judge|'s default grade).
 } deriving (Eq, Show)

-- | Compute the 'Opinion's from the |Judges|' evaluation on all or some 'Section's.
opinionsBySection ::
 forall judge grade.
 Show judge =>
 Show grade =>
 Eq judge =>
 Hashable judge =>
 Ord grade =>
 Judges judge grade ->
 Tree (Section judge grade) ->
 Either (ErrorSection judge)
        (Tree (Opinions judge grade))
opinionsBySection js = go (singleGrade <$> js)
	where
	go defaultGradeByJudge (Node gradeByJudge opinionByJudgeBySection) =
		let maybeShareBySectionByJudge :: HM.HashMap judge [Maybe Share] =
			foldr (\section -> HM.unionWith (<>) $ pure . sectionShare <$> rootLabel section)
			 HM.empty opinionByJudgeBySection in
		let shareBySectionByJudge :: HM.HashMap judge [Share] =
			(<$> maybeShareBySectionByJudge) $ \maybeShareBySection ->
				let usedShare    = sum $ fromMaybe 0 <$> maybeShareBySection in
				let unusedShares = toRational $ List.length $ List.filter isNothing maybeShareBySection in
				let evenShare    = (1 - usedShare) / unusedShares in
				fromMaybe evenShare <$> maybeShareBySection
		in
		case opinionByJudgeBySection of
		 [] | unknownJudges <- gradeByJudge`HM.difference`defaultGradeByJudge
		    , not $ null unknownJudges ->
			Left $ ErrorSection_unknown_judges $ HS.fromMap $ (() <$) $ unknownJudges
		    | otherwise ->
			-- NOTE: no Section, current Opinions is derived from current Node and default grades.
			let opin :: HM.HashMap judge (Map grade Share) =
				HM.mapWithKey (\judge -> maybe (defaultGradeByJudge HM.! judge) singleGrade . sectionGrade) gradeByJudge in
			Right $ Node (HM.union opin defaultGradeByJudge) []
		 _ | ko <- HM.filter (\ss -> any (< 0) ss || sum ss /= 1) shareBySectionByJudge
			 , not (null ko) ->
			Left $ ErrorSection_invalid_shares ko
		 _ -> do
			-- NOTE: current Opinions is computed from its sub-'Section's.
			let defaultGradeByJudge' :: HM.HashMap judge (Map grade Share) =
				-- NOTE: grades set at current node become the new default grades within its 'Section's.
				HM.union
				 (HM.mapWithKey (\judge ->
					maybe (defaultGradeByJudge HM.! judge) singleGrade . sectionGrade) gradeByJudge)
				 defaultGradeByJudge
			opins <- traverse (go defaultGradeByJudge') opinionByJudgeBySection
			let distByJudgeBySection :: [HM.HashMap judge (Map grade Share)] = rootLabel <$> opins
			let distBySectionByJudge :: HM.HashMap judge [Map grade Share] =
				foldr (\distByJudge -> HM.unionWith (<>) (pure <$> distByJudge))
				 HM.empty distByJudgeBySection
			let numSections   = List.length opinionByJudgeBySection
			let defaultShares = List.replicate numSections $ 1 % fromIntegral numSections
			let opin :: HM.HashMap judge (Map grade Share) =
				HM.intersectionWith -- NOTE: just used to zip actually
				 (\shareBySection distBySection ->
					Map.unionsWith (+) $ -- NOTE: merge dists
					List.zipWith (\share dist -> (share *) <$> dist) -- NOTE: shrink dists
					 shareBySection distBySection)
				 (shareBySectionByJudge`HM.union`(defaultShares <$ defaultGradeByJudge))
				 distBySectionByJudge
			Right $ Node opin opins

-- * Type 'ErrorSection'
data ErrorSection judge
 =   ErrorSection_invalid_shares (HM.HashMap judge [Share])
     -- ^ When at least one of the 'Share's is not positive, or when their sum is not 1.
 |   ErrorSection_unknown_judges (HS.HashSet judge)
     -- ^ When at least one 'Section'
 deriving (Eq,Show)