diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 612ce4aad..844919ed2 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -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 diff --git a/templates/widgets/exam-occurrence-mapping.hamlet b/templates/widgets/exam-occurrence-mapping.hamlet index 36f99950e..78cdf5b13 100644 --- a/templates/widgets/exam-occurrence-mapping.hamlet +++ b/templates/widgets/exam-occurrence-mapping.hamlet @@ -29,8 +29,8 @@ $newline never _{examOccurrenceName}