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

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Handler.Exam.AutoOccurrence
  ( examAutoOccurrenceCalculateWidget
  , postEAutoOccurrenceR
  ) where

import Import
import Handler.Utils
import Handler.Utils.Exam

import qualified Data.Map as Map
import qualified Data.Set as Set

import qualified Database.Esqueleto.Legacy as E
import Database.Persist.Sql (updateWhereCount)

newtype ExamAutoOccurrenceCalculateForm = ExamAutoOccurrenceCalculateForm
  { eaofConfig :: ExamAutoOccurrenceConfig
  } deriving stock   (Eq, Ord, Read, Show, Generic)
    deriving newtype (Default, FromJSON, ToJSON)

makeLenses_ ''ExamAutoOccurrenceCalculateForm

data ExamAutoOccurrenceAcceptForm = ExamAutoOccurrenceAcceptForm
  { eaofMapping    :: ExamOccurrenceMapping ExamOccurrenceId
  , eaofAssignment :: Map UserId (Maybe ExamOccurrenceId)
  , eaofSuccess :: Bool
  } deriving (Eq, Ord, Read, Show, Generic)

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

data ExamAutoOccurrenceButton
  = BtnExamAutoOccurrenceCalculate
  | BtnExamAutoOccurrenceAccept
  | BtnExamAutoOccurrenceNudgeUp | BtnExamAutoOccurrenceNudgeDown
  | BtnExamAutoOccurrenceIgnore | BtnExamAutoOccurrenceReconsider
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
instance Universe ExamAutoOccurrenceButton
instance Finite ExamAutoOccurrenceButton

nullaryPathPiece ''ExamAutoOccurrenceButton $ camelToPathPiece' 4

instance Button UniWorX ExamAutoOccurrenceButton where
  btnLabel BtnExamAutoOccurrenceCalculate = i18n MsgBtnExamAutoOccurrenceCalculate
  btnLabel BtnExamAutoOccurrenceAccept = i18n MsgBtnExamAutoOccurrenceAccept
  btnLabel BtnExamAutoOccurrenceNudgeUp = toWidget iconExamAutoOccurrenceNudgeUp
  btnLabel BtnExamAutoOccurrenceNudgeDown = toWidget iconExamAutoOccurrenceNudgeDown
  btnLabel BtnExamAutoOccurrenceIgnore = toWidget iconExamAutoOccurrenceIgnore
  btnLabel BtnExamAutoOccurrenceReconsider = toWidget iconExamAutoOccurrenceReconsider

  btnClasses BtnExamAutoOccurrenceNudgeUp = [BCIsButton]
  btnClasses BtnExamAutoOccurrenceNudgeDown = [BCIsButton]
  btnClasses BtnExamAutoOccurrenceIgnore = [BCIsButton]
  btnClasses BtnExamAutoOccurrenceReconsider = [BCIsButton]
  btnClasses _ = [BCIsButton, BCPrimary]


examAutoOccurrenceCalculateForm :: Map ExamOccurrenceId ExamOccurrenceCapacity
                                -> Map UserId (User, Maybe ExamOccurrenceId)
                                -> ExamAutoOccurrenceCalculateForm
                                -> Form ExamAutoOccurrenceCalculateForm
examAutoOccurrenceCalculateForm occurrences (fromIntegral . length -> usersCount) ExamAutoOccurrenceCalculateForm { eaofConfig }
  = identifyForm FIDExamAutoOccurrenceCalculate . renderAForm FormStandard $ ExamAutoOccurrenceCalculateForm <$> eaocForm
  where
    eaocForm =
      (set _eaocIgnoreRooms . automaticIfTrue <$> apopt checkBoxField (fslI MsgExamAutoOccurrenceMinimizeRooms & setTooltip MsgExamAutoOccurrenceMinimizeRoomsTip) (Just . minimizeRooms $ eaofConfig ^. _eaocIgnoreRooms))
      <*> pure def
    automaticIfTrue :: Bool -> ExamAutoOccurrenceIgnoreRooms
    automaticIfTrue True  = ExamAutoOccurrenceIgnoreRooms {eaoirIgnored, eaoirSorted=True}
    automaticIfTrue False = ExamAutoOccurrenceIgnoreRooms {eaoirIgnored=Set.empty, eaoirSorted=False}
    minimizeRooms :: ExamAutoOccurrenceIgnoreRooms -> Bool
    minimizeRooms ExamAutoOccurrenceIgnoreRooms {eaoirSorted} = eaoirSorted
    eaoirIgnored :: Set ExamOccurrenceId
    -- ^ Minimise number of occurrences used
    --
    -- Prefer occurrences with higher capacity
    --
    -- If a single occurrence can accommodate all participants, pick the one with
    -- the least capacity
    eaoirIgnored
      | Just largeEnoughs <- fromNullable . filter ((>= Restricted usersCount) . view _2) $ Map.toList occurrences
      = Set.delete (view _1 $ minimumBy (comparing $ view _2) largeEnoughs) $ Map.keysSet occurrences
      | otherwise
      = Set.fromList . view _2 . foldl' accF (Restricted 0, [])
          . sortOn (Down . view _2) $ Map.toList occurrences
      where
        accF :: (ExamOccurrenceCapacity, [ExamOccurrenceId])
            -> (ExamOccurrenceId, ExamOccurrenceCapacity)
            -> (ExamOccurrenceCapacity, [ExamOccurrenceId])
        accF (accSize, accIgnored) (occId, occSize)
          | accSize >= Restricted usersCount
          = (accSize, occId:accIgnored)
          | otherwise
          = (accSize <> occSize, accIgnored)

examAutoOccurrenceNudgeForm :: ExamOccurrenceId -> Maybe ExamAutoOccurrenceCalculateForm -> Form ExamAutoOccurrenceCalculateForm
examAutoOccurrenceNudgeForm occId protoForm html = do
  cID <- encrypt occId
  (btnRes, wgt) <- identifyForm (FIDExamAutoOccurrenceNudge $ ciphertext cID) (buttonForm' [BtnExamAutoOccurrenceNudgeUp, BtnExamAutoOccurrenceNudgeDown]) html
  oldDataRes <- globalPostParamField PostExamAutoOccurrencePrevious secretJsonField
  oldDataId <- newIdent

  let protoForm' = fromMaybe def $ protoForm <|> oldDataRes
      genForm btn = protoForm' & _eaofConfig . _eaocNudge %~ Map.insertWith (+) occId n
        where n = case btn of
                BtnExamAutoOccurrenceNudgeUp   ->  1
                BtnExamAutoOccurrenceNudgeDown -> -1
                _other                         -> 0
      res = genForm <$> btnRes
      oldDataView = fieldView (secretJsonField :: Field Handler _) oldDataId (toPathPiece PostExamAutoOccurrencePrevious) [] (Right . fromMaybe protoForm' $ formResult' res) False
  return (res, wgt <> oldDataView)

examAutoOccurrenceIgnoreRoomsForm :: ExamOccurrenceId
                                  -> Maybe ExamAutoOccurrenceCalculateForm
                                  -> Maybe ExamAutoOccurrenceCalculateForm
                                  -> Form ExamAutoOccurrenceCalculateForm
examAutoOccurrenceIgnoreRoomsForm occId calculateRes protoForm html = do
  cID <- encrypt occId
  oldDataRes <- globalPostParamField PostExamAutoOccurrencePrevious secretJsonField
  oldDataId <- newIdent

  -- create both buttons
  (btnResIgnore, wgtIgnore) <- identifyForm (FIDExamAutoOccurrenceIgnoreRoom $ ciphertext cID) (buttonForm' [BtnExamAutoOccurrenceIgnore]) html
  (btnResReconsider, wgtReconsider) <- identifyForm (FIDExamAutoOccurrenceIgnoreRoom $ ciphertext cID) (buttonForm' [BtnExamAutoOccurrenceReconsider]) html

  -- choose the relevant button to display
  let btnRes = btnResIgnore <|> btnResReconsider
      wgt = case btnRes of
        (FormSuccess BtnExamAutoOccurrenceIgnore)     -> wgtReconsider
        (FormSuccess BtnExamAutoOccurrenceReconsider) -> wgtIgnore
        _otherwise -> case eaocIgnoreRooms . eaofConfig $ fromMaybe def $ calculateRes <|> oldDataRes of
          ExamAutoOccurrenceIgnoreRooms {eaoirIgnored}
            | Set.member occId eaoirIgnored
            -> wgtReconsider
            | otherwise
            -> wgtIgnore
  

  let protoForm' = fromMaybe def $ calculateRes <|> protoForm <|> oldDataRes
      genForm btn = protoForm' & _eaofConfig . _eaocIgnoreRooms . _eaoirIgnored %~ action occId
        where
          action = case btn of
            BtnExamAutoOccurrenceIgnore     -> Set.insert
            BtnExamAutoOccurrenceReconsider -> Set.delete
            _other                          -> flip const   -- i.e. ignore argument
      res = genForm <$> btnRes
      oldDataView = fieldView (secretJsonField :: Field Handler _) oldDataId (toPathPiece PostExamAutoOccurrencePrevious) [] (Right . fromMaybe protoForm' $ formResult' res) False
  return (res, wgt <> oldDataView)

examAutoOccurrenceAcceptForm :: Maybe ExamAutoOccurrenceAcceptForm -> Form ExamAutoOccurrenceAcceptForm
examAutoOccurrenceAcceptForm confirmData = identifyForm FIDExamAutoOccurrenceConfirm $ \html -> do
  (confirmDataRes, confirmDataView) <- mreq secretJsonField "" confirmData
  let fs :: FieldSettings UniWorX
      fs = (if maybe False eaofSuccess confirmData then id else set _fsAttrs [("disabled", "")]) ""
  (acceptRes, acceptView) <- buttonForm'' [BtnExamAutoOccurrenceAccept] fs mempty
  return (acceptRes *> confirmDataRes, toWidget html <> fvWidget confirmDataView <> acceptView)


examAutoOccurrenceCalculateWidget :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Widget
examAutoOccurrenceCalculateWidget tid ssh csh examn = do
  (formView, formEncoding) <- liftHandler . generateFormPost $ examAutoOccurrenceCalculateForm Map.empty Map.empty def

  wrapForm' BtnExamAutoOccurrenceCalculate $(i18nWidgetFile "exam-auto-occurrence-calculate") def
    { formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR
    , formEncoding
    }


postEAutoOccurrenceR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
postEAutoOccurrenceR tid ssh csh examn = do
  (Entity eId Exam{ examOccurrenceRule }, occurrences, participants) <- runDB $ do
    exam@(Entity eId _) <- fetchExam tid ssh csh examn
    occurrences <- selectList [ ExamOccurrenceExam ==. eId ] [ Asc ExamOccurrenceName ]
    participants <- E.select . E.from $ \(registration `E.InnerJoin` user) -> do
      E.on $ registration E.^. ExamRegistrationUser E.==. user E.^. UserId
      E.where_ $ registration E.^. ExamRegistrationExam E.==. E.val eId
      return (user, registration)
    return (exam, occurrences, participants)


  let participants' = Map.fromList $ do
        (Entity uid userRec, Entity _ ExamRegistration{..}) <- participants
        return (uid, (userRec, examRegistrationOccurrence))
      occurrences' = Map.fromList $ map (\(Entity eoId ExamOccurrence{..}) -> (eoId, _examOccurrenceCapacityIso # (fromIntegral <$> examOccurrenceCapacity))) occurrences
  ((calculateRes, _), _) <- runFormPost $ examAutoOccurrenceCalculateForm occurrences' participants' def


  (nudgeRes, ignoreRes) <- mdo
    nudgeRes <- sequence . flip Map.fromSet (setOf (folded . _entityKey) occurrences) $ \occId ->
      runFormPost $ examAutoOccurrenceNudgeForm occId (formResult' . asum $ nudgeRes ^.. ifolded . ifiltered (\occId' _ -> occId' /= occId) . _1 . _1 ++ ignoreRes ^.. folded . _1 . _1)
    ignoreRes <- sequence . flip Map.fromSet (setOf (folded . _entityKey) occurrences) $ \occId ->
      runFormPost $ examAutoOccurrenceIgnoreRoomsForm occId (formResult' calculateRes) (formResult' . asum $ nudgeRes ^.. folded . _1 . _1 ++ ignoreRes ^.. ifolded . ifiltered (\occId' _ -> occId' /= occId) . _1 . _1)
    return (nudgeRes, ignoreRes)


  let calculateRes' = asum $ calculateRes : nudgeRes ^.. folded . _1 . _1 ++ ignoreRes ^.. folded . _1 . _1

  calcResult <- formResultMaybe calculateRes' $ \ExamAutoOccurrenceCalculateForm{..} -> do
    let autoOccurrenceResult = examAutoOccurrence eId examOccurrenceRule eaofConfig occurrences' participants'
    (eaofMapping, eaofAssignment, eaofSuccess) <- case autoOccurrenceResult of
      (Left e) -> do
        addMessageI Error e
        pure ( ExamOccurrenceMapping {
              examOccurrenceMappingRule = examOccurrenceRule,
              examOccurrenceMappingMapping = Map.empty
            }
           , Map.map (view _2) participants'
           , False
           )
      (Right res) -> pure $ uncurry (,,True) res
    return $ Just ExamAutoOccurrenceAcceptForm{..}

  ((confirmRes, confirmView), confirmEncoding) <- runFormPost $ examAutoOccurrenceAcceptForm calcResult
  let confirmWidget = wrapForm confirmView def
        { formAction   = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR
        , formEncoding = confirmEncoding
        , formSubmit   = FormNoSubmit
        }

  formResult confirmRes $ \ExamAutoOccurrenceAcceptForm{..} -> do
    Sum assignedCount <- runDB $ do
      let eaofMapping'' :: Maybe (ExamOccurrenceMapping ExamOccurrenceName)
          eaofMapping'' = ($ eaofMapping) . traverseExamOccurrenceMapping $ \eoId -> case filter ((== eoId) . entityKey) occurrences of
            [Entity _ ExamOccurrence{..}] -> Just examOccurrenceName
            _other -> Nothing
      eaofMapping' <- case eaofMapping'' of
        Nothing -> invalidArgsI [MsgExamAutoOccurrenceOccurrencesChangedInFlight]
        Just x  -> return $ Just x
      update eId [ ExamExamOccurrenceMapping =. eaofMapping' ]
      fmap fold . iforM eaofAssignment $ \pid occ -> case occ of
        Just _  -> Sum <$> updateWhereCount [ ExamRegistrationExam ==. eId, ExamRegistrationUser ==. pid, ExamRegistrationOccurrence ==. Nothing ] [ ExamRegistrationOccurrence =. occ ]
        Nothing -> return mempty
    addMessageI Success $ MsgExamAutoOccurrenceParticipantsAssigned assignedCount
    redirect $ CExamR tid ssh csh examn EUsersR

  let nudgeWgt = nudgeRes <&> \((_, nudgeView), nudgeEncoding) ->
        wrapForm nudgeView def
          { formAction   = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR
          , formEncoding = nudgeEncoding
          , formSubmit   = FormNoSubmit
          , formAttrs = [("class", "buttongroup")]
          }

  let ignoreRoomWgt = ignoreRes <&> \((_, ignoreRoomsView), ignoreRoomsEncoding) ->
        wrapForm ignoreRoomsView def
          { formAction   = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR
          , formEncoding = ignoreRoomsEncoding
          , formSubmit   = FormNoSubmit
          , formAttrs = [("class", "buttongroup")]
          }
      isIgnored :: ExamOccurrenceId -> Bool
      isIgnored occId = maybe False (Set.member occId) $ formResult' calculateRes' ^? _Just . _eaofConfig . _eaocIgnoreRooms . _eaoirIgnored

  ExamAutoOccurrenceAcceptForm{..} <- maybe (redirect $ CExamR tid ssh csh examn EUsersR) return calcResult

  let heading = MsgTitleExamAutoOccurrence tid ssh csh examn
      mappingWgt
        = let occLoads :: Map ExamOccurrenceId Natural
              occLoads = Map.fromListWith (+) . mapMaybe (\(_, mOcc) -> (, 1) <$> mOcc) $ Map.toList eaofAssignment

              occLoad = fromMaybe 0 . flip Map.lookup occLoads

              occMappingRule = examOccurrenceMappingRule eaofMapping

              loadProp curr max'
                | Just max'' <- assertM (/= 0) max'
                = MsgProportion (toMessage curr) (toMessage max'') (toRational curr / toRational max'')
                | otherwise
                = MsgProportionNoRatio (toMessage curr) $ maybe "∞" toMessage max'

              occMapping occId = examOccurrenceMappingDescriptionWidget occMappingRule <$> Map.lookup occId (examOccurrenceMappingMapping eaofMapping)
           in $(widgetFile "widgets/exam-occurrence-mapping")

  siteLayoutMsg heading $ do
    setTitleI heading
    $(widgetFile "exam/auto-occurrence-confirm")
