From e994fafe28a32022c06c2cce123181525061f24e Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 29 Jan 2020 20:31:37 +0100 Subject: [PATCH] feat(exams): automatic exam occurrence assignment --- ghci.sh | 2 +- messages/uniworx/de-de-formal.msg | 16 +- messages/uniworx/en-eu.msg | 2 +- models/exams.model | 1 + package.yaml | 3 + routes | 1 + src/Database/Persist/Class/Instances.hs | 9 +- src/Foundation.hs | 1 + src/Handler/Exam.hs | 1 + src/Handler/Exam/AutoOccurrence.hs | 137 +++++++++++ src/Handler/Exam/Edit.hs | 1 + src/Handler/Exam/New.hs | 1 + src/Handler/Exam/Show.hs | 4 + src/Handler/Exam/Users.hs | 4 +- src/Handler/Utils/Exam.hs | 224 +++++++++++------- src/Handler/Utils/Widgets.hs | 13 + src/Model.hs | 6 + src/Model/Types/Exam.hs | 56 ++++- src/Utils/Form.hs | 1 + stack.yaml.lock | 7 + templates/exam-show.hamlet | 20 ++ templates/exam-users.hamlet | 3 + templates/exam/auto-occurrence-confirm.hamlet | 3 + ...exam-occurrence-mapping-description.hamlet | 15 ++ .../widgets/exam-occurrence-mapping.hamlet | 41 ++++ test/Database.hs | 1 + 26 files changed, 480 insertions(+), 93 deletions(-) create mode 100644 src/Handler/Exam/AutoOccurrence.hs create mode 100644 templates/exam/auto-occurrence-confirm.hamlet create mode 100644 templates/widgets/exam-occurrence-mapping-description.hamlet create mode 100644 templates/widgets/exam-occurrence-mapping.hamlet diff --git a/ghci.sh b/ghci.sh index ab5cf41bd..750d384b8 100755 --- a/ghci.sh +++ b/ghci.sh @@ -20,4 +20,4 @@ if [[ -d .stack-work-ghci ]]; then trap move-back EXIT fi -stack ghci --flag uniworx:dev --flag uniworx:library-only ${@:-uniworx:lib} +stack ghci --flag uniworx:dev --flag uniworx:library-only --ghci-options -fobject-code ${@:-uniworx:lib} diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 81bbd36ff..f31a52272 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -1267,6 +1267,7 @@ BreadcrumbExternalExamGrades: Prüfungsleistungen BreadcrumbExternalExamStaffInvite: Einladung zum Prüfer BreadcrumbParticipantsList: Kursteilnehmerlisten BreadcrumbParticipants: Kursteilnehmerliste +BreadcrumbExamAutoOccurrence: Automatische Raumverteilung ExternalExamEdit coursen@CourseName examn@ExamName: Bearbeiten: #{coursen}, #{examn} ExternalExamGrades coursen@CourseName examn@ExamName: Prüfungsleistungen: #{coursen}, #{examn} @@ -1574,7 +1575,7 @@ ExamBonusRoundNonPositive: Vielfaches, auf das gerundet werden soll, muss positi ExamBonusRoundTip: Bonuspunkte werden kaufmännisch auf ein Vielfaches der angegeben Zahl gerundet. ExamAutomaticOccurrenceAssignment: Termin- bzw. Raumzuteilung -ExamAutomaticOccurrenceAssignmentTip: Sollen Prüfungsteilnehmer automatisch auf die zur Verfügung stehenden Räume bzw. Termine verteilt werden, sich selbstständig einen Raum bzw. Termin aussuchen dürfen oder manuell durch Kursverwalter zugeteilt werden? Manuelle Umverteilung bzw. vorheriges Festlegen von Zuteilungen einzelner Teilnehmer ist trotzdem möglich. +ExamAutomaticOccurrenceAssignmentTip: Sollen Prüfungsteilnehmer automatisch auf die zur Verfügung stehenden Räume bzw. Termine verteilt werden, sich selbstständig einen Raum bzw. Termin aussuchen dürfen oder manuell durch Kursverwalter zugeteilt werden? Die automatische Verteilung muss von einem Kursverwalter ausgelöst werden und geschieht nicht mit Ablauf einer Frist o.Ä.. Manuelle Umverteilung bzw. vorheriges Festlegen von Zuteilungen einzelner Teilnehmer ist somit immer möglich. ExamOccurrenceRule: Verfahren ExamOccurrenceRuleParticipant: Termin- bzw. Raumzuteilungsverfahren ExamRoomManual': Keine automatische bzw. selbstständige Zuteilung @@ -2270,4 +2271,15 @@ ExternalExamUserMustBeStaff: Sie selbst müssen stets assoziierte Person sein, f ExternalExamCourseExists: Der angegebene Kurs existiert im System. Prüfungen sollten daher direkt beim Kurs (statt extern) hinterlegt werden. ExternalExamExists coursen@CourseName examn@ExamName: Prüfung „#{examn}“ für Kurs „#{coursen}“ existiert bereits. ExternalExamCreated coursen@CourseName examn@ExamName: Prüfung „#{examn}“ für Kurs „#{coursen}“ erfolgreich angelegt. -ExternalExamEdited coursen@CourseName examn@ExamName: Prüfung „#{examn}“ für Kurs „#{coursen}“ erfolgreich bearbeitet. \ No newline at end of file +ExternalExamEdited coursen@CourseName examn@ExamName: Prüfung „#{examn}“ für Kurs „#{coursen}“ erfolgreich bearbeitet. + +ExamAutoOccurrenceMinimizeRooms: Verwendete Räume minimieren +ExamAutoOccurrenceMinimizeRoomsTip: Soll, für die Aufteilung, die Liste an Räumen zunächst reduziert werden, sodass nur so wenige Räume verwendet werden, wie nötig (größte zuerst)? +ExamAutoOccurrenceOccurrencesChangedInFlight: Raumliste wurde verändert +ExamAutoOccurrenceParticipantsAssigned num@Int64: Verteilungstabelle erfolgreich gespeichert und #{num} Teilnehmer zugewiesen +TitleExamAutoOccurrence tid@TermId ssh@SchoolId csh@CourseShorthand examn@ExamName: #{tid}-#{ssh}-#{csh} #{examn}: Automatische Raumverteilung +BtnExamAutoOccurrenceCalculate: Verteilung berechnen +BtnExamAutoOccurrenceAccept: Verteilung akzeptieren +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 cfac175fd..1f697b94d 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -1572,7 +1572,7 @@ ExamBonusRoundNonPositive: Rounding multiple must be positive and greater than z ExamBonusRoundTip: Bonus points are rounded commercially to a multiple of the given number ExamAutomaticOccurrenceAssignment: Selection of occurrences/rooms for/by participants -ExamAutomaticOccurrenceAssignmentTip: Should exam participants be distributed automatically among the configured occurrences/rooms, should they instead be permitted to autonomously choose an occurrence/a room, or should they be assigned to occurrences/rooms manually by course administrators? Manipulation of the distribution and manually assigning participants remains possible. +ExamAutomaticOccurrenceAssignmentTip: Should exam participants be distributed automatically among the configured occurrences/rooms, should they instead be permitted to autonomously choose an occurrence/room, or should they be assigned to occurrences/rooms manually by course administrators? Automatic distribution needs to be triggered by a course administrator. It is not done automatically at a predefined time. Thus manipulation of the distribution and manually assigning participants remains possible. ExamOccurrenceRule: Procedure ExamOccurrenceRuleParticipant: Occurrence/room assignment procedure ExamRoomManual': No automatic or autonomous assignment diff --git a/models/exams.model b/models/exams.model index 5baa6e711..2bdc42cda 100644 --- a/models/exams.model +++ b/models/exams.model @@ -4,6 +4,7 @@ Exam gradingRule ExamGradingRule Maybe bonusRule ExamBonusRule Maybe occurrenceRule ExamOccurrenceRule + examOccurrenceMapping (ExamOccurrenceMapping ExamOccurrenceName) Maybe visibleFrom UTCTime Maybe registerFrom UTCTime Maybe registerTo UTCTime Maybe diff --git a/package.yaml b/package.yaml index f8d437c20..86e2ff3c8 100644 --- a/package.yaml +++ b/package.yaml @@ -138,6 +138,7 @@ dependencies: - prometheus-metrics-ghc - wai-middleware-prometheus - extended-reals + - rfc5051 other-extensions: - GeneralizedNewtypeDeriving @@ -182,6 +183,8 @@ default-extensions: - DeriveGeneric - DeriveLift - DeriveFunctor + - DeriveFoldable + - DeriveTraversable - DerivingStrategies - DerivingVia - DataKinds diff --git a/routes b/routes index 8bf60981c..52f9bad23 100644 --- a/routes +++ b/routes @@ -188,6 +188,7 @@ /register ERegisterR POST !timeANDcourse-registeredAND¬exam-registered !timeANDexam-registeredAND¬exam-result /register/#ExamOccurrenceName ERegisterOccR POST !exam-occurrence-registrationANDtimeANDcapacityANDcourse-registeredAND¬exam-occurrence-registered !exam-occurrence-registrationANDtimeANDexam-occurrence-registeredAND¬exam-result /grades EGradesR GET POST !exam-office + /assign-occurrences EAutoOccurrenceR POST /apps CApplicationsR GET POST !/apps/files CAppsFilesR GET /apps/#CryptoFileNameCourseApplication CourseApplicationR: diff --git a/src/Database/Persist/Class/Instances.hs b/src/Database/Persist/Class/Instances.hs index 8fc9eb20b..193ea1f16 100644 --- a/src/Database/Persist/Class/Instances.hs +++ b/src/Database/Persist/Class/Instances.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableInstances, GeneralizedNewtypeDeriving #-} module Database.Persist.Class.Instances ( @@ -10,12 +10,15 @@ import ClassyPrelude import Database.Persist.Class import Database.Persist.Types (HaskellName, DBName, PersistValue) import Database.Persist.Types.Instances () +import Database.Persist.Sql import Data.Binary (Binary) import qualified Data.Binary as Binary import qualified Data.Map as Map +import Data.Aeson (ToJSONKey, FromJSONKey) + instance PersistEntity record => Hashable (Key record) where hashWithSalt s = hashWithSalt s . toPersistValue @@ -34,3 +37,7 @@ uniqueToMap = fmap Map.fromList $ zip <$> persistUniqueToFieldNames <*> persistU instance PersistEntity record => Eq (Unique record) where (==) = (==) `on` uniqueToMap + + +deriving newtype instance ToJSONKey (BackendKey SqlBackend) +deriving newtype instance FromJSONKey (BackendKey SqlBackend) diff --git a/src/Foundation.hs b/src/Foundation.hs index a4d40b60e..184cedf7c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1923,6 +1923,7 @@ instance YesodBreadcrumbs UniWorX where EInviteR -> i18nCrumb MsgBreadcrumbExamParticipantInvite . Just $ CExamR tid ssh csh examn EShowR ERegisterR -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR ERegisterOccR _occn -> i18nCrumb MsgBreadcrumbExamRegister . Just $ CExamR tid ssh csh examn EShowR + EAutoOccurrenceR -> i18nCrumb MsgBreadcrumbExamAutoOccurrence . Just $ CExamR tid ssh csh examn EUsersR breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of TUsersR -> maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do diff --git a/src/Handler/Exam.hs b/src/Handler/Exam.hs index 6580c90f4..ca916130c 100644 --- a/src/Handler/Exam.hs +++ b/src/Handler/Exam.hs @@ -11,3 +11,4 @@ import Handler.Exam.Edit as Handler.Exam import Handler.Exam.Show as Handler.Exam import Handler.Exam.Users as Handler.Exam import Handler.Exam.AddUser as Handler.Exam +import Handler.Exam.AutoOccurrence as Handler.Exam diff --git a/src/Handler/Exam/AutoOccurrence.hs b/src/Handler/Exam/AutoOccurrence.hs new file mode 100644 index 000000000..908449351 --- /dev/null +++ b/src/Handler/Exam/AutoOccurrence.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Handler.Exam.AutoOccurrence + ( examAutoOccurrenceCalculateWidget + , postEAutoOccurrenceR + ) where + +import Import +import Handler.Utils +import Handler.Utils.Exam + +import qualified Data.Map as Map + +import qualified Database.Esqueleto as E +import Database.Persist.Sql (updateWhereCount) + + +newtype ExamAutoOccurrenceCalculateForm = ExamAutoOccurrenceCalculateForm + { eaofConfig :: ExamAutoOccurrenceConfig + } deriving stock (Eq, Ord, Read, Show, Generic, Typeable) + deriving newtype (Default) + +data ExamAutoOccurrenceAcceptForm = ExamAutoOccurrenceAcceptForm + { eaofMapping :: Maybe (ExamOccurrenceMapping ExamOccurrenceId) + , eaofAssignment :: Map UserId (Maybe ExamOccurrenceId) + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''ExamAutoOccurrenceAcceptForm + +data ExamAutoOccurrenceButton + = BtnExamAutoOccurrenceCalculate + | BtnExamAutoOccurrenceAccept + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe ExamAutoOccurrenceButton +instance Finite ExamAutoOccurrenceButton + +nullaryPathPiece ''ExamAutoOccurrenceButton $ camelToPathPiece' 4 + +embedRenderMessage ''UniWorX ''ExamAutoOccurrenceButton id +instance Button UniWorX ExamAutoOccurrenceButton where + btnClasses _ = [BCIsButton, BCPrimary] + + +examAutoOccurrenceCalculateForm :: ExamAutoOccurrenceCalculateForm -> Form ExamAutoOccurrenceCalculateForm +examAutoOccurrenceCalculateForm ExamAutoOccurrenceCalculateForm{ eaofConfig } + = identifyForm FIDExamAutoOccurrenceCalculate . renderAForm FormStandard $ ExamAutoOccurrenceCalculateForm <$> eaocForm + where + eaocForm = + (set _eaocMinimizeRooms <$> apopt checkBoxField (fslI MsgExamAutoOccurrenceMinimizeRooms & setTooltip MsgExamAutoOccurrenceMinimizeRoomsTip) (Just $ eaofConfig ^. _eaocMinimizeRooms)) + <*> pure def + +examAutoOccurrenceAcceptForm :: Maybe ExamAutoOccurrenceAcceptForm -> Form ExamAutoOccurrenceAcceptForm +examAutoOccurrenceAcceptForm confirmData = identifyForm FIDExamAutoOccurrenceConfirm $ \html -> do + (confirmDataRes, confirmDataView) <- mreq secretJsonField "" confirmData + (acceptRes, acceptView) <- buttonForm' [BtnExamAutoOccurrenceAccept] mempty + return (acceptRes *> confirmDataRes, toWidget html <> fvInput confirmDataView <> acceptView) + + +examAutoOccurrenceCalculateWidget :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Widget +examAutoOccurrenceCalculateWidget tid ssh csh examn = do + (formView, formEncoding) <- liftHandler . generateFormPost $ examAutoOccurrenceCalculateForm def + + wrapForm' BtnExamAutoOccurrenceCalculate formView def + { formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR + , formEncoding + } + + +postEAutoOccurrenceR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html +postEAutoOccurrenceR tid ssh csh examn = do + (Entity eId Exam{ examOccurrenceRule }, occurrences) <- runDB $ do + exam@(Entity eId _) <- fetchExam tid ssh csh examn + occurrences <- selectList [ ExamOccurrenceExam ==. eId ] [ Asc ExamOccurrenceName ] + return (exam, occurrences) + + + ((calculateRes, _), _) <- runFormPost $ examAutoOccurrenceCalculateForm def + + 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 + return (user, registration) + let participants' = Map.fromList $ do + (Entity uid userRec, Entity _ ExamRegistration{..}) <- participants + return (uid, (userRec, examRegistrationOccurrence)) + occurrences' = Map.fromList $ map (\(Entity eoId ExamOccurrence{..}) -> (eoId, examOccurrenceCapacity)) occurrences + (eaofMapping, eaofAssignment) = examAutoOccurrence eId examOccurrenceRule eaofConfig occurrences' participants' + return $ Just ExamAutoOccurrenceAcceptForm{..} + + ((confirmRes, confirmView), confirmEncoding) <- runFormPost $ examAutoOccurrenceAcceptForm calcResult + let confirmWidget = wrapForm confirmView def + { formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAutoOccurrenceR + , formEncoding = confirmEncoding + , formSubmit = FormNoSubmit + } + + formResult confirmRes $ \ExamAutoOccurrenceAcceptForm{..} -> do + Sum assignedCount <- runDB $ do + let eaofMapping'' :: Maybe (Maybe (ExamOccurrenceMapping ExamOccurrenceName)) + eaofMapping'' = (<$> eaofMapping) . traverseExamOccurrenceMapping $ \eoId -> case filter ((== eoId) . entityKey) occurrences of + [Entity _ ExamOccurrence{..}] -> Just examOccurrenceName + _other -> Nothing + eaofMapping' <- case eaofMapping'' of + Nothing -> return Nothing + Just Nothing -> invalidArgsI [MsgExamAutoOccurrenceOccurrencesChangedInFlight] + Just (Just x ) -> return $ Just x + update eId [ ExamExamOccurrenceMapping =. eaofMapping' ] + fmap fold . iforM eaofAssignment $ \pid occ -> case occ of + Just _ -> Sum <$> updateWhereCount [ ExamRegistrationExam ==. eId, ExamRegistrationUser ==. pid, ExamRegistrationOccurrence ==. Nothing ] [ ExamRegistrationOccurrence =. occ ] + Nothing -> return mempty + addMessageI Success $ MsgExamAutoOccurrenceParticipantsAssigned assignedCount + redirect $ CExamR tid ssh csh examn EUsersR + + ExamAutoOccurrenceAcceptForm{..} <- maybe (redirect $ CExamR tid ssh csh examn EUsersR) return calcResult + + let heading = MsgTitleExamAutoOccurrence tid ssh csh examn + mappingWgt + = let occLoads :: Map ExamOccurrenceId Natural + occLoads = Map.fromListWith (+) . mapMaybe (\(_, mOcc) -> (, 1) <$> mOcc) $ Map.toList eaofAssignment + + occLoad = fromMaybe 0 . flip Map.lookup occLoads + + occMappingRule = examOccurrenceMappingRule <$> eaofMapping + + loadProp curr max' + | max' /= 0 = MsgProportion (toMessage curr) (toMessage max') (toRational curr / toRational max') + | otherwise = MsgProportionNoRatio (toMessage curr) (toMessage max') + + occMapping occId = examOccurrenceMappingDescriptionWidget <$> occMappingRule <*> (Map.lookup occId . examOccurrenceMappingMapping =<< eaofMapping) + in $(widgetFile "widgets/exam-occurrence-mapping") + + siteLayoutMsg heading $ do + setTitleI heading + $(widgetFile "exam/auto-occurrence-confirm") diff --git a/src/Handler/Exam/Edit.hs b/src/Handler/Exam/Edit.hs index 52d90559f..ae40a86c3 100644 --- a/src/Handler/Exam/Edit.hs +++ b/src/Handler/Exam/Edit.hs @@ -35,6 +35,7 @@ postEEditR tid ssh csh examn = do , examGradingRule = efGradingRule , examBonusRule = efBonusRule , examOccurrenceRule = efOccurrenceRule + , examExamOccurrenceMapping = examExamOccurrenceMapping oldExam , examVisibleFrom = efVisibleFrom , examRegisterFrom = efRegisterFrom , examRegisterTo = efRegisterTo diff --git a/src/Handler/Exam/New.hs b/src/Handler/Exam/New.hs index d4e6582a7..7cbfdb32d 100644 --- a/src/Handler/Exam/New.hs +++ b/src/Handler/Exam/New.hs @@ -32,6 +32,7 @@ postCExamNewR tid ssh csh = do , examGradingRule = efGradingRule , examBonusRule = efBonusRule , examOccurrenceRule = efOccurrenceRule + , examExamOccurrenceMapping = Nothing , examVisibleFrom = efVisibleFrom , examRegisterFrom = efRegisterFrom , examRegisterTo = efRegisterTo diff --git a/src/Handler/Exam/Show.hs b/src/Handler/Exam/Show.hs index e072b9e71..1bb67c713 100644 --- a/src/Handler/Exam/Show.hs +++ b/src/Handler/Exam/Show.hs @@ -145,6 +145,7 @@ getEShowR tid ssh csh examn = do showAchievedPoints = not $ null results showOccurrenceRegisterColumn = occurrenceAssignmentsShown || (mayRegister && examOccurrenceRule == ExamRoomFifo) markUnregisteredOccurrences mOcc = occurrenceAssignmentsShown && hasRegistration && isn't _Just (registerWidget mOcc) + showOccurrenceMappingColumn = examOccurrenceRuleAutomatic examOccurrenceRule && occurrenceAssignmentsShown && is _Just examExamOccurrenceMapping let heading = prependCourseTitle tid ssh csh $ CI.original examName @@ -161,4 +162,7 @@ getEShowR tid ssh csh examn = do examBonusW :: ExamBonusRule -> Widget examBonusW bonusRule = $(widgetFile "widgets/bonusRule") + + occurrenceMapping :: ExamOccurrenceName -> Maybe Widget + occurrenceMapping occName = examOccurrenceMappingDescriptionWidget <$> fmap examOccurrenceMappingRule examExamOccurrenceMapping <*> (fmap examOccurrenceMappingMapping examExamOccurrenceMapping >>= Map.lookup occName) $(widgetFile "exam-show") diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 39624ab04..eee9a53b0 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -11,6 +11,8 @@ import Handler.Utils.Exam import Handler.Utils.Users import Handler.Utils.Csv +import Handler.Exam.AutoOccurrence (examAutoOccurrenceCalculateWidget) + import Handler.ExamOffice.Exam (examCloseWidget) import qualified Database.Esqueleto as E @@ -390,7 +392,7 @@ embedRenderMessage ''UniWorX ''ExamUserCsvException id getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html getEUsersR = postEUsersR postEUsersR tid ssh csh examn = do - (((Any computedValues, registrationResult), examUsersTable), Entity eId examVal, bonus) <- runDB $ do + (((Any computedValues, registrationResult), examUsersTable), Entity eId examVal@Exam{..}, bonus) <- runDB $ do exam@(Entity eid examVal@Exam{..}) <- fetchExam tid ssh csh examn examParts <- selectList [ExamPartExam ==. eid] [Asc ExamPartName] bonus <- examBonus exam diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index f4d1d32d9..9ccb492d4 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -1,12 +1,17 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} + module Handler.Utils.Exam ( fetchExamAux , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam , examBonus, examBonusPossible, examBonusAchieved , examResultBonus, examGrade + , ExamAutoOccurrenceConfig + , eaocMinimizeRooms, eaocFinenessCost + , _eaocMinimizeRooms, _eaocFinenessCost , examAutoOccurrence ) where -import Import.NoFoundation hiding (distribute) +import Import.NoFoundation import Database.Persist.Sql (SqlBackendCanRead) import qualified Database.Esqueleto as E @@ -26,7 +31,7 @@ import qualified Data.CaseInsensitive as CI import Control.Monad.Trans.Random.Lazy (evalRand) import System.Random (mkStdGen) -import Control.Monad.Random.Class (weightedMay) +import Control.Monad.Random.Class (weighted) import Control.Monad.ST (ST, runST) import Data.Array (Array) @@ -40,9 +45,10 @@ import qualified Data.List as List import Data.ExtendedReal -import qualified Data.Text as Text import qualified Data.Char as Char +import qualified Data.RFC5051 as RFC5051 + fetchExamAux :: ( SqlBackendCanRead backend , E.SqlSelect b a @@ -184,17 +190,32 @@ examGrade Exam{..} mBonus (otoList -> results) where lowerBounds :: [(ExamGrade, Points)] lowerBounds = zip [Grade40, Grade37 ..] examGradingKey' + +data ExamAutoOccurrenceConfig = ExamAutoOccurrenceConfig + { eaocMinimizeRooms :: Bool + , eaocFinenessCost :: Rational -- ^ Cost factor incentivising shorter common prefixes on breaks between rooms + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +instance Default ExamAutoOccurrenceConfig where + def = ExamAutoOccurrenceConfig + { eaocMinimizeRooms = False + , eaocFinenessCost = 0.2 + } + +makeLenses_ ''ExamAutoOccurrenceConfig examAutoOccurrence :: forall seed. Hashable seed => seed -> ExamOccurrenceRule + -> ExamAutoOccurrenceConfig -> Map ExamOccurrenceId Natural -> Map UserId (User, Maybe ExamOccurrenceId) -> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId)) -examAutoOccurrence (hash -> seed) rule occurrences users +examAutoOccurrence (hash -> seed) rule ExamAutoOccurrenceConfig{..} occurrences users | sum occurrences < usersCount + || sum occurrences <= 0 || Map.null users = nullResult | otherwise @@ -203,8 +224,8 @@ examAutoOccurrence (hash -> seed) rule occurrences users -> ( Nothing , flip Map.mapWithKey users $ \uid (_, mOcc) -> let randomOcc = flip evalRand (mkStdGen $ hashWithSalt seed uid) $ - weightedMay $ over _2 fromIntegral <$> occurrences' - in mOcc <|> randomOcc + weighted $ over _2 fromIntegral <$> occurrences' + in Just $ fromMaybe randomOcc mOcc ) _ | Just (postprocess -> (resMapping, result)) <- bestOption -> ( Just $ ExamOccurrenceMapping rule resMapping @@ -221,38 +242,21 @@ examAutoOccurrence (hash -> seed) rule occurrences users users' = case rule of ExamRoomSurname -> Map.fromListWith Set.union - [ (map CI.mk $ unpack userSurname', Set.singleton uid) + [ (map CI.mk $ unpack userSurname, Set.singleton uid) | (uid, (User{..}, Nothing)) <- Map.toList users - , let userSurname' = Text.filter Char.isLetter userSurname - , not $ null userSurname' + , not $ null userSurname ] ExamRoomMatriculation -> let matrUsers = Map.fromListWith Set.union [ (map CI.mk $ unpack matriculation', Set.singleton uid) | (uid, (User{..}, Nothing)) <- Map.toList users - , let Just matriculation' = Text.filter Char.isDigit <$> userMatrikelnummer + , let Just matriculation' = userMatrikelnummer , not $ null matriculation' ] in Map.mapKeysWith Set.union (take . F.minimum . Set.map length $ Map.keysSet matrUsers) matrUsers _ -> Map.singleton [] $ Map.keysSet users - usersGroups :: Natural -- ^ fineness - -> Map [CI Char] (Set UserId) - -- ^ Partition users into monotonously finer - usersGroups (fromIntegral -> c) = Map.mapKeysWith Set.union restr users' - where - restr = case rule of - ExamRoomSurname - -> take c - ExamRoomMatriculation - -> reverse . take c . reverse - _other - -> id - - maximumFineness :: Natural - -- ^ Fineness at which `usersGroups` becomes constant - maximumFineness = fromIntegral . F.maximum . Set.map length $ Map.keysSet users' occurrences' :: [(ExamOccurrenceId, Natural)] -- ^ Minimise number of occurrences used @@ -262,6 +266,8 @@ examAutoOccurrence (hash -> seed) rule occurrences users -- If a single occurrence can accomodate all participants, pick the one with -- the least capacity occurrences' + | not eaocMinimizeRooms + = Map.toList occurrences | Just largeEnoughs <- fromNullable . filter ((>= usersCount) . view _2) $ Map.toList occurrences = pure $ minimumBy (comparing $ view _2) largeEnoughs | otherwise @@ -278,24 +284,12 @@ examAutoOccurrence (hash -> seed) rule occurrences users , occ : accOccs ) - largestOccurrence :: Num a => a - largestOccurrence = fromIntegral . maximum . mapNonNull (view _2) $ impureNonNull occurrences' - - finenessCost :: Natural -> Natural - finenessCost x = round (finenessConst * largestOccurrence) * fromIntegral (length occurrences') * x * x - where - finenessConst :: Rational - -- ^ Cost (scaled to proportion of occurrence) of having higher fineness - finenessConst = 1 % 5 -- TODO: tweak - - distribute :: forall wordId lineId cost. - ( Num cost - , Ord wordId, Ord lineId - ) + _ => [(wordId, Natural)] -> [(lineId, Natural)] - -> Maybe (cost, Map lineId (Set wordId)) + -> (wordId -> wordId -> Extended Rational) + -> 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 -- filled as evenly as possible (proportionally) @@ -303,8 +297,8 @@ examAutoOccurrence (hash -> seed) rule occurrences users -- Return a cost scaled to item-size squared -- -- See under \"Shortest Path\" - distribute wordLengths lineLengths - | null wordLengths = Just (0, Map.empty) + distribute wordLengths lineLengths breakCost + | null wordLengths = Just (0, [ (l, []) | (l, _) <- lineLengths ]) | null lineLengths = Nothing | otherwise = let (cost, result) = distribute' in case cost of @@ -344,7 +338,7 @@ examAutoOccurrence (hash -> seed) rule occurrences users bounds = (0, Map.size wordMap) - distribute' :: (Extended Rational, Map lineId (Set wordId)) + distribute' :: (Extended Rational, [(lineId, [wordId])]) distribute' = runST $ do minima <- ST.newListArray (0, Map.size wordMap) $ 0 : repeat PosInf :: forall s. ST s (STArray s Int (Extended Rational)) breaks <- ST.newArray (0, Map.size wordMap) 0 :: forall s. ST s (STUArray s Int Int) @@ -363,7 +357,22 @@ examAutoOccurrence (hash -> seed) rule occurrences users | otherwise = 0 w = offsets Array.! j - offsets Array.! i - cost <- (+) (widthCost potWidth w) <$> ST.readArray minima i + prevMin <- ST.readArray minima i + let cost = prevMin + widthCost potWidth w + breakCost' + breakCost' + | j < Map.size wordMap + , j > 0 + = breakCost (wordIx # pred j) (wordIx # j) + | otherwise + = 0 + traceM $ show ( i + , j + , potWidth + , w + , (fromRational :: Rational -> Centi) <$> prevMin + , (fromRational :: Rational -> Centi) <$> widthCost potWidth w + , (fromRational :: Rational -> Centi) <$> breakCost' + ) when (isFinite cost) $ do minCost <- ST.readArray minima j when (cost < minCost) $ do @@ -372,66 +381,119 @@ examAutoOccurrence (hash -> seed) rule occurrences users go i' $ succ j | otherwise = return () in go i' $ succ i' + traceM . show . map (fmap (fromRational :: Rational -> Centi)) =<< ST.getElems minima traceM . show =<< ST.getElems breaks let accumResult lineIx j (accCost, accMap) = do i <- ST.readArray breaks j accCost' <- (+) accCost <$> ST.readArray minima j - traceM $ show (accCost', lineIx, [i .. pred j]) - let accMap' = Map.insertWith Set.union (lineIxs List.!! lineIx) (Set.fromList $ map (review wordIx) [i .. pred j]) accMap + traceM $ show ((fromRational :: Rational -> Centi) <$> accCost', lineIx, (i, pred j)) + let accMap' = (lineIxs List.!! lineIx, map (review wordIx) [i .. pred j]) : accMap if | i > 0 -> accumResult (succ lineIx) i (accCost', accMap') | otherwise -> return (accCost', accMap') lineIxs = reverse $ map (view _1) lineLengths - in accumResult 0 (Map.size wordMap) (0, Map.empty) + in accumResult 0 (Map.size wordMap) (0, []) widthCost :: Natural -> Natural -> Extended Rational widthCost lineWidth w | lineWidth < w = PosInf - | otherwise = Finite (((fromIntegral lineWidth % fromIntegral w) - 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) lineLengths) (map (view _2) wordLengths) + optimumRatio = ((%) `on` fromIntegral . sum) (map (view _2) wordLengths) (map (view _2) lineLengths) + charCost :: [CI Char] -> [CI Char] -> Extended Rational + charCost pA pB = Finite (max 1 $ List.genericLength (pA `lcp` pB) * eaocFinenessCost * fromIntegral longestLine) ^ 2 + where + longestLine = maximum . mapNonNull (view _2) $ impureNonNull occurrences' - options :: [(Natural, (Natural, Map ExamOccurrenceId (Set [CI Char])))] - options = do - fineness <- [0..maximumFineness] - - let usersGroups' = fromIntegral . Set.size <$> usersGroups fineness - - traceM $ show usersGroups' - traceM . show $ map snd occurrences' - -- The algorithm used in `distribute` produces no usable result if the - -- situation occurs, that a single item does not fit within a bucket. - -- In a naive attempt to prevent this we ensure that all items fit into - -- all buckets. - guard . (\(fromIntegral -> maxSize) -> all ((>= maxSize) . view _2) occurrences') . maybe 0 maximum $ fromNullable usersGroups' + lcp :: Eq a => [a] -> [a] -> [a] + -- ^ Longest common prefix + lcp [] _ = [] + lcp _ [] = [] + lcp (a:as) (b:bs) + | a == b = a:lcp as bs + | otherwise = [] - let - packets :: [([CI Char], Natural)] - packets = Map.toAscList usersGroups' - (resultCost, result) <- hoistMaybe $ distribute packets occurrences' + bestOption :: Maybe [(ExamOccurrenceId, [[CI Char]])] + bestOption = do + (_cost, res) <- distribute (sortBy (RFC5051.compareUnicode `on` toListOf (_1 . folded . to CI.foldedCase)) . Map.toAscList $ fromIntegral . Set.size <$> users') occurrences' charCost - traceM $ show (fineness, finenessCost fineness, resultCost) - traceM . show . map (foldMap $ \prefix -> Sum $ usersGroups' Map.! prefix) $ Map.elems result - - return (fineness, (resultCost, result)) - bestOption :: Maybe (Map ExamOccurrenceId (Set [CI Char])) - bestOption = options - & over _tail (takeWhile $ \(fineness, (resCost, _)) -> finenessCost fineness <= resCost) - & map (view $ _2 . _2) - & fmap last . fromNullable + -- traceM $ show cost - postprocess :: Map ExamOccurrenceId (Set [CI Char]) - -> ( [(ExamOccurrenceId, [CI Char])] + return res + + postprocess :: [(ExamOccurrenceId, [[CI Char]])] + -> ( Map ExamOccurrenceId (Set ExamOccurrenceMappingDescription) , Map UserId (Maybe ExamOccurrenceId) ) postprocess result = (resultAscList, resultUsers) where - resultAscList = sortOn (view _2) . map (over _2 Set.findMax) $ Map.toList result + resultAscList = Map.fromListWith Set.union $ accRes (pure <$> Set.lookupMin rangeAlphabet) result + where + accRes _ [] = [] + accRes prevEnd ((occA, nsA) : (occB, nsB) : xs) + | Just minA <- prevEnd <|> preview _head nsA + , Just maxA <- nsA ^? _last + , Just minB <- nsB ^? _head + = let common = maxA `lcp` minB + mayRange' = mayRange . max 1 . succ $ length common + 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 + -> let break' = (occSize occA * Char.ord firstA + occSize occB * Char.ord firstB) % (occSize occA + occSize occB) + & floor + & Char.chr + & Char.toUpper + & CI.mk + & pure + & (common ++) + succBreak = fmap reverse . go $ reverse break' + where + go [] = Nothing + go (c:cs) + | c' <- CI.map succ c + , c' `Set.member` rangeAlphabet + = Just $ c' : cs + | otherwise + = go cs + in (occA, Set.insert (ExamOccurrenceMappingRange minA break') . Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ length common)) . Set.filter (not . mayRange') $ Set.fromList nsA) : accRes succBreak ((occB, nsB) : xs) + | otherwise + -> (occA, Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ length common)) $ Set.fromList nsA) : accRes prevEnd ((occB, nsB) : xs) + | null nsA + = accRes prevEnd $ (occB, nsB) : xs + | otherwise -- null nsB + = accRes prevEnd $ (occA, nsA) : xs + accRes prevEnd [(occZ, nsZ)] + | Just minAlpha <- Set.lookupMin rangeAlphabet + , Just maxAlpha <- Set.lookupMax rangeAlphabet + , minZ <- fromMaybe (pure minAlpha) prevEnd + = let commonLength = max 1 $ length minZ + in pure (occZ, Set.insert (ExamOccurrenceMappingRange minZ $ replicate commonLength maxAlpha) . Set.map (ExamOccurrenceMappingSpecial . take commonLength) . Set.filter (not . mayRange commonLength) $ Set.fromList nsZ) + | otherwise + = pure (occZ, Set.map (ExamOccurrenceMappingSpecial . take (max 1 $ maybe 0 length prevEnd)) $ Set.fromList nsZ) resultUsers = Map.fromList $ do - (occId, buckets) <- Map.toList result - user <- Set.toList $ foldMap (\b -> foldMap snd . filter (\(b', _) -> b `List.isPrefixOf` b') $ Map.toList users') buckets + (occId, buckets) <- result + user <- Set.toList $ foldMap (\b -> foldMap snd . filter (\(b', _) -> b == b') $ Map.toList users') buckets return (user, Just occId) + + occSize :: Num a => ExamOccurrenceId -> a + occSize occId = fromIntegral . length $ Map.filter (== Just occId) resultUsers + + rangeAlphabet :: Set (CI Char) + rangeAlphabet + | ExamRoomSurname <- rule + = Set.fromList $ map CI.mk ['A'..'Z'] + | ExamRoomMatriculation <- rule + = Set.fromList $ map CI.mk ['0'..'9'] + | otherwise + = mempty + mayRange :: Int -> [CI Char] -> Bool + mayRange l = all (`Set.member` rangeAlphabet) . take l diff --git a/src/Handler/Utils/Widgets.hs b/src/Handler/Utils/Widgets.hs index 994fe893d..be3e0424d 100644 --- a/src/Handler/Utils/Widgets.hs +++ b/src/Handler/Utils/Widgets.hs @@ -8,6 +8,8 @@ import Text.Hamlet (shamletFile) import Handler.Utils.DateTime +import qualified Data.Char as Char + --------- -- Simple utilities for consistent display @@ -102,3 +104,14 @@ i18n :: forall m msg. , RenderMessage (HandlerSite m) msg ) => msg -> m () i18n = toWidget . (SomeMessage :: msg -> SomeMessage (HandlerSite m)) + + +examOccurrenceMappingDescriptionWidget :: ExamOccurrenceRule -> Set ExamOccurrenceMappingDescription -> Widget +examOccurrenceMappingDescriptionWidget rule descriptions = $(widgetFile "widgets/exam-occurrence-mapping-description") + where + titleCase = over _head Char.toUpper . map CI.foldedCase + doPrefix + | ExamRoomMatriculation <- rule + = False + | otherwise + = True diff --git a/src/Model.hs b/src/Model.hs index f59815c79..3821126b6 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -37,6 +37,12 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll submissionRatingDone :: Submission -> Bool submissionRatingDone Submission{..} = isJust submissionRatingTime + +deriving newtype instance ToJSONKey UserId +deriving newtype instance FromJSONKey UserId +deriving newtype instance ToJSONKey ExamOccurrenceId +deriving newtype instance FromJSONKey ExamOccurrenceId + -- ToMarkup and ToMessage instances for displaying selected database primary keys instance ToMarkup (Key School) where diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index e6186c2b0..59c4396dd 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -11,7 +11,14 @@ module Model.Types.Exam , _examResult , ExamBonusRule(..) , ExamOccurrenceRule(..) + , examOccurrenceRuleAutomatic + , ExamOccurrenceMappingDescription(..) + , _eaomrStart, _eaomrEnd, _eaomrSpecial + , _ExamOccurrenceMappingRange, _ExamOccurrenceMappingSpecial , ExamOccurrenceMapping(..) + , _examOccurrenceMappingRule + , _examOccurrenceMappingMapping + , traverseExamOccurrenceMapping , ExamGrade(..) , numberGrade , ExamGradeDefCenter(..) @@ -28,6 +35,8 @@ import Import.NoModel import Model.Types.Common import qualified Data.Text as Text +import qualified Data.Map as Map +import qualified Data.Set as Set import Utils.Lens.TH @@ -44,6 +53,8 @@ import Text.Blaze (ToMarkup(..)) import qualified Data.Foldable +import Data.Aeson (genericToJSON, genericParseJSON) + data ExamResult' res = ExamAttended { examResult :: res } | ExamNoShow @@ -152,18 +163,51 @@ deriveJSON defaultOptions , tagSingleConstructors = True } ''ExamOccurrenceRule derivePersistFieldJSON ''ExamOccurrenceRule +makePrisms ''ExamOccurrenceRule + +examOccurrenceRuleAutomatic :: ExamOccurrenceRule -> Bool +examOccurrenceRuleAutomatic x = or $ map ($ x) + [ is _ExamRoomSurname + , is _ExamRoomMatriculation + , is _ExamRoomRandom + ] + +data ExamOccurrenceMappingDescription + = ExamOccurrenceMappingRange { eaomrStart, eaomrEnd :: [CI Char] } + | ExamOccurrenceMappingSpecial { eaomrSpecial :: [CI Char] } + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + , constructorTagModifier = camelToPathPiece' 3 + } ''ExamOccurrenceMappingDescription + +makeLenses_ ''ExamOccurrenceMappingDescription +makePrisms ''ExamOccurrenceMappingDescription data ExamOccurrenceMapping roomId = ExamOccurrenceMapping { examOccurrenceMappingRule :: ExamOccurrenceRule - , examOccurrenceMappingMapping :: [(roomId, [CI Char])] + , examOccurrenceMappingMapping :: Map roomId (Set ExamOccurrenceMappingDescription) } deriving (Eq, Ord, Read, Show, Generic, Typeable) -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 3 - , constructorTagModifier = camelToPathPiece' 1 - , tagSingleConstructors = False - } ''ExamOccurrenceMapping +instance ToJSONKey roomId => ToJSON (ExamOccurrenceMapping roomId) where + toJSON = genericToJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 3 + , constructorTagModifier = camelToPathPiece' 1 + , tagSingleConstructors = False + } +instance (FromJSONKey roomId, Ord roomId) => FromJSON (ExamOccurrenceMapping roomId) where + parseJSON = genericParseJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 3 + , constructorTagModifier = camelToPathPiece' 1 + , tagSingleConstructors = False + } derivePersistFieldJSON ''ExamOccurrenceMapping +makeLenses_ ''ExamOccurrenceMapping + +traverseExamOccurrenceMapping :: Ord roomId' + => Traversal (ExamOccurrenceMapping roomId) (ExamOccurrenceMapping roomId') roomId roomId' +traverseExamOccurrenceMapping = _examOccurrenceMappingMapping . iso Map.toList (Map.fromListWith Set.union) . traverse . _1 + data ExamGrade = Grade50 diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 52024081d..4b12d47b4 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -229,6 +229,7 @@ data FormIdentifier | FIDUserAuthMode | FIDAllUsersAction | FIDLanguage + | FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm deriving (Eq, Ord, Read, Show) instance PathPiece FormIdentifier where diff --git a/stack.yaml.lock b/stack.yaml.lock index e67cca322..8e2842628 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -277,6 +277,13 @@ packages: sha256: 6d64803c639ed4c7204ea6fab0536b97d3ee16cdecb9b4a883cd8e56d3c61402 original: hackage: wai-middleware-prometheus-1.0.0 +- completed: + hackage: extended-reals-0.2.3.0@sha256:78a498d703fffcecfba8e66cfb3e64c4307b2c126a442f6d28cfdd997829f1bf,1563 + pantry-tree: + size: 398 + sha256: 29629bb0ac41c49671b7f792e540165ee091eb24ffd0eaff229a2f40cc03f3af + original: + hackage: extended-reals-0.2.3.0 snapshots: - completed: size: 498180 diff --git a/templates/exam-show.hamlet b/templates/exam-show.hamlet index 3652474ef..0b6bde895 100644 --- a/templates/exam-show.hamlet +++ b/templates/exam-show.hamlet @@ -114,6 +114,22 @@ $if not (null occurrences) _{MsgExamRoomAssigned} $if not occurrenceAssignmentsVisible \ ^{isVisible False} + $if showOccurrenceMappingColumn + $case fmap examOccurrenceMappingRule examExamOccurrenceMapping + $of Just ExamRoomSurname + + _{MsgExamRoomMappingSurname} + $if not occurrenceAssignmentsVisible + \ ^{isVisible False} + $of Just ExamRoomMatriculation + + _{MsgExamRoomMappingMatriculation} + $if not occurrenceAssignmentsVisible + \ ^{isVisible False} + $of _ + + $if not occurrenceAssignmentsVisible + ^{isVisible False} _{MsgExamRoomDescription} $forall (occurrence, registered) <- occurrences @@ -133,6 +149,10 @@ $if not (null occurrences) $nothing $if registered #{iconOK} + $if showOccurrenceMappingColumn + + $maybe mappingWgt <- occurrenceMapping examOccurrenceName + ^{mappingWgt} $maybe desc <- examOccurrenceDescription #{desc} diff --git a/templates/exam-users.hamlet b/templates/exam-users.hamlet index 06e3e489f..68cc39d21 100644 --- a/templates/exam-users.hamlet +++ b/templates/exam-users.hamlet @@ -1,6 +1,9 @@ $newline never
^{closeWgt} +$if examOccurrenceRuleAutomatic examOccurrenceRule +
+ ^{examAutoOccurrenceCalculateWidget tid ssh csh examn}
$if computedValues ^{computedValuesTip} diff --git a/templates/exam/auto-occurrence-confirm.hamlet b/templates/exam/auto-occurrence-confirm.hamlet new file mode 100644 index 000000000..0e94455e7 --- /dev/null +++ b/templates/exam/auto-occurrence-confirm.hamlet @@ -0,0 +1,3 @@ +$newline never +^{mappingWgt} +^{confirmWidget} diff --git a/templates/widgets/exam-occurrence-mapping-description.hamlet b/templates/widgets/exam-occurrence-mapping-description.hamlet new file mode 100644 index 000000000..356911383 --- /dev/null +++ b/templates/widgets/exam-occurrence-mapping-description.hamlet @@ -0,0 +1,15 @@ +$newline never +
    + $forall desc <- descriptions +
  • + $case desc + $of ExamOccurrenceMappingRange minChars maxChars + $if doPrefix + #{titleCase minChars}… – #{titleCase maxChars}… + $else + …#{titleCase minChars} – …#{titleCase maxChars} + $of ExamOccurrenceMappingSpecial special + $if doPrefix + #{titleCase special}… + $else + …#{titleCase special} diff --git a/templates/widgets/exam-occurrence-mapping.hamlet b/templates/widgets/exam-occurrence-mapping.hamlet new file mode 100644 index 000000000..36f99950e --- /dev/null +++ b/templates/widgets/exam-occurrence-mapping.hamlet @@ -0,0 +1,41 @@ +$newline never + + + + + $forall Entity occId ExamOccurrence{ examOccurrenceName, examOccurrenceRoom, examOccurrenceStart, examOccurrenceEnd, examOccurrenceDescription, examOccurrenceCapacity } <- occurrences + +
    + _{MsgExamRoomName} + + _{MsgExamRoomLoad} + $maybe rule <- occMappingRule + $case rule + $of ExamRoomSurname + + _{MsgExamRoomMappingSurname} + $of ExamRoomMatriculation + + _{MsgExamRoomMappingMatriculation} + $of _ + + + _{MsgExamRoom} + + _{MsgExamRoomTime} + + _{MsgExamRoomDescription} +
    + _{examOccurrenceName} + + _{loadProp (occLoad occId) examOccurrenceCapacity} + $maybe mappingWgt <- occMapping occId + + ^{mappingWgt} + + #{examOccurrenceRoom} + + ^{formatTimeRangeW SelFormatDateTime examOccurrenceStart examOccurrenceEnd} + + $maybe desc <- examOccurrenceDescription + #{desc} diff --git a/test/Database.hs b/test/Database.hs index 8335ef6ac..9038f14cb 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -505,6 +505,7 @@ fillDb = do , examGradingRule = Nothing , examBonusRule = Nothing , examOccurrenceRule = ExamRoomManual + , examExamOccurrenceMapping = Nothing , examVisibleFrom = Just now , examRegisterFrom = Just now , examRegisterTo = Just $ addUTCTime (14 * nominalDay) now