chore: rewrite ExamRoomRandom mapping, so it actually respects room sizes

src/Handler/Utils/Exam.hs

@@ -1,4 +1,5 @@
 {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
+{-# OPTIONS_GHC -Wwarn #-}
 
 module Handler.Utils.Exam
   ( fetchExamAux
@@ -264,7 +265,7 @@ examAutoOccurrence :: forall seed.
                    -> Map ExamOccurrenceId Natural
                    -> Map UserId (User, Maybe ExamOccurrenceId)
                    -> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId))
-examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users
+examAutoOccurrence (hash -> seed) rule config@ExamAutoOccurrenceConfig{..} occurrences users
   | sum occurrences' < usersCount
     || sum occurrences' <= 0
     || Map.null users'
@@ -273,11 +274,39 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
   = 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
+           , Map.union (Map.map snd assignedUsers) randomlyAssignedUsers
            )
+           where
+             assignedUsers,unassignedUsers :: Map UserId (User, Maybe ExamOccurrenceId)
+             (assignedUsers, unassignedUsers) = Map.partition (isJust . snd) 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 (Ratio Natural)
+                currentRatios = Map.merge Map.dropMissing Map.dropMissing (Map.zipWithMatched $ const (%)) currentOccurrences occurrencesMap
+                biggestOutlier :: ExamOccurrenceId
+                biggestOutlier = fst $ List.maximumBy (\a b -> compare (snd a) (snd b)) $ Map.toList currentRatios
+             extraCapacity :: Natural
+             extraCapacity = sum (map snd 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
       _ | Just (postprocess -> (resMapping, result)) <- bestOption
           -> ( Just $ ExamOccurrenceMapping rule resMapping
              , Map.unionWith (<|>) (view _2 <$> users) result