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

feat: exam auto-occurrence nudging

Browse Source
This commit is contained in:
Gregor Kleen 2020-01-30 17:24:22 +01:00
parent fa7f63d8f7
commit a91fd7fd63
8 changed files with 103 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
frontend/src/app.sass
View File

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

2
messages/uniworx/de-de-formal.msg
View File

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

2
messages/uniworx/en-eu.msg
View File

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

41
src/Handler/Exam/AutoOccurrence.hs
View File

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

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

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

2
src/Utils/Form.hs
View File

@ -229,7 +229,7 @@ data FormIdentifier
| FIDUserAuthMode
| FIDAllUsersAction
| FIDLanguage
| FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm
| FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID
deriving (Eq, Ord, Read, Show)
instance PathPiece FormIdentifier where

1
src/Utils/Parameters.hs
View File

@ -57,6 +57,7 @@ data GlobalPostParam = PostFormIdentifier
| PostBearer
| PostDBCsvImportAction
| PostLoginDummy
| PostExamAutoOccurrencePrevious
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe GlobalPostParam

5
templates/widgets/exam-occurrence-mapping.hamlet
View File

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