refactor: calculate mimizeRooms before examAutoOccurrence

src/Handler/Exam/AutoOccurrence.hs

@@ -52,19 +52,43 @@ instance Button UniWorX ExamAutoOccurrenceButton where
   btnClasses _ = [BCIsButton, BCPrimary]
 
 
-examAutoOccurrenceCalculateForm :: ExamAutoOccurrenceCalculateForm -> Form ExamAutoOccurrenceCalculateForm
+examAutoOccurrenceCalculateForm :: Map ExamOccurrenceId ExamOccurrenceCapacity
-examAutoOccurrenceCalculateForm ExamAutoOccurrenceCalculateForm{ eaofConfig }
+                                -> Map UserId (User, Maybe ExamOccurrenceId)
+                                -> ExamAutoOccurrenceCalculateForm
+                                -> Form ExamAutoOccurrenceCalculateForm
+examAutoOccurrenceCalculateForm occurrences (fromIntegral . length -> usersCount) ExamAutoOccurrenceCalculateForm { eaofConfig }
   = identifyForm FIDExamAutoOccurrenceCalculate . renderAForm FormStandard $ ExamAutoOccurrenceCalculateForm <$> eaocForm
   where
     eaocForm =
-      (set _eaocIgnoreRooms . automaticIfTrue <$> apopt checkBoxField (fslI MsgExamAutoOccurrenceMinimizeRooms & setTooltip MsgExamAutoOccurrenceMinimizeRoomsTip) (Just . ignoreRooms $ eaofConfig ^. _eaocIgnoreRooms))
+      (set _eaocIgnoreRooms . automaticIfTrue <$> apopt checkBoxField (fslI MsgExamAutoOccurrenceMinimizeRooms & setTooltip MsgExamAutoOccurrenceMinimizeRoomsTip) (Just . minimizeRooms $ eaofConfig ^. _eaocIgnoreRooms))
       <*> pure def
     automaticIfTrue :: Bool -> ExamAutoOccurrenceIgnoreRooms
-    automaticIfTrue True  = EAOIRAutomatic
+    automaticIfTrue True  = ExamAutoOccurrenceIgnoreRooms {eaoirIgnored, eaoirSorted=True}
-    automaticIfTrue False = def
+    automaticIfTrue False = ExamAutoOccurrenceIgnoreRooms {eaoirIgnored=Set.empty, eaoirSorted=False}
-    ignoreRooms :: ExamAutoOccurrenceIgnoreRooms -> Bool
+    minimizeRooms :: ExamAutoOccurrenceIgnoreRooms -> Bool
-    ignoreRooms EAOIRAutomatic = True
+    minimizeRooms ExamAutoOccurrenceIgnoreRooms {eaoirSorted} = eaoirSorted
-    ignoreRooms EAOIRManual {eaoirmSorted} = eaoirmSorted
+    eaoirIgnored :: 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
+    eaoirIgnored
+      | Just largeEnoughs <- fromNullable . filter ((>= Restricted usersCount) . view _2) $ Map.toList occurrences
+      = Set.delete (view _1 $ minimumBy (comparing $ view _2) largeEnoughs) $ Map.keysSet occurrences
+      | otherwise
+      = Set.fromList . view _2 . foldl' accF (Restricted 0, [])
+          . sortOn (Down . view _2) $ Map.toList occurrences
+      where
+        accF :: (ExamOccurrenceCapacity, [ExamOccurrenceId])
+            -> (ExamOccurrenceId, ExamOccurrenceCapacity)
+            -> (ExamOccurrenceCapacity, [ExamOccurrenceId])
+        accF (accSize, accIgnored) (occId, occSize)
+          | accSize >= Restricted usersCount
+          = (accSize, occId:accIgnored)
+          | otherwise
+          = (accSize <> occSize, accIgnored)
 
 examAutoOccurrenceNudgeForm :: ExamOccurrenceId -> Maybe ExamAutoOccurrenceCalculateForm -> Form ExamAutoOccurrenceCalculateForm
 examAutoOccurrenceNudgeForm occId protoForm html = do
