From 5a3b2881c4a036eed705cc0e0426c2325a3d5638 Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Mon, 8 Feb 2021 15:19:09 +0100 Subject: [PATCH] chore: rewrite resultAscList --- src/Handler/Utils/Exam.hs | 150 +++++++++++++++++--------------------- 1 file changed, 67 insertions(+), 83 deletions(-) diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 08fa8a5c3..4291d68e4 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -49,8 +49,6 @@ import qualified Data.List as List import Data.ExtendedReal -import qualified Data.Char as Char - import qualified Data.RFC5051 as RFC5051 import Handler.Utils.I18n @@ -534,65 +532,75 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences -> ( Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription) , Map UserId (Maybe ExamOccurrenceId) ) - postprocess result = (resultAscList, resultUsers) + postprocess result = seq resultAscList (resultAscList, resultUsers) where - resultAscList = pad . Map.fromListWith Set.union $ accRes (pure <$> Set.lookupMin rangeAlphabet) result + rangeAlphabet :: [CI Char] + rangeAlphabet + | ExamRoomSurname <- rule + = map CI.mk ['A'..'Z'] + | ExamRoomMatriculation <- rule + = map CI.mk ['0'..'9'] + | otherwise + = [] + + resultAscList :: Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription) + resultAscList = case fromNullable rangeAlphabet of + Nothing -> Map.empty + (Just alphabet) -> Map.map Set.singleton $ Map.fromList $ go (singleton $ head alphabet) [] result + where + go :: NonNull [CI Char] -> [(ExamOccurrenceId, ExamOccurrenceMappingDescription)] -> [(ExamOccurrenceId, [[CI Char]])] -> [(ExamOccurrenceId, ExamOccurrenceMappingDescription)] + go _start acc [] = acc + -- special case necessary, so ranges always end on last alphabet + go start acc [(_occurrenceId, [])] = case acc of + [] -> [] + ((occurrenceId, mappingDescription):t) -> (occurrenceId, mappingDescription {eaomrEnd}) : t + where + eaomrEnd :: [CI Char] + eaomrEnd = replicate (length start) $ last alphabet + go start acc ((_occurrenceId, []):t) = go start acc t + go start acc ((occurrenceId, userTags):t) + | matchMappingDescription mappingDescription userTags = go nextStart ((occurrenceId, mappingDescription) : acc) t + | otherwise = go (impureNonNull $ replicate (succ $ length start) $ head alphabet) [] result + where + mappingDescription :: ExamOccurrenceMappingDescription + mappingDescription = ExamOccurrenceMappingRange (toNullable start) end + -- | pre/suffix of larges user tag + end :: [CI Char] + -- userTags is guaranteed nonNull + end = case t of + [] -> replicate (length start) $ last alphabet + _nonEmpty -> maximum $ impureNonNull $ map (transformTag start) userTags + nextStart :: NonNull [CI Char] + -- end is guaranteed nonNull, all empty tags are filtered out in users' + nextStart = impureNonNull $ reverse $ increase $ reverse end + alphabetCycle :: [CI Char] + alphabetCycle = List.cycle $ toNullable alphabet + increase :: [CI Char] -> [CI Char] + increase [] = [] + increase (c:cs) + | nextChar == head alphabet = nextChar : increase cs + | otherwise = nextChar : cs + where + nextChar :: CI Char + nextChar = dropWhile (/= c) alphabetCycle List.!! 1 + + transformTag :: (MonoFoldable f) => f -> [CI Char] -> [CI Char] + transformTag (length -> l) tag = case rule of + ExamRoomMatriculation -> drop (max 0 $ length tag - l) tag + _rule -> take l tag + + matchMappingDescription :: ExamOccurrenceMappingDescription -> [[CI Char]] -> Bool + matchMappingDescription ExamOccurrenceMappingRange {eaomrStart, eaomrEnd} = all $ \tag -> + (eaomrStart <= transformTag eaomrStart tag) && (transformTag eaomrEnd tag <= eaomrEnd) + + matchMappingDescription ExamOccurrenceMappingSpecial {eaomrSpecial} = all $ checkSpecial eaomrSpecial where - accRes _ [] = [] - accRes prevEnd ((occA, nsA) : (occB, nsB) : xs) - | Just minA <- prevEnd <|> preview _head nsA - , Just maxA <- nsA ^? _last - , Just minB <- nsB ^? _head - = let common = maxA `lcp` minB - in if - | Just rmaxA <- nsA ^? to (filter . mayRange . succ $ length common) . _last - , Just rminA <- maybe id (:) prevEnd nsA ^? to (filter . mayRange . succ $ length common) . _head - , Just rminB <- nsB ^? to (filter . mayRange . succ $ length common) . _head - , firstA : _ <- CI.foldedCase <$> drop (length common) rmaxA - , firstB : _ <- CI.foldedCase <$> drop (length common) rminB - -> 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 - go (c:cs) - | c' <- CI.map succ c - , c' `Set.member` rangeAlphabet - = Just $ c' : cs - | otherwise - = go cs - commonLength = max 1 . succ . length $ minA `lcp` break' - isBreakSpecialStart c = not (mayRange (length rminA ) c) && length (rminA `lcp` c) >= pred (length rminA ) - isBreakSpecialEnd c = not (mayRange (length break') c) && length (break' `lcp` c) >= pred (length break') - rangeSpecials = Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsA - breakSpecialsStart = Set.map (ExamOccurrenceMappingSpecial . take (length rminA)) . Set.filter isBreakSpecialStart $ Set.fromList nsA - breakSpecialsEnd = Set.map (ExamOccurrenceMappingSpecial . take (length break')) . Set.filter isBreakSpecialEnd $ Set.fromList nsA - in (occA, Set.insert (ExamOccurrenceMappingRange rminA break') $ breakSpecialsStart <> breakSpecialsEnd <> rangeSpecials) : accRes succBreak ((occB, nsB) : xs) - | otherwise - -> (occA, Set.map (ExamOccurrenceMappingSpecial . take (max 1 . max (succ $ length common) $ maybe 0 length prevEnd)) $ Set.fromList nsA) : accRes (Just $ take (succ $ length common) minB) ((occB, nsB) : xs) - | null nsA - = accRes prevEnd $ (occB, nsB) : xs - | otherwise -- null nsB - = accRes prevEnd $ (occA, nsA) : xs - accRes prevEnd [(occZ, nsZ)] - | Just minAlpha <- Set.lookupMin rangeAlphabet - , Just maxAlpha <- Set.lookupMax rangeAlphabet - , minZ <- fromMaybe (pure minAlpha) prevEnd - = let commonLength = max 1 . succ . length $ takeWhile (== maxAlpha) minZ - isBreakSpecial c = not (mayRange (length minZ) c) && length (minZ `lcp` c) >= pred (length minZ) - rangeSpecials = Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsZ - breakSpecials = Set.map (ExamOccurrenceMappingSpecial . take (length minZ)) . Set.filter isBreakSpecial $ Set.fromList nsZ - in pure (occZ, Set.insert (ExamOccurrenceMappingRange minZ $ replicate commonLength maxAlpha) $ rangeSpecials <> breakSpecials) - | otherwise - = pure (occZ, Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ maybe 0 length prevEnd)) $ Set.fromList nsZ) + checkSpecial :: [CI Char] -> [CI Char] -> Bool + checkSpecial = case rule of + ExamRoomMatriculation -> isSuffixOf + _rule -> isPrefixOf + + resultUsers :: Map UserId (Maybe ExamOccurrenceId) resultUsers = Map.fromList $ do (occId, buckets) <- result let matchWord b b' = case rule of @@ -603,30 +611,6 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences 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 - occSize occId = fromIntegral . length $ Map.filter (== Just occId) resultUsers - - rangeAlphabet :: Set (CI Char) - rangeAlphabet - | ExamRoomSurname <- rule - = Set.fromList $ map CI.mk ['A'..'Z'] - | ExamRoomMatriculation <- rule - = Set.fromList $ map CI.mk ['0'..'9'] - | otherwise - = 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 - deregisterExamUsersCount :: (MonadIO m, HandlerSite m ~ UniWorX, MonadHandler m, MonadCatch m) => ExamId -> [UserId] -> SqlPersistT m Int64 deregisterExamUsersCount eId uids = do