diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 26bdcc946..c6da1aef6 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -255,14 +255,13 @@ examAutoOccurrence :: forall seed. => seed -> ExamOccurrenceRule -> ExamAutoOccurrenceConfig - -> Map ExamOccurrenceId Natural + -> 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 - | sum occurrences' < usersCount - || sum occurrences' <= 0 + | occurrencesSize < Restricted usersCount -- this guarantees occurrencesSize > 0 as well = Left ExamAutoOccurrenceExceptionNotEnoughSpace | otherwise = case rule of @@ -278,28 +277,46 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences (assignedUsers, unassignedUsers) = Map.partition (has $ _2 . _Just) users shuffledUsers :: [UserId] shuffledUsers = shuffle' (Map.keys unassignedUsers) (length unassignedUsers) (mkStdGen seed) - occurrencesMap :: Map ExamOccurrenceId Natural - occurrencesMap = Map.fromList occurrences'' + restrictedOccurrences :: Map ExamOccurrenceId Natural + unrestrictedOccurrences :: [ExamOccurrenceId] + (unrestrictedOccurrences, restrictedOccurrences) + = second Map.fromList $ partitionRestricted ([], []) occurrences'' + 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 -- 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 + 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 occurrencesMap + currentOccurrences restrictedOccurrences calculateRatio :: ExamOccurrenceId -> Natural -> Natural -> Rational calculateRatio k c m = fromIntegral c % fromIntegral m - 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 - extraCapacity = sumOf (folded . _2) occurrences'' - fromIntegral (length unassignedUsers) + extraCapacity + | restrictedSpace > numUnassignedUsers = restrictedSpace - numUnassignedUsers + | otherwise = 0 + where + restrictedSpace :: Natural + restrictedSpace = sum restrictedOccurrences + numUnassignedUsers :: Natural + numUnassignedUsers = fromIntegral $ length unassignedUsers finalOccurrences :: [(ExamOccurrenceId, Natural)] - finalOccurrences = Map.toList $ decreaseBiggestOutlier extraCapacity occurrencesMap + finalOccurrences = Map.toList $ decreaseBiggestOutlier extraCapacity restrictedOccurrences -- fill in users in a random order randomlyAssignedUsers :: Map UserId (Maybe ExamOccurrenceId) - randomlyAssignedUsers = Map.fromList $ fst $ foldl' addUsers ([], shuffledUsers) finalOccurrences + randomlyAssignedUsers = Map.fromList $ fillUnrestricted (List.cycle unrestrictedOccurrences) + $ foldl' addUsers ([], shuffledUsers) finalOccurrences addUsers :: ([(UserId, Maybe ExamOccurrenceId)], [UserId]) -> (ExamOccurrenceId, Natural) -> ([(UserId, Maybe ExamOccurrenceId)], [UserId]) @@ -307,6 +324,12 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences 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) _ -> bimap (ExamOccurrenceMapping rule) (Map.unionWith (<|>) (view _2 <$> users)) . postprocess <$> bestOption where usersCount :: forall a. Num a => a @@ -333,17 +356,22 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences _ | null users-> Map.empty | otherwise -> Map.singleton [] $ Map.keysSet users - occurrences' :: Map ExamOccurrenceId Natural + occurrencesSize :: ExamOccurrenceCapacity + occurrencesSize = fold 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 (> 0) occurrences) $ Map.mapMaybe snd users + 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 - predToPositive :: Natural -> Maybe Natural - predToPositive 0 = Nothing - predToPositive 1 = Nothing - predToPositive n = Just $ pred n - - occurrences'' :: [(ExamOccurrenceId, Natural)] + occurrences'' :: [(ExamOccurrenceId, ExamOccurrenceCapacity)] -- ^ Minimise number of occurrences used -- -- Prefer occurrences with higher capacity @@ -353,26 +381,26 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences occurrences'' | not eaocMinimizeRooms = Map.toList occurrences' - | Just largeEnoughs <- fromNullable . filter ((>= usersCount) . view _2) $ Map.toList occurrences' + | Just largeEnoughs <- fromNullable . filter ((>= Restricted usersCount) . view _2) $ Map.toList occurrences' = pure $ minimumBy (comparing $ view _2) largeEnoughs | otherwise - = view _2 . foldl' accF (0, []) . sortOn (Down . view _2) $ Map.toList occurrences' + = view _2 . foldl' accF (Restricted 0, []) . sortOn (Down . view _2) $ Map.toList occurrences' where - accF :: (Natural, [(ExamOccurrenceId, Natural)]) - -> (ExamOccurrenceId, Natural) - -> (Natural, [(ExamOccurrenceId, Natural)]) + accF :: (ExamOccurrenceCapacity, [(ExamOccurrenceId, ExamOccurrenceCapacity)]) + -> (ExamOccurrenceId, ExamOccurrenceCapacity) + -> (ExamOccurrenceCapacity, [(ExamOccurrenceId, ExamOccurrenceCapacity)]) accF acc@(accSize, accOccs) occ@(_, occSize) - | accSize >= usersCount + | accSize >= Restricted usersCount = acc | otherwise - = ( accSize + occSize + = ( accSize <> occSize , occ : accOccs ) distribute :: forall wordId lineId cost. _ => [(wordId, Natural)] -- ^ Word sizes (in order) - -> [(lineId, Natural)] -- ^ Line sizes (in order) + -> [(lineId, ExamOccurrenceCapacity)] -- ^ Line sizes (in order) -> (lineId -> Integer) -- ^ Nudge -> (wordId -> wordId -> Extended Rational) -- ^ Break cost -> Maybe (cost, [(lineId, [wordId])]) @@ -393,7 +421,8 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences where longestLine :: Natural -- ^ For scaling costs - longestLine = maximum . mapNonNull (view _2) $ impureNonNull lineLengths + longestLine = maximum $ impureNonNull $ catMaybes $ (view $ _2 . _examOccurrenceCapacityIso) <$> lineLengths + -- only evaluated for restricted lines, so impureNonNull is fine here wordMap :: Map wordId Natural wordMap = Map.fromListWith (+) wordLengths @@ -444,15 +473,15 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences , lineIx < length lineLengths = over _1 Just $ lineLengths List.!! lineIx | otherwise - = (Nothing, 0) + = (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 = sumOf (folded . _2) $ drop lineIx lineLengths + remainingLineSpace = foldMap (view _2) $ drop lineIx lineLengths breakCost' - | remainingWords > remainingLineSpace + | Restricted remainingWords > remainingLineSpace = PosInf | j < Map.size wordMap , j > 0 @@ -491,18 +520,23 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences in accumResult 0 (Map.size wordMap) (0, []) - widthCost :: Maybe lineId -> Natural -> Natural -> Extended Rational - widthCost l lineWidth w + widthCost :: Maybe lineId -> ExamOccurrenceCapacity -> Natural -> Extended Rational + widthCost _l Unrestricted _w = 0 + widthCost l (Restricted lineWidth) w | lineWidth < w = PosInf | otherwise = Finite (max 1 . abs $ ((fromIntegral w % fromIntegral lineWidth) - optimumRatio') * fromIntegral longestLine) ^ 2 where - optimumRatio = ((%) `on` fromIntegral . sum) (map (view _2) wordLengths) (map (view _2) lineLengths) + optimumRatio = ((%) `on` fromIntegral . max 1 . sum) (map (view _2) wordLengths) restrictedLengths + restrictedLengths = catMaybes $ (view $ _2 . _examOccurrenceCapacityIso) <$> lineLengths + -- ^ might be empty, so we need max 1 after sum! optimumRatio' = maybe 0 (fromIntegral . lineNudge) l * eaocNudgeSize + optimumRatio charCost :: [CI Char] -> [CI Char] -> Extended Rational charCost pA pB = Finite (max 1 $ List.genericLength (pA `lcp` pB) * eaocFinenessCost * fromIntegral longestLine) ^ 2 where - longestLine = maximum . mapNonNull (view _2) $ impureNonNull occurrences'' + longestLine :: Natural + longestLine = maybe 1 maximum $ fromNullable $ catMaybes + $ (view $ _2 . _examOccurrenceCapacityIso) <$> occurrences'' lcp :: Eq a => [a] -> [a] -> [a]