Merge branch 'exam-rooms' into 'master'

Fix problems with examAutoOccurence

See merge request uni2work/uni2work!33

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
+CourseSortingOnlyLoggedIn: Das Benutzerinterface zur Sortierung dieser Tabelle ist nur für eingeloggte Benutzer aktiv

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
 

package.yaml

@@ -162,6 +162,8 @@ dependencies:
   - nonce
   - IntervalMap
   - haskell-src-meta
+  - either
+
 other-extensions:
   - GeneralizedNewtypeDeriving
   - IncoherentInstances

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

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

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)

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

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

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

templates/i18n/exam-auto-occurrence-calculate/de-de-formal.hamlet

@@ -1,12 +1,11 @@
 $newline never
 <p>
-  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.
 
   <br />
 
-  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.
 

templates/i18n/exam-auto-occurrence-calculate/en-eu.hamlet

@@ -1,18 +1,17 @@
 $newline never
 <p>
-  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.
 
   <br />
 
-  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.
 
   <br />
 
-  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.
 

templates/i18n/implementation/de-de-formal.hamlet

@@ -29,3 +29,4 @@ $newline never
     <li>Steffen Jost
     <li>Gregor Kleen
     <li>Sarah Vaupel
+    <li>Wolfgang Witt

templates/i18n/implementation/en-eu.hamlet

@@ -28,3 +28,4 @@ $newline never
     <li>Steffen Jost
     <li>Gregor Kleen
     <li>Sarah Vaupel
+    <li>Wolfgang Witt

templates/widgets/exam-occurrence-mapping-description.hamlet

@@ -13,3 +13,5 @@ $newline never
             #{titleCase special}…
           $else
             …#{titleCase special}
+        $of ExamOccurrenceMappingRandom
+          _{MsgExamRoomMappingRandomHere}

templates/widgets/exam-occurrence-mapping.hamlet

@@ -6,16 +6,18 @@ $newline never
         _{MsgExamRoomName}
       <th .table__th colspan=2>
         _{MsgExamRoomLoad}
-      $maybe rule <- occMappingRule
-        $case rule
-          $of ExamRoomSurname
-            <th .table__th>
-              _{MsgExamRoomMappingSurname}
-          $of ExamRoomMatriculation
-            <th .table__th>
-              _{MsgExamRoomMappingMatriculation}
-          $of _
-            <th .table__td>
+      $case occMappingRule
+        $of ExamRoomSurname
+          <th .table__th>
+            _{MsgExamRoomMappingSurname}
+        $of ExamRoomMatriculation
+          <th .table__th>
+            _{MsgExamRoomMappingMatriculation}
+        $of ExamRoomRandom
+          <th .table__th>
+            _{MsgExamRoomMappingRandom}
+        $of _
+          <th .table__td>
       <th .table__th>
         _{MsgExamRoom}
       <th .table__th>

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