fix: exam auto-occurrence by matriculation

src/Handler/Utils/Exam.hs

@@ -415,12 +415,43 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
       | otherwise = []
 
     bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])]
-    bestOption = do
+    bestOption = case rule of
-      (_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` toListOf (_1 . folded . to CI.foldedCase)) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' charCost
+      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)
+                    -> let break'
-                             & floor
+                             | occSize occA > 0 || occSize occB > 0
-                             & Char.chr
+                             = (occSize occA * Char.ord firstA + occSize occB * Char.ord firstB) % (occSize occA + occSize occB)
-                             & Char.toUpper
+                                 & floor
-                             & CI.mk
+                                 & Char.chr
-                             & pure
+                                 & Char.toUpper
-                             & (common ++)
+                                 & 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

templates/widgets/exam-occurrence-mapping.hamlet

@@ -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}