fix: exam auto-occurrence by matriculation
This commit is contained in:
Gregor Kleen
parent
5bff34ed0a
commit
3ef10d98a1
@ -415,12 +415,43 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
|
||||
| otherwise = []
|
||||
|
||||
bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])]
|
||||
bestOption = do
|
||||
(_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` toListOf (_1 . folded . to CI.foldedCase)) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' charCost
|
||||
bestOption = case rule of
|
||||
ExamRoomSurname -> do
|
||||
(_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` toListOf (_1 . folded . to CI.foldedCase)) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' charCost
|
||||
-- traceM $ show cost
|
||||
return res
|
||||
ExamRoomMatriculation -> do
|
||||
let usersFineness n = Map.toAscList $ fromIntegral . Set.size <$> Map.mapKeysWith Set.union (reverse . take (fromIntegral n) . reverse) users'
|
||||
-- finenessCost n = Finite (max 1 $ fromIntegral n * eaocFinenessCost * fromIntegral longestLine) ^ 2 * length occurrences'
|
||||
|
||||
-- traceM $ show cost
|
||||
distributeFine :: Natural -> Maybe (Extended Rational, _)
|
||||
distributeFine n = distribute (usersFineness n) occurrences' charCost
|
||||
|
||||
return res
|
||||
maximumFineness = fromIntegral . F.minimum . Set.map length $ Map.keysSet users'
|
||||
|
||||
resultFineness :: [(ExamOccurrenceId, [[CI Char]])] -> Natural
|
||||
resultFineness (map (view _2) -> res)
|
||||
| Just res' <- fromNullable res
|
||||
= maybe 0 maximum . fromNullable $ zipWith transFineness res (tail res')
|
||||
| otherwise = 0
|
||||
where
|
||||
transFineness :: [[CI Char]] -> [[CI Char]] -> Natural
|
||||
transFineness nsA nsB
|
||||
| Just maxA <- nsA ^? _last
|
||||
, Just minB <- nsB ^? _head
|
||||
= succ . List.genericLength $ maxA `lcp` minB
|
||||
| otherwise
|
||||
= 0
|
||||
|
||||
genResults f
|
||||
| f > maximumFineness = []
|
||||
| otherwise =
|
||||
let mRes = distributeFine f
|
||||
in (mRes ^.. _Just) ++ bool [] (genResults $ succ f) (maybe True (>= f) $ mRes ^? _Just . _2 . to resultFineness)
|
||||
|
||||
(_cost, res) <- fmap (minimumBy . comparing $ view _1) . fromNullable $ genResults 1
|
||||
return res
|
||||
_other -> Nothing
|
||||
|
||||
postprocess :: [(ExamOccurrenceId, [[CI Char]])]
|
||||
-> ( Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription)
|
||||
@ -428,7 +459,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
|
||||
)
|
||||
postprocess result = (resultAscList, resultUsers)
|
||||
where
|
||||
resultAscList = Map.fromListWith Set.union $ accRes (pure <$> Set.lookupMin rangeAlphabet) result
|
||||
resultAscList = pad . Map.fromListWith Set.union $ accRes (pure <$> Set.lookupMin rangeAlphabet) result
|
||||
where
|
||||
accRes _ [] = []
|
||||
accRes prevEnd ((occA, nsA) : (occB, nsB) : xs)
|
||||
@ -445,13 +476,16 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
|
||||
, mayRange (succ $ length common) minB
|
||||
, firstA : _ <- suffA
|
||||
, firstB : _ <- suffB
|
||||
-> let break' = (occSize occA * Char.ord firstA + occSize occB * Char.ord firstB) % (occSize occA + occSize occB)
|
||||
& floor
|
||||
& Char.chr
|
||||
& Char.toUpper
|
||||
& CI.mk
|
||||
& pure
|
||||
& (common ++)
|
||||
-> let break'
|
||||
| occSize occA > 0 || occSize occB > 0
|
||||
= (occSize occA * Char.ord firstA + occSize occB * Char.ord firstB) % (occSize occA + occSize occB)
|
||||
& floor
|
||||
& Char.chr
|
||||
& Char.toUpper
|
||||
& CI.mk
|
||||
& pure
|
||||
& (common ++)
|
||||
| otherwise = common ++ pure (CI.mk firstA)
|
||||
succBreak = fmap reverse . go $ reverse break'
|
||||
where
|
||||
go [] = Nothing
|
||||
@ -478,7 +512,12 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
|
||||
= pure (occZ, Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ maybe 0 length prevEnd)) $ Set.fromList nsZ)
|
||||
resultUsers = Map.fromList $ do
|
||||
(occId, buckets) <- result
|
||||
user <- Set.toList $ foldMap (\b -> foldMap snd . filter (\(b', _) -> b == b') $ Map.toList users') buckets
|
||||
let matchWord b b' = case rule of
|
||||
ExamRoomMatriculation
|
||||
-> b `isSuffixOf` b'
|
||||
_other
|
||||
-> b == b'
|
||||
user <- Set.toList $ foldMap (\b -> foldMap snd . filter (\(b', _) -> matchWord b b') $ Map.toList users') buckets
|
||||
return (user, Just occId)
|
||||
|
||||
occSize :: Num a => ExamOccurrenceId -> a
|
||||
@ -494,3 +533,13 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
|
||||
= mempty
|
||||
mayRange :: Int -> [CI Char] -> Bool
|
||||
mayRange l = all (`Set.member` rangeAlphabet) . take l
|
||||
|
||||
pad :: Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription) -> Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription)
|
||||
pad res
|
||||
| ExamRoomMatriculation <- rule
|
||||
, Just minAlpha <- Set.lookupMin rangeAlphabet
|
||||
= let maxLength = maybe 0 maximum . fromNullable $ res ^.. folded . folded . (_eaomrStart <> _eaomrEnd <> _eaomrSpecial) . to length
|
||||
padSuff cs = replicate (maxLength - length cs) minAlpha ++ cs
|
||||
in Set.map (appEndo $ foldMap Endo [ over l padSuff | l <- [_eaomrStart, _eaomrEnd, _eaomrSpecial]]) <$> res
|
||||
| otherwise
|
||||
= res
|
||||
|
||||
@ -29,8 +29,8 @@ $newline never
|
||||
_{examOccurrenceName}
|
||||
<td .table__td>
|
||||
_{loadProp (occLoad occId) examOccurrenceCapacity}
|
||||
$maybe mappingWgt <- occMapping occId
|
||||
<td .table__td>
|
||||
<td .table__td>
|
||||
$maybe mappingWgt <- occMapping occId
|
||||
^{mappingWgt}
|
||||
<td .table__td>
|
||||
#{examOccurrenceRoom}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user