-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}

module Handler.Utils.Exam
  ( fetchExamAux
  , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam
  , examRelevantSheets, examBonusPossible, examBonusAchieved
  , examResultBonus, examGrade
  , examBonusGrade
  , ExamAutoOccurrenceConfig
  , eaocIgnoreRooms, eaocFinenessCost, eaocNudge, eaocNudgeSize
  , _eaocIgnoreRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize
  , ExamAutoOccurrenceIgnoreRooms(..), _eaoirIgnored, _eaoirSorted
  , ExamAutoOccurrenceException(..)
  , examAutoOccurrence
  , deregisterExamUsersCount, deregisterExamUsers
  , examAidsPresetWidget, examOnlinePresetWidget, examSynchronicityPresetWidget, examRequiredEquipmentPresetWidget
  , evalExamModeDNF
  , showExamOccurrenceRoom
  ) where

import Import

import Data.Ratio ((%))
import Database.Persist.Sql (SqlBackendCanRead)
import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.Utils as E
import qualified Database.Esqueleto.Internal.Internal as E
import Database.Esqueleto.Utils.TH

import qualified Data.Conduit.List as C

import qualified Data.Map as Map
import qualified Data.Map.Merge.Lazy as Map
import qualified Data.Set as Set

import qualified Data.Foldable as F

import qualified Data.CaseInsensitive as CI

import System.Random (mkStdGen)
import System.Random.Shuffle (shuffle')
import Control.Monad.ST (ST, runST)

import Data.Array (Array)
import qualified Data.Array as Array

import Data.Array.ST (STArray, STUArray)
import qualified Data.Array.ST as ST

import Data.Foldable (foldMap')
import Data.List (findIndex, unfoldr)
import qualified Data.List as List

import Data.Either.Combinators (maybeToRight)

import Data.ExtendedReal

import qualified Data.RFC5051 as RFC5051

import Handler.Utils.I18n
import Handler.Utils.Sheet


fetchExamAux :: ( SqlBackendCanRead backend
                , E.SqlSelect b a
                , MonadHandler m
                , Typeable a
                )
             => (E.SqlExpr (Entity Exam) -> E.SqlExpr (Entity Course) -> b)
             -> TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT backend m a
fetchExamAux prj tid ssh csh examn =
    let cachId = encodeUtf8 $ tshow (tid, ssh, csh, examn)
    in  cachedBy cachId $ do
        tutList <- E.select . E.from $ \(course `E.InnerJoin` tut) -> do
            E.on     $ course E.^. CourseId E.==. tut E.^. ExamCourse
            E.where_ $ course E.^. CourseTerm      E.==. E.val tid
                E.&&.  course E.^. CourseSchool    E.==. E.val ssh
                E.&&.  course E.^. CourseShorthand E.==. E.val csh
                E.&&.  tut    E.^. ExamName    E.==. E.val examn
            return $ prj tut course
        case tutList of
          [tut] -> return tut
          _other  -> notFound

fetchExam :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Entity Exam)
fetchExam = fetchExamAux const

fetchExamId :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Exam)
fetchExamId tid ssh cid examn = E.unValue <$> fetchExamAux (\tutorial _ -> tutorial E.^. ExamId) tid ssh cid examn

fetchCourseIdExamId  :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Course, Key Exam)
fetchCourseIdExamId tid ssh cid examn = $(unValueN 2) <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial E.^. ExamId)) tid ssh cid examn

fetchCourseIdExam  :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Course, Entity Exam)
fetchCourseIdExam tid ssh cid examn = over _1 E.unValue <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial)) tid ssh cid examn


examRelevantSheets :: (MonadHandler m, MonadThrow m)
                   => Entity Exam
                   -> Bool -- ^ relevant for bonus (restricted to sheet having `sheetActiveTo` before `examOccurrenceStart`)?
                   -> ReaderT SqlBackend m (Map UserId (SheetTypeSummary ExamPartId))
examRelevantSheets (Entity eId Exam{..}) forBonus = runConduit $
  let
    rawData = E.selectSource . E.from $ \(((examRegistration `E.LeftOuterJoin` examOccurrence) `E.InnerJoin` sheet) `E.LeftOuterJoin` submission) -> E.distinctOnOrderBy [ E.asc $ examRegistration E.^. ExamRegistrationUser, E.asc $ sheet E.^. SheetId ] $ do
      E.on $ submission E.?. SubmissionSheet E.==. E.just (sheet E.^. SheetId)
       E.&&. E.exists (E.from $ \submissionUser -> E.where_ $ submissionUser E.^. SubmissionUserUser E.==. examRegistration E.^. ExamRegistrationUser
                                                        E.&&. E.just (submissionUser E.^. SubmissionUserSubmission) E.==. submission E.?. SubmissionId
                      )
      E.on E.true
      E.on $ examRegistration E.^. ExamRegistrationOccurrence E.==. examOccurrence E.?. ExamOccurrenceId
      E.where_ $ sheet E.^. SheetCourse E.==. E.val examCourse
           E.&&. examRegistration E.^. ExamRegistrationExam E.==. E.val eId
      when forBonus $
        E.where_ $ E.case_
          [ E.when_
              ( E.isJust $ examRegistration E.^. ExamRegistrationOccurrence )
            E.then_
              (       E.maybe E.true ((E.<=. examOccurrence E.?. ExamOccurrenceStart) . E.just) (sheet E.^. SheetActiveTo)
                E.&&. sheet E.^. SheetVisibleFrom E.<=. examOccurrence E.?. ExamOccurrenceStart
              )
          ]
          ( E.else_ . E.not_ . E.isNothing $ sheet E.^. SheetVisibleFrom
          )
      return (examRegistration E.^. ExamRegistrationUser, sheet E.^. SheetType, submission, sheet E.^. SheetCourse)
    accum = C.foldM ?? Map.empty $ \acc (E.Value uid, E.Value sheetType, fmap entityVal -> sub, E.Value cId) -> do
      sheetType' <- fmap entityKey <$> resolveSheetType cId sheetType
      return . flip (Map.insertWith mappend uid) acc . sheetTypeSum sheetType' $ assertM submissionRatingDone sub >>= submissionRatingPoints
   in rawData .| accum

