refactor: calculate mimizeRooms before examAutoOccurrence
This commit is contained in:
Wolfgang Witt
Gregor Kleen
parent
d5bd5042ad
commit
b2d6eada17
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user