{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} module Handler.Utils.Exam ( fetchExamAux , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam , examBonus, examBonusPossible, examBonusAchieved , examResultBonus, examGrade , getRelevantSheetsUpTo, examBonusGrade , ExamAutoOccurrenceConfig , eaocMinimizeRooms, eaocFinenessCost, eaocNudge, eaocNudgeSize , _eaocMinimizeRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize , examAutoOccurrence , deregisterExamUsersCount, deregisterExamUsers , examAidsPresetWidget, examOnlinePresetWidget, examSynchronicityPresetWidget, examRequiredEquipmentPresetWidget , evalExamModeDNF , showExamOccurrenceRoom ) where import Import import Database.Persist.Sql (SqlBackendCanRead) import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Internal.Internal 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 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.RFC5051 as RFC5051 import Handler.Utils.I18n import Handler.Utils.Sheet 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, MonadThrow m) => Entity Exam -> ReaderT SqlBackend m (Map UserId (SheetTypeSummary ExamPartId)) 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, sheet E.^. SheetCourse) accum = C.foldM ?? Map.empty $ \acc (E.Value uid, E.Value sheetType, fmap entityVal -> sub, E.Value cId) -> do sheetType' <- fmap entityKey <$> resolveSheetType cId sheetType return . flip (Map.insertWith mappend uid) acc . sheetTypeSum sheetType' $ assertM submissionRatingDone sub >>= submissionRatingPoints in rawData .| accum examBonusPossible, examBonusAchieved :: Ord epId => UserId -> Map UserId (SheetTypeSummary epId) -> SheetGradeSummary examBonusPossible uid bonusMap = normalSummary $ Map.findWithDefault mempty uid bonusMap examBonusAchieved uid bonusMap = mappend <$> normalSummary <*> bonusSummary $ Map.findWithDefault mempty uid bonusMap getRelevantSheetsUpTo :: CourseId -> UserId -> Maybe UTCTime -> DB (Map SheetId (SheetType SqlBackendKey, Maybe Points)) getRelevantSheetsUpTo cid uid mCutoff = fmap postprocess . E.select . E.from $ \(sheet `E.LeftOuterJoin` submission) -> E.distinctOnOrderBy [ 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.==. E.val uid E.&&. E.just (submissionUser E.^. SubmissionUserSubmission) E.==. submission E.?. SubmissionId ) E.where_ $ sheet E.^. SheetCourse E.==. E.val cid case mCutoff of Just cutoff -> E.where_ $ E.maybe E.true (E.<=. E.val cutoff) (sheet E.^. SheetActiveTo) E.&&. E.maybe E.false (E.<=. E.val cutoff) (sheet E.^. SheetVisibleFrom) Nothing -> E.where_ . E.not_ . E.isNothing $ sheet E.^. SheetVisibleFrom return (sheet E.^. SheetId, sheet E.^. SheetType, submission) where postprocess :: [(E.Value SheetId, E.Value (SheetType SqlBackendKey), Maybe (Entity Submission))] -> Map SheetId (SheetType SqlBackendKey, Maybe Points) postprocess = Map.fromList . map postprocess' where postprocess' (E.Value sId, E.Value sType, fmap entityVal -> sub) = (sId, ) . (sType, ) $ assertM submissionRatingDone sub >>= submissionRatingPoints examResultBonus :: ExamBonusRule -> SheetGradeSummary -- ^ `examBonusPossible` -> SheetGradeSummary -- ^ `examBonusAchieved` -> Maybe Points examResultBonus bonusRule bonusPossible bonusAchieved = case bonusRule of ExamBonusManual{} -> Nothing ExamBonusPoints{..} -> Just . roundToPoints' bonusRound $ toRational bonusMaxPoints * bonusProp bonusMaxPoints where bonusProp :: Points -> Rational bonusProp mPoints | possible <= 0 = 1 | otherwise = achieved / possible where achieved = toRational (getSum $ achievedPoints bonusAchieved - achievedPassPoints bonusAchieved) + scalePasses (getSum $ achievedPasses bonusAchieved) possible = toRational (getSum $ sumSheetsPoints bonusPossible - sumSheetsPassPoints 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 | pointsPossible <= 0, passesPossible <= 0 = 1 -- This arbitrarily identifies a pass as being worth one point if all sheets are `Bonus`; maybe weird | pointsPossible <= 0 = toRational mPoints / fromInteger passesPossible | passesPossible <= 0 = 0 | otherwise = fromInteger passes / fromInteger passesPossible * toRational pointsPossible where passesPossible = getSum $ numSheetsPasses bonusPossible pointsPossible = getSum $ sumSheetsPoints bonusPossible - sumSheetsPassPoints bonusPossible roundToPoints' mult = (* mult) . (realToFrac :: Uni -> Points) . roundToPoints . (/ toRational mult) 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' examBonusGrade :: ( MonoFoldable sheets , Element sheets ~ (SheetType epId, Maybe Points) , MonoFoldable results , Element results ~ ExamResultPoints , Ord epId ) => Exam -> Either Points sheets -- ^ `Points` retrieved from relevant `ExamBonus`, iff it exists -> results -> (Maybe Points, Maybe ExamResultGrade) examBonusGrade exam@Exam{..} bonusInp = (mBonus, ) . examGrade exam mBonus where mBonus = asum [ bonusInp ^? _Left , join $ examResultBonus <$> examBonusRule <*> bonusPossible <*> bonusAchieved ] sheetSummary = flip (previews _Right) bonusInp . ofoldMap $ uncurry sheetTypeSum bonusPossible = normalSummary <$> sheetSummary bonusAchieved = (<>) <$> fmap normalSummary sheetSummary <*> fmap bonusSummary sheetSummary data ExamAutoOccurrenceConfig = ExamAutoOccurrenceConfig { eaocMinimizeRooms :: Bool , eaocFinenessCost :: Rational -- ^ Cost factor incentivising shorter common prefixes on breaks between rooms , eaocNudge :: Map ExamOccurrenceId Integer , eaocNudgeSize :: Rational } deriving (Eq, Ord, Read, Show, Generic, Typeable) instance Default ExamAutoOccurrenceConfig where def = ExamAutoOccurrenceConfig { eaocMinimizeRooms = False , eaocFinenessCost = 0.2 , eaocNudge = Map.empty , eaocNudgeSize = 0.05 } makeLenses_ ''ExamAutoOccurrenceConfig deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } ''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 matrUsers _ -> Map.singleton [] $ Map.keysSet users occurrences' :: Map ExamOccurrenceId Natural -- ^ reduce room capacity for every pre-assigned user by 1 -- also remove empty/pre-filled rooms occurrences' = foldl' (flip $ Map.update predToPositive) (Map.filter (> 0) occurrences) $ Map.mapMaybe snd users predToPositive :: Natural -> Maybe Natural predToPositive 0 = Nothing predToPositive 1 = Nothing predToPositive n = Just $ pred n occurrences'' :: [(ExamOccurrenceId, Natural)] -- ^ Minimise number of occurrences used -- -- Prefer occurrences with higher capacity -- -- If a single occurrence can accommodate 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)] -- ^ Word sizes (in order) -> [(lineId, Natural)] -- ^ Line sizes (in order) -> (lineId -> Integer) -- ^ Nudge -> (wordId -> wordId -> Extended Rational) -- ^ Break cost -> 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 under \"Shortest Path\" distribute wordLengths lineLengths lineNudge 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' = elemIndex 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) -- find current line let walkBack 0 = return 0 walkBack i'' = fmap succ $ walkBack =<< ST.readArray breaks i'' -- calculate line breaks forM_ (Array.range (0, Map.size wordMap)) $ \i -> do let go j | j <= Map.size wordMap = do lineIx <- walkBack i -- identifier and potential width of current line let (l, potWidth) | lineIx >= 0 , lineIx < length lineLengths = over _1 Just $ lineLengths List.!! lineIx | otherwise = (Nothing, 0) -- cumulative width for words [i,j), no whitespace required w = offsets Array.! j - offsets Array.! i prevMin <- ST.readArray minima i let cost = prevMin + widthCost l potWidth w + breakCost' remainingWords = offsets Array.! Map.size wordMap - offsets Array.! i remainingLineSpace = sum (map snd $ drop lineIx lineLengths) breakCost' | remainingWords > remainingLineSpace = PosInf | 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 $ succ j | otherwise = return () in go $ succ i -- traceM . show . map (fmap (fromRational :: Rational -> Centi)) =<< ST.getElems minima -- traceM . show =<< ST.getElems breaks usedLines <- walkBack $ Map.size wordMap 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 then accumResult (succ lineIx) i (accCost', accMap') else return (accCost', accMap') lineIxs = reverse $ map (view _1) $ take usedLines lineLengths in accumResult 0 (Map.size wordMap) (0, []) widthCost :: Maybe lineId -> Natural -> Natural -> Extended Rational widthCost l 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) optimumRatio' = maybe 0 (fromIntegral . lineNudge) l * eaocNudgeSize + optimumRatio 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 = [] lineNudges = fromMaybe 0 . flip Map.lookup eaocNudge bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])] bestOption = case rule of ExamRoomSurname -> do (_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` (pack . toListOf (_1 . folded . to CI.foldedCase))) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences'' lineNudges 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'' lineNudges 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 = seq resultAscList (resultAscList, resultUsers) where maxTagLength :: Int maxTagLength = maximum $ map (length . snd) result rangeAlphabet :: [CI Char] rangeAlphabet = case rule of ExamRoomSurname -> map CI.mk ['A'..'Z'] -- ExamRoomSurname -> map CI.mk [c | c <- universeF, isPrint c] -- all printable unicode characters ExamRoomMatriculation-> map CI.mk ['0'..'9'] _rule -> [] 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 | length start < maxTagLength = go (impureNonNull $ replicate (succ $ length start) $ head alphabet) [] result | otherwise = Map.empty 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 | length biggestTag < length start -- add padding, to keep equal length -> biggestTag ++ replicate (length start - length biggestTag) paddingChar | otherwise -> biggestTag where biggestTag :: [CI Char] biggestTag = maximum $ impureNonNull $ map (transformTag start) userTags paddingChar :: CI Char paddingChar = CI.mk ' ' 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 | nextChar == paddingChar = head alphabet : cs | otherwise = nextChar : cs where nextChar :: CI Char nextChar | c `elem` alphabet = dropWhile (/= c) alphabetCycle List.!! 1 | c < head alphabet -- includes padding char = head alphabet | c > last alphabet -- basically all non-ascii printable characters = head alphabet -- TODO what if the border is between to non-ascii characters? 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 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 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) deregisterExamUsersCount :: (MonadIO m, HandlerSite m ~ UniWorX, MonadHandler m, MonadCatch m) => ExamId -> [UserId] -> SqlPersistT m Int64 deregisterExamUsersCount eId uids = do partResults <- E.select . E.from $ \(examPart `E.InnerJoin` examPartResult) -> do E.on $ examPart E.^. ExamPartId E.==. examPartResult E.^. ExamPartResultExamPart E.where_ $ examPart E.^. ExamPartExam E.==. E.val eId E.&&. examPartResult E.^. ExamPartResultUser `E.in_` E.valList uids return examPartResult forM_ partResults $ \(Entity resId ExamPartResult{..}) -> do delete resId audit $ TransactionExamPartResultDeleted examPartResultExamPart examPartResultUser results <- selectList [ ExamResultExam ==. eId, ExamResultUser <-. uids ] [] forM_ results $ \(Entity resId ExamResult{..}) -> do delete resId audit $ TransactionExamResultDeleted examResultExam examResultUser boni <- selectList [ ExamBonusExam ==. eId, ExamBonusUser <-. uids ] [] forM_ boni $ \(Entity bonusId ExamBonus{..}) -> do delete bonusId audit $ TransactionExamBonusDeleted examBonusExam examBonusUser regs <- selectList [ ExamRegistrationExam ==. eId, ExamRegistrationUser <-. uids ] [] fmap (ala Sum foldMap) . forM regs $ \(Entity regId ExamRegistration{..}) -> do delete regId audit $ TransactionExamDeregister examRegistrationExam examRegistrationUser return 1 deregisterExamUsers :: (MonadIO m, HandlerSite m ~ UniWorX, MonadHandler m, MonadCatch m) => ExamId -> [UserId] -> SqlPersistT m () deregisterExamUsers eId uids = void $ deregisterExamUsersCount eId uids examAidsPresetWidget :: ExamAidsPreset -> Widget examAidsPresetWidget preset = $(i18nWidgetFile "exam-mode/aids") examOnlinePresetWidget :: ExamOnlinePreset -> Widget examOnlinePresetWidget preset = $(i18nWidgetFile "exam-mode/online") examSynchronicityPresetWidget :: ExamSynchronicityPreset -> Widget examSynchronicityPresetWidget preset = $(i18nWidgetFile "exam-mode/synchronicity") examRequiredEquipmentPresetWidget :: ExamRequiredEquipmentPreset -> Widget examRequiredEquipmentPresetWidget preset = $(i18nWidgetFile "exam-mode/requiredEquipment") evalExamModeDNF :: ExamModeDNF -> ExamMode -> Bool evalExamModeDNF (ExamModeDNF PredDNF{..}) ExamMode{..} = dnfTerms & map (Set.toList . toNullable) . Set.toList & map ( maybe True (ofoldr1 (&&)) . fromNullable . map (\pl -> bool id not (is _PLNegated pl) . evalPred $ plVar pl) ) & maybe False (ofoldr1 (||)) . fromNullable where evalPred :: ExamModePredicate -> Bool evalPred = \case ExamModePredAids p -> examAids == Just (ExamAidsPreset p) ExamModePredOnline p -> examOnline == Just (ExamOnlinePreset p) ExamModePredSynchronicity p -> examSynchronicity == Just (ExamSynchronicityPreset p) ExamModePredRequiredEquipment p -> examRequiredEquipment == Just (ExamRequiredEquipmentPreset p) showExamOccurrenceRoom :: forall examOccurrence examOccurrenceId examId. ( E.SqlProject ExamOccurrence ExamOccurrenceId examOccurrence examOccurrenceId , E.SqlProject ExamOccurrence ExamId examOccurrence examId ) => E.SqlExpr (E.Value UserId) -> E.SqlExpr examOccurrence -> E.SqlExpr (E.Value Bool) showExamOccurrenceRoom uid occurrence = E.or [ E.exists . E.from $ \register -> E.where_ $ register E.^. ExamRegistrationUser E.==. uid E.&&. E.maybe E.false (\occId -> E.unSqlProjectExpr (Proxy @ExamOccurrence) (Proxy @examOccurrence) occId E.==. occurrence `E.sqlProject` ExamOccurrenceId) (register E.^. ExamRegistrationOccurrence) , E.exists . E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` exam) -> do E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId E.where_ $ lecturer E.^. LecturerUser E.==. uid E.&&. E.unSqlProjectExpr (Proxy @ExamOccurrence) (Proxy @examOccurrence) (exam E.^. ExamId) E.==. occurrence `E.sqlProject` ExamOccurrenceExam , E.exists . E.from $ \examCorrector -> E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. uid E.&&. E.unSqlProjectExpr (Proxy @ExamOccurrence) (Proxy @examOccurrence) (examCorrector E.^. ExamCorrectorExam) E.==. occurrence `E.sqlProject` ExamOccurrenceExam ]