From b2d6eada176dd201daf0d40661a701da6e144257 Mon Sep 17 00:00:00 2001 From: Wolfgang Witt Date: Fri, 19 Mar 2021 11:57:30 +0100 Subject: [PATCH] refactor: calculate mimizeRooms before examAutoOccurrence --- src/Handler/Exam/AutoOccurrence.hs | 88 ++++++++++++++++++++---------- src/Handler/Utils/Exam.hs | 47 ++++------------ test/Handler/Utils/ExamSpec.hs | 2 +- 3 files changed, 72 insertions(+), 65 deletions(-) diff --git a/src/Handler/Exam/AutoOccurrence.hs b/src/Handler/Exam/AutoOccurrence.hs index f8d2908cf..9de43a616 100644 --- a/src/Handler/Exam/AutoOccurrence.hs +++ b/src/Handler/Exam/AutoOccurrence.hs @@ -52,19 +52,43 @@ instance Button UniWorX ExamAutoOccurrenceButton where btnClasses _ = [BCIsButton, BCPrimary] -examAutoOccurrenceCalculateForm :: ExamAutoOccurrenceCalculateForm -> Form ExamAutoOccurrenceCalculateForm -examAutoOccurrenceCalculateForm ExamAutoOccurrenceCalculateForm{ eaofConfig } +examAutoOccurrenceCalculateForm :: Map ExamOccurrenceId ExamOccurrenceCapacity + -> 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 False = def - ignoreRooms :: ExamAutoOccurrenceIgnoreRooms -> Bool - ignoreRooms EAOIRAutomatic = True - ignoreRooms EAOIRManual {eaoirmSorted} = eaoirmSorted + automaticIfTrue True = ExamAutoOccurrenceIgnoreRooms {eaoirIgnored, eaoirSorted=True} + automaticIfTrue False = ExamAutoOccurrenceIgnoreRooms {eaoirIgnored=Set.empty, eaoirSorted=False} + minimizeRooms :: ExamAutoOccurrenceIgnoreRooms -> Bool + minimizeRooms ExamAutoOccurrenceIgnoreRooms {eaoirSorted} = eaoirSorted + 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 EAOIRManual {eaoirmIgnored, eaoirmSorted} = EAOIRManual {eaoirmIgnored=setAction occId eaoirmIgnored, eaoirmSorted} - setAction = case btn of + action = 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 - 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 - autoOccurrenceResult = examAutoOccurrence eId examOccurrenceRule eaofConfig occurrences' participants' - (eaofMapping, eaofAssignment, ignoredOccurrences) <- case autoOccurrenceResult of + + calcResult <- formResultMaybe calculateRes' $ \ExamAutoOccurrenceCalculateForm{..} -> do + let autoOccurrenceResult = examAutoOccurrence eId examOccurrenceRule eaofConfig occurrences' participants' + (eaofMapping, eaofAssignment) <- 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 diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index a3cf09c7f..df5b2c6d4 100644 --- a/src/Handler/Utils/Exam.hs +++ b/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 - | EAOIRManual {eaoirmIgnored :: Set ExamOccurrenceId, eaoirmSorted :: Bool} + = ExamAutoOccurrenceIgnoreRooms {eaoirIgnored :: Set ExamOccurrenceId, eaoirSorted :: 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 - -- - -- Prefer occurrences with higher capacity - -- - -- 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 - ) + -- ^ Only use non-ignored occurrences + -- Sort by size if specified (here increasing, since it is reversed later) + occurrences'' = case eaocIgnoreRooms of + ExamAutoOccurrenceIgnoreRooms {..} -> ((if eaoirSorted then sortOn (view _2) else id) $ Map.toList $ Map.withoutKeys occurrences' eaoirIgnored) 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 diff --git a/test/Handler/Utils/ExamSpec.hs b/test/Handler/Utils/ExamSpec.hs index 12617d859..c0675a2cd 100644 --- a/test/Handler/Utils/ExamSpec.hs +++ b/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