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

fix: user with a pre-assigned room count towards the capacity limit

Browse Source
This commit is contained in:
Wolfgang Witt 2021-02-01 15:53:15 +01:00 committed by Wolfgang Witt
parent 46e6ca9217
commit 4fc05351fa
1 changed files with 18 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -267,8 +267,8 @@ examAutoOccurrence :: forall seed.
-> Map UserId (User, Maybe ExamOccurrenceId) -> Map UserId (User, Maybe ExamOccurrenceId)
-> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId)) -> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId))
examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users
| sum occurrences < usersCount | sum occurrences' < usersCount
|| sum occurrences <= 0 || sum occurrences' <= 0
|| Map.null users || Map.null users
= nullResult = nullResult
| otherwise | otherwise
@ -277,7 +277,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
-> ( Nothing -> ( Nothing
, flip Map.mapWithKey users $ \uid (_, mOcc) , flip Map.mapWithKey users $ \uid (_, mOcc)
-> let randomOcc = flip evalRand (mkStdGen $ hashWithSalt seed uid) $ -> let randomOcc = flip evalRand (mkStdGen $ hashWithSalt seed uid) $
weighted $ over _2 fromIntegral <$> occurrences' weighted $ over _2 fromIntegral <$> occurrences''
in Just $ fromMaybe randomOcc mOcc in Just $ fromMaybe randomOcc mOcc
) )
_ | Just (postprocess -> (resMapping, result)) <- bestOption _ | Just (postprocess -> (resMapping, result)) <- bestOption
@ -309,21 +309,28 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
in Map.mapKeysWith Set.union (take . F.minimum . Set.map length $ Map.keysSet matrUsers) matrUsers in Map.mapKeysWith Set.union (take . F.minimum . Set.map length $ Map.keysSet matrUsers) matrUsers
_ -> Map.singleton [] $ Map.keysSet users _ -> Map.singleton [] $ Map.keysSet users
occurrences' :: Map ExamOccurrenceId Natural
-- ^ reduce room capacity for every pre-assigned user by 1
occurrences' = foldl' (flip $ Map.adjust predOrZero) occurrences $ Map.mapMaybe snd users
where
predOrZero :: Natural -> Natural
predOrZero 0 = 0
predOrZero n = pred n
occurrences' :: [(ExamOccurrenceId, Natural)] occurrences'' :: [(ExamOccurrenceId, Natural)]
-- ^ Minimise number of occurrences used -- ^ Minimise number of occurrences used
-- --
-- Prefer occurrences with higher capacity -- Prefer occurrences with higher capacity
-- --
-- If a single occurrence can accommodate all participants, pick the one with -- If a single occurrence can accommodate all participants, pick the one with
-- the least capacity -- the least capacity
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 ((>= 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 (0, []) . sortOn (Down . view _2) $ Map.toList occurrences'
where where
accF :: (Natural, [(ExamOccurrenceId, Natural)]) accF :: (Natural, [(ExamOccurrenceId, Natural)])
-> (ExamOccurrenceId, Natural) -> (ExamOccurrenceId, Natural)
@ -469,7 +476,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
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 = maximum . mapNonNull (view _2) $ impureNonNull occurrences''
lcp :: Eq a => [a] -> [a] -> [a] lcp :: Eq a => [a] -> [a] -> [a]
@ -485,7 +492,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])] bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])]
bestOption = case rule of bestOption = case rule of
ExamRoomSurname -> do ExamRoomSurname -> do
(_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` (pack . toListOf (_1 . folded . to CI.foldedCase))) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' lineNudges charCost (_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 -- traceM $ show cost
return res return res
ExamRoomMatriculation -> do ExamRoomMatriculation -> do
@ -493,7 +500,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
-- finenessCost n = Finite (max 1 $ fromIntegral n * eaocFinenessCost * fromIntegral longestLine) ^ 2 * length occurrences' -- finenessCost n = Finite (max 1 $ fromIntegral n * eaocFinenessCost * fromIntegral longestLine) ^ 2 * length occurrences'
distributeFine :: Natural -> Maybe (Extended Rational, _) distributeFine :: Natural -> Maybe (Extended Rational, _)
distributeFine n = distribute (usersFineness n) occurrences' lineNudges charCost distributeFine n = distribute (usersFineness n) occurrences'' lineNudges charCost
maximumFineness = fromIntegral . F.minimum . Set.map length $ Map.keysSet users' maximumFineness = fromIntegral . F.minimum . Set.map length $ Map.keysSet users'