examBonusPossible, examBonusAchieved :: Ord epId => UserId -> Map UserId (SheetTypeSummary epId) -> SheetGradeSummary
examBonusPossible uid bonusMap = normalSummary $ Map.findWithDefault mempty uid bonusMap
examBonusAchieved uid bonusMap = mappend <$> normalSummary <*> bonusSummary $ Map.findWithDefault mempty uid bonusMap




examResultBonus :: ExamBonusRule
                -> SheetGradeSummary -- ^ `examBonusPossible`
                -> SheetGradeSummary -- ^ `examBonusAchieved`
                -> Maybe Points
examResultBonus bonusRule bonusPossible bonusAchieved = case bonusRule of
  ExamBonusManual{}
    -> Nothing
  ExamBonusPoints{..}
    -> Just . roundToPoints' bonusRound $ toRational bonusMaxPoints * bonusProp bonusMaxPoints
  where
    bonusProp :: Points -> Rational
    bonusProp mPoints
      | possible <= 0 = 1
      | otherwise = achieved / possible
      where
        achieved = toRational (getSum $ achievedPoints  bonusAchieved - achievedPassPoints  bonusAchieved) + scalePasses (getSum $ achievedPasses  bonusAchieved)
        possible = toRational (getSum $ sumSheetsPoints bonusPossible - sumSheetsPassPoints bonusPossible) + scalePasses (getSum $ numSheetsPasses bonusPossible)

        scalePasses :: Integer -> Rational
        -- ^ Rescale passes so count of all sheets with pass is worth as many points as sum of all sheets with points
        scalePasses passes
          | pointsPossible <= 0, passesPossible <= 0 = 1 -- This arbitrarily identifies a pass as being worth one point if all sheets are `Bonus`; maybe weird
          | pointsPossible <= 0 = toRational mPoints / fromInteger passesPossible
          | passesPossible <= 0 = 0
          | otherwise = fromInteger passes / fromInteger passesPossible * toRational pointsPossible
          where
            passesPossible = getSum $ numSheetsPasses bonusPossible
            pointsPossible = getSum $ sumSheetsPoints bonusPossible - sumSheetsPassPoints bonusPossible

    roundToPoints' mult = (* mult) . (realToFrac :: Uni -> Points) . roundToPoints . (/ toRational mult)

examGrade :: ( MonoFoldable mono
             , Element mono ~ ExamResultPoints
             )
          => Exam
          -> Maybe Points -- ^ Bonus
          -> mono -- ^ `ExamPartResult`s
          -> Maybe ExamResultGrade
examGrade Exam{..} mBonus (otoList -> results)
  = traverse pointsToGrade achievedPoints'
  where
    achievedPoints' :: ExamResultPoints
    achievedPoints' = withBonus . getSum <$> foldMap (fmap Sum) results

    withBonus :: Points -> Points
    withBonus ps
      | Just bonusRule <- examBonusRule
      = if
          |    maybe True not (bonusRule ^? _bonusOnlyPassed)
            || fmap (view passingGrade) (pointsToGrade ps) == Just (_Wrapped # True)
            -> maybe id (+) mBonus ps
          | otherwise
            -> ps
      | otherwise
      = ps

    pointsToGrade :: Points -> Maybe ExamGrade
    pointsToGrade ps = examGradingRule <&> \case
      ExamGradingKey{..}
        -> gradeFromKey examGradingKey
      where
        gradeFromKey :: [Points] -> ExamGrade
        gradeFromKey examGradingKey' = maximum $ Grade50 `ncons` [ g | (g, b) <- lowerBounds, b <= ps ]
          where
            lowerBounds :: [(ExamGrade, Points)]
            lowerBounds = zip [Grade40, Grade37 ..] examGradingKey'

examBonusGrade :: ( MonoFoldable sheets
                  , Element sheets ~ (SheetType epId, Maybe Points)
                  , MonoFoldable results
                  , Element results ~ ExamResultPoints
                  , Ord epId
                  )
               => Exam
               -> Either Points sheets -- ^ `Points` retrieved from relevant `ExamBonus`, iff it exists
               -> results
               -> (Maybe Points, Maybe ExamResultGrade)
examBonusGrade exam@Exam{..} bonusInp = (mBonus, ) . examGrade exam mBonus
  where mBonus = asum
          [ bonusInp ^? _Left
          , join $ examResultBonus <$> examBonusRule <*> bonusPossible <*> bonusAchieved
          ]
        sheetSummary = flip (previews _Right) bonusInp . ofoldMap $ uncurry sheetTypeSum
        bonusPossible = normalSummary <$> sheetSummary
        bonusAchieved = (<>) <$> fmap normalSummary sheetSummary <*> fmap bonusSummary sheetSummary

data ExamAutoOccurrenceIgnoreRooms
  = ExamAutoOccurrenceIgnoreRooms {eaoirIgnored :: Set ExamOccurrenceId, eaoirSorted :: Bool}
  deriving (Eq, Ord, Read, Show, Generic)

instance Default ExamAutoOccurrenceIgnoreRooms where
  def = ExamAutoOccurrenceIgnoreRooms Set.empty False

makeLenses_ ''ExamAutoOccurrenceIgnoreRooms

deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  } ''ExamAutoOccurrenceIgnoreRooms

data ExamAutoOccurrenceConfig = ExamAutoOccurrenceConfig
  { eaocIgnoreRooms   :: ExamAutoOccurrenceIgnoreRooms
  , eaocFinenessCost  :: Rational -- ^ Cost factor incentivising shorter common prefixes on breaks between rooms
  , eaocNudge         :: Map ExamOccurrenceId Integer
  , eaocNudgeSize     :: Rational
  } deriving (Eq, Ord, Read, Show, Generic)

