From a91fd7fd6387e82331d881ec32e830fd59634d9d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 30 Jan 2020 17:24:22 +0100 Subject: [PATCH] feat: exam auto-occurrence nudging --- frontend/src/app.sass | 7 ++ messages/uniworx/de-de-formal.msg | 2 + messages/uniworx/en-eu.msg | 2 + src/Handler/Exam/AutoOccurrence.hs | 41 +++++++++- src/Handler/Utils/Exam.hs | 74 ++++++++++++------- src/Utils/Form.hs | 2 +- src/Utils/Parameters.hs | 1 + .../widgets/exam-occurrence-mapping.hamlet | 5 +- 8 files changed, 103 insertions(+), 31 deletions(-) diff --git a/frontend/src/app.sass b/frontend/src/app.sass index 9b842f8a2..b4acef15e 100644 --- a/frontend/src/app.sass +++ b/frontend/src/app.sass @@ -249,6 +249,13 @@ button, box-shadow: 0 0 0 0.25rem rgba(50, 115, 220, 0.25) outline: 0 + .buttongroup > & + min-width: 0 + +.buttongroup + display: grid + grid: min-content / auto-flow 1fr + input[type="submit"][disabled], input[type="button"][disabled], button[disabled], diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index d7f784150..ebff2b149 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -2285,6 +2285,8 @@ ExamAutoOccurrenceParticipantsAssigned num@Int64: Verteilungstabelle erfolgreich TitleExamAutoOccurrence tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: #{tid} - #{ssh} - #{csh} #{examn}: Automatische Raum-/Terminverteilung BtnExamAutoOccurrenceCalculate: Verteilungstabelle berechnen BtnExamAutoOccurrenceAccept: Verteilung akzeptieren +BtnExamAutoOccurrenceNudgeUp: + +BtnExamAutoOccurrenceNudgeDown: - ExamRoomMappingSurname: Nachnamen beginnend mit ExamRoomMappingMatriculation: Matrikelnummern endend in ExamRoomLoad: Auslastung \ No newline at end of file diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index 345fe2d08..b26b66919 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -2284,6 +2284,8 @@ ExamAutoOccurrenceParticipantsAssigned num: Occurrence/room assignment rule save TitleExamAutoOccurrence tid ssh csh examn: #{tid} - #{ssh} - #{csh} #{examn}: Automatic occurrence/room distribution BtnExamAutoOccurrenceCalculate: Calculate assignment rules BtnExamAutoOccurrenceAccept: Accept assignments +BtnExamAutoOccurrenceNudgeUp: + +BtnExamAutoOccurrenceNudgeDown: - ExamRoomMappingSurname: Surnames starting with ExamRoomMappingMatriculation: Matriculation numbers ending in ExamRoomLoad: Utilisation \ No newline at end of file diff --git a/src/Handler/Exam/AutoOccurrence.hs b/src/Handler/Exam/AutoOccurrence.hs index 925df22fd..222fd7896 100644 --- a/src/Handler/Exam/AutoOccurrence.hs +++ b/src/Handler/Exam/AutoOccurrence.hs @@ -18,7 +18,9 @@ import Database.Persist.Sql (updateWhereCount) newtype ExamAutoOccurrenceCalculateForm = ExamAutoOccurrenceCalculateForm { eaofConfig :: ExamAutoOccurrenceConfig } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) - deriving newtype (Default) + deriving newtype (Default, FromJSON, ToJSON) + +makeLenses_ ''ExamAutoOccurrenceCalculateForm data ExamAutoOccurrenceAcceptForm = ExamAutoOccurrenceAcceptForm { eaofMapping :: Maybe (ExamOccurrenceMapping ExamOccurrenceId) @@ -32,6 +34,7 @@ deriveJSON defaultOptions data ExamAutoOccurrenceButton = BtnExamAutoOccurrenceCalculate | BtnExamAutoOccurrenceAccept + | BtnExamAutoOccurrenceNudgeUp | BtnExamAutoOccurrenceNudgeDown deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe ExamAutoOccurrenceButton instance Finite ExamAutoOccurrenceButton @@ -40,6 +43,8 @@ nullaryPathPiece ''ExamAutoOccurrenceButton $ camelToPathPiece' 4 embedRenderMessage ''UniWorX ''ExamAutoOccurrenceButton id instance Button UniWorX ExamAutoOccurrenceButton where + btnClasses BtnExamAutoOccurrenceNudgeUp = [BCIsButton] + btnClasses BtnExamAutoOccurrenceNudgeDown = [BCIsButton] btnClasses _ = [BCIsButton, BCPrimary] @@ -51,6 +56,23 @@ examAutoOccurrenceCalculateForm ExamAutoOccurrenceCalculateForm{ eaofConfig } (set _eaocMinimizeRooms <$> apopt checkBoxField (fslI MsgExamAutoOccurrenceMinimizeRooms & setTooltip MsgExamAutoOccurrenceMinimizeRoomsTip) (Just $ eaofConfig ^. _eaocMinimizeRooms)) <*> pure def +examAutoOccurrenceNudgeForm :: ExamOccurrenceId -> Maybe ExamAutoOccurrenceCalculateForm -> Form ExamAutoOccurrenceCalculateForm +examAutoOccurrenceNudgeForm occId protoForm html = do + cID <- encrypt occId + (btnRes, wgt) <- identifyForm (FIDExamAutoOccurrenceNudge $ ciphertext cID) (buttonForm' [BtnExamAutoOccurrenceNudgeUp, BtnExamAutoOccurrenceNudgeDown]) html + oldDataRes <- globalPostParamField PostExamAutoOccurrencePrevious secretJsonField + oldDataId <- newIdent + + let protoForm' = fromMaybe def $ oldDataRes <|> protoForm + genForm btn = protoForm' & _eaofConfig . _eaocNudge %~ Map.insertWith (+) occId n + where n = case btn of + BtnExamAutoOccurrenceNudgeUp -> 1 + BtnExamAutoOccurrenceNudgeDown -> -1 + _other -> 0 + res = genForm <$> btnRes + oldDataView = fieldView (secretJsonField :: Field Handler _) oldDataId (toPathPiece PostExamAutoOccurrencePrevious) [] (Right . fromMaybe protoForm' $ formResult' res) False + return (res, wgt <> oldDataView) + examAutoOccurrenceAcceptForm :: Maybe ExamAutoOccurrenceAcceptForm -> Form ExamAutoOccurrenceAcceptForm examAutoOccurrenceAcceptForm confirmData = identifyForm FIDExamAutoOccurrenceConfirm $ \html -> do (confirmDataRes, confirmDataView) <- mreq secretJsonField "" confirmData @@ -78,7 +100,14 @@ postEAutoOccurrenceR tid ssh csh examn = do ((calculateRes, _), _) <- runFormPost $ examAutoOccurrenceCalculateForm def - calcResult <- formResultMaybe calculateRes $ \ExamAutoOccurrenceCalculateForm{..} -> runDB $ do + nudgeRes <- sequence . flip Map.fromSet (setOf (folded . _entityKey) occurrences) $ \occId -> + runFormPost $ examAutoOccurrenceNudgeForm occId (formResult' calculateRes) + + let calculateRes' = asum $ + [ calculateRes + ] ++ toListOf (folded . _1 . _1) nudgeRes + + 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 @@ -114,6 +143,14 @@ postEAutoOccurrenceR tid ssh csh examn = do addMessageI Success $ MsgExamAutoOccurrenceParticipantsAssigned assignedCount redirect $ CExamR tid ssh csh examn EUsersR + let nudgeWgt = nudgeRes <&> \((_, nudgeView), nudgeEncoding) -> + wrapForm nudgeView def + { formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR + , formEncoding = nudgeEncoding + , formSubmit = FormNoSubmit + , formAttrs = [("class", "buttongroup")] + } + ExamAutoOccurrenceAcceptForm{..} <- maybe (redirect $ CExamR tid ssh csh examn EUsersR) return calcResult let heading = MsgTitleExamAutoOccurrence tid ssh csh examn diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 205e0f94c..129d11b7e 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -1,11 +1,13 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} + module Handler.Utils.Exam ( fetchExamAux , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam , examBonus, examBonusPossible, examBonusAchieved , examResultBonus, examGrade , ExamAutoOccurrenceConfig - , eaocMinimizeRooms, eaocFinenessCost - , _eaocMinimizeRooms, _eaocFinenessCost + , eaocMinimizeRooms, eaocFinenessCost, eaocNudge, eaocNudgeSize + , _eaocMinimizeRooms, _eaocFinenessCost, _eaocNudge, _eaocNudgeSize , examAutoOccurrence ) where @@ -192,15 +194,23 @@ examGrade Exam{..} mBonus (otoList -> results) data ExamAutoOccurrenceConfig = ExamAutoOccurrenceConfig { eaocMinimizeRooms :: Bool , eaocFinenessCost :: Rational -- ^ Cost factor incentivising shorter common prefixes on breaks between rooms + , eaocNudge :: Map ExamOccurrenceId Integer + , eaocNudgeSize :: Rational } deriving (Eq, Ord, Read, Show, Generic, Typeable) instance Default ExamAutoOccurrenceConfig where def = ExamAutoOccurrenceConfig { eaocMinimizeRooms = False - , eaocFinenessCost = 0.1 + , eaocFinenessCost = 0.2 + , eaocNudge = Map.empty + , eaocNudgeSize = 0.05 } makeLenses_ ''ExamAutoOccurrenceConfig + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''ExamAutoOccurrenceConfig examAutoOccurrence :: forall seed. @@ -283,9 +293,10 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences distribute :: forall wordId lineId cost. _ - => [(wordId, Natural)] - -> [(lineId, Natural)] - -> (wordId -> wordId -> Extended Rational) + => [(wordId, Natural)] -- ^ Word sizes (in order) + -> [(lineId, Natural)] -- ^ Line sizes (in order) + -> (lineId -> Integer) -- ^ Nudge + -> (wordId -> wordId -> Extended Rational) -- ^ Break cost -> Maybe (cost, [(lineId, [wordId])]) -- ^ Distribute the given items (@wordId@s) with associated size in -- contiguous blocks into the given buckets (@lineId@s) such that they are @@ -294,7 +305,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences -- Return a cost scaled to item-size squared -- -- See under \"Shortest Path\" - distribute wordLengths lineLengths breakCost + distribute wordLengths lineLengths lineNudge breakCost | null wordLengths = Just (0, [ (l, []) | (l, _) <- lineLengths ]) | null lineLengths = Nothing | otherwise = let (cost, result) = distribute' @@ -347,15 +358,15 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences walkBack 0 = return 0 walkBack i'' = fmap succ $ walkBack =<< ST.readArray breaks i'' lineIx <- walkBack i - let potWidth + let (l, potWidth) | lineIx >= 0 , lineIx < length lineLengths - = view _2 $ lineLengths List.!! lineIx + = over _1 Just $ lineLengths List.!! lineIx | otherwise - = 0 + = (Nothing, 0) w = offsets Array.! j - offsets Array.! i prevMin <- ST.readArray minima i - let cost = prevMin + widthCost potWidth w + breakCost' + let cost = prevMin + widthCost l potWidth w + breakCost' breakCost' | j < Map.size wordMap , j > 0 @@ -393,12 +404,13 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences in accumResult 0 (Map.size wordMap) (0, []) - widthCost :: Natural -> Natural -> Extended Rational - widthCost lineWidth w + widthCost :: Maybe lineId -> Natural -> Natural -> Extended Rational + widthCost l lineWidth w | lineWidth < w = PosInf - | otherwise = Finite (max 1 . abs $ ((fromIntegral w % fromIntegral lineWidth) - optimumRatio) * fromIntegral longestLine) ^ 2 + | otherwise = Finite (max 1 . abs $ ((fromIntegral w % fromIntegral lineWidth) - optimumRatio') * fromIntegral longestLine) ^ 2 where optimumRatio = ((%) `on` fromIntegral . sum) (map (view _2) wordLengths) (map (view _2) lineLengths) + optimumRatio' = maybe 0 (fromIntegral . lineNudge) l * eaocNudgeSize + optimumRatio charCost :: [CI Char] -> [CI Char] -> Extended Rational charCost pA pB = Finite (max 1 $ List.genericLength (pA `lcp` pB) * eaocFinenessCost * fromIntegral longestLine) ^ 2 @@ -414,10 +426,12 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences | a == b = a:lcp as bs | otherwise = [] + lineNudges = fromMaybe 0 . flip Map.lookup eaocNudge + bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])] bestOption = case rule of ExamRoomSurname -> do - (_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` toListOf (_1 . folded . to CI.foldedCase)) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' charCost + (_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` toListOf (_1 . folded . to CI.foldedCase)) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' lineNudges charCost -- traceM $ show cost return res ExamRoomMatriculation -> do @@ -425,7 +439,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences -- finenessCost n = Finite (max 1 $ fromIntegral n * eaocFinenessCost * fromIntegral longestLine) ^ 2 * length occurrences' distributeFine :: Natural -> Maybe (Extended Rational, _) - distributeFine n = distribute (usersFineness n) occurrences' charCost + distributeFine n = distribute (usersFineness n) occurrences' lineNudges charCost maximumFineness = fromIntegral . F.minimum . Set.map length $ Map.keysSet users' @@ -459,7 +473,7 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences ) postprocess result = (resultAscList, resultUsers) where - resultAscList = pad . Map.fromListWith Set.union $ accRes (pure <$> Set.lookupMin rangeAlphabet) result + resultAscList = pad . Map.fromListWith Set.union . accRes (pure <$> Set.lookupMin rangeAlphabet) $ (\r -> traceShow (over (traverse . _2 . traverse . traverse) CI.original r) r) result where accRes _ [] = [] accRes prevEnd ((occA, nsA) : (occB, nsB) : xs) @@ -467,14 +481,12 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences , Just maxA <- nsA ^? _last , Just minB <- nsB ^? _head = let common = maxA `lcp` minB - suffA = CI.foldedCase <$> drop (length common) maxA - suffB = CI.foldedCase <$> drop (length common) minB in if - | mayRange (succ $ length common) maxA - , mayRange (succ $ length common) minA - , mayRange (succ $ length common) minB - , firstA : _ <- suffA - , firstB : _ <- suffB + | Just rmaxA <- nsA ^? to (filter . mayRange . succ $ length common) . _last + , Just rminA <- maybe id (:) prevEnd nsA ^? to (filter . mayRange . succ $ length common) . _head + , Just rminB <- nsB ^? to (filter . mayRange . succ $ length common) . _head + , firstA : _ <- CI.foldedCase <$> drop (length common) rmaxA + , firstB : _ <- CI.foldedCase <$> drop (length common) rminB -> let break' | occSize occA > 0 || occSize occB > 0 = (occSize occA * Char.ord firstA + occSize occB * Char.ord firstB) % (occSize occA + occSize occB) @@ -495,9 +507,14 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences | otherwise = go cs commonLength = max 1 . succ . length $ minA `lcp` break' - in (occA, Set.insert (ExamOccurrenceMappingRange minA break') . Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsA) : accRes succBreak ((occB, nsB) : xs) + isBreakSpecialStart c = not (mayRange (length rminA ) c) && length (rminA `lcp` c) >= pred (length rminA ) + isBreakSpecialEnd c = not (mayRange (length break') c) && length (break' `lcp` c) >= pred (length break') + rangeSpecials = Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsA + breakSpecialsStart = Set.map (ExamOccurrenceMappingSpecial . take (length rminA)) . Set.filter isBreakSpecialStart $ Set.fromList nsA + breakSpecialsEnd = Set.map (ExamOccurrenceMappingSpecial . take (length break')) . Set.filter isBreakSpecialEnd $ Set.fromList nsA + in (occA, Set.insert (ExamOccurrenceMappingRange rminA break') $ breakSpecialsStart <> breakSpecialsEnd <> rangeSpecials) : accRes succBreak ((occB, nsB) : xs) | otherwise - -> (occA, Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ maybe 0 length prevEnd)) $ Set.fromList nsA) : accRes prevEnd ((occB, nsB) : xs) + -> (occA, Set.map (ExamOccurrenceMappingSpecial . take (max 1 . max (succ $ length common) $ maybe 0 length prevEnd)) $ Set.fromList nsA) : accRes (Just $ take (succ $ length common) minB) ((occB, nsB) : xs) | null nsA = accRes prevEnd $ (occB, nsB) : xs | otherwise -- null nsB @@ -507,7 +524,10 @@ examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences , Just maxAlpha <- Set.lookupMax rangeAlphabet , minZ <- fromMaybe (pure minAlpha) prevEnd = let commonLength = max 1 . succ . length $ takeWhile (== maxAlpha) minZ - in pure (occZ, Set.insert (ExamOccurrenceMappingRange minZ $ replicate commonLength maxAlpha) . Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsZ) + isBreakSpecial c = not (mayRange (length minZ) c) && length (minZ `lcp` c) >= pred (length minZ) + rangeSpecials = Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsZ + breakSpecials = Set.map (ExamOccurrenceMappingSpecial . take (length minZ)) . Set.filter isBreakSpecial $ Set.fromList nsZ + in pure (occZ, Set.insert (ExamOccurrenceMappingRange minZ $ replicate commonLength maxAlpha) $ rangeSpecials <> breakSpecials) | otherwise = pure (occZ, Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ maybe 0 length prevEnd)) $ Set.fromList nsZ) resultUsers = Map.fromList $ do diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 4b12d47b4..78af6cfaf 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -229,7 +229,7 @@ data FormIdentifier | FIDUserAuthMode | FIDAllUsersAction | FIDLanguage - | FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm + | FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/src/Utils/Parameters.hs b/src/Utils/Parameters.hs index 96fe65fd9..f78926740 100644 --- a/src/Utils/Parameters.hs +++ b/src/Utils/Parameters.hs @@ -57,6 +57,7 @@ data GlobalPostParam = PostFormIdentifier | PostBearer | PostDBCsvImportAction | PostLoginDummy + | PostExamAutoOccurrencePrevious deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe GlobalPostParam diff --git a/templates/widgets/exam-occurrence-mapping.hamlet b/templates/widgets/exam-occurrence-mapping.hamlet index 78cdf5b13..a3c8b8ef0 100644 --- a/templates/widgets/exam-occurrence-mapping.hamlet +++ b/templates/widgets/exam-occurrence-mapping.hamlet @@ -4,7 +4,7 @@ $newline never _{MsgExamRoomName} - + _{MsgExamRoomLoad} $maybe rule <- occMappingRule $case rule @@ -29,6 +29,9 @@ $newline never _{examOccurrenceName} _{loadProp (occLoad occId) examOccurrenceCapacity} + + $maybe nudgeWgt' <- Map.lookup occId nudgeWgt + ^{nudgeWgt'} $maybe mappingWgt <- occMapping occId ^{mappingWgt}