feat: exam auto-occurrence nudging

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],

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

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

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

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, eaocNudge, eaocNudgeSize
-  , _eaocMinimizeRooms, _eaocFinenessCost
+  , _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)]
+               => [(wordId, Natural)] -- ^ Word sizes (in order)
-               -> [(lineId, Natural)]
+               -> [(lineId, Natural)] -- ^ Line sizes (in order)
-               -> (wordId -> wordId -> Extended Rational)
+               -> (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 <https://xxyxyz.org/line-breaking/> 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 :: Maybe lineId -> Natural -> Natural -> Extended Rational
-        widthCost lineWidth w
+        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
+                  | Just rmaxA <- nsA ^? to (filter . mayRange . succ $ length common) . _last
-                  , mayRange (succ $ length common) minA
+                  , Just rminA <- maybe id (:) prevEnd nsA ^? to (filter . mayRange . succ $ length common) . _head
-                  , mayRange (succ $ length common) minB
+                  , Just rminB <- nsB ^? to (filter . mayRange . succ $ length common) . _head
-                  , firstA : _ <- suffA
+                  , firstA : _ <- CI.foldedCase <$> drop (length common) rmaxA
-                  , firstB : _ <- suffB
+                  , 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

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

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

templates/widgets/exam-occurrence-mapping.hamlet

@@ -4,7 +4,7 @@ $newline never
     <tr .table__row .table__row--head>
       <th .table__th>
         _{MsgExamRoomName}
-      <th .table__th>
+      <th .table__th colspan=2>
         _{MsgExamRoomLoad}
       $maybe rule <- occMappingRule
         $case rule
@@ -29,6 +29,9 @@ $newline never
           _{examOccurrenceName}
         <td .table__td>
           _{loadProp (occLoad occId) examOccurrenceCapacity}
+        <td .table__td>
+          $maybe nudgeWgt' <- Map.lookup occId nudgeWgt
+            ^{nudgeWgt'}
         <td .table__td>
           $maybe mappingWgt <- occMapping occId
             ^{mappingWgt}