instance Default ExamAutoOccurrenceConfig where
  def = ExamAutoOccurrenceConfig
    { eaocIgnoreRooms   = def
    , eaocFinenessCost  = 0.2
    , eaocNudge         = Map.empty
    , eaocNudgeSize     = 0.05
    }

makeLenses_ ''ExamAutoOccurrenceConfig

deriveJSON defaultOptions
  { fieldLabelModifier = camelToPathPiece' 1
  } ''ExamAutoOccurrenceConfig

data ExamAutoOccurrenceException
  = ExamAutoOccurrenceExceptionRuleNoOp
  | ExamAutoOccurrenceExceptionNotEnoughSpace
  | ExamAutoOccurrenceExceptionNoUsers
  | ExamAutoOccurrenceExceptionRoomTooSmall
  deriving (Show, Eq, Generic)

instance Exception ExamAutoOccurrenceException

embedRenderMessage ''UniWorX ''ExamAutoOccurrenceException id

examAutoOccurrence :: forall seed.
                      Hashable seed
                   => seed
                   -> ExamOccurrenceRule
                   -> ExamAutoOccurrenceConfig
                   -> Map ExamOccurrenceId ExamOccurrenceCapacity
                   -> Map UserId (User, Maybe ExamOccurrenceId)
                   -> Either ExamAutoOccurrenceException
                      (ExamOccurrenceMapping ExamOccurrenceId, Map UserId (Maybe ExamOccurrenceId))
examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users
  | Map.null users'
  = Left ExamAutoOccurrenceExceptionNoUsers
  | occurrencesSize < Restricted usersCount -- this guarantees occurrencesSize > 0 as well
  = Left ExamAutoOccurrenceExceptionNotEnoughSpace
  | otherwise
  = case rule of
      ExamRoomRandom
        -> Right ( ExamOccurrenceMapping {
              examOccurrenceMappingRule = rule,
              examOccurrenceMappingMapping = Map.fromList $ set _2 (Set.singleton ExamOccurrenceMappingRandom) <$> occurrences''
            }
           , Map.union (view _2 <$> assignedUsers) randomlyAssignedUsers
           )
           where
             assignedUsers,unassignedUsers :: Map UserId (User, Maybe ExamOccurrenceId)
             (assignedUsers, unassignedUsers) = Map.partition (has $ _2 . _Just) users
             shuffledUsers :: [UserId]
             shuffledUsers = shuffle' (Map.keys unassignedUsers) (length unassignedUsers) (mkStdGen seed)
             restrictedOccurrences :: Map ExamOccurrenceId Natural
             unrestrictedOccurrences :: Set ExamOccurrenceId
             (unrestrictedOccurrences, restrictedOccurrences)
                = bimap Set.fromList Map.fromList $ partitionRestricted ([], []) occurrences''
             -- reduce available space until to excess space is left while keeping the filling ratio as equal as possible
             decreaseBiggestOutlier :: Natural -> Map ExamOccurrenceId Natural -> Map ExamOccurrenceId Natural
             decreaseBiggestOutlier 0 currentOccurrences = currentOccurrences
             decreaseBiggestOutlier n currentOccurrences
                = decreaseBiggestOutlier (pred n) $ Map.update predToPositive biggestOutlier currentOccurrences
              where
                currentRatios :: Map ExamOccurrenceId Rational
                currentRatios = Map.merge Map.dropMissing Map.dropMissing (Map.zipWithMatched calculateRatio)
                                    currentOccurrences restrictedOccurrences
                calculateRatio :: ExamOccurrenceId -> Natural -> Natural -> Rational
                calculateRatio k c m = fromIntegral c / max 1 (fromIntegral m * sizeModifier)
                  where
                    sizeModifier :: Rational
                    sizeModifier = 1 + eaocNudgeSize * fromIntegral (lineNudges k)
                biggestOutlier :: ExamOccurrenceId
                biggestOutlier = fst . List.maximumBy (comparing $ view _2) $ Map.toList currentRatios
             predToPositive :: Natural -> Maybe Natural
             predToPositive 0 = Nothing
             predToPositive 1 = Nothing
             predToPositive x = Just $ pred x
             extraCapacity :: Natural
             extraUsers :: Natural
             (extraCapacity, extraUsers)
              | restrictedSpace > numUnassignedUsers
              = (restrictedSpace - numUnassignedUsers, 0)
              | otherwise
              = (0, numUnassignedUsers - restrictedSpace)
              where
                restrictedSpace :: Natural
                restrictedSpace = sum restrictedOccurrences
                numUnassignedUsers :: Natural
                numUnassignedUsers = fromIntegral $ length unassignedUsers
             finalOccurrences :: [(ExamOccurrenceId, Natural)]
             finalOccurrences = Map.toList $ decreaseBiggestOutlier extraCapacity restrictedOccurrences
             unrestrictedPositiveNudges :: Map ExamOccurrenceId Natural
             unrestrictedNegativeNudges :: Map ExamOccurrenceId Natural
             (unrestrictedPositiveNudges, unrestrictedNegativeNudges)
                = bimap (Map.map fromIntegral) (Map.map $ fromIntegral . negate) $ Map.partition (> 0)
                    $ Map.filter (/= 0) $ Map.restrictKeys eaocNudge unrestrictedOccurrences
             -- extra entries caused by nudges
             nudgedUnrestrictedOccurrences :: [ExamOccurrenceId]
             nudgedUnrestrictedOccurrences = nudgedPositiveOccurrences unrestrictedPositiveNudges []
                                            ++ nudgedNegativeOccurrences unrestrictedNegativeNudges []
              where
                replicateMany :: Int -> [a] -> [a]
                replicateMany n as = take (n * length as) $ List.cycle as
                nudgeEffect :: Int
                nudgeEffect = max 1 $ ceiling $ eaocNudgeSize * fromIntegral extraUsers
                -- for a positive nudge, add one entry to the front of the list
                nudgedPositiveOccurrences :: Map ExamOccurrenceId Natural -> [ExamOccurrenceId] -> [ExamOccurrenceId]
                nudgedPositiveOccurrences nudges acc
                  | null nudges = acc
                  | otherwise = nudgedPositiveOccurrences (Map.mapMaybe predToPositive nudges)
                                  $ nudgeOccurrences' ++ acc
                  where
                    nudgeOccurrences :: [ExamOccurrenceId]
                    nudgeOccurrences = Set.toList (Set.intersection unrestrictedOccurrences $ Map.keysSet nudges)
                    nudgeOccurrences' :: [ExamOccurrenceId]
                    nudgeOccurrences' = replicateMany nudgeEffect nudgeOccurrences
                -- for a negative nudge, add one entry for every other unrestricted occurrence to the front of the list
                nudgedNegativeOccurrences :: Map ExamOccurrenceId Natural ->[ExamOccurrenceId] -> [ExamOccurrenceId]
                nudgedNegativeOccurrences nudges acc
                  | null nudges = acc
                  | otherwise = nudgedNegativeOccurrences (Map.mapMaybe predToPositive nudges)
                                  $ nudgeOccurrences' ++ acc
                  where
                    nudgeOccurrences :: [ExamOccurrenceId]
                    nudgeOccurrences = Set.toList (Set.difference unrestrictedOccurrences $ Map.keysSet nudges)
                    nudgeOccurrences' :: [ExamOccurrenceId]
                    nudgeOccurrences' = replicateMany nudgeEffect nudgeOccurrences
             -- fill in users in a random order
             randomlyAssignedUsers :: Map UserId (Maybe ExamOccurrenceId)
             randomlyAssignedUsers = Map.fromList $ fillUnrestricted
                                      (nudgedUnrestrictedOccurrences ++ List.cycle (Set.toList unrestrictedOccurrences))
                                      $ foldl' addUsers ([], shuffledUsers) finalOccurrences
             addUsers :: ([(UserId, Maybe ExamOccurrenceId)], [UserId])
                      -> (ExamOccurrenceId, Natural)
                      -> ([(UserId, Maybe ExamOccurrenceId)], [UserId])
             addUsers (acc, userList) (roomId, roomSize) = (map (, Just roomId) newUsers ++ acc, remainingUsers) 
              where
                newUsers, remainingUsers :: [UserId]
                (newUsers, remainingUsers) = List.genericSplitAt roomSize userList
             -- if there are remaining users, we are guaranteed to have at least one unrestricted room (toplevel check)
             fillUnrestricted :: [ExamOccurrenceId] -> ([(UserId, Maybe ExamOccurrenceId)], [UserId]) -> [(UserId, Maybe ExamOccurrenceId)]
             fillUnrestricted _unrestrictedRooms (acc, []) = acc
             fillUnrestricted [] _ = error "fillUnrestricted should only be called with an infinite list"
             fillUnrestricted (nextRoom:followingRooms) (acc, nextUser:remainingUsers)
              = fillUnrestricted followingRooms ((nextUser, Just nextRoom) : acc, remainingUsers)
      _ -> over _1 (ExamOccurrenceMapping rule) . over _2 (Map.unionWith (<|>) (view _2 <$> users)) . postprocess <$> bestOption
  where
    usersCount :: forall a. Num a => a
    usersCount = getSum $ foldMap (Sum . fromIntegral . Set.size) users'

    users' :: Map [CI Char] (Set UserId)
    -- ^ Finest partition of users
    users' = case rule of
      ExamRoomSurname
        -> Map.fromListWith Set.union
           [ (map CI.mk $ unpack userSurname, Set.singleton uid)
           | (uid, (User{..}, Nothing)) <- Map.toList users
           , not $ null userSurname
           ]
      ExamRoomMatriculation
        -> let matrUsers
                 = Map.fromListWith Set.union
                   [ (map CI.mk $ unpack matriculation', Set.singleton uid)
                   | (uid, (User{..}, Nothing)) <- Map.toList users
                   , matriculation' <- userMatrikelnummer ^.. _Just . filtered (not . null)
                   ]
               takeEnd n chars = drop (length chars - n) chars
            in Map.mapKeysWith Set.union (takeEnd . F.minimum . Set.map length $ Map.keysSet matrUsers) matrUsers
      _ | null unassignedUsers -> Map.empty
        | otherwise -> Map.singleton [] $ Map.keysSet unassignedUsers
      where
        unassignedUsers = Map.filter (has $ _2 . _Nothing) users

    occurrencesSize :: ExamOccurrenceCapacity
    occurrencesSize = foldMap' (view _2) occurrences''

    occurrences' :: Map ExamOccurrenceId ExamOccurrenceCapacity
    -- ^ reduce room capacity for every pre-assigned user by 1
    -- also remove empty/pre-filled rooms
    occurrences' = foldl' (flip $ Map.update predToPositive) (Map.filter (> Restricted 0) occurrences)
                      $ Map.mapMaybe snd users
      where
        predToPositive :: ExamOccurrenceCapacity -> Maybe ExamOccurrenceCapacity
        predToPositive Unrestricted = Just Unrestricted
        predToPositive (Restricted 0) = Nothing
        predToPositive (Restricted 1) = Nothing
        predToPositive (Restricted n) = Just $ Restricted $ pred n

    occurrences'' :: [(ExamOccurrenceId, ExamOccurrenceCapacity)]
    -- ^ Only use non-ignored occurrences
    -- Sort by size if specified (here increasing, since it is reversed later)
    occurrences'' = case eaocIgnoreRooms of
      ExamAutoOccurrenceIgnoreRooms {..} -> (if eaoirSorted then sortOn (view _2) else id) $ Map.toList $ Map.withoutKeys occurrences' eaoirIgnored
    
    partitionRestricted :: ([a], [(a, Natural)]) -> [(a,ExamOccurrenceCapacity)] -> ([a], [(a, Natural)])
    partitionRestricted acc []                   = acc
    partitionRestricted acc ((a,Unrestricted):t) = partitionRestricted (over _1 (a:) acc) t
    partitionRestricted acc ((a,Restricted n):t) = partitionRestricted (over _2 ((a,n):) acc) t

    distribute :: forall wordId lineId cost.
                  _
               => [(wordId, Natural)] -- ^ Word sizes (in order)
               -> [(lineId, ExamOccurrenceCapacity)] -- ^ Line sizes (in order)
               -> (lineId -> Integer) -- ^ Nudge
               -> (wordId -> wordId -> Extended Rational) -- ^ Break cost
               -> Maybe (cost, [(lineId, [wordId])])
    -- ^ Distribute the given items (@wordId@s) with associated size in
    -- contiguous blocks into the given buckets (@lineId@s) such that they are
    -- filled as evenly as possible (proportionally)
    --
    -- Return a cost scaled to item-size squared
    --
    -- See <https://xxyxyz.org/line-breaking/> under \"Shortest Path\"
    distribute wordLengths lineLengths lineNudge breakCost
      | null wordLengths = Just (0, [ (l, []) | (l, _) <- lineLengths ])
      | null lineLengths = Nothing
      | otherwise        = let (cost, result) = distribute'
                            in case cost of
                                 Finite c -> Just (fromInteger $ round c, result)
                                 _other   -> Nothing
      where
        restrictedLines :: [(lineId, Natural)]
        unrestrictedLines :: [lineId]
        -- partitionRestricted reverses the order of occurrences
        (unrestrictedLines, restrictedLines) = partitionRestricted ([], []) lineLengths

        -- reorder so unrestricted lines are at the end and my be left empty
        lineLengths' :: [(lineId, ExamOccurrenceCapacity)]
        lineLengths' = (over _2 Restricted <$> restrictedLines) ++ ((, Unrestricted) <$> unrestrictedLines)

        restrictedLengths :: [Natural]
        restrictedLengths = view _2 <$> restrictedLines

        restrictedSpace :: Natural
        restrictedSpace = sum restrictedLengths
        
        longestLine :: Natural
        -- ^ For scaling costs
        -- longest restricted line (or 1 if all unrestricted)
        longestLine = maybe numUnassignedUsers maximum $ fromNullable restrictedLengths

        wordMap :: Map wordId Natural
        wordMap = Map.fromListWith (+) wordLengths

        wordIx :: Iso' wordId Int
        wordIx = iso (\wId -> let Just ix' = elemIndex wId $ Array.elems collapsedWords
                               in ix'
                     )
                     (collapsedWords Array.!)

        collapsedWords :: Array Int wordId
        collapsedWords = Array.array
                           (0, pred $ Map.size wordMap)
                           [ (ix', wId)
                           | wId <- Map.keys wordMap
                           , let Just ix' = findIndex ((== wId) . view _1) wordLengths
                           ]

        offsets :: Array Int Natural
        offsets = Array.listArray bounds $ unfoldr (uncurry accOffsets) (0, 0)
          where
            accOffsets :: Natural -> Int -> Maybe (Natural, (Natural, Int))
            accOffsets accSize ix'
              | ix' <= 0 = Just (0, (0, 1))
              | Array.inRange bounds ix' = let newSize = accSize + wordMap Map.! (wordIx # pred ix')
                                            in Just (newSize, (newSize, succ ix'))
              | otherwise = Nothing

            bounds = (0, Map.size wordMap)

        distribute' :: (Extended Rational, [(lineId, [wordId])])
        distribute' = runST $ do
          minima <- ST.newListArray (0, Map.size wordMap) $ 0 : repeat PosInf :: forall s. ST s (STArray s Int (Extended Rational))
          breaks <- ST.newArray (0, Map.size wordMap) 0 :: forall s. ST s (STUArray s Int Int)

          -- find current line
          let
            walkBack 0   = return 0
            walkBack i'' = fmap succ $ walkBack =<< ST.readArray breaks i''
          -- calculate line breaks
          forM_ (Array.range (0, Map.size wordMap)) $ \i -> do
            let go j
                  | j <= Map.size wordMap = do
                    lineIx <- walkBack i
                    -- identifier and potential width of current line
                    let (l, potWidth)
                          | lineIx >= 0
                          , lineIx < length lineLengths'
                          = over _1 Just $ lineLengths' List.!! lineIx
                          | otherwise
                          = (Nothing, Restricted 0)
                        -- cumulative width for words [i,j), no whitespace required
                        w = offsets Array.! j - offsets Array.! i
                    prevMin <- ST.readArray minima i
                    let cost = prevMin + widthCost l potWidth w + breakCost'
                        remainingWords = offsets Array.! Map.size wordMap - offsets Array.! i
                        remainingLineSpace = foldMap (view _2) $ drop lineIx lineLengths'
                        breakCost'
                          | Restricted remainingWords > remainingLineSpace
                          = PosInf 
                          | j < Map.size wordMap
                          , j > 0
                          = breakCost (wordIx # pred j) (wordIx # j)
                          | otherwise
                          = 0
                    -- traceM $ show ( i
                    --               , j
                    --               , potWidth
                    --               , w
                    --               , (fromRational :: Rational -> Centi) <$> prevMin
                    --               , (fromRational :: Rational -> Centi) <$> widthCost potWidth w
                    --               , (fromRational :: Rational -> Centi) <$> breakCost'
                    --               )
                    when (isFinite cost) $ do
                      minCost <- ST.readArray minima j
                      when (cost < minCost) $ do
                        ST.writeArray minima j cost
                        ST.writeArray breaks j i
                      go $ succ j
                  | otherwise = return ()
             in go $ succ i
            -- traceM . show . map (fmap (fromRational :: Rational -> Centi)) =<< ST.getElems minima
            -- traceM . show =<< ST.getElems breaks

          usedLines <- walkBack $ Map.size wordMap
          let accumResult lineIx j (accCost, accMap) = do
                i <- ST.readArray breaks j
                accCost' <- (+) accCost <$> ST.readArray minima j
                -- traceM $ show ((fromRational :: Rational -> Centi) <$> accCost', lineIx, (i, pred j))
                let accMap' = (lineIxs List.!! lineIx, map (review wordIx) [i .. pred j]) : accMap
                if i > 0
                  then accumResult (succ lineIx) i (accCost', accMap')
                  else return (accCost', accMap')
              lineIxs = reverse $ map (view _1) $ take usedLines lineLengths'
           in accumResult 0 (Map.size wordMap) (0, [])

        optimumRatio :: Rational
        optimumRatio = ((%) `on` fromIntegral . max 1 . sum) (map (view _2) wordLengths) restrictedLengths

        numUnassignedUsers :: Natural
        numUnassignedUsers = sum $ view _2 <$> wordLengths

        extraUsers :: Natural
        extraUsers
          | numUnassignedUsers > restrictedSpace = numUnassignedUsers - restrictedSpace
          | otherwise = 0

        widthCost :: Maybe lineId -> ExamOccurrenceCapacity -> Natural -> Extended Rational
        widthCost l Unrestricted w
          = Finite $ max 1 $ (fromIntegral w - sizeModifier * (fromIntegral extraUsers % List.genericLength unrestrictedLines)) ^ 2
          where
            sizeModifier :: Rational
            sizeModifier = 1 + maybe 0 (fromIntegral . lineNudge) l * eaocNudgeSize
        widthCost l (Restricted lineWidth) w
          | lineWidth < w = PosInf
          | otherwise = Finite $ max 1 $ ((fromIntegral w / nudgedWidth - optimumRatio) * fromIntegral longestLine) ^ 2
          where
            nudgedWidth :: Rational
            nudgedWidth = max 1 $ sizeModifier * fromIntegral lineWidth
            sizeModifier :: Rational
            sizeModifier = 1 + maybe 0 (fromIntegral . lineNudge) l * eaocNudgeSize

    charCost :: [CI Char] -> [CI Char] -> Extended Rational
    charCost pA pB = Finite (max 1 $ List.genericLength (pA `lcp` pB) * eaocFinenessCost * fromIntegral longestLine) ^ 2
      where
        longestLine :: Natural
        longestLine = maybe (sum $ fromIntegral . length <$> users') maximum $ fromNullable $ catMaybes
                        $ view (_2 . _examOccurrenceCapacityIso) <$> occurrences''


    lcp :: Eq a => [a] -> [a] -> [a]
    -- ^ Longest common prefix
    lcp [] _ = []
    lcp _ [] = []
    lcp (a:as) (b:bs)
      | a == b    = a:lcp as bs
      | otherwise = []

    lineNudges = fromMaybe 0 . flip Map.lookup eaocNudge

    bestOption :: Either ExamAutoOccurrenceException [(ExamOccurrenceId, [[CI Char]])]
    bestOption = case rule of
      ExamRoomSurname -> maybeToRight ExamAutoOccurrenceExceptionRoomTooSmall $ do
        (_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` (pack . toListOf (_1 . folded . to CI.foldedCase))) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences'' lineNudges charCost
        -- traceM $ show cost
        return res
      ExamRoomMatriculation -> maybeToRight ExamAutoOccurrenceExceptionRoomTooSmall $ do
        let usersFineness n = Map.toAscList $ fromIntegral . Set.size <$> Map.mapKeysWith Set.union (reverse . take (fromIntegral n) . reverse) users'
            -- finenessCost n = Finite (max 1 $ fromIntegral n * eaocFinenessCost * fromIntegral longestLine) ^ 2 * length occurrences'

            distributeFine :: Natural -> Maybe (Extended Rational, _)
            distributeFine n = distribute (usersFineness n) occurrences'' lineNudges charCost

            maximumFineness = fromIntegral . F.minimum . Set.map length $ Map.keysSet users'

            resultFineness :: [(ExamOccurrenceId, [[CI Char]])] -> Natural
            resultFineness (map (view _2) -> res)
              | Just res' <- fromNullable res
              = maybe 0 maximum . fromNullable $ zipWith transFineness res (tail res')
              | otherwise = 0
              where
                transFineness :: [[CI Char]] -> [[CI Char]] -> Natural
                transFineness nsA nsB
                  | Just maxA <- nsA ^? _last
                  , Just minB <- nsB ^? _head
                  = succ . List.genericLength $ maxA `lcp` minB
                  | otherwise
                  = 0

            genResults f
              | f > maximumFineness = []
              | otherwise =
                let mRes = distributeFine f
                 in (mRes ^.. _Just) ++ bool [] (genResults $ succ f) (maybe True (>= f) $ mRes ^? _Just . _2 . to resultFineness)

        (_cost, res) <- fmap (minimumBy . comparing $ view _1) . fromNullable $ genResults 1
        return res
      _other -> Left ExamAutoOccurrenceExceptionRuleNoOp

    postprocess :: [(ExamOccurrenceId, [[CI Char]])]
                -> ( Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription)
                   , Map UserId (Maybe ExamOccurrenceId)
                   )
    postprocess result = (resultAscList, resultUsers)
      where
        maxTagLength :: Int
        maxTagLength = maybe 0 maximum $ fromNullable $ concatMap (map length . snd) result

        rangeAlphabet :: [CI Char]
        rangeAlphabet = case rule of
          ExamRoomSurname -> map CI.mk ['A'..'Z']
          ExamRoomMatriculation-> map CI.mk ['0'..'9']
          _rule -> []

        resultAscList :: Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription)
        resultAscList = case fromNullable rangeAlphabet of
            Nothing -> Map.empty
            (Just alphabet) -> Map.fromList $ go (singleton $ head alphabet) 1 [] result
              where
                go :: NonNull [CI Char]
                  -> Int
                  -> [(ExamOccurrenceId, Set ExamOccurrenceMappingDescription)]
                  -> [(ExamOccurrenceId, [[CI Char]])]
                  -> [(ExamOccurrenceId, Set ExamOccurrenceMappingDescription)]
                go _start _borderLength acc [] = acc
                -- special case necessary, so ranges always end on last alphabet
                go start _borderLength acc [(_occurrenceId, [])] = case acc of
                  [] -> []
                  ((occurrenceId, mappingDescription):t) -> (occurrenceId, Set.map extendEnd mappingDescription) : t
                  where
                    extendEnd :: ExamOccurrenceMappingDescription -> ExamOccurrenceMappingDescription
                    extendEnd ExamOccurrenceMappingRange {eaomrStart} = ExamOccurrenceMappingRange {eaomrStart, eaomrEnd}
                    extendEnd examOccurrenceMappingSpecial = examOccurrenceMappingSpecial
                    eaomrEnd :: [CI Char]
                    eaomrEnd = replicate (length start) $ last alphabet
                go start borderLength acc ((_occurrenceId, []):t) = go start borderLength acc t
                go start borderLength acc ((occurrenceId, userTags):t)
                  | matchMappingDescription mappingDescription userTags
                    && (null t || toNullable nextStart > end)
                  = go nextStart borderLength ((occurrenceId, mappingDescription) : acc) t
                  | borderLength < maxTagLength
                  = go restartStart restartBorderLength [] result
                  | otherwise
                  = []  -- shouldn't happen, but ensures termination on invalid input (e.g. non-monotonic)
                  where
                    restartBorderLength :: Int
                    restartBorderLength = succ borderLength

                    restartStart :: NonNull [CI Char]
                    restartStart = case rule of
                      ExamRoomMatriculation -> impureNonNull $ replicate restartBorderLength $ head alphabet
                      _rule -> singleton $ head alphabet

                    mappingDescription :: Set ExamOccurrenceMappingDescription
                    mappingDescription
                      -- if start > end, the room only consists of users with a non-ascii tag directly adjacent to the last room
                      -- therefore, leave out a potentially confusing range description
                      | toNullable start > end = Set.fromList specialMapping
                      | otherwise  = Set.fromList $ ExamOccurrenceMappingRange (toNullable start) end : specialMapping
                      
                    specialMapping :: [ExamOccurrenceMappingDescription]
                    specialMapping
                      = [ExamOccurrenceMappingSpecial {eaomrSpecial=tag}
                        | (transformTag borderLength -> tag) <- userTags
                        , not $ all (`elem` alphabet) tag]

                    -- | pre/suffix of largest user tag
                    -- special (i.e. non-ascii) tags use the largest smaller ascii-char according to  RFC5051.compareUnicode,
                    -- ending the tag with ..ZZZ-padding
                    end :: [CI Char]
                    end = case t of
                      [] -> replicate borderLength $ last alphabet
                      _nonEmpty -> withAlphabetChars
                          $ transformTag borderLength
                          $ maximumBy (\a b -> RFC5051.compareUnicode (pack $ map CI.foldedCase a) (pack $ map CI.foldedCase b))
                          -- userTags is guaranteed non-null
                          $ impureNonNull userTags
                      where
                        withAlphabetChars :: [CI Char] -> [CI Char]
                        withAlphabetChars [] = []
                        withAlphabetChars (c:cs)
                          | c `elem` alphabet = c : withAlphabetChars cs
                          | otherwise= case previousAlphabetChar c of
                            Nothing -> []
                            (Just c') -> c' : replicate (length cs) (last alphabet)
                        previousAlphabetChar :: CI Char -> Maybe (CI Char)
                        previousAlphabetChar c = fmap last $ fromNullable $ nfilter ((== GT) . compareChars c) alphabet
                        compareChars :: CI Char -> CI Char -> Ordering
                        compareChars a b = RFC5051.compareUnicode (pack [CI.foldedCase a]) (pack [CI.foldedCase b])
                    nextStart :: NonNull [CI Char]
                    -- end is guaranteed nonNull, all empty tags are filtered out in users'
                    nextStart
                      | length end < borderLength
                      = impureNonNull $ end <> [head alphabet]
                      | otherwise
                      = impureNonNull $ reverse $ increase $ reverse end
                    alphabetCycle :: [CI Char]
                    alphabetCycle = List.cycle $ toNullable alphabet
                    increase :: [CI Char] -> [CI Char]
                    increase [] = []
                    increase (c:cs)
                      | nextChar == head alphabet, rule == ExamRoomMatriculation
                      = nextChar : increase cs
                      | nextChar == head alphabet
                      = increase cs
                      | otherwise
                      = nextChar : cs
                      where
                        nextChar :: CI Char
                        nextChar
                          | c `elem` alphabet
                          = dropWhile (/= c) alphabetCycle List.!! 1
                          | otherwise -- shouldn't happen, simply use head alphabet as a fallback
                          = head alphabet
        
        transformTag :: Int -> [CI Char] -> [CI Char]
        transformTag l tag = case rule of
          ExamRoomMatriculation -> drop (max 0 $ length tag - l) tag
          _rule -> take l tag

        matchMappingDescription :: Set ExamOccurrenceMappingDescription -> [[CI Char]] -> Bool
        matchMappingDescription mappingDescription userTags = flip all userTags $ \tag -> flip any mappingDescription $ \case
          ExamOccurrenceMappingRange {eaomrStart, eaomrEnd}
            -- non-rangeAlphabet-chars get a special mapping, so <= is fine here
            -> (eaomrStart <= transformTag (length eaomrStart) tag) && (transformTag (length eaomrEnd) tag <= eaomrEnd)
          ExamOccurrenceMappingSpecial {eaomrSpecial} -> checkSpecial eaomrSpecial tag
            where
              checkSpecial :: [CI Char] -> [CI Char] -> Bool
              checkSpecial = case rule of
                ExamRoomMatriculation -> isSuffixOf
                _rule -> isPrefixOf
          ExamOccurrenceMappingRandom -> False    -- Something went wrong, throw an error instead?

        resultUsers :: Map UserId (Maybe ExamOccurrenceId)
        resultUsers = Map.fromList $ do
          (occId, buckets) <- result
          let matchWord b b' = case rule of
                ExamRoomMatriculation
                  -> b `isSuffixOf` b'
                _other
                  -> b == b'
          user <- Set.toList $ foldMap (\b -> foldMap snd . filter (\(b', _) -> matchWord b b') $ Map.toList users') buckets
          return (user, Just occId)


deregisterExamUsersCount :: (MonadIO m, HandlerSite m ~ UniWorX, MonadHandler m, MonadCatch m) => ExamId -> [UserId] -> SqlPersistT m Int64
deregisterExamUsersCount eId uids = do
  partResults <- E.select . E.from $ \(examPart `E.InnerJoin` examPartResult) -> do
    E.on $ examPart E.^. ExamPartId E.==. examPartResult E.^. ExamPartResultExamPart
    E.where_ $ examPart E.^. ExamPartExam E.==. E.val eId
         E.&&. examPartResult E.^. ExamPartResultUser `E.in_` E.valList uids
    return examPartResult
  forM_ partResults $ \(Entity resId ExamPartResult{..}) -> do
    delete resId
    audit $ TransactionExamPartResultDeleted examPartResultExamPart examPartResultUser

  results <- selectList [ ExamResultExam ==. eId, ExamResultUser <-. uids ] []
  forM_ results $ \(Entity resId ExamResult{..}) -> do
    delete resId
    audit $ TransactionExamResultDeleted examResultExam examResultUser

  boni <- selectList [ ExamBonusExam ==. eId, ExamBonusUser <-. uids ] []
  forM_ boni $ \(Entity bonusId ExamBonus{..}) -> do
    delete bonusId
    audit $ TransactionExamBonusDeleted examBonusExam examBonusUser

  regs <- selectList [ ExamRegistrationExam ==. eId, ExamRegistrationUser <-. uids ] []
  fmap (ala Sum foldMap) . forM regs $ \(Entity regId ExamRegistration{..}) -> do
    delete regId
    audit $ TransactionExamDeregister examRegistrationExam examRegistrationUser
    return 1

deregisterExamUsers :: (MonadIO m, HandlerSite m ~ UniWorX, MonadHandler m, MonadCatch m) => ExamId -> [UserId] -> SqlPersistT m ()
deregisterExamUsers eId uids = void $ deregisterExamUsersCount eId uids


examAidsPresetWidget :: ExamAidsPreset -> Widget
examAidsPresetWidget preset = $(i18nWidgetFile "exam-mode/aids")

examOnlinePresetWidget :: ExamOnlinePreset -> Widget
examOnlinePresetWidget preset = $(i18nWidgetFile "exam-mode/online")

examSynchronicityPresetWidget :: ExamSynchronicityPreset -> Widget
examSynchronicityPresetWidget preset = $(i18nWidgetFile "exam-mode/synchronicity")

examRequiredEquipmentPresetWidget :: ExamRequiredEquipmentPreset -> Widget
examRequiredEquipmentPresetWidget preset = $(i18nWidgetFile "exam-mode/requiredEquipment")


evalExamModeDNF :: ExamModeDNF -> ExamMode -> Bool
evalExamModeDNF (ExamModeDNF PredDNF{..}) ExamMode{..}
  = dnfTerms
  & Set.toList
  & map ( maybe True (ofoldr1 (&&))
        . fromNullable
        . map (\pl -> bool id not (is _PLNegated pl) . evalPred $ plVar pl)
        . Set.toList . toNullable
        )
  & maybe False (ofoldr1 (||)) . fromNullable
  where
    evalPred :: ExamModePredicate -> Bool
    evalPred = \case
      ExamModePredAids p
        -> examAids              == Just (ExamAidsPreset p)
      ExamModePredOnline p
        -> examOnline            == Just (ExamOnlinePreset p)
      ExamModePredSynchronicity p
        -> examSynchronicity     == Just (ExamSynchronicityPreset p)
      ExamModePredRequiredEquipment p
        -> examRequiredEquipment == Just (ExamRequiredEquipmentPreset p)

showExamOccurrenceRoom :: forall examOccurrence examOccurrenceId examId.
                          ( E.SqlProject ExamOccurrence ExamOccurrenceId examOccurrence examOccurrenceId
                          , E.SqlProject ExamOccurrence ExamId examOccurrence examId
                          )
                       => E.SqlExpr (E.Value UserId) -> E.SqlExpr examOccurrence -> E.SqlExpr (E.Value Bool)
showExamOccurrenceRoom uid occurrence = E.or
  [ E.exists . E.from $ \register ->
      E.where_ $ register E.^. ExamRegistrationUser E.==. uid
           E.&&. E.maybe E.false (\occId -> E.unSqlProjectExpr (Proxy @ExamOccurrence) (Proxy @examOccurrence) occId E.==. occurrence `E.sqlProject` ExamOccurrenceId) (register E.^. ExamRegistrationOccurrence)
  , E.exists . E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` exam) -> do
      E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
      E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
      E.where_ $ lecturer E.^. LecturerUser E.==. uid
           E.&&. E.unSqlProjectExpr (Proxy @ExamOccurrence) (Proxy @examOccurrence) (exam E.^. ExamId) E.==. occurrence `E.sqlProject` ExamOccurrenceExam
  , E.exists . E.from $ \examCorrector ->
      E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. uid
           E.&&. E.unSqlProjectExpr (Proxy @ExamOccurrence) (Proxy @examOccurrence) (examCorrector E.^. ExamCorrectorExam) E.==. occurrence `E.sqlProject` ExamOccurrenceExam
  ]