@@ -86,16 +110,20 @@ examAutoOccurrenceNudgeForm occId protoForm html = do
 examAutoOccurrenceIgnoreRoomsForm :: ExamOccurrenceId -> Maybe ExamAutoOccurrenceCalculateForm -> Form ExamAutoOccurrenceCalculateForm
 examAutoOccurrenceIgnoreRoomsForm occId protoForm html = do
   cID <- encrypt occId
-  (btnRes, wgt) <- identifyForm (FIDExamAutoOccurrenceIgnoreRoom $ ciphertext cID) (buttonForm' [BtnExamAutoOccurrenceIgnore, BtnExamAutoOccurrenceReconsider]) html
   oldDataRes <- globalPostParamField PostExamAutoOccurrencePrevious secretJsonField
   oldDataId <- newIdent
+  let shownButtons = case eaocIgnoreRooms . eaofConfig $ fromMaybe def oldDataRes of
+        ExamAutoOccurrenceIgnoreRooms {eaoirIgnored}
+          | Set.member occId eaoirIgnored
+          -> [BtnExamAutoOccurrenceReconsider]
+          | otherwise
+          -> [BtnExamAutoOccurrenceIgnore]
+  (btnRes, wgt) <- identifyForm (FIDExamAutoOccurrenceIgnoreRoom $ ciphertext cID) (buttonForm' shownButtons) html
 
   let protoForm' = fromMaybe def $ protoForm <|> oldDataRes
-      genForm btn = protoForm' & _eaofConfig . _eaocIgnoreRooms %~ action
+      genForm btn = protoForm' & _eaofConfig . _eaocIgnoreRooms . _eaoirIgnored %~ action occId
         where
-          action EAOIRAutomatic = EAOIRManual {eaoirmIgnored=setAction occId Set.empty, eaoirmSorted=True}
+          action = case btn of
-          action EAOIRManual {eaoirmIgnored, eaoirmSorted} = EAOIRManual {eaoirmIgnored=setAction occId eaoirmIgnored, eaoirmSorted}
-          setAction = case btn of
             BtnExamAutoOccurrenceIgnore     -> Set.insert
             BtnExamAutoOccurrenceReconsider -> Set.delete
             _other                          -> flip const   -- i.e. ignore argument
@@ -112,7 +140,7 @@ examAutoOccurrenceAcceptForm confirmData = identifyForm FIDExamAutoOccurrenceCon
 
 examAutoOccurrenceCalculateWidget :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Widget
 examAutoOccurrenceCalculateWidget tid ssh csh examn = do
-  (formView, formEncoding) <- liftHandler . generateFormPost $ examAutoOccurrenceCalculateForm def
+  (formView, formEncoding) <- liftHandler . generateFormPost $ examAutoOccurrenceCalculateForm Map.empty Map.empty def
 
   wrapForm' BtnExamAutoOccurrenceCalculate $(i18nWidgetFile "exam-auto-occurrence-calculate") def
     { formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR
@@ -128,7 +156,20 @@ postEAutoOccurrenceR tid ssh csh examn = do
     return (exam, occurrences)
 
 
-  ((calculateRes, _), _) <- runFormPost $ examAutoOccurrenceCalculateForm def
+  participants <- runDB $ E.select . E.from $ \(registration `E.InnerJoin` user) -> do
+      E.on $ registration E.^. ExamRegistrationUser E.==. user E.^. UserId
+      E.where_ $ registration E.^. ExamRegistrationExam E.==. E.val eId
+      return (user, registration)
+  let participants' = Map.fromList $ do
+        (Entity uid userRec, Entity _ ExamRegistration{..}) <- participants
+        return (uid, (userRec, examRegistrationOccurrence))
+      occurrences' = Map.fromList $ map (\(Entity eoId ExamOccurrence{..}) -> (eoId, _examOccurrenceCapacityIso # (fromIntegral <$> examOccurrenceCapacity))) occurrences
+  ((calculateRes, _), _) <- runFormPost $ examAutoOccurrenceCalculateForm occurrences' participants' def
+
+  liftIO $ do
+    putStrLn "-------------------"
+    print calculateRes
+    putStrLn "-------------------"
 
   (nudgeRes, ignoreRes) <- mdo
     nudgeRes <- sequence . flip Map.fromSet (setOf (folded . _entityKey) occurrences) $ \occId ->
@@ -140,17 +181,10 @@ postEAutoOccurrenceR tid ssh csh examn = do
 
   let calculateRes' = asum $ calculateRes : nudgeRes ^.. folded . _1 . _1 ++ ignoreRes ^.. folded . _1 . _1
 
-  calcResult <- formResultMaybe calculateRes' $ \ExamAutoOccurrenceCalculateForm{..} -> runDB $ do
+
-    participants <- E.select . E.from $ \(registration `E.InnerJoin` user) -> do
+  calcResult <- formResultMaybe calculateRes' $ \ExamAutoOccurrenceCalculateForm{..} -> do
-      E.on $ registration E.^. ExamRegistrationUser E.==. user E.^. UserId
+    let autoOccurrenceResult = examAutoOccurrence eId examOccurrenceRule eaofConfig occurrences' participants'
-      E.where_ $ registration E.^. ExamRegistrationExam E.==. E.val eId
+    (eaofMapping, eaofAssignment) <- case autoOccurrenceResult of
-      return (user, registration)
-    let participants' = Map.fromList $ do
-          (Entity uid userRec, Entity _ ExamRegistration{..}) <- participants
-          return (uid, (userRec, examRegistrationOccurrence))
-        occurrences' = Map.fromList $ map (\(Entity eoId ExamOccurrence{..}) -> (eoId, _examOccurrenceCapacityIso # (fromIntegral <$> examOccurrenceCapacity))) occurrences
-        autoOccurrenceResult = examAutoOccurrence eId examOccurrenceRule eaofConfig occurrences' participants'
-    (eaofMapping, eaofAssignment, ignoredOccurrences) <- case autoOccurrenceResult of
       (Left e) -> do
         addMessageI Error e
         pure ( ExamOccurrenceMapping {
@@ -158,10 +192,8 @@ postEAutoOccurrenceR tid ssh csh examn = do
               examOccurrenceMappingMapping = Map.empty
             }
            , Map.map (view _2) participants'
-           , eaocIgnoreRooms eaofConfig
            )
       (Right r) -> pure r
-    -- TODO use returned ignoredOccurrences
     return $ Just ExamAutoOccurrenceAcceptForm{..}
 
   ((confirmRes, confirmView), confirmEncoding) <- runFormPost $ examAutoOccurrenceAcceptForm calcResult

src/Handler/Utils/Exam.hs

@@ -9,6 +9,7 @@ module Handler.Utils.Exam
   , ExamAutoOccurrenceConfig, ExamAutoOccurrenceIgnoreRooms(..)
   , eaocIgnoreRooms, eaocFinenessCost, eaocNudge, eaocNudgeSize
   , _eaocIgnoreRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize
+  , ExamAutoOccurrenceIgnoreRooms(..), _eaoirIgnored, _eaoirSorted
   , ExamAutoOccurrenceException(..)
   , examAutoOccurrence
   , deregisterExamUsersCount, deregisterExamUsers
@@ -219,12 +220,13 @@ examBonusGrade exam@Exam{..} bonusInp = (mBonus, ) . examGrade exam mBonus
         bonusAchieved = (<>) <$> fmap normalSummary sheetSummary <*> fmap bonusSummary sheetSummary
 
 data ExamAutoOccurrenceIgnoreRooms
-  = EAOIRAutomatic
+  = ExamAutoOccurrenceIgnoreRooms {eaoirIgnored :: Set ExamOccurrenceId, eaoirSorted :: Bool}
-  | EAOIRManual {eaoirmIgnored :: Set ExamOccurrenceId, eaoirmSorted :: Bool}
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
 
 instance Default ExamAutoOccurrenceIgnoreRooms where
-  def = EAOIRManual Set.empty False
+  def = ExamAutoOccurrenceIgnoreRooms Set.empty False
+
+makeLenses_ ''ExamAutoOccurrenceIgnoreRooms
 
 deriveJSON defaultOptions
   { fieldLabelModifier = camelToPathPiece' 1
@@ -270,7 +272,7 @@ examAutoOccurrence :: forall seed.
                    -> Map ExamOccurrenceId ExamOccurrenceCapacity
                    -> Map UserId (User, Maybe ExamOccurrenceId)
                    -> Either ExamAutoOccurrenceException
-                      (ExamOccurrenceMapping ExamOccurrenceId, Map UserId (Maybe ExamOccurrenceId), ExamAutoOccurrenceIgnoreRooms)
+                      (ExamOccurrenceMapping ExamOccurrenceId, Map UserId (Maybe ExamOccurrenceId))
 examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users
   | Map.null users'
   = Left ExamAutoOccurrenceExceptionNoUsers
@@ -284,7 +286,6 @@ 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)
@@ -408,35 +409,10 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
         predToPositive (Restricted n) = Just $ Restricted $ pred n
 
     occurrences'' :: [(ExamOccurrenceId, ExamOccurrenceCapacity)]
-    -- ^ Minimise number of occurrences used
+    -- ^ Only use non-ignored occurrences
-    --
+    -- Sort by size if specified (here increasing, since it is reversed later)
-    -- Prefer occurrences with higher capacity
+    occurrences'' = case eaocIgnoreRooms of
-    --
+      ExamAutoOccurrenceIgnoreRooms {..} -> ((if eaoirSorted then sortOn (view _2) else id) $ Map.toList $ Map.withoutKeys occurrences' eaoirIgnored)
-    -- If a single occurrence can accommodate all participants, pick the one with
-    -- the least capacity
-    ignoredOccurrences :: ExamAutoOccurrenceIgnoreRooms
-    -- ^ will always be EAOIRManual with eaoirSorted noting if occurrences were downwards sorted by size
-    (occurrences'', ignoredOccurrences) = case eaocIgnoreRooms of
-      EAOIRManual {..} -> ((if eaoirmSorted then sortOn (view _2) else id) $ Map.toList $ Map.withoutKeys occurrences' eaoirmIgnored, eaocIgnoreRooms)
-      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, EAOIRManual {eaoirmIgnored=Set.delete (view _1 pickedLargeEnough) $ Map.keysSet occurrences', eaoirmSorted=True})
-        | otherwise
-        -> (\(_, used, unused) -> (used, EAOIRManual {eaoirmIgnored=Set.fromList unused, eaoirmSorted=True}))
-            . foldl' accF (Restricted 0, [], []) . sortOn (Down . view _2) $ Map.toList occurrences'
-        where
-          accF :: (ExamOccurrenceCapacity, [(ExamOccurrenceId, ExamOccurrenceCapacity)], [ExamOccurrenceId])
-              -> (ExamOccurrenceId, ExamOccurrenceCapacity)
-              -> (ExamOccurrenceCapacity, [(ExamOccurrenceId, ExamOccurrenceCapacity)], [ExamOccurrenceId])
-          accF (accSize, accOccs, accIgnored) occ@(occId, occSize)
-            | accSize >= Restricted usersCount
-            = (accSize, accOccs, occId:accIgnored)
-            | otherwise
-            = ( accSize <> occSize
-              , occ : accOccs
-              , accIgnored
-              )
     
     partitionRestricted :: ([a], [(a, Natural)]) -> [(a,ExamOccurrenceCapacity)] -> ([a], [(a, Natural)])
     partitionRestricted acc []                   = acc
@@ -666,9 +642,8 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences
     postprocess :: [(ExamOccurrenceId, [[CI Char]])]
                 -> ( Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription)
                    , Map UserId (Maybe ExamOccurrenceId)
-                   , ExamAutoOccurrenceIgnoreRooms
                    )
-    postprocess result = (resultAscList, resultUsers, ignoredOccurrences)
+    postprocess result = (resultAscList, resultUsers)
       where
         maxTagLength :: Int
         maxTagLength = maybe 0 maximum $ fromNullable $ concatMap (map length . snd) result

test/Handler/Utils/ExamSpec.hs

@@ -122,7 +122,7 @@ spec = do
                 let userProperties :: Map UserId (UserProperties, Maybe ExamOccurrenceId)
                     userProperties = Map.map (first UserProperties) users
                 case autoOccurrenceResult of
-                    (Right (occurrenceMapping, userMap, _ignoredRooms)) -> do
+                    (Right (occurrenceMapping, userMap)) -> do
                         -- user count stays constant
                         myAnnotate "number of users changed" $ shouldBe (length userMap) (length users)
                         -- no room is overfull