chore: rewrite resultAscList
This commit is contained in:
Wolfgang Witt
Wolfgang Witt
parent
f0f6706bcf
commit
5a3b2881c4
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user