chore: allow ignoring occurances based on a curated set

src/Handler/Utils/Exam.hs

@@ -7,8 +7,8 @@ module Handler.Utils.Exam
   , examResultBonus, examGrade
   , examBonusGrade
   , ExamAutoOccurrenceConfig
-  , eaocMinimizeRooms, eaocFinenessCost, eaocNudge, eaocNudgeSize
-  , _eaocMinimizeRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize
+  , eaocIgnoreRooms, eaocFinenessCost, eaocNudge, eaocNudgeSize
+  , _eaocIgnoreRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize
   , ExamAutoOccurrenceException(..)
   , examAutoOccurrence
   , deregisterExamUsersCount, deregisterExamUsers
@@ -217,9 +217,18 @@ examBonusGrade exam@Exam{..} bonusInp = (mBonus, ) . examGrade exam mBonus
         bonusPossible = normalSummary <$> sheetSummary
         bonusAchieved = (<>) <$> fmap normalSummary sheetSummary <*> fmap bonusSummary sheetSummary
 
+data ExamAutoOccurrenceIgnoreRooms = EAOIRAutomatic | EAOIRManual (Set ExamOccurrenceId)
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+instance Default ExamAutoOccurrenceIgnoreRooms where
+  def = EAOIRManual Set.empty
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  } ''ExamAutoOccurrenceIgnoreRooms
 
 data ExamAutoOccurrenceConfig = ExamAutoOccurrenceConfig
