chore: inform examAutoOccurrence about unrestricted room sizes
This commit is contained in:
Wolfgang Witt
Gregor Kleen
parent
d3661b69fd
commit
7e425754fc
@ -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]
|
||||
|
||||
Loading…
Reference in New Issue
Block a user