{-# 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 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, Typeable) 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, Typeable) 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, Typeable) 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 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 ]