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}
|