546 lines
25 KiB
Haskell
546 lines
25 KiB
Haskell
module Handler.Utils.Exam
|
|
( fetchExamAux
|
|
, fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam
|
|
, examBonus, examBonusPossible, examBonusAchieved
|
|
, examResultBonus, examGrade
|
|
, ExamAutoOccurrenceConfig
|
|
, eaocMinimizeRooms, eaocFinenessCost
|
|
, _eaocMinimizeRooms, _eaocFinenessCost
|
|
, examAutoOccurrence
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
|
|
import Database.Persist.Sql (SqlBackendCanRead)
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import qualified Database.Esqueleto.Internal.Sql as E
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
import qualified Data.Conduit.List as C
|
|
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
|
|
import Data.Fixed (Fixed(..))
|
|
import qualified Data.Foldable as F
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Control.Monad.Trans.Random.Lazy (evalRand)
|
|
import System.Random (mkStdGen)
|
|
import Control.Monad.Random.Class (weighted)
|
|
import Control.Monad.ST (ST, runST)
|
|
|
|
import Data.Array (Array)
|
|
import qualified Data.Array as Array
|
|
|
|
import Data.Array.ST (STArray, STUArray)
|
|
import qualified Data.Array.ST as ST
|
|
|
|
import Data.List (findIndex, unfoldr)
|
|
import qualified Data.List as List
|
|
|
|
import Data.ExtendedReal
|
|
|
|
import qualified Data.Char as Char
|
|
|
|
import qualified Data.RFC5051 as RFC5051
|
|
|
|
|
|
fetchExamAux :: ( SqlBackendCanRead backend
|
|
, E.SqlSelect b a
|
|
, MonadHandler m
|
|
, Typeable a
|
|
)
|
|
=> (E.SqlExpr (Entity Exam) -> E.SqlExpr (Entity Course) -> b)
|
|
-> TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT backend m a
|
|
fetchExamAux prj tid ssh csh examn =
|
|
let cachId = encodeUtf8 $ tshow (tid, ssh, csh, examn)
|
|
in cachedBy cachId $ do
|
|
tutList <- E.select . E.from $ \(course `E.InnerJoin` tut) -> do
|
|
E.on $ course E.^. CourseId E.==. tut E.^. ExamCourse
|
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.&&. tut E.^. ExamName E.==. E.val examn
|
|
return $ prj tut course
|
|
case tutList of
|
|
[tut] -> return tut
|
|
_other -> notFound
|
|
|
|
fetchExam :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Entity Exam)
|
|
fetchExam = fetchExamAux const
|
|
|
|
fetchExamId :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Exam)
|
|
fetchExamId tid ssh cid examn = E.unValue <$> fetchExamAux (\tutorial _ -> tutorial E.^. ExamId) tid ssh cid examn
|
|
|
|
fetchCourseIdExamId :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Course, Key Exam)
|
|
fetchCourseIdExamId tid ssh cid examn = $(unValueN 2) <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial E.^. ExamId)) tid ssh cid examn
|
|
|
|
fetchCourseIdExam :: MonadHandler m => TermId -> SchoolId -> CourseShorthand -> ExamName -> ReaderT SqlBackend m (Key Course, Entity Exam)
|
|
fetchCourseIdExam tid ssh cid examn = over _1 E.unValue <$> fetchExamAux (\tutorial course -> (course E.^. CourseId, tutorial)) tid ssh cid examn
|
|
|
|
|
|
examBonus :: MonadHandler m => Entity Exam -> ReaderT SqlBackend m (Map UserId SheetTypeSummary)
|
|
examBonus (Entity eId Exam{..}) = runConduit $
|
|
let
|
|
rawData = E.selectSource . E.from $ \(((examRegistration `E.LeftOuterJoin` examOccurrence) `E.InnerJoin` sheet) `E.LeftOuterJoin` submission) -> E.distinctOnOrderBy [ E.asc $ examRegistration E.^. ExamRegistrationUser, E.asc $ sheet E.^. SheetId ] $ do
|
|
E.on $ submission E.?. SubmissionSheet E.==. E.just (sheet E.^. SheetId)
|
|
E.&&. E.exists (E.from $ \submissionUser -> E.where_ $ submissionUser E.^. SubmissionUserUser E.==. examRegistration E.^. ExamRegistrationUser
|
|
E.&&. E.just (submissionUser E.^. SubmissionUserSubmission) E.==. submission E.?. SubmissionId
|
|
)
|
|
E.on E.true
|
|
E.on $ examRegistration E.^. ExamRegistrationOccurrence E.==. examOccurrence E.?. ExamOccurrenceId
|
|
E.where_ $ sheet E.^. SheetCourse E.==. E.val examCourse
|
|
E.&&. examRegistration E.^. ExamRegistrationExam E.==. E.val eId
|
|
E.where_ $ E.case_
|
|
[ E.when_
|
|
( E.not_ . E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence )
|
|
E.then_
|
|
( E.maybe E.true ((E.<=. examOccurrence E.?. ExamOccurrenceStart) . E.just) (sheet E.^. SheetActiveTo)
|
|
E.&&. sheet E.^. SheetVisibleFrom E.<=. examOccurrence E.?. ExamOccurrenceStart
|
|
)
|
|
]
|
|
( E.else_ . E.not_ . E.isNothing $ sheet E.^. SheetVisibleFrom
|
|
)
|
|
return (examRegistration E.^. ExamRegistrationUser, sheet E.^. SheetType, submission)
|
|
accum = C.fold ?? Map.empty $ \acc (E.Value uid, E.Value sheetType, fmap entityVal -> sub) ->
|
|
flip (Map.insertWith mappend uid) acc . sheetTypeSum sheetType $ assertM submissionRatingDone sub >>= submissionRatingPoints
|
|
in rawData .| accum
|
|
|
|
examBonusPossible, examBonusAchieved :: UserId -> Map UserId SheetTypeSummary -> SheetGradeSummary
|
|
examBonusPossible uid bonusMap = normalSummary $ Map.findWithDefault mempty uid bonusMap
|
|
examBonusAchieved uid bonusMap = mappend <$> normalSummary <*> bonusSummary $ Map.findWithDefault mempty uid bonusMap
|
|
|
|
|
|
examResultBonus :: ExamBonusRule
|
|
-> SheetGradeSummary -- ^ `examBonusPossible`
|
|
-> SheetGradeSummary -- ^ `examBonusAchieved`
|
|
-> Points
|
|
examResultBonus bonusRule bonusPossible bonusAchieved = case bonusRule of
|
|
ExamBonusManual{}
|
|
-> 0
|
|
ExamBonusPoints{..}
|
|
-> roundToPoints bonusRound $ toRational bonusMaxPoints * bonusProp
|
|
where
|
|
bonusProp :: Rational
|
|
bonusProp
|
|
| possible <= 0 = 1
|
|
| otherwise = achieved / possible
|
|
where
|
|
achieved = toRational (getSum $ achievedPoints bonusAchieved) + scalePasses (getSum $ achievedPasses bonusAchieved)
|
|
possible = toRational (getSum $ sumSheetsPoints bonusPossible) + scalePasses (getSum $ numSheetsPasses bonusPossible)
|
|
|
|
scalePasses :: Integer -> Rational
|
|
-- ^ Rescale passes so count of all sheets with pass is worth as many points as sum of all sheets with points
|
|
scalePasses passes
|
|
| passesPossible <= 0 = 0
|
|
| otherwise = fromInteger passes / fromInteger passesPossible * toRational pointsPossible
|
|
where
|
|
passesPossible = getSum $ numSheetsPasses bonusPossible
|
|
pointsPossible = getSum $ sumSheetsPoints bonusPossible
|
|
|
|
roundToPoints :: forall a. HasResolution a => Fixed a -> Rational -> Fixed a
|
|
-- ^ 'round-to-nearest' whole multiple
|
|
roundToPoints (MkFixed mult'@(fromInteger -> mult)) ((* toRational (resolution (Proxy @a))) -> raw)
|
|
= MkFixed . (* mult') $
|
|
let (whole, frac) = raw `divMod'` mult
|
|
in if | abs frac < abs (mult / 2)
|
|
-> whole
|
|
| raw >= 0
|
|
-> succ whole
|
|
| otherwise
|
|
-> pred whole
|
|
|
|
examGrade :: ( MonoFoldable mono
|
|
, Element mono ~ ExamResultPoints
|
|
)
|
|
=> Exam
|
|
-> Maybe Points -- ^ Bonus
|
|
-> mono -- ^ `ExamPartResult`s
|
|
-> Maybe ExamResultGrade
|
|
examGrade Exam{..} mBonus (otoList -> results)
|
|
= traverse pointsToGrade achievedPoints'
|
|
where
|
|
achievedPoints' :: ExamResultPoints
|
|
achievedPoints' = withBonus . getSum <$> foldMap (fmap Sum) results
|
|
|
|
withBonus :: Points -> Points
|
|
withBonus ps
|
|
| Just bonusRule <- examBonusRule
|
|
= if
|
|
| maybe True not (bonusRule ^? _bonusOnlyPassed)
|
|
|| fmap (view passingGrade) (pointsToGrade ps) == Just (_Wrapped # True)
|
|
-> maybe id (+) mBonus ps
|
|
| otherwise
|
|
-> ps
|
|
| otherwise
|
|
= ps
|
|
|
|
pointsToGrade :: Points -> Maybe ExamGrade
|
|
pointsToGrade ps = examGradingRule <&> \case
|
|
ExamGradingKey{..}
|
|
-> gradeFromKey examGradingKey
|
|
where
|
|
gradeFromKey :: [Points] -> ExamGrade
|
|
gradeFromKey examGradingKey' = maximum $ Grade50 `ncons` [ g | (g, b) <- lowerBounds, b <= ps ]
|
|
where
|
|
lowerBounds :: [(ExamGrade, Points)]
|
|
lowerBounds = zip [Grade40, Grade37 ..] examGradingKey'
|
|
|
|
data ExamAutoOccurrenceConfig = ExamAutoOccurrenceConfig
|
|
{ eaocMinimizeRooms :: Bool
|
|
, eaocFinenessCost :: Rational -- ^ Cost factor incentivising shorter common prefixes on breaks between rooms
|
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
instance Default ExamAutoOccurrenceConfig where
|
|
def = ExamAutoOccurrenceConfig
|
|
{ eaocMinimizeRooms = False
|
|
, eaocFinenessCost = 0.2
|
|
}
|
|
|
|
makeLenses_ ''ExamAutoOccurrenceConfig
|
|
|
|
|
|
examAutoOccurrence :: forall seed.
|
|
Hashable seed
|
|
=> seed
|
|
-> ExamOccurrenceRule
|
|
-> ExamAutoOccurrenceConfig
|
|
-> Map ExamOccurrenceId Natural
|
|
-> Map UserId (User, Maybe ExamOccurrenceId)
|
|
-> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId))
|
|
examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users
|
|
| sum occurrences < usersCount
|
|
|| sum occurrences <= 0
|
|
|| Map.null users
|
|
= nullResult
|
|
| otherwise
|
|
= case rule of
|
|
ExamRoomRandom
|
|
-> ( Nothing
|
|
, flip Map.mapWithKey users $ \uid (_, mOcc)
|
|
-> let randomOcc = flip evalRand (mkStdGen $ hashWithSalt seed uid) $
|
|
weighted $ over _2 fromIntegral <$> occurrences'
|
|
in Just $ fromMaybe randomOcc mOcc
|
|
)
|
|
_ | Just (postprocess -> (resMapping, result)) <- bestOption
|
|
-> ( Just $ ExamOccurrenceMapping rule resMapping
|
|
, Map.unionWith (<|>) (view _2 <$> users) result
|
|
)
|
|
_ -> nullResult
|
|
where
|
|
nullResult = (Nothing, view _2 <$> users)
|
|
usersCount :: forall a. Num a => a
|
|
usersCount = getSum $ foldMap (Sum . fromIntegral . Set.size) users'
|
|
|
|
users' :: Map [CI Char] (Set UserId)
|
|
-- ^ Finest partition of users
|
|
users' = case rule of
|
|
ExamRoomSurname
|
|
-> Map.fromListWith Set.union
|
|
[ (map CI.mk $ unpack userSurname, Set.singleton uid)
|
|
| (uid, (User{..}, Nothing)) <- Map.toList users
|
|
, not $ null userSurname
|
|
]
|
|
ExamRoomMatriculation
|
|
-> let matrUsers
|
|
= Map.fromListWith Set.union
|
|
[ (map CI.mk $ unpack matriculation', Set.singleton uid)
|
|
| (uid, (User{..}, Nothing)) <- Map.toList users
|
|
, matriculation' <- userMatrikelnummer ^.. _Just . filtered (not . null)
|
|
]
|
|
in Map.mapKeysWith Set.union (take . F.minimum . Set.map length $ Map.keysSet matrUsers) matrUsers
|
|
_ -> Map.singleton [] $ Map.keysSet users
|
|
|
|
|
|
occurrences' :: [(ExamOccurrenceId, Natural)]
|
|
-- ^ Minimise number of occurrences used
|
|
--
|
|
-- Prefer occurrences with higher capacity
|
|
--
|
|
-- If a single occurrence can accomodate all participants, pick the one with
|
|
-- the least capacity
|
|
occurrences'
|
|
| not eaocMinimizeRooms
|
|
= Map.toList occurrences
|
|
| Just largeEnoughs <- fromNullable . filter ((>= usersCount) . view _2) $ Map.toList occurrences
|
|
= pure $ minimumBy (comparing $ view _2) largeEnoughs
|
|
| otherwise
|
|
= view _2 . foldl' accF (0, []) . sortOn (Down . view _2) $ Map.toList occurrences
|
|
where
|
|
accF :: (Natural, [(ExamOccurrenceId, Natural)])
|
|
-> (ExamOccurrenceId, Natural)
|
|
-> (Natural, [(ExamOccurrenceId, Natural)])
|
|
accF acc@(accSize, accOccs) occ@(_, occSize)
|
|
| accSize >= usersCount
|
|
= acc
|
|
| otherwise
|
|
= ( accSize + occSize
|
|
, occ : accOccs
|
|
)
|
|
|
|
distribute :: forall wordId lineId cost.
|
|
_
|
|
=> [(wordId, Natural)]
|
|
-> [(lineId, Natural)]
|
|
-> (wordId -> wordId -> Extended Rational)
|
|
-> Maybe (cost, [(lineId, [wordId])])
|
|
-- ^ Distribute the given items (@wordId@s) with associated size in
|
|
-- contiguous blocks into the given buckets (@lineId@s) such that they are
|
|
-- filled as evenly as possible (proportionally)
|
|
--
|
|
-- Return a cost scaled to item-size squared
|
|
--
|
|
-- See <https://xxyxyz.org/line-breaking/> under \"Shortest Path\"
|
|
distribute wordLengths lineLengths breakCost
|
|
| null wordLengths = Just (0, [ (l, []) | (l, _) <- lineLengths ])
|
|
| null lineLengths = Nothing
|
|
| otherwise = let (cost, result) = distribute'
|
|
in case cost of
|
|
Finite c -> Just (fromInteger $ round c, result)
|
|
_other -> Nothing
|
|
where
|
|
longestLine :: Natural
|
|
-- ^ For scaling costs
|
|
longestLine = maximum . mapNonNull (view _2) $ impureNonNull lineLengths
|
|
|
|
wordMap :: Map wordId Natural
|
|
wordMap = Map.fromListWith (+) wordLengths
|
|
|
|
wordIx :: Iso' wordId Int
|
|
wordIx = iso (\wId -> let Just ix' = findIndex (== wId) $ Array.elems collapsedWords
|
|
in ix'
|
|
)
|
|
(collapsedWords Array.!)
|
|
|
|
collapsedWords :: Array Int wordId
|
|
collapsedWords = Array.array
|
|
(0, pred $ Map.size wordMap)
|
|
[ (ix', wId)
|
|
| wId <- Map.keys wordMap
|
|
, let Just ix' = findIndex ((== wId) . view _1) wordLengths
|
|
]
|
|
|
|
offsets :: Array Int Natural
|
|
offsets = Array.listArray bounds $ unfoldr (uncurry accOffsets) (0, 0)
|
|
where
|
|
accOffsets :: Natural -> Int -> Maybe (Natural, (Natural, Int))
|
|
accOffsets accSize ix'
|
|
| ix' <= 0 = Just (0, (0, 1))
|
|
| Array.inRange bounds ix' = let newSize = accSize + wordMap Map.! (wordIx # pred ix')
|
|
in Just (newSize, (newSize, succ ix'))
|
|
| otherwise = Nothing
|
|
|
|
bounds = (0, Map.size wordMap)
|
|
|
|
distribute' :: (Extended Rational, [(lineId, [wordId])])
|
|
distribute' = runST $ do
|
|
minima <- ST.newListArray (0, Map.size wordMap) $ 0 : repeat PosInf :: forall s. ST s (STArray s Int (Extended Rational))
|
|
breaks <- ST.newArray (0, Map.size wordMap) 0 :: forall s. ST s (STUArray s Int Int)
|
|
|
|
forM_ (Array.range (0, Map.size wordMap)) $ \i' -> do
|
|
let go i j
|
|
| j <= Map.size wordMap = do
|
|
let
|
|
walkBack 0 = return 0
|
|
walkBack i'' = fmap succ $ walkBack =<< ST.readArray breaks i''
|
|
lineIx <- walkBack i
|
|
let potWidth
|
|
| lineIx >= 0
|
|
, lineIx < length lineLengths
|
|
= view _2 $ lineLengths List.!! lineIx
|
|
| otherwise
|
|
= 0
|
|
w = offsets Array.! j - offsets Array.! i
|
|
prevMin <- ST.readArray minima i
|
|
let cost = prevMin + widthCost potWidth w + breakCost'
|
|
breakCost'
|
|
| j < Map.size wordMap
|
|
, j > 0
|
|
= breakCost (wordIx # pred j) (wordIx # j)
|
|
| otherwise
|
|
= 0
|
|
-- traceM $ show ( i
|
|
-- , j
|
|
-- , potWidth
|
|
-- , w
|
|
-- , (fromRational :: Rational -> Centi) <$> prevMin
|
|
-- , (fromRational :: Rational -> Centi) <$> widthCost potWidth w
|
|
-- , (fromRational :: Rational -> Centi) <$> breakCost'
|
|
-- )
|
|
when (isFinite cost) $ do
|
|
minCost <- ST.readArray minima j
|
|
when (cost < minCost) $ do
|
|
ST.writeArray minima j cost
|
|
ST.writeArray breaks j i
|
|
go i' $ succ j
|
|
| otherwise = return ()
|
|
in go i' $ succ i'
|
|
-- traceM . show . map (fmap (fromRational :: Rational -> Centi)) =<< ST.getElems minima
|
|
-- traceM . show =<< ST.getElems breaks
|
|
|
|
let accumResult lineIx j (accCost, accMap) = do
|
|
i <- ST.readArray breaks j
|
|
accCost' <- (+) accCost <$> ST.readArray minima j
|
|
-- traceM $ show ((fromRational :: Rational -> Centi) <$> accCost', lineIx, (i, pred j))
|
|
let accMap' = (lineIxs List.!! lineIx, map (review wordIx) [i .. pred j]) : accMap
|
|
if
|
|
| i > 0 -> accumResult (succ lineIx) i (accCost', accMap')
|
|
| otherwise -> return (accCost', accMap')
|
|
lineIxs = reverse $ map (view _1) lineLengths
|
|
in accumResult 0 (Map.size wordMap) (0, [])
|
|
|
|
|
|
widthCost :: Natural -> Natural -> Extended Rational
|
|
widthCost lineWidth w
|
|
| lineWidth < w = PosInf
|
|
| otherwise = Finite (max 1 . abs $ ((fromIntegral w % fromIntegral lineWidth) - optimumRatio) * fromIntegral longestLine) ^ 2
|
|
where
|
|
optimumRatio = ((%) `on` fromIntegral . sum) (map (view _2) wordLengths) (map (view _2) lineLengths)
|
|
|
|
charCost :: [CI Char] -> [CI Char] -> Extended Rational
|
|
charCost pA pB = Finite (max 1 $ List.genericLength (pA `lcp` pB) * eaocFinenessCost * fromIntegral longestLine) ^ 2
|
|
where
|
|
longestLine = maximum . mapNonNull (view _2) $ impureNonNull occurrences'
|
|
|
|
|
|
lcp :: Eq a => [a] -> [a] -> [a]
|
|
-- ^ Longest common prefix
|
|
lcp [] _ = []
|
|
lcp _ [] = []
|
|
lcp (a:as) (b:bs)
|
|
| a == b = a:lcp as bs
|
|
| otherwise = []
|
|
|
|
bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])]
|
|
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'
|
|
|
|
distributeFine :: Natural -> Maybe (Extended Rational, _)
|
|
distributeFine n = distribute (usersFineness n) occurrences' charCost
|
|
|
|
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)
|
|
, Map UserId (Maybe ExamOccurrenceId)
|
|
)
|
|
postprocess result = (resultAscList, resultUsers)
|
|
where
|
|
resultAscList = pad . Map.fromListWith Set.union $ accRes (pure <$> Set.lookupMin rangeAlphabet) result
|
|
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
|
|
mayRange' = mayRange . max 1 . succ $ length common
|
|
suffA = CI.foldedCase <$> drop (length common) maxA
|
|
suffB = CI.foldedCase <$> drop (length common) minB
|
|
in if
|
|
| mayRange (succ $ length common) maxA
|
|
, mayRange (succ $ length common) minA
|
|
, mayRange (succ $ length common) minB
|
|
, firstA : _ <- suffA
|
|
, firstB : _ <- suffB
|
|
-> 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
|
|
in (occA, Set.insert (ExamOccurrenceMappingRange minA break') . Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ length common)) . Set.filter (not . mayRange') $ Set.fromList nsA) : accRes succBreak ((occB, nsB) : xs)
|
|
| otherwise
|
|
-> (occA, Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ length common)) $ Set.fromList nsA) : accRes prevEnd ((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 $ length minZ
|
|
in pure (occZ, Set.insert (ExamOccurrenceMappingRange minZ $ replicate commonLength maxAlpha) . Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsZ)
|
|
| otherwise
|
|
= pure (occZ, Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ maybe 0 length prevEnd)) $ Set.fromList nsZ)
|
|
resultUsers = Map.fromList $ do
|
|
(occId, buckets) <- result
|
|
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
|
|
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
|