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

fix: examAutoOccurence no longer user >100% of a room

Browse Source
This commit is contained in:
Wolfgang Witt 2021-01-18 14:48:26 +01:00 committed by Wolfgang Witt
parent 9f83cc2e5b
commit eaf245beaa
1 changed files with 13 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -396,19 +396,23 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
minima <- ST.newListArray (0, Map.size wordMap) $ 0 : repeat PosInf :: forall s. ST s (STArray s Int (Extended Rational)) minima <- ST.newListArray (0, Map.size wordMap) $ 0 : repeat PosInf :: forall s. ST s (STArray s Int (Extended Rational))
breaks <- ST.newArray (0, Map.size wordMap) 0 :: forall s. ST s (STUArray s Int Int) breaks <- ST.newArray (0, Map.size wordMap) 0 :: forall s. ST s (STUArray s Int Int)
forM_ (Array.range (0, Map.size wordMap)) $ \i' -> do -- find current line
let go i j let
walkBack 0 = return 0
walkBack i'' = fmap succ $ walkBack =<< ST.readArray breaks i''
-- calculate line breaks
forM_ (Array.range (0, Map.size wordMap)) $ \i -> do
let go j
| j <= Map.size wordMap = do | j <= Map.size wordMap = do
let
walkBack 0 = return 0
walkBack i'' = fmap succ $ walkBack =<< ST.readArray breaks i''
lineIx <- walkBack i lineIx <- walkBack i
-- identifier and potential width of current line
let (l, potWidth) let (l, potWidth)
| lineIx >= 0 | lineIx >= 0
, lineIx < length lineLengths , lineIx < length lineLengths
= over _1 Just $ lineLengths List.!! lineIx = over _1 Just $ lineLengths List.!! lineIx
| otherwise | otherwise
= (Nothing, 0) = (Nothing, 0)
-- cumulative width for words [i,j), no whitespace required
w = offsets Array.! j - offsets Array.! i w = offsets Array.! j - offsets Array.! i
prevMin <- ST.readArray minima i prevMin <- ST.readArray minima i
let cost = prevMin + widthCost l potWidth w + breakCost' let cost = prevMin + widthCost l potWidth w + breakCost'
@ -431,12 +435,13 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
when (cost < minCost) $ do when (cost < minCost) $ do
ST.writeArray minima j cost ST.writeArray minima j cost
ST.writeArray breaks j i ST.writeArray breaks j i
go i' $ succ j go $ succ j
| otherwise = return () | otherwise = return ()
in go i' $ succ i' in go $ succ i
-- traceM . show . map (fmap (fromRational :: Rational -> Centi)) =<< ST.getElems minima -- traceM . show . map (fmap (fromRational :: Rational -> Centi)) =<< ST.getElems minima
-- traceM . show =<< ST.getElems breaks -- traceM . show =<< ST.getElems breaks
usedLines <- walkBack $ Map.size wordMap
let accumResult lineIx j (accCost, accMap) = do let accumResult lineIx j (accCost, accMap) = do
i <- ST.readArray breaks j i <- ST.readArray breaks j
accCost' <- (+) accCost <$> ST.readArray minima j accCost' <- (+) accCost <$> ST.readArray minima j
@ -445,7 +450,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
if if
| i > 0 -> accumResult (succ lineIx) i (accCost', accMap') | i > 0 -> accumResult (succ lineIx) i (accCost', accMap')
| otherwise -> return (accCost', accMap') | otherwise -> return (accCost', accMap')
lineIxs = reverse $ map (view _1) lineLengths lineIxs = reverse $ map (view _1) $ take usedLines lineLengths
in accumResult 0 (Map.size wordMap) (0, []) in accumResult 0 (Map.size wordMap) (0, [])