{-# 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.Char as Char 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 = 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) . 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 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)] -- ^ 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) 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 (l, potWidth) | lineIx >= 0 , lineIx < length lineLengths = over _1 Just $ lineLengths List.!! lineIx | otherwise = (Nothing, 0) w = offsets Array.! j - offsets Array.! i prevMin <- ST.readArray minima i let cost = prevMin + widthCost l 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 :: 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 = (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 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) 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 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 ]