diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg
index 3be85654d..f2e4518b1 100644
--- a/messages/uniworx/misc/de-de-formal.msg
+++ b/messages/uniworx/misc/de-de-formal.msg
@@ -2800,9 +2800,15 @@ BtnExamAutoOccurrenceNudgeUp: +
BtnExamAutoOccurrenceNudgeDown: -
ExamRoomMappingSurname: Nachnamen beginnend mit
ExamRoomMappingMatriculation: Matrikelnummern endend in
+ExamRoomMappingRandom: Verteilung
+ExamRoomMappingRandomHere: Zufällig
ExamRoomLoad: Auslastung
ExamRegisteredCount: Anmeldungen
ExamRegisteredCountOf num@Int64 count@Int64: #{num}/#{count}
+ExamAutoOccurrenceExceptionRuleNoOp: Kein Verfahren zur automatischen Verteilung gewählt
+ExamAutoOccurrenceExceptionNotEnoughSpace: Mehr Teilnehmende als verfügbare Plätze
+ExamAutoOccurrenceExceptionNoUsers: Nach dem gewähltem Verfahren können keine Teilnehmenden verteilt werden
+ExamAutoOccurrenceExceptionRoomTooSmall: Automatische Verteilung gescheitert. Ein anderes Verteil-Verfahren kann erfolgreich sein. Alternativ kann es helfen Räume zu minimieren oder kleine Räume zu entfernen.
NoFilter: Keine Einschränkung
@@ -3181,4 +3187,4 @@ WGFFileUpload: Dateifeld
WorkflowGraphFormUploadIsDirectory: Upload ist Verzeichnis
WorkflowGraphFormInvalidNumberOfFiles: Es muss genau eine Datei hochgeladen werden
-CourseSortingOnlyLoggedIn: Das Benutzerinterface zur Sortierung dieser Tabelle ist nur für eingeloggte Benutzer aktiv
\ No newline at end of file
+CourseSortingOnlyLoggedIn: Das Benutzerinterface zur Sortierung dieser Tabelle ist nur für eingeloggte Benutzer aktiv
diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg
index 3f425b064..892b593f9 100644
--- a/messages/uniworx/misc/en-eu.msg
+++ b/messages/uniworx/misc/en-eu.msg
@@ -2792,7 +2792,7 @@ ExamAutoOccurrenceHeading: Automatic occurrence/room distribution
ExamAutoOccurrenceMinimizeRooms: Minimize number of occurrences used
ExamAutoOccurrenceMinimizeRoomsTip: Should the list of occurrences/rooms be reduced prior to distribution? Only as many occurrence/rooms as necessary would be used (starting with the biggest).
ExamAutoOccurrenceOccurrencesChangedInFlight: Occurrences/rooms changed
-ExamAutoOccurrenceParticipantsAssigned num: Occurrence/room assignment rule saved successfully. Also assigned occurence/room to #{num} #{pluralEN num "participant" "participants"}
+ExamAutoOccurrenceParticipantsAssigned num: Occurrence/room assignment rule saved successfully. Also assigned occurrence/room to #{num} #{pluralEN num "participant" "participants"}
TitleExamAutoOccurrence tid ssh csh examn: #{tid} - #{ssh} - #{csh} #{examn}: Automatic occurrence/room distribution
BtnExamAutoOccurrenceCalculate: Calculate assignment rules
BtnExamAutoOccurrenceAccept: Accept assignments
@@ -2800,9 +2800,15 @@ BtnExamAutoOccurrenceNudgeUp: +
BtnExamAutoOccurrenceNudgeDown: -
ExamRoomMappingSurname: Surnames starting with
ExamRoomMappingMatriculation: Matriculation numbers ending in
+ExamRoomMappingRandom: Distribution
+ExamRoomMappingRandomHere: Random
ExamRoomLoad: Utilisation
ExamRegisteredCount: Registrations
ExamRegisteredCountOf num count: #{num}/#{count}
+ExamAutoOccurrenceExceptionRuleNoOp: Didn't chose an automatic distribution procedure
+ExamAutoOccurrenceExceptionNotEnoughSpace: More participants than available space
+ExamAutoOccurrenceExceptionNoUsers: No participants can be distributed with the chosen procedure
+ExamAutoOccurrenceExceptionRoomTooSmall: Automatic distribution failed. A different distribution procedure might succeed. Alternatively, minimizing rooms or removing small rooms might help.
NoFilter: No restriction
diff --git a/package.yaml b/package.yaml
index bd5247ac1..c9d092443 100644
--- a/package.yaml
+++ b/package.yaml
@@ -162,6 +162,8 @@ dependencies:
- nonce
- IntervalMap
- haskell-src-meta
+ - either
+
other-extensions:
- GeneralizedNewtypeDeriving
- IncoherentInstances
diff --git a/src/Handler/Exam/AutoOccurrence.hs b/src/Handler/Exam/AutoOccurrence.hs
index 1d4fe0b26..2715da603 100644
--- a/src/Handler/Exam/AutoOccurrence.hs
+++ b/src/Handler/Exam/AutoOccurrence.hs
@@ -23,7 +23,7 @@ newtype ExamAutoOccurrenceCalculateForm = ExamAutoOccurrenceCalculateForm
makeLenses_ ''ExamAutoOccurrenceCalculateForm
data ExamAutoOccurrenceAcceptForm = ExamAutoOccurrenceAcceptForm
- { eaofMapping :: Maybe (ExamOccurrenceMapping ExamOccurrenceId)
+ { eaofMapping :: ExamOccurrenceMapping ExamOccurrenceId
, eaofAssignment :: Map UserId (Maybe ExamOccurrenceId)
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
@@ -114,7 +114,12 @@ postEAutoOccurrenceR tid ssh csh examn = do
(Entity uid userRec, Entity _ ExamRegistration{..}) <- participants
return (uid, (userRec, examRegistrationOccurrence))
occurrences' = Map.fromList $ map (\(Entity eoId ExamOccurrence{..}) -> (eoId, fromIntegral examOccurrenceCapacity)) occurrences
- (eaofMapping, eaofAssignment) = examAutoOccurrence eId examOccurrenceRule eaofConfig occurrences' participants'
+ autoOccurrenceResult = examAutoOccurrence eId examOccurrenceRule eaofConfig occurrences' participants'
+ (eaofMapping, eaofAssignment) <- case autoOccurrenceResult of
+ (Left e) -> do
+ addMessageI Error e
+ redirect $ CExamR tid ssh csh examn EUsersR
+ (Right r) -> pure r
return $ Just ExamAutoOccurrenceAcceptForm{..}
((confirmRes, confirmView), confirmEncoding) <- runFormPost $ examAutoOccurrenceAcceptForm calcResult
@@ -126,14 +131,13 @@ postEAutoOccurrenceR tid ssh csh examn = do
formResult confirmRes $ \ExamAutoOccurrenceAcceptForm{..} -> do
Sum assignedCount <- runDB $ do
- let eaofMapping'' :: Maybe (Maybe (ExamOccurrenceMapping ExamOccurrenceName))
- eaofMapping'' = (<$> eaofMapping) . traverseExamOccurrenceMapping $ \eoId -> case filter ((== eoId) . entityKey) occurrences of
+ let eaofMapping'' :: Maybe (ExamOccurrenceMapping ExamOccurrenceName)
+ eaofMapping'' = ($ eaofMapping) . traverseExamOccurrenceMapping $ \eoId -> case filter ((== eoId) . entityKey) occurrences of
[Entity _ ExamOccurrence{..}] -> Just examOccurrenceName
_other -> Nothing
eaofMapping' <- case eaofMapping'' of
- Nothing -> return Nothing
- Just Nothing -> invalidArgsI [MsgExamAutoOccurrenceOccurrencesChangedInFlight]
- Just (Just x ) -> return $ Just x
+ Nothing -> invalidArgsI [MsgExamAutoOccurrenceOccurrencesChangedInFlight]
+ Just x -> return $ Just x
update eId [ ExamExamOccurrenceMapping =. eaofMapping' ]
fmap fold . iforM eaofAssignment $ \pid occ -> case occ of
Just _ -> Sum <$> updateWhereCount [ ExamRegistrationExam ==. eId, ExamRegistrationUser ==. pid, ExamRegistrationOccurrence ==. Nothing ] [ ExamRegistrationOccurrence =. occ ]
@@ -158,13 +162,13 @@ postEAutoOccurrenceR tid ssh csh examn = do
occLoad = fromMaybe 0 . flip Map.lookup occLoads
- occMappingRule = examOccurrenceMappingRule <$> eaofMapping
+ occMappingRule = examOccurrenceMappingRule eaofMapping
loadProp curr max'
| max' /= 0 = MsgProportion (toMessage curr) (toMessage max') (toRational curr / toRational max')
| otherwise = MsgProportionNoRatio (toMessage curr) (toMessage max')
- occMapping occId = examOccurrenceMappingDescriptionWidget <$> occMappingRule <*> (Map.lookup occId . examOccurrenceMappingMapping =<< eaofMapping)
+ occMapping occId = examOccurrenceMappingDescriptionWidget occMappingRule <$> Map.lookup occId (examOccurrenceMappingMapping eaofMapping)
in $(widgetFile "widgets/exam-occurrence-mapping")
siteLayoutMsg heading $ do
diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs
index 67d0b310e..10e4f9b00 100644
--- a/src/Handler/Utils/Exam.hs
+++ b/src/Handler/Utils/Exam.hs
@@ -9,6 +9,7 @@ module Handler.Utils.Exam
, ExamAutoOccurrenceConfig
, eaocMinimizeRooms, eaocFinenessCost, eaocNudge, eaocNudgeSize
, _eaocMinimizeRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize
+ , ExamAutoOccurrenceException(..)
, examAutoOccurrence
, deregisterExamUsersCount, deregisterExamUsers
, examAidsPresetWidget, examOnlinePresetWidget, examSynchronicityPresetWidget, examRequiredEquipmentPresetWidget
@@ -27,15 +28,15 @@ import Database.Esqueleto.Utils.TH
import qualified Data.Conduit.List as C
import qualified Data.Map as Map
+import qualified Data.Map.Merge.Lazy 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 System.Random.Shuffle (shuffle')
import Control.Monad.ST (ST, runST)
import Data.Array (Array)
@@ -47,9 +48,9 @@ import qualified Data.Array.ST as ST
import Data.List (findIndex, unfoldr)
import qualified Data.List as List
-import Data.ExtendedReal
+import Data.Either.Combinators (maybeToRight)
-import qualified Data.Char as Char
+import Data.ExtendedReal
import qualified Data.RFC5051 as RFC5051
@@ -257,6 +258,16 @@ deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1
} ''ExamAutoOccurrenceConfig
+data ExamAutoOccurrenceException
+ = ExamAutoOccurrenceExceptionRuleNoOp
+ | ExamAutoOccurrenceExceptionNotEnoughSpace
+ | ExamAutoOccurrenceExceptionNoUsers
+ | ExamAutoOccurrenceExceptionRoomTooSmall
+ deriving (Show, Generic, Typeable)
+
+instance Exception ExamAutoOccurrenceException
+
+embedRenderMessage ''UniWorX ''ExamAutoOccurrenceException id
examAutoOccurrence :: forall seed.
Hashable seed
@@ -265,28 +276,58 @@ examAutoOccurrence :: forall seed.
-> ExamAutoOccurrenceConfig
-> Map ExamOccurrenceId Natural
-> Map UserId (User, Maybe ExamOccurrenceId)
- -> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId))
+ -> Either ExamAutoOccurrenceException (ExamOccurrenceMapping ExamOccurrenceId, Map UserId (Maybe ExamOccurrenceId))
examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users
- | sum occurrences < usersCount
- || sum occurrences <= 0
- || Map.null users
- = nullResult
+ | Map.null users'
+ = Left ExamAutoOccurrenceExceptionNoUsers
+ | sum occurrences' < usersCount
+ || sum occurrences' <= 0
+ = Left ExamAutoOccurrenceExceptionNotEnoughSpace
| 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
+ -> Right ( ExamOccurrenceMapping {
+ examOccurrenceMappingRule = rule,
+ examOccurrenceMappingMapping = Map.fromList $ set _2 (Set.singleton ExamOccurrenceMappingRandom) <$> occurrences''
+ }
+ , Map.union (view _2 <$> assignedUsers) randomlyAssignedUsers
)
- _ | Just (postprocess -> (resMapping, result)) <- bestOption
- -> ( Just $ ExamOccurrenceMapping rule resMapping
- , Map.unionWith (<|>) (view _2 <$> users) result
- )
- _ -> nullResult
+ where
+ assignedUsers,unassignedUsers :: Map UserId (User, Maybe ExamOccurrenceId)
+ (assignedUsers, unassignedUsers) = Map.partition (has $ _2 . _Just) users
+ shuffledUsers :: [UserId]
+ shuffledUsers = shuffle' (Map.keys unassignedUsers) (length unassignedUsers) (mkStdGen seed)
+ occurrencesMap :: Map ExamOccurrenceId Natural
+ occurrencesMap = Map.fromList occurrences''
+ -- reduce available space until to excess space is left while keeping the filling ratio as equal as possible
+ decreaseBiggestOutlier :: Natural -> Map ExamOccurrenceId Natural -> Map ExamOccurrenceId Natural
+ decreaseBiggestOutlier 0 currentOccurrences = currentOccurrences
+ decreaseBiggestOutlier n currentOccurrences = decreaseBiggestOutlier (pred n)
+ $ Map.update predToPositive biggestOutlier currentOccurrences
+ where
+ currentRatios :: Map ExamOccurrenceId Rational
+ currentRatios = Map.merge Map.dropMissing Map.dropMissing (Map.zipWithMatched calculateRatio)
+ currentOccurrences occurrencesMap
+ calculateRatio :: ExamOccurrenceId -> Natural -> Natural -> Rational
+ calculateRatio k c m = fromIntegral c % fromIntegral m - eaocNudgeSize * fromIntegral (lineNudges k)
+ biggestOutlier :: ExamOccurrenceId
+ biggestOutlier = fst . List.maximumBy (comparing $ view _2) $ Map.toList currentRatios
+ extraCapacity :: Natural
+ extraCapacity = sumOf (folded . _2) occurrences'' - fromIntegral (length unassignedUsers)
+ finalOccurrences :: [(ExamOccurrenceId, Natural)]
+ finalOccurrences = Map.toList $ decreaseBiggestOutlier extraCapacity occurrencesMap
+ -- fill in users in a random order
+ randomlyAssignedUsers :: Map UserId (Maybe ExamOccurrenceId)
+ randomlyAssignedUsers = Map.fromList $ fst $ foldl' addUsers ([], shuffledUsers) finalOccurrences
+ addUsers :: ([(UserId, Maybe ExamOccurrenceId)], [UserId])
+ -> (ExamOccurrenceId, Natural)
+ -> ([(UserId, Maybe ExamOccurrenceId)], [UserId])
+ addUsers (acc, userList) (roomId, roomSize) = (map (, Just roomId) newUsers ++ acc, remainingUsers)
+ where
+ newUsers, remainingUsers :: [UserId]
+ (newUsers, remainingUsers) = List.genericSplitAt roomSize userList
+ _ -> bimap (ExamOccurrenceMapping rule) (Map.unionWith (<|>) (view _2 <$> users)) . postprocess <$> bestOption
where
- nullResult = (Nothing, view _2 <$> users)
usersCount :: forall a. Num a => a
usersCount = getSum $ foldMap (Sum . fromIntegral . Set.size) users'
@@ -306,24 +347,35 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
| (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
+ takeEnd n chars = drop (length chars - n) chars
+ in Map.mapKeysWith Set.union (takeEnd . F.minimum . Set.map length $ Map.keysSet matrUsers) matrUsers
+ _ | null users-> Map.empty
+ | otherwise -> 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
- occurrences' :: [(ExamOccurrenceId, Natural)]
+ 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 accomodate all participants, pick the one with
+ -- If a single occurrence can accommodate all participants, pick the one with
-- the least capacity
- occurrences'
+ occurrences''
| not eaocMinimizeRooms
- = Map.toList occurrences
- | Just largeEnoughs <- fromNullable . filter ((>= usersCount) . view _2) $ Map.toList occurrences
+ = 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
+ = view _2 . foldl' accF (0, []) . sortOn (Down . view _2) $ Map.toList occurrences'
where
accF :: (Natural, [(ExamOccurrenceId, Natural)])
-> (ExamOccurrenceId, Natural)
@@ -396,23 +448,31 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
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
+ -- 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
- let
- walkBack 0 = return 0
- walkBack i'' = fmap succ $ walkBack =<< ST.readArray breaks i''
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 = sumOf (folded . _2) $ drop lineIx lineLengths
breakCost'
+ | remainingWords > remainingLineSpace
+ = PosInf
| j < Map.size wordMap
, j > 0
= breakCost (wordIx # pred j) (wordIx # j)
@@ -431,21 +491,22 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
when (cost < minCost) $ do
ST.writeArray minima j cost
ST.writeArray breaks j i
- go i' $ succ j
+ go $ succ j
| otherwise = return ()
- in go i' $ succ i'
+ 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 -> accumResult (succ lineIx) i (accCost', accMap')
- | otherwise -> return (accCost', accMap')
- lineIxs = reverse $ map (view _1) lineLengths
+ 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, [])
@@ -460,7 +521,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
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'
+ longestLine = maximum . mapNonNull (view _2) $ impureNonNull occurrences''
lcp :: Eq a => [a] -> [a] -> [a]
@@ -473,18 +534,18 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
lineNudges = fromMaybe 0 . flip Map.lookup eaocNudge
- bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])]
+ bestOption :: Either ExamAutoOccurrenceException [(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
+ ExamRoomSurname -> maybeToRight ExamAutoOccurrenceExceptionRoomTooSmall $ 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
+ ExamRoomMatriculation -> maybeToRight ExamAutoOccurrenceExceptionRoomTooSmall $ 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
+ distributeFine n = distribute (usersFineness n) occurrences'' lineNudges charCost
maximumFineness = fromIntegral . F.minimum . Set.map length $ Map.keysSet users'
@@ -510,7 +571,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
(_cost, res) <- fmap (minimumBy . comparing $ view _1) . fromNullable $ genResults 1
return res
- _other -> Nothing
+ _other -> Left ExamAutoOccurrenceExceptionRuleNoOp
postprocess :: [(ExamOccurrenceId, [[CI Char]])]
-> ( Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription)
@@ -518,63 +579,135 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
)
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)
+ maxTagLength :: Int
+ maxTagLength = maybe 0 maximum $ fromNullable $ concatMap (map length . snd) result
+
+ rangeAlphabet :: [CI Char]
+ rangeAlphabet = case rule of
+ ExamRoomSurname -> map CI.mk ['A'..'Z']
+ ExamRoomMatriculation-> map CI.mk ['0'..'9']
+ _rule -> []
+
+ resultAscList :: Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription)
+ resultAscList = case fromNullable rangeAlphabet of
+ Nothing -> Map.empty
+ (Just alphabet) -> Map.fromList $ go (singleton $ head alphabet) 1 [] result
+ where
+ go :: NonNull [CI Char]
+ -> Int
+ -> [(ExamOccurrenceId, Set ExamOccurrenceMappingDescription)]
+ -> [(ExamOccurrenceId, [[CI Char]])]
+ -> [(ExamOccurrenceId, Set ExamOccurrenceMappingDescription)]
+ go _start _borderLength acc [] = acc
+ -- special case necessary, so ranges always end on last alphabet
+ go start _borderLength acc [(_occurrenceId, [])] = case acc of
+ [] -> []
+ ((occurrenceId, mappingDescription):t) -> (occurrenceId, Set.map extendEnd mappingDescription) : t
+ where
+ extendEnd :: ExamOccurrenceMappingDescription -> ExamOccurrenceMappingDescription
+ extendEnd ExamOccurrenceMappingRange {eaomrStart} = ExamOccurrenceMappingRange {eaomrStart, eaomrEnd}
+ extendEnd examOccurrenceMappingSpecial = examOccurrenceMappingSpecial
+ eaomrEnd :: [CI Char]
+ eaomrEnd = replicate (length start) $ last alphabet
+ go start borderLength acc ((_occurrenceId, []):t) = go start borderLength acc t
+ go start borderLength acc ((occurrenceId, userTags):t)
+ | matchMappingDescription mappingDescription userTags
+ && (null t || toNullable nextStart > end)
+ = go nextStart borderLength ((occurrenceId, mappingDescription) : acc) t
+ | borderLength < maxTagLength
+ = go restartStart restartBorderLength [] result
| 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)
+ = [] -- shouldn't happen, but ensures termination on invalid input (e.g. non-monotonic)
+ where
+ restartBorderLength :: Int
+ restartBorderLength = succ borderLength
+
+ restartStart :: NonNull [CI Char]
+ restartStart = case rule of
+ ExamRoomMatriculation -> impureNonNull $ replicate restartBorderLength $ head alphabet
+ _rule -> singleton $ head alphabet
+
+ mappingDescription :: Set ExamOccurrenceMappingDescription
+ mappingDescription
+ -- if start > end, the room only consists of users with a non-ascii tag directly adjacent to the last room
+ -- therefore, leave out a potentially confusing range description
+ | toNullable start > end = Set.fromList specialMapping
+ | otherwise = Set.fromList $ ExamOccurrenceMappingRange (toNullable start) end : specialMapping
+
+ specialMapping :: [ExamOccurrenceMappingDescription]
+ specialMapping
+ = [ExamOccurrenceMappingSpecial {eaomrSpecial=tag}
+ | (transformTag borderLength -> tag) <- userTags
+ , not $ all (`elem` alphabet) tag]
+
+ -- | pre/suffix of largest user tag
+ -- special (i.e. non-ascii) tags use the largest smaller ascii-char according to RFC5051.compareUnicode,
+ -- ending the tag with ..ZZZ-padding
+ end :: [CI Char]
+ end = case t of
+ [] -> replicate borderLength $ last alphabet
+ _nonEmpty -> withAlphabetChars
+ $ transformTag borderLength
+ $ maximumBy (\a b -> RFC5051.compareUnicode (pack $ map CI.foldedCase a) (pack $ map CI.foldedCase b))
+ -- userTags is guaranteed non-null
+ $ impureNonNull userTags
+ where
+ withAlphabetChars :: [CI Char] -> [CI Char]
+ withAlphabetChars [] = []
+ withAlphabetChars (c:cs)
+ | c `elem` alphabet = c : withAlphabetChars cs
+ | otherwise= case previousAlphabetChar c of
+ Nothing -> []
+ (Just c') -> c' : replicate (length cs) (last alphabet)
+ previousAlphabetChar :: CI Char -> Maybe (CI Char)
+ previousAlphabetChar c = fmap last $ fromNullable $ nfilter ((== GT) . compareChars c) alphabet
+ compareChars :: CI Char -> CI Char -> Ordering
+ compareChars a b = RFC5051.compareUnicode (pack [CI.foldedCase a]) (pack [CI.foldedCase b])
+ nextStart :: NonNull [CI Char]
+ -- end is guaranteed nonNull, all empty tags are filtered out in users'
+ nextStart
+ | length end < borderLength
+ = impureNonNull $ end <> [head alphabet]
+ | otherwise
+ = 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, rule == ExamRoomMatriculation
+ = nextChar : increase cs
+ | nextChar == head alphabet
+ = increase cs
+ | otherwise
+ = nextChar : cs
+ where
+ nextChar :: CI Char
+ nextChar
+ | c `elem` alphabet
+ = dropWhile (/= c) alphabetCycle List.!! 1
+ | otherwise -- shouldn't happen, simply use head alphabet as a fallback
+ = head alphabet
+
+ transformTag :: Int -> [CI Char] -> [CI Char]
+ transformTag l tag = case rule of
+ ExamRoomMatriculation -> drop (max 0 $ length tag - l) tag
+ _rule -> take l tag
+
+ matchMappingDescription :: Set ExamOccurrenceMappingDescription -> [[CI Char]] -> Bool
+ matchMappingDescription mappingDescription userTags = flip all userTags $ \tag -> flip any mappingDescription $ \case
+ ExamOccurrenceMappingRange {eaomrStart, eaomrEnd}
+ -- non-rangeAlphabet-chars get a special mapping, so <= is fine here
+ -> (eaomrStart <= transformTag (length eaomrStart) tag) && (transformTag (length eaomrEnd) tag <= eaomrEnd)
+ ExamOccurrenceMappingSpecial {eaomrSpecial} -> checkSpecial eaomrSpecial tag
+ where
+ checkSpecial :: [CI Char] -> [CI Char] -> Bool
+ checkSpecial = case rule of
+ ExamRoomMatriculation -> isSuffixOf
+ _rule -> isPrefixOf
+ ExamOccurrenceMappingRandom -> False -- Something went wrong, throw an error instead?
+
+ resultUsers :: Map UserId (Maybe ExamOccurrenceId)
resultUsers = Map.fromList $ do
(occId, buckets) <- result
let matchWord b b' = case rule of
@@ -585,30 +718,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
diff --git a/src/Model/Types/Changelog.hs b/src/Model/Types/Changelog.hs
index bc07b524a..1285782d5 100644
--- a/src/Model/Types/Changelog.hs
+++ b/src/Model/Types/Changelog.hs
@@ -29,21 +29,22 @@ makePrisms ''ChangelogItemKind
classifyChangelogItem :: ChangelogItem -> ChangelogItemKind
classifyChangelogItem = \case
- ChangelogHaskellCampusLogin -> ChangelogItemBugfix
- ChangelogTooltipsWithoutJavascript -> ChangelogItemBugfix
- ChangelogButtonsWorkWithoutJavascript -> ChangelogItemBugfix
- ChangelogTableFormsWorkAfterAjax -> ChangelogItemBugfix
- ChangelogPassingByPointsWorks -> ChangelogItemBugfix
- ChangelogErrorMessagesForTableItemVanish -> ChangelogItemBugfix
- ChangelogExamAchievementParticipantDuplication -> ChangelogItemBugfix
- ChangelogFormsTimesReset -> ChangelogItemBugfix
- ChangelogAllocationCourseAcceptSubstitutesFixed -> ChangelogItemBugfix
- ChangelogStoredMarkup -> ChangelogItemBugfix
- ChangelogFixPersonalisedSheetFilesKeep -> ChangelogItemBugfix
- ChangelogHonorRoomHidden -> ChangelogItemBugfix
- ChangelogFixSheetBonusRounding -> ChangelogItemBugfix
- ChangelogFixExamBonusAllSheetsBonus -> ChangelogItemBugfix
- _other -> ChangelogItemFeature
+ ChangelogHaskellCampusLogin -> ChangelogItemBugfix
+ ChangelogTooltipsWithoutJavascript -> ChangelogItemBugfix
+ ChangelogButtonsWorkWithoutJavascript -> ChangelogItemBugfix
+ ChangelogTableFormsWorkAfterAjax -> ChangelogItemBugfix
+ ChangelogPassingByPointsWorks -> ChangelogItemBugfix
+ ChangelogErrorMessagesForTableItemVanish -> ChangelogItemBugfix
+ ChangelogExamAchievementParticipantDuplication -> ChangelogItemBugfix
+ ChangelogFormsTimesReset -> ChangelogItemBugfix
+ ChangelogAllocationCourseAcceptSubstitutesFixed -> ChangelogItemBugfix
+ ChangelogStoredMarkup -> ChangelogItemBugfix
+ ChangelogFixPersonalisedSheetFilesKeep -> ChangelogItemBugfix
+ ChangelogHonorRoomHidden -> ChangelogItemBugfix
+ ChangelogFixSheetBonusRounding -> ChangelogItemBugfix
+ ChangelogFixExamBonusAllSheetsBonus -> ChangelogItemBugfix
+ ChangelogExamAutomaticRoomDistributionRespectSize -> ChangelogItemBugfix
+ _other -> ChangelogItemFeature
changelogItemDays :: Map ChangelogItem Day
changelogItemDays = Map.fromListWithKey (\k d1 d2 -> bool (error $ "Duplicate changelog days for " <> show k) d1 $ d1 /= d2)
diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs
index 1a9cb0ef4..3910f402a 100644
--- a/src/Model/Types/Exam.hs
+++ b/src/Model/Types/Exam.hs
@@ -191,6 +191,7 @@ examOccurrenceRuleAutomatic x = any ($ x)
data ExamOccurrenceMappingDescription
= ExamOccurrenceMappingRange { eaomrStart, eaomrEnd :: [CI Char] }
| ExamOccurrenceMappingSpecial { eaomrSpecial :: [CI Char] }
+ | ExamOccurrenceMappingRandom
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1
diff --git a/templates/i18n/changelog/exam-automatic-room-distribution-respect-size.de-de-formal.hamlet b/templates/i18n/changelog/exam-automatic-room-distribution-respect-size.de-de-formal.hamlet
new file mode 100644
index 000000000..41a2fd613
--- /dev/null
+++ b/templates/i18n/changelog/exam-automatic-room-distribution-respect-size.de-de-formal.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Diverse Verbesserungen an der automatischen Zuteilung von Klausurteilnehmern auf Termine/Räume
diff --git a/templates/i18n/changelog/exam-automatic-room-distribution-respect-size.en-eu.hamlet b/templates/i18n/changelog/exam-automatic-room-distribution-respect-size.en-eu.hamlet
new file mode 100644
index 000000000..a9b07c71d
--- /dev/null
+++ b/templates/i18n/changelog/exam-automatic-room-distribution-respect-size.en-eu.hamlet
@@ -0,0 +1,2 @@
+$newline never
+Several improvements for the automated distribution of exam participants to occurrences/rooms
diff --git a/templates/i18n/exam-auto-occurrence-calculate/de-de-formal.hamlet b/templates/i18n/exam-auto-occurrence-calculate/de-de-formal.hamlet
index ef8c4e35b..7db981398 100644
--- a/templates/i18n/exam-auto-occurrence-calculate/de-de-formal.hamlet
+++ b/templates/i18n/exam-auto-occurrence-calculate/de-de-formal.hamlet
@@ -1,12 +1,11 @@
$newline never
- Bei der Berechnung der Verteilung werden stets alle #
- Klausurteilnehmer berücksichtigt, unabhängig davon, ob ihnen bereits #
- ein Raum/Termin zugewiesen ist, oder nicht.
+ Bei der Berechnung der Verteilung werden nur neu zugewiesene #
+ Klausurteilnehmer berücksichtigt.
- Es werden dennoch nur Klausurteilnehmer anhand der neu berechneten #
+ Es werden nur Klausurteilnehmer anhand der neu berechneten #
Verteilung zugewiesen, die aktuell keinen zugewiesenen Raum/Termin #
haben.
diff --git a/templates/i18n/exam-auto-occurrence-calculate/en-eu.hamlet b/templates/i18n/exam-auto-occurrence-calculate/en-eu.hamlet
index a6b938066..8161a3680 100644
--- a/templates/i18n/exam-auto-occurrence-calculate/en-eu.hamlet
+++ b/templates/i18n/exam-auto-occurrence-calculate/en-eu.hamlet
@@ -1,18 +1,17 @@
$newline never
- When assignment rules are calculated all exam participants are #
- considered, regardless of whether they are already assigned to an #
- occurrence/room.
+ When assignment rules are calculated only newly assigned #
+ exam participants are considered.
- Nonetheless only exam participants, who are not already assigned to #
+ Only exam participants, who are not already assigned to #
an occurrence/room, will be assigned according to the newly #
calculated assignment rules.
- Thus calculating new assignment rules multiple times may lead to a #
+ Thus, calculating new assignment rules multiple times may lead to a #
situation in which the occurrence/room assignments of most #
participants do not match the newest assignment rules.
diff --git a/templates/i18n/implementation/de-de-formal.hamlet b/templates/i18n/implementation/de-de-formal.hamlet
index 23876d482..03418198d 100644
--- a/templates/i18n/implementation/de-de-formal.hamlet
+++ b/templates/i18n/implementation/de-de-formal.hamlet
@@ -29,3 +29,4 @@ $newline never
Steffen Jost
Gregor Kleen
Sarah Vaupel
+ Wolfgang Witt
diff --git a/templates/i18n/implementation/en-eu.hamlet b/templates/i18n/implementation/en-eu.hamlet
index ead3e0dbd..ca7ddead0 100644
--- a/templates/i18n/implementation/en-eu.hamlet
+++ b/templates/i18n/implementation/en-eu.hamlet
@@ -28,3 +28,4 @@ $newline never
Steffen Jost
Gregor Kleen
Sarah Vaupel
+ Wolfgang Witt
diff --git a/templates/widgets/exam-occurrence-mapping-description.hamlet b/templates/widgets/exam-occurrence-mapping-description.hamlet
index 356911383..d4caa6628 100644
--- a/templates/widgets/exam-occurrence-mapping-description.hamlet
+++ b/templates/widgets/exam-occurrence-mapping-description.hamlet
@@ -13,3 +13,5 @@ $newline never
#{titleCase special}…
$else
…#{titleCase special}
+ $of ExamOccurrenceMappingRandom
+ _{MsgExamRoomMappingRandomHere}
diff --git a/templates/widgets/exam-occurrence-mapping.hamlet b/templates/widgets/exam-occurrence-mapping.hamlet
index 0d0b87940..4383169af 100644
--- a/templates/widgets/exam-occurrence-mapping.hamlet
+++ b/templates/widgets/exam-occurrence-mapping.hamlet
@@ -6,16 +6,18 @@ $newline never
_{MsgExamRoomName}
_{MsgExamRoomLoad}
- $maybe rule <- occMappingRule
- $case rule
- $of ExamRoomSurname
- |
- _{MsgExamRoomMappingSurname}
- $of ExamRoomMatriculation
- |
- _{MsgExamRoomMappingMatriculation}
- $of _
- |
+ $case occMappingRule
+ $of ExamRoomSurname
+ |
+ _{MsgExamRoomMappingSurname}
+ $of ExamRoomMatriculation
+ |
+ _{MsgExamRoomMappingMatriculation}
+ $of ExamRoomRandom
+ |
+ _{MsgExamRoomMappingRandom}
+ $of _
+ |
|
_{MsgExamRoom}
|
diff --git a/test/Handler/Utils/ExamSpec.hs b/test/Handler/Utils/ExamSpec.hs
new file mode 100644
index 000000000..839e186f3
--- /dev/null
+++ b/test/Handler/Utils/ExamSpec.hs
@@ -0,0 +1,374 @@
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
+
+module Handler.Utils.ExamSpec (spec) where
+
+import TestImport
+import Data.Universe (Universe, Finite, universeF)
+
+import ModelSpec () -- instance Arbitrary User
+
+import Test.Hspec.QuickCheck (prop)
+import Test.HUnit.Lang (HUnitFailure(..), FailureReason(..))
+
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.Text as Text
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Foldable as Foldable
+
+import qualified Data.RFC5051 as RFC5051
+
+import Handler.Utils.Exam
+
+
+-- direct copy&paste from an (currently) unmerged pull request for hspec-expectations
+-- https://github.com/hspec/hspec-expectations/blob/6b4a475e42b0d44008c150727dea25dd79f568f2/src/Test/Hspec/Expectations.hs
+-- |
+-- If you have a test case that has multiple assertions, you can use the
+-- 'annotate' function to provide a string message that will be attached to
+-- the 'Expectation'.
+--
+-- @
+-- describe "annotate" $ do
+-- it "adds the message" $ do
+-- annotate "obvious falsehood" $ do
+-- True `shouldBe` False
+--
+-- ========>
+--
+-- 1) annotate, adds the message
+-- obvious falsehood
+-- expected: False
+-- but got: True
+-- @
+myAnnotate :: HasCallStack => String -> Expectation -> Expectation
+myAnnotate msg = handle $ \(HUnitFailure loc exn) ->
+ throwIO $ HUnitFailure loc $ case exn of
+ Reason str ->
+ Reason $ msg ++
+ if null str then str else ": " <> str
+ ExpectedButGot mmsg expected got ->
+ let
+ mmsg' =
+ Just $ msg <> maybe "" (": " <>) mmsg
+ in
+ ExpectedButGot mmsg' expected got
+
+
+instance Arbitrary ExamOccurrence where
+ arbitrary = ExamOccurrence
+ <$> arbitrary -- examOccurrenceExam
+ <*> arbitrary -- examOccurrenceName
+ <*> arbitrary -- examOccurrenceRoom
+ <*> arbitrary -- examOccurrenceRoomHidden
+ <*> frequency [(let d = fromIntegral i in ceiling $ 100 * exp(- d*d / 50), pure i) | i <- [10 ..1000]] -- examOccurrenceCapacity
+ <*> arbitrary -- examOccurrenceStart
+ <*> arbitrary -- examOccurrenceEnd
+ <*> arbitrary -- examOccurrenceDescription
+
+
+data Preselection = NoPreselection | SomePreselection
+ deriving stock (Show, Bounded, Enum)
+ deriving anyclass (Universe, Finite)
+
+data Nudges = NoNudges | SmallNudges | LargeNudges
+ deriving stock (Show, Bounded, Enum)
+ deriving anyclass (Universe, Finite)
+
+uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
+uncurry3 f (a, b, c) = f a b c
+
+uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
+uncurry4 f (a, b, c, d) = f a b c d
+
+-- | Kopie der User-Datenstruktur beschränkt auf interessante Felder (besser verständliche Show-Instanz)
+newtype UserProperties = UserProperties {user :: User}
+
+instance Show UserProperties where
+ --show :: UserProperties -> String
+ show UserProperties {user=User {userSurname, userMatrikelnummer}}
+ = "User {userSurname=" ++ show userSurname
+ ++ ", userMatrikelnummer=" ++ show userMatrikelnummer ++ "}"
+
+-- function Handler.Utils.examAutoOccurrence
+spec :: Spec
+spec = do
+ describe "examAutoOccurrence" $ do
+ describe "Surname" $ testWithRule ExamRoomSurname
+ describe "Matriculation" $ testWithRule ExamRoomMatriculation
+ describe "Random" $ testWithRule ExamRoomRandom
+ where
+ testWithRule :: ExamOccurrenceRule -> Spec
+ testWithRule rule =
+ forM_ universeF $ \nudges -> describe (show nudges) $
+ forM_ universeF $ \preselection ->
+ prop (show preselection) $ propertyTest rule nudges preselection
+ seed :: ()
+ seed = ()
+ propertyTest :: ExamOccurrenceRule -> Nudges -> Preselection -> Gen Property
+ propertyTest rule nudges preselection = do
+ (users, occurrences) <- genUsersWithOccurrences preselection
+ eaocNudge <- case nudges of
+ NoNudges -> pure Map.empty
+ SmallNudges -> let nudgeFrequency = [(10, 0), (5, 1), (5, -1), (3, 2), (3, -2), (1, 3), (1, -3)]
+ in foldM (genNudge nudgeFrequency) Map.empty $ Map.keys occurrences
+ LargeNudges -> let nudgeFrequency = [(7, 0), (5, 3), (5, -3), (3, 6), (3, -6), (2, 9), (2, -9),
+ (2, 11), (2, -11), (1, 15), (1,-15), (1, 17), (1, -17)]
+ in foldM (genNudge nudgeFrequency) Map.empty $ Map.keys occurrences
+ let config :: ExamAutoOccurrenceConfig
+ config = def {eaocNudge}
+ autoOccurrenceResult = examAutoOccurrence seed rule config occurrences users
+ pure $ ioProperty $ do
+ let userProperties :: Map UserId (UserProperties, Maybe ExamOccurrenceId)
+ userProperties = Map.map (first UserProperties) users
+ case autoOccurrenceResult of
+ (Right (occurrenceMapping, userMap)) -> do
+ -- user count stays constant
+ myAnnotate "number of users changed" $ shouldBe (length userMap) (length users)
+ -- no room is overfull
+ myAnnotate "room capacity exceeded" $ shouldSatisfy (userProperties, occurrences, userMap) $ uncurry3 fitsInRooms
+ -- mapping is a valid description
+ myAnnotate "invalid mapping description" $ shouldSatisfy (rule, occurrenceMapping) $ uncurry validRangeDescription
+ -- every (relevant) user got assigned a room
+ let foldFn :: (UserId, Maybe ExamOccurrenceId) -> Bool -> Bool
+ foldFn _userMapping False = False
+ foldFn (_userId, Just _occurrenceId) True = True
+ foldFn (userId, Nothing) True
+ = (rule == ExamRoomMatriculation)
+ -- every user with a userMatrikelnummer got a room
+ -- fail on unknown user
+ || maybe False (isNothing . userMatrikelnummer . fst) (Map.lookup userId users)
+ myAnnotate "user didn't get a room" $ shouldSatisfy userMap $ foldr foldFn True . Map.toList
+ -- all users match the shown ranges
+ myAnnotate "shown ranges don't match userMap"
+ $ shouldSatisfy (rule, userProperties, occurrenceMapping, userMap) $ uncurry4 showsCorrectRanges
+ -- is a nullResult justified?
+ (Left autoOccurrenceException) ->
+ -- disabled for now, probably not correct with the current implementation
+ myAnnotate "unjustified nullResult"
+ $ shouldSatisfy (autoOccurrenceException, rule, userProperties, occurrences) $ uncurry4 isNullResultJustified
+ -- | generate users without any pre-assigned rooms
+ genUsersWithOccurrences :: Preselection -> Gen (Map UserId (User, Maybe ExamOccurrenceId), Map ExamOccurrenceId Natural)
+ genUsersWithOccurrences preselection = do
+ rawUsers <- scale (50 *) $ listOf $ Entity <$> arbitrary <*> arbitrary
+ occurrences <- genOccurrences $ length rawUsers
+ -- user surnames anpassen, sodass interessante instanz
+ users <- fmap Map.fromList $ forM rawUsers $ \Entity {entityKey, entityVal} -> do
+ userSurname <- elements surnames
+ assignedRoom <- case preselection of
+ NoPreselection -> pure Nothing
+ SomePreselection -> frequency [(97, pure Nothing), (3, elements $ map Just $ Map.keys occurrences)]
+ pure (entityKey, (entityVal {userSurname}, assignedRoom))
+ pure (users, occurrences)
+ genOccurrences :: Int -> Gen (Map ExamOccurrenceId Natural)
+ genOccurrences numUsers = do
+ -- extra space to allow nice borders
+ extraSpace <- elements [numUsers `div` 5 .. numUsers `div` 2]
+ let totalSpaceRequirement = fromIntegral $ numUsers + extraSpace
+ createOccurrences acc
+ | sum (map snd acc) < totalSpaceRequirement = do
+ Entity {entityKey, entityVal} <- Entity <$> arbitrary <*> arbitrary
+ createOccurrences $ (entityKey, fromIntegral $ examOccurrenceCapacity entityVal) : acc
+ | otherwise = pure acc
+ Map.fromList <$> createOccurrences []
+ genNudge :: [(Int, Integer)] -> Map ExamOccurrenceId Integer -> ExamOccurrenceId -> Gen (Map ExamOccurrenceId Integer)
+ genNudge nudgesList acc occurrenceId
+ = fmap appendNonZero $ frequency $ map (second pure) nudgesList
+ where
+ appendNonZero :: Integer -> Map ExamOccurrenceId Integer
+ appendNonZero 0 = acc
+ appendNonZero nudge = Map.insert occurrenceId nudge acc
+ -- name list copied from test/Database/Fill.hs
+ surnames :: [Text]
+ surnames = [ "Smith", "Johnson", "Williams", "Brown"
+ , "Jones", "Miller", "Davis", "Garcia"
+ , "Rodriguez", "Wilson", "Martinez", "Anderson"
+ , "Taylor", "Thomas", "Hernandez", "Moore"
+ , "Martin", "Jackson", "Thompson", "White"
+ , "Lopez", "Lee", "Gonzalez", "Harris"
+ , "Clark", "Lewis", "Robinson", "Walker"
+ , "Perez", "Hall", "Young", "zu Allen", "Fu"
+ , "Meier", "Meyer", "Maier", "Mayer"
+ , "Meir", "Müller", "Schulze", "Schmitt"
+ , "FTB Modul", "Mártinèz", "zu Walker", "Schmidt"
+ , "Únîcòdé", "Ähm-Ümlaüte", "von Leerzeichen"
+ ]
+ occurrenceMap :: Map UserId (Maybe ExamOccurrenceId) -> Map ExamOccurrenceId [UserId]
+ occurrenceMap userMap = foldl' (\acc (userId, maybeOccurrenceId) -> appendJust maybeOccurrenceId userId acc)
+ Map.empty $ Map.toAscList userMap
+ where
+ appendJust :: Maybe ExamOccurrenceId -> UserId -> Map ExamOccurrenceId [UserId] -> Map ExamOccurrenceId [UserId]
+ appendJust Nothing _userId = id
+ appendJust (Just occurrenceId) userId = Map.insertWith (++) occurrenceId [userId]
+ -- | Are all rooms large enough to hold all assigned Users?
+ fitsInRooms :: Map UserId (UserProperties, Maybe ExamOccurrenceId)
+ -> Map ExamOccurrenceId Natural
+ -> Map UserId (Maybe ExamOccurrenceId)
+ -> Bool
+ fitsInRooms userProperties occurrences userMap
+ = all roomIsBigEnough $ Map.toAscList $ occurrenceMap userMap
+ where
+ roomIsBigEnough :: (ExamOccurrenceId, [UserId]) -> Bool
+ roomIsBigEnough (roomId, userIds) = case lookup roomId occurrences of
+ Nothing -> False
+ (Just capacity) -> length userIds <= fromIntegral capacity
+ || all (isJust . snd) (Map.restrictKeys userProperties $ Set.fromList userIds)
+ -- | No range overlap for different rooms + end is always the greater value
+ validRangeDescription :: ExamOccurrenceRule -> ExamOccurrenceMapping ExamOccurrenceId -> Bool
+ validRangeDescription rule ExamOccurrenceMapping {examOccurrenceMappingMapping}
+ = all (\(roomId, ranges) -> all (descriptionValid roomId) ranges) $ Map.toAscList examOccurrenceMappingMapping
+ where
+ descriptionValid:: ExamOccurrenceId -> ExamOccurrenceMappingDescription -> Bool
+ descriptionValid roomId description
+ = endAfterStart description
+ && all (all $ noDirectOverlap description) (Map.delete roomId examOccurrenceMappingMapping)
+ endAfterStart :: ExamOccurrenceMappingDescription -> Bool
+ endAfterStart
+ ExamOccurrenceMappingRange {eaomrStart=(pack . map CI.foldedCase -> start), eaomrEnd=(pack . map CI.foldedCase -> end)}
+ = RFC5051.compareUnicode start end /= GT
+ endAfterStart _mappingDescription = True
+ -- also check for equal length with ExamRoomMatriculation
+ noDirectOverlap :: ExamOccurrenceMappingDescription -> ExamOccurrenceMappingDescription -> Bool
+ noDirectOverlap ExamOccurrenceMappingRandom other = other == ExamOccurrenceMappingRandom
+ noDirectOverlap other ExamOccurrenceMappingRandom = other == ExamOccurrenceMappingRandom
+ noDirectOverlap
+ ExamOccurrenceMappingRange {eaomrStart=cs0@(pack . map CI.foldedCase -> s0), eaomrEnd=ce0@(pack . map CI.foldedCase -> e0)}
+ ExamOccurrenceMappingRange {eaomrStart=cs1@(pack . map CI.foldedCase -> s1), eaomrEnd=ce1@(pack . map CI.foldedCase -> e1)}
+ = equalLengthForMatriculation [cs0, ce0, cs1, ce1]
+ && ((RFC5051.compareUnicode s0 s1 == LT && RFC5051.compareUnicode e0 s1 == LT)
+ || (RFC5051.compareUnicode s0 e1 == GT && RFC5051.compareUnicode e0 s1 == GT))
+ noDirectOverlap
+ ExamOccurrenceMappingRange {eaomrStart, eaomrEnd}
+ ExamOccurrenceMappingSpecial {eaomrSpecial}
+ = equalLengthForMatriculation [eaomrStart, eaomrEnd, eaomrSpecial]
+ && noDirectOverlapRangeSpecial eaomrStart eaomrEnd eaomrSpecial
+ noDirectOverlap
+ ExamOccurrenceMappingSpecial {eaomrSpecial}
+ ExamOccurrenceMappingRange {eaomrStart, eaomrEnd}
+ = equalLengthForMatriculation [eaomrStart, eaomrEnd, eaomrSpecial]
+ && noDirectOverlapRangeSpecial eaomrStart eaomrEnd eaomrSpecial
+ noDirectOverlap ExamOccurrenceMappingSpecial {eaomrSpecial=s0} ExamOccurrenceMappingSpecial {eaomrSpecial=s1}
+ = equalLengthForMatriculation [s0, s1] && s0 /= s1
+ equalLengthForMatriculation :: [[CI Char]] -> Bool
+ equalLengthForMatriculation [] = True
+ equalLengthForMatriculation (h:t) = (rule /= ExamRoomMatriculation) || all (== length h) (length <$> t)
+ noDirectOverlapRangeSpecial :: [CI Char] -> [CI Char] -> [CI Char] -> Bool
+ noDirectOverlapRangeSpecial
+ (pack . map CI.foldedCase -> start)
+ (pack . map CI.foldedCase -> end)
+ (pack . map CI.foldedCase -> special)
+ = RFC5051.compareUnicode special start == LT || RFC5051.compareUnicode special end == GT
+ -- RFC5051.compareUnicode :: Text -> Text -> Ordering
+ -- | Does the (currently surname) User fit to the displayed ranges?
+ -- Users with a previously assigned room are checked if the assignment stays the same, regardless of the ranges.
+ showsCorrectRanges :: ExamOccurrenceRule
+ -> Map UserId (UserProperties, Maybe ExamOccurrenceId)
+ -> ExamOccurrenceMapping ExamOccurrenceId
+ -> Map UserId (Maybe ExamOccurrenceId)
+ -> Bool
+ showsCorrectRanges rule userProperties ExamOccurrenceMapping {examOccurrenceMappingMapping} userMap
+ = all userFitsInRange $ Map.toAscList $ occurrenceMap userMap
+ where
+ userFitsInRange :: (ExamOccurrenceId, [UserId]) -> Bool
+ userFitsInRange (roomId, userIds) = flip all userIds $ \userId ->
+ case (Map.lookup roomId examOccurrenceMappingMapping, Map.lookup userId userProperties) of
+ (_maybeRanges, Just (_userProperty, Just fixedRoomId))
+ -> roomId == fixedRoomId
+ (Just ranges, Just (UserProperties User {userSurname, userMatrikelnummer}, Nothing))
+ -> any fitsInRange ranges
+ where
+ ciTag :: Maybe [CI Char]
+ ciTag = map CI.mk . Text.unpack <$> case rule of
+ ExamRoomSurname
+ | Text.null userSurname -> Nothing
+ | otherwise-> Just userSurname
+ ExamRoomMatriculation
+ | maybe True Text.null userMatrikelnummer -> Nothing
+ | otherwise -> userMatrikelnummer
+ _rule -> Nothing
+ fitsInRange :: ExamOccurrenceMappingDescription -> Bool
+ fitsInRange mappingDescription = case (ciTag, mappingDescription) of
+ (_tag, ExamOccurrenceMappingRandom) -> True
+ (Nothing, _mappingDescription) -> True
+ (Just tag, ExamOccurrenceMappingRange {eaomrStart=(pack . map CI.foldedCase -> start), eaomrEnd=(pack . map CI.foldedCase-> end)})
+ -> (RFC5051.compareUnicode start (pack $ map CI.foldedCase $ transformTag start tag) /= GT)
+ && (RFC5051.compareUnicode end (pack $ map CI.foldedCase $ transformTag end tag) /= LT)
+ (Just tag, ExamOccurrenceMappingSpecial {eaomrSpecial})
+ -> checkSpecial eaomrSpecial tag
+ transformTag :: (MonoFoldable f) => f -> [CI Char] -> [CI Char]
+ transformTag (length -> rangeLength) = case rule of
+ ExamRoomMatriculation -> reverse . take rangeLength . reverse
+ _rule -> take rangeLength
+ checkSpecial :: [CI Char] -> [CI Char] -> Bool
+ checkSpecial = case rule of
+ ExamRoomMatriculation -> isSuffixOf
+ _rule -> isPrefixOf
+ _otherwise -> (rule /= ExamRoomSurname) && (rule /= ExamRoomMatriculation)
+ -- | Is mapping impossible due to the given reason?
+ isNullResultJustified :: ExamAutoOccurrenceException
+ -> ExamOccurrenceRule
+ -> Map UserId (UserProperties, Maybe ExamOccurrenceId)
+ -> Map ExamOccurrenceId Natural -> Bool
+ isNullResultJustified ExamAutoOccurrenceExceptionRuleNoOp rule _userProperties _occurrences
+ = not $ examOccurrenceRuleAutomatic rule
+ isNullResultJustified ExamAutoOccurrenceExceptionNotEnoughSpace rule userProperties occurrences
+ = fromIntegral (length $ relevantUsers rule userProperties) > sum occurrences
+ isNullResultJustified ExamAutoOccurrenceExceptionNoUsers rule userProperties _occurrences
+ = noRelevantUsers rule userProperties
+ isNullResultJustified ExamAutoOccurrenceExceptionRoomTooSmall rule userProperties occurrences
+ = mappingImpossiblePlausible rule userProperties occurrences
+ noRelevantUsers :: ExamOccurrenceRule -> Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Bool
+ noRelevantUsers rule = null . relevantUsers rule
+ relevantUsers :: ExamOccurrenceRule
+ -> Map UserId (UserProperties, Maybe ExamOccurrenceId)
+ -> Map UserId (UserProperties, Maybe ExamOccurrenceId)
+ relevantUsers rule = Map.filter $ isRelevantUser rule
+ isRelevantUser :: ExamOccurrenceRule -> (UserProperties, Maybe ExamOccurrenceId) -> Bool
+ isRelevantUser _rule (_user, Just _assignedRoom) = False
+ isRelevantUser rule (UserProperties User {userSurname, userMatrikelnummer}, Nothing) = case rule of
+ ExamRoomSurname -> not $ null userSurname
+ ExamRoomMatriculation -> maybe False (not . null) userMatrikelnummer
+ ExamRoomRandom -> True
+ _rule -> False
+ mappingImpossiblePlausible :: ExamOccurrenceRule -> Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map ExamOccurrenceId Natural -> Bool
+ mappingImpossiblePlausible
+ rule
+ userProperties@(sortBy RFC5051.compareUnicode . mapRuleProperty rule . Map.elems . relevantUsers rule -> users')
+ (map snd . Map.toList . adjustOccurrences userProperties -> occurrences') = go 0 users' occurrences'
+ where
+ smallestRoom :: Natural
+ smallestRoom = maybe 0 minimum $ fromNullable occurrences'
+ -- If there exists a bucket with the same tag bigger than the smallest room a nullResult might be returned
+ -- It may still work, but is not guaranteed (e.g. both the first bucket)
+ go :: forall a. Eq a => Natural -> [a] -> [Natural] -> Bool
+ go biggestUserBucket [] _occurrences = biggestUserBucket > smallestRoom
+ go _biggestUserBucket _remainingUsers [] = True
+ go biggestUserBucket remainingUsers (0:t) = go biggestUserBucket remainingUsers t
+ go biggestUserBucket remainingUsers@(h:_t) (firstOccurrence:laterOccurrences)
+ | nextUsers <= firstOccurrence
+ = go (max biggestUserBucket nextUsers) remainingUsers' $ firstOccurrence - nextUsers : laterOccurrences
+ | otherwise
+ = go biggestUserBucket remainingUsers laterOccurrences
+ where
+ nextUsers :: Natural
+ remainingUsers' :: [a]
+ (fromIntegral . length -> nextUsers, remainingUsers') = span (== h) remainingUsers
+ mapRuleProperty :: ExamOccurrenceRule -> [(UserProperties, b)] -> [Text]
+ mapRuleProperty rule (map fst -> users') = map (ruleProperty rule minMatrLength) users'
+ where
+ minMatrLength :: Int
+ minMatrLength = Foldable.minimum $ map (maybe 0 Text.length . userMatrikelnummer . user) users'
+ ruleProperty :: ExamOccurrenceRule -> Int -> UserProperties -> Text
+ ruleProperty rule n = case rule of
+ ExamRoomSurname -> userSurname . user
+ ExamRoomMatriculation -> maybe Text.empty (Text.takeEnd n) . userMatrikelnummer . user
+ _rule -> const $ pack $ show rule
+ -- copied and adjusted from Hander.Utils.Exam
+ adjustOccurrences :: Map UserId (UserProperties, Maybe ExamOccurrenceId) -> Map ExamOccurrenceId Natural -> Map ExamOccurrenceId Natural
+ -- ^ reduce room capacity for every pre-assigned user by 1
+ adjustOccurrences userProperties occurrences
+ = foldl' (flip $ Map.update predToPositive) (Map.filter (> 0) occurrences) $ Map.mapMaybe snd userProperties
+ predToPositive :: Natural -> Maybe Natural
+ predToPositive 0 = Nothing
+ predToPositive 1 = Nothing
+ predToPositive n = Just $ pred n
|