From 6e20c22f7dcfd00c77ff46a9a2c4f66f1ffa3161 Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Mon, 15 Mar 2021 14:20:49 +0100 Subject: [PATCH] chore: introduce a real cost function for unrestricted rooms --- src/Handler/Utils/Exam.hs | 56 +++++++++++++++++++++++++++++---------- 1 file changed, 42 insertions(+), 14 deletions(-) diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 16be8b762..dc5ef2656 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -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