-  { eaocMinimizeRooms :: Bool
+  { eaocIgnoreRooms   :: ExamAutoOccurrenceIgnoreRooms
   , eaocFinenessCost  :: Rational -- ^ Cost factor incentivising shorter common prefixes on breaks between rooms
   , eaocNudge         :: Map ExamOccurrenceId Integer
   , eaocNudgeSize     :: Rational
@@ -227,7 +236,7 @@ data ExamAutoOccurrenceConfig = ExamAutoOccurrenceConfig
 
 instance Default ExamAutoOccurrenceConfig where
   def = ExamAutoOccurrenceConfig
-    { eaocMinimizeRooms = False
+    { eaocIgnoreRooms   = def
     , eaocFinenessCost  = 0.2
     , eaocNudge         = Map.empty
     , eaocNudgeSize     = 0.05
@@ -257,7 +266,8 @@ examAutoOccurrence :: forall seed.
                    -> ExamAutoOccurrenceConfig
                    -> Map ExamOccurrenceId ExamOccurrenceCapacity
                    -> Map UserId (User, Maybe ExamOccurrenceId)
-                   -> Either ExamAutoOccurrenceException (ExamOccurrenceMapping ExamOccurrenceId, Map UserId (Maybe ExamOccurrenceId))
+                   -> Either ExamAutoOccurrenceException
+                      (ExamOccurrenceMapping ExamOccurrenceId, Map UserId (Maybe ExamOccurrenceId), Set ExamOccurrenceId)
 examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users
   | Map.null users'
   = Left ExamAutoOccurrenceExceptionNoUsers
@@ -271,6 +281,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
               examOccurrenceMappingMapping = Map.fromList $ set _2 (Set.singleton ExamOccurrenceMappingRandom) <$> occurrences''
             }
            , Map.union (view _2 <$> assignedUsers) randomlyAssignedUsers
+           , ignoredOccurrences
            )
            where
              assignedUsers,unassignedUsers :: Map UserId (User, Maybe ExamOccurrenceId)
@@ -352,7 +363,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
              fillUnrestricted [] _ = error "fillUnrestricted should only be called with an infinite list"
              fillUnrestricted (nextRoom:followingRooms) (acc, nextUser:remainingUsers)
               = fillUnrestricted followingRooms ((nextUser, Just nextRoom) : acc, remainingUsers)
-      _ -> bimap (ExamOccurrenceMapping rule) (Map.unionWith (<|>) (view _2 <$> users)) . postprocess <$> bestOption
+      _ -> over _1 (ExamOccurrenceMapping rule) . over _2 (Map.unionWith (<|>) (view _2 <$> users)) . postprocess <$> bestOption
   where
     usersCount :: forall a. Num a => a
     usersCount = getSum $ foldMap (Sum . fromIntegral . Set.size) users'
@@ -394,30 +405,33 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
         predToPositive (Restricted n) = Just $ Restricted $ pred n
 
     occurrences'' :: [(ExamOccurrenceId, ExamOccurrenceCapacity)]
+    ignoredOccurrences :: Set ExamOccurrenceId
     -- ^ Minimise number of occurrences used
     --
     -- Prefer occurrences with higher capacity
     --
     -- If a single occurrence can accommodate all participants, pick the one with
     -- the least capacity
-    occurrences''
-      | not eaocMinimizeRooms
-      = Map.toList occurrences'
-      | Just largeEnoughs <- fromNullable . filter ((>= Restricted usersCount) . view _2) $ Map.toList occurrences'
-      = pure $ minimumBy (comparing $ view _2) largeEnoughs
-      | otherwise
-      = view _2 . foldl' accF (Restricted 0, []) . sortOn (Down . view _2) $ Map.toList occurrences'
-      where
-        accF :: (ExamOccurrenceCapacity, [(ExamOccurrenceId, ExamOccurrenceCapacity)])
-             -> (ExamOccurrenceId, ExamOccurrenceCapacity)
-             -> (ExamOccurrenceCapacity, [(ExamOccurrenceId, ExamOccurrenceCapacity)])
-        accF acc@(accSize, accOccs) occ@(_, occSize)
-          | accSize >= Restricted usersCount
-          = acc
-          | otherwise
-          = ( accSize <> occSize
-            , occ : accOccs
-            )
+    (occurrences'', ignoredOccurrences) = case eaocIgnoreRooms of
+      (EAOIRManual manuallyIgnored) -> (Map.toList $ Map.restrictKeys occurrences' manuallyIgnored, manuallyIgnored)
+      EAOIRAutomatic -- effect of ticked minimizeRooms Checkbox
+        | Just largeEnoughs <- fromNullable . filter ((>= Restricted usersCount) . view _2) $ Map.toList occurrences'
+        -> let pickedLargeEnough = minimumBy (comparing $ view _2) largeEnoughs
+            in (pure pickedLargeEnough, Set.delete (view _1 pickedLargeEnough) $ Map.keysSet occurrences')
+        | otherwise
+        -> (\(_,b,c) -> (b,c)) . foldl' accF (Restricted 0, [], Set.empty) . sortOn (Down . view _2) $ Map.toList occurrences'
+        where
+          accF :: (ExamOccurrenceCapacity, [(ExamOccurrenceId, ExamOccurrenceCapacity)], Set ExamOccurrenceId)
+              -> (ExamOccurrenceId, ExamOccurrenceCapacity)
+              -> (ExamOccurrenceCapacity, [(ExamOccurrenceId, ExamOccurrenceCapacity)], Set ExamOccurrenceId)
+          accF (accSize, accOccs, accIgnored) occ@(occId, occSize)
+            | accSize >= Restricted usersCount
+            = (accSize, accOccs, Set.insert occId accIgnored)
+            | otherwise
+            = ( accSize <> occSize
+              , occ : accOccs
+              , accIgnored
+              )
     
     partitionRestricted :: ([a], [(a, Natural)]) -> [(a,ExamOccurrenceCapacity)] -> ([a], [(a, Natural)])
     partitionRestricted acc []                   = acc
@@ -646,8 +660,9 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
     postprocess :: [(ExamOccurrenceId, [[CI Char]])]
                 -> ( Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription)
                    , Map UserId (Maybe ExamOccurrenceId)
+                   , Set ExamOccurrenceId
                    )
-    postprocess result = (resultAscList, resultUsers)
+    postprocess result = (resultAscList, resultUsers, ignoredOccurrences)
       where
         maxTagLength :: Int
         maxTagLength = maybe 0 maximum $ fromNullable $ concatMap (map length . snd) result