896 lines
45 KiB
Haskell
896 lines
45 KiB
Haskell
-- 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
|
|
]
|