fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore: allow ignoring occurances based on a curated set

Browse Source
This commit is contained in:
Wolfgang Witt 2021-03-17 15:49:38 +01:00 committed by Gregor Kleen
parent ddb68eeb98
commit 25262aa7a5
1 changed files with 40 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

65
src/Handler/Utils/Exam.hs
View File

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