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

chore: allow nudges between unrestricted rooms (random)

Browse Source
This commit is contained in:
Wolfgang Witt 2021-03-17 13:46:28 +01:00 committed by Gregor Kleen
parent 3ab8be2e0d
commit ddb68eeb98
1 changed files with 29 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -291,16 +291,16 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
currentRatios = Map.merge Map.dropMissing Map.dropMissing (Map.zipWithMatched calculateRatio) currentRatios = Map.merge Map.dropMissing Map.dropMissing (Map.zipWithMatched calculateRatio)
currentOccurrences restrictedOccurrences currentOccurrences restrictedOccurrences
calculateRatio :: ExamOccurrenceId -> Natural -> Natural -> Rational calculateRatio :: ExamOccurrenceId -> Natural -> Natural -> Rational
calculateRatio k c m = fromIntegral c / (max 1 $ fromIntegral m * sizeModifier) calculateRatio k c m = fromIntegral c / max 1 (fromIntegral m * sizeModifier)
where where
sizeModifier :: Rational sizeModifier :: Rational
sizeModifier = 1 + eaocNudgeSize * fromIntegral (lineNudges k) sizeModifier = 1 + 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 :: Natural -> Maybe Natural
predToPositive 0 = Nothing predToPositive 0 = Nothing
predToPositive 1 = Nothing predToPositive 1 = Nothing
predToPositive x = Just $ pred x predToPositive x = Just $ pred x
extraCapacity :: Natural extraCapacity :: Natural
extraCapacity extraCapacity
| restrictedSpace > numUnassignedUsers = restrictedSpace - numUnassignedUsers | restrictedSpace > numUnassignedUsers = restrictedSpace - numUnassignedUsers
@ -312,9 +312,32 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
numUnassignedUsers = fromIntegral $ length unassignedUsers numUnassignedUsers = fromIntegral $ length unassignedUsers
finalOccurrences :: [(ExamOccurrenceId, Natural)] finalOccurrences :: [(ExamOccurrenceId, Natural)]
finalOccurrences = Map.toList $ decreaseBiggestOutlier extraCapacity restrictedOccurrences 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
-- 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)
$ Set.toList (Set.intersection unrestrictedOccurrences $ Map.keysSet nudges) ++ acc
-- 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)
$ Set.toList (Set.difference unrestrictedOccurrences $ Map.keysSet nudges) ++ acc
-- 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 $ fillUnrestricted (List.cycle $ Set.toList unrestrictedOccurrences) randomlyAssignedUsers = Map.fromList $ fillUnrestricted
(nudgedUnrestrictedOccurrences ++ List.cycle (Set.toList unrestrictedOccurrences))
$ foldl' addUsers ([], shuffledUsers) finalOccurrences $ foldl' addUsers ([], shuffledUsers) finalOccurrences
addUsers :: ([(UserId, Maybe ExamOccurrenceId)], [UserId]) addUsers :: ([(UserId, Maybe ExamOccurrenceId)], [UserId])
-> (ExamOccurrenceId, Natural) -> (ExamOccurrenceId, Natural)