fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore: inform examAutoOccurrence about unrestricted room sizes

Browse Source
This commit is contained in:
Wolfgang Witt 2021-03-10 15:07:05 +01:00 committed by Gregor Kleen
parent d3661b69fd
commit 7e425754fc
1 changed files with 69 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

104
src/Handler/Utils/Exam.hs
View File

@ -255,14 +255,13 @@ examAutoOccurrence :: forall seed.
=> seed => seed
-> ExamOccurrenceRule -> ExamOccurrenceRule
-> ExamAutoOccurrenceConfig -> ExamAutoOccurrenceConfig
-> Map ExamOccurrenceId Natural -> Map ExamOccurrenceId ExamOccurrenceCapacity
-> Map UserId (User, Maybe ExamOccurrenceId) -> Map UserId (User, Maybe ExamOccurrenceId)
-> Either ExamAutoOccurrenceException (ExamOccurrenceMapping ExamOccurrenceId, Map UserId (Maybe ExamOccurrenceId)) -> Either ExamAutoOccurrenceException (ExamOccurrenceMapping ExamOccurrenceId, Map UserId (Maybe ExamOccurrenceId))
examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users
| Map.null users' | Map.null users'
= Left ExamAutoOccurrenceExceptionNoUsers = Left ExamAutoOccurrenceExceptionNoUsers
| sum occurrences' < usersCount | occurrencesSize < Restricted usersCount -- this guarantees occurrencesSize > 0 as well
|| sum occurrences' <= 0
= Left ExamAutoOccurrenceExceptionNotEnoughSpace = Left ExamAutoOccurrenceExceptionNotEnoughSpace
| otherwise | otherwise
= case rule of = case rule of
@ -278,28 +277,46 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
(assignedUsers, unassignedUsers) = Map.partition (has $ _2 . _Just) users (assignedUsers, unassignedUsers) = Map.partition (has $ _2 . _Just) users
shuffledUsers :: [UserId] shuffledUsers :: [UserId]
shuffledUsers = shuffle' (Map.keys unassignedUsers) (length unassignedUsers) (mkStdGen seed) shuffledUsers = shuffle' (Map.keys unassignedUsers) (length unassignedUsers) (mkStdGen seed)
occurrencesMap :: Map ExamOccurrenceId Natural restrictedOccurrences :: Map ExamOccurrenceId Natural
occurrencesMap = Map.fromList occurrences'' 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 -- 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 :: Natural -> Map ExamOccurrenceId Natural -> Map ExamOccurrenceId Natural
decreaseBiggestOutlier 0 currentOccurrences = currentOccurrences decreaseBiggestOutlier 0 currentOccurrences = currentOccurrences
decreaseBiggestOutlier n currentOccurrences = decreaseBiggestOutlier (pred n) decreaseBiggestOutlier n currentOccurrences
$ Map.update predToPositive biggestOutlier currentOccurrences = decreaseBiggestOutlier (pred n) $ Map.update predToPositive biggestOutlier currentOccurrences
where where
currentRatios :: Map ExamOccurrenceId Rational currentRatios :: Map ExamOccurrenceId Rational
currentRatios = Map.merge Map.dropMissing Map.dropMissing (Map.zipWithMatched calculateRatio) currentRatios = Map.merge Map.dropMissing Map.dropMissing (Map.zipWithMatched calculateRatio)
currentOccurrences occurrencesMap currentOccurrences restrictedOccurrences
calculateRatio :: ExamOccurrenceId -> Natural -> Natural -> Rational calculateRatio :: ExamOccurrenceId -> Natural -> Natural -> Rational
calculateRatio k c m = fromIntegral c % fromIntegral m - eaocNudgeSize * fromIntegral (lineNudges k) calculateRatio k c m = fromIntegral c % fromIntegral m - eaocNudgeSize * fromIntegral (lineNudges k)
biggestOutlier :: ExamOccurrenceId biggestOutlier :: ExamOccurrenceId
biggestOutlier = fst . List.maximumBy (comparing $ view _2) $ Map.toList currentRatios 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 :: 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 :: [(ExamOccurrenceId, Natural)]
finalOccurrences = Map.toList $ decreaseBiggestOutlier extraCapacity occurrencesMap finalOccurrences = Map.toList $ decreaseBiggestOutlier extraCapacity restrictedOccurrences
-- fill in users in a random order -- fill in users in a random order
randomlyAssignedUsers :: Map UserId (Maybe ExamOccurrenceId) 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]) addUsers :: ([(UserId, Maybe ExamOccurrenceId)], [UserId])
-> (ExamOccurrenceId, Natural) -> (ExamOccurrenceId, Natural)
-> ([(UserId, Maybe ExamOccurrenceId)], [UserId]) -> ([(UserId, Maybe ExamOccurrenceId)], [UserId])
@ -307,6 +324,12 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
where where
newUsers, remainingUsers :: [UserId] newUsers, remainingUsers :: [UserId]
(newUsers, remainingUsers) = List.genericSplitAt roomSize userList (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 _ -> bimap (ExamOccurrenceMapping rule) (Map.unionWith (<|>) (view _2 <$> users)) . postprocess <$> bestOption
where where
usersCount :: forall a. Num a => a usersCount :: forall a. Num a => a
@ -333,17 +356,22 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
_ | null users-> Map.empty _ | null users-> Map.empty
| otherwise -> Map.singleton [] $ Map.keysSet users | 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 -- ^ reduce room capacity for every pre-assigned user by 1
-- also remove empty/pre-filled rooms -- 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 occurrences'' :: [(ExamOccurrenceId, ExamOccurrenceCapacity)]
predToPositive 0 = Nothing
predToPositive 1 = Nothing
predToPositive n = Just $ pred n
occurrences'' :: [(ExamOccurrenceId, Natural)]
-- ^ Minimise number of occurrences used -- ^ Minimise number of occurrences used
-- --
-- Prefer occurrences with higher capacity -- Prefer occurrences with higher capacity
@ -353,26 +381,26 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
occurrences'' occurrences''
| not eaocMinimizeRooms | not eaocMinimizeRooms
= Map.toList occurrences' = 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 = pure $ minimumBy (comparing $ view _2) largeEnoughs
| otherwise | 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 where
accF :: (Natural, [(ExamOccurrenceId, Natural)]) accF :: (ExamOccurrenceCapacity, [(ExamOccurrenceId, ExamOccurrenceCapacity)])
-> (ExamOccurrenceId, Natural) -> (ExamOccurrenceId, ExamOccurrenceCapacity)
-> (Natural, [(ExamOccurrenceId, Natural)]) -> (ExamOccurrenceCapacity, [(ExamOccurrenceId, ExamOccurrenceCapacity)])
accF acc@(accSize, accOccs) occ@(_, occSize) accF acc@(accSize, accOccs) occ@(_, occSize)
| accSize >= usersCount | accSize >= Restricted usersCount
= acc = acc
| otherwise | otherwise
= ( accSize + occSize = ( accSize <> occSize
, occ : accOccs , occ : accOccs
) )
distribute :: forall wordId lineId cost. distribute :: forall wordId lineId cost.
_ _
=> [(wordId, Natural)] -- ^ Word sizes (in order) => [(wordId, Natural)] -- ^ Word sizes (in order)
-> [(lineId, Natural)] -- ^ Line sizes (in order) -> [(lineId, ExamOccurrenceCapacity)] -- ^ Line sizes (in order)
-> (lineId -> Integer) -- ^ Nudge -> (lineId -> Integer) -- ^ Nudge
-> (wordId -> wordId -> Extended Rational) -- ^ Break cost -> (wordId -> wordId -> Extended Rational) -- ^ Break cost
-> Maybe (cost, [(lineId, [wordId])]) -> Maybe (cost, [(lineId, [wordId])])
@ -393,7 +421,8 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
where where
longestLine :: Natural longestLine :: Natural
-- ^ For scaling costs -- ^ 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 wordId Natural
wordMap = Map.fromListWith (+) wordLengths wordMap = Map.fromListWith (+) wordLengths
@ -444,15 +473,15 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
, lineIx < length lineLengths , lineIx < length lineLengths
= over _1 Just $ lineLengths List.!! lineIx = over _1 Just $ lineLengths List.!! lineIx
| otherwise | otherwise
= (Nothing, 0) = (Nothing, Restricted 0)
-- cumulative width for words [i,j), no whitespace required -- cumulative width for words [i,j), no whitespace required
w = offsets Array.! j - offsets Array.! i w = offsets Array.! j - offsets Array.! i
prevMin <- ST.readArray minima i prevMin <- ST.readArray minima i
let cost = prevMin + widthCost l potWidth w + breakCost' let cost = prevMin + widthCost l potWidth w + breakCost'
remainingWords = offsets Array.! Map.size wordMap - offsets Array.! i remainingWords = offsets Array.! Map.size wordMap - offsets Array.! i
remainingLineSpace = sumOf (folded . _2) $ drop lineIx lineLengths remainingLineSpace = foldMap (view _2) $ drop lineIx lineLengths
breakCost' breakCost'
| remainingWords > remainingLineSpace | Restricted remainingWords > remainingLineSpace
= PosInf = PosInf
| j < Map.size wordMap | j < Map.size wordMap
, j > 0 , j > 0
@ -491,18 +520,23 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
in accumResult 0 (Map.size wordMap) (0, []) in accumResult 0 (Map.size wordMap) (0, [])
widthCost :: Maybe lineId -> Natural -> Natural -> Extended Rational widthCost :: Maybe lineId -> ExamOccurrenceCapacity -> Natural -> Extended Rational
widthCost l lineWidth w widthCost _l Unrestricted _w = 0
widthCost l (Restricted lineWidth) w
| lineWidth < w = PosInf | lineWidth < w = PosInf
| otherwise = Finite (max 1 . abs $ ((fromIntegral w % fromIntegral lineWidth) - optimumRatio') * fromIntegral longestLine) ^ 2 | otherwise = Finite (max 1 . abs $ ((fromIntegral w % fromIntegral lineWidth) - optimumRatio') * fromIntegral longestLine) ^ 2
where 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 optimumRatio' = maybe 0 (fromIntegral . lineNudge) l * eaocNudgeSize + optimumRatio
charCost :: [CI Char] -> [CI Char] -> Extended Rational charCost :: [CI Char] -> [CI Char] -> Extended Rational
charCost pA pB = Finite (max 1 $ List.genericLength (pA `lcp` pB) * eaocFinenessCost * fromIntegral longestLine) ^ 2 charCost pA pB = Finite (max 1 $ List.genericLength (pA `lcp` pB) * eaocFinenessCost * fromIntegral longestLine) ^ 2
where 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] lcp :: Eq a => [a] -> [a] -> [a]