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

chore: introduce a real cost function for unrestricted rooms

Browse Source
This commit is contained in:
Wolfgang Witt 2021-03-15 14:20:49 +01:00 committed by Gregor Kleen
parent b7d7252649
commit 6e20c22f7d
1 changed files with 42 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -281,10 +281,6 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} 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
decreaseBiggestOutlier :: Natural -> Map ExamOccurrenceId Natural -> Map ExamOccurrenceId Natural
decreaseBiggestOutlier 0 currentOccurrences = currentOccurrences
@ -396,6 +392,11 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
= ( accSize <> occSize
, occ : accOccs
)
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
distribute :: forall wordId lineId cost.
_
@ -419,10 +420,32 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
Finite c -> Just (fromInteger $ round c, result)
_other -> Nothing
where
restrictedLines :: [(lineId, Natural)]
unrestrictedLines :: [lineId]
(unrestrictedLines, restrictedLines) = partitionRestricted ([], []) lineLengths
-- reorder so unrestricted lines are at the end and my be left empty
lineLengths' :: [(lineId, ExamOccurrenceCapacity)]
lineLengths' = (over _2 Restricted <$> restrictedLines) ++ ((, Unrestricted) <$> unrestrictedLines)
restrictedLengths :: [Natural]
restrictedLengths = view _2 <$> restrictedLines
restrictedSpace :: Natural
restrictedSpace = sum restrictedLengths
extraCapacity :: Natural
extraCapacity
| restrictedSpace > numUnassignedUsers = restrictedSpace - numUnassignedUsers
| otherwise = 0
where
numUnassignedUsers :: Natural
numUnassignedUsers = sum $ view _2 <$> wordLengths
longestLine :: Natural
-- ^ For scaling costs
longestLine = maximum $ impureNonNull $ catMaybes $ view (_2 . _examOccurrenceCapacityIso) <$> lineLengths
-- only evaluated for restricted lines, so impureNonNull is fine here
-- longest restricted line (or 1 if all unrestricted)
longestLine = maybe 1 maximum $ fromNullable restrictedLengths
wordMap :: Map wordId Natural
wordMap = Map.fromListWith (+) wordLengths
@ -470,8 +493,8 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
-- identifier and potential width of current line
let (l, potWidth)
| lineIx >= 0
, lineIx < length lineLengths
= over _1 Just $ lineLengths List.!! lineIx
, lineIx < length lineLengths'
= over _1 Just $ lineLengths' List.!! lineIx
| otherwise
= (Nothing, Restricted 0)
-- cumulative width for words [i,j), no whitespace required
@ -479,7 +502,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
prevMin <- ST.readArray minima i
let cost = prevMin + widthCost l potWidth w + breakCost'
remainingWords = offsets Array.! Map.size wordMap - offsets Array.! i
remainingLineSpace = foldMap (view _2) $ drop lineIx lineLengths
remainingLineSpace = foldMap (view _2) $ drop lineIx lineLengths'
breakCost'
| Restricted remainingWords > remainingLineSpace
= PosInf
@ -516,19 +539,24 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
if i > 0
then accumResult (succ lineIx) i (accCost', accMap')
else return (accCost', accMap')
lineIxs = reverse $ map (view _1) $ take usedLines lineLengths
lineIxs = reverse $ map (view _1) $ take usedLines lineLengths'
in accumResult 0 (Map.size wordMap) (0, [])
optimumRatio :: Rational
optimumRatio = ((%) `on` fromIntegral . max 1 . sum) (map (view _2) wordLengths) restrictedLengths
widthCost :: Maybe lineId -> ExamOccurrenceCapacity -> Natural -> Extended Rational
widthCost _l Unrestricted _w = 0
widthCost l Unrestricted w
= Finite ((fromIntegral w - fromIntegral extraCapacity) % List.genericLength unrestrictedLines
- nudgeRatio * fromIntegral longestLine)^2
where
nudgeRatio :: Rational
nudgeRatio = maybe 0 (fromIntegral . lineNudge) l * eaocNudgeSize
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 . 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' :: Rational
optimumRatio' = maybe 0 (fromIntegral . lineNudge) l * eaocNudgeSize + optimumRatio
charCost :: [CI Char] -> [CI Char] -> Extended Rational