diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 2cdc8cee8..fecc3beb2 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1352,8 +1352,12 @@ ExamBonusAchieved: Bonuspunkte ExamEditHeading examn@ExamName: #{examn} bearbeiten ExamBonusMaxPoints: Maximal erreichbare Prüfungs-Bonuspunkte +ExamBonusMaxPointsTip: Bonuspunkte werden, anhand der erreichten Übungspunkte bzw. der Anzahl von bestandenen Übungsblättern, linear zwischen null und der angegebenen Schranke interpoliert. ExamBonusMaxPointsNonPositive: Maximaler Prüfungsbonus muss positiv und größer null sein ExamBonusOnlyPassed: Bonus nur nach Bestehen anrechnen +ExamBonusRound: Bonus runden auf +ExamBonusRoundNonPositive: Vielfaches, auf das gerundet werden soll, muss positiv und größer null sein +ExamBonusRoundTip: Bonuspunkte werden kaufmännisch auf ein Vielfaches der angegeben Zahl gerundet. ExamAutomaticOccurrenceAssignment: Automatische Termin- bzw. Raumzuteilung ExamAutomaticOccurrenceAssignmentTip: Sollen Prüfungsteilnehmer zum Zeitpunkt der Bekanntgabe der Raum- bzw. Terminzuteilung automatisch auf die zur Verfügung stehenden Räume bzw. Termine verteilt werden? Manuelle Umverteilung bzw. vorheriges Festlegen von Zuteilungen einzelner Teilnehmer ist trotzdem möglich. diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index 8398abebd..9f6bbe364 100644 --- a/src/Handler/Utils/Exam.hs +++ b/src/Handler/Utils/Exam.hs @@ -17,6 +17,8 @@ import qualified Data.Conduit.List as C import qualified Data.Map as Map +import Data.Fixed (Fixed(..)) + fetchExamAux :: ( SqlBackendCanRead backend , E.SqlSelect b a @@ -90,7 +92,7 @@ examResultBonus :: ExamBonusRule -> Points examResultBonus bonusRule bonusPossible bonusAchieved = case bonusRule of ExamBonusPoints{..} - -> roundToPoints $ toRational bonusMaxPoints * bonusProp + -> roundToPoints bonusRound $ toRational bonusMaxPoints * bonusProp where bonusProp :: Rational bonusProp @@ -109,8 +111,17 @@ examResultBonus bonusRule bonusPossible bonusAchieved = case bonusRule of passesPossible = getSum $ numSheetsPasses bonusPossible pointsPossible = getSum $ sumSheetsPoints bonusPossible - roundToPoints :: forall a. HasResolution a => Rational -> Fixed a - roundToPoints = MkFixed . round . ((*) . toRational $ resolution (Proxy @a)) + roundToPoints :: forall a. HasResolution a => Fixed a -> Rational -> Fixed a + -- ^ 'round-to-nearest' whole multiple + roundToPoints (MkFixed mult'@(fromInteger -> mult)) ((* toRational (resolution (Proxy @a))) -> raw) + = MkFixed . (* mult') $ + let (whole, frac) = raw `divMod'` mult + in if | abs frac < abs (mult / 2) + -> whole + | raw >= 0 + -> succ whole + | otherwise + -> pred whole examGrade :: ( MonoFoldable mono , Element mono ~ ExamResultPoints diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index ab8ede956..ff88d91af 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -537,8 +537,9 @@ examBonusRuleForm prev = multiActionA actions (fslI MsgExamBonusRule) $ classify actions = Map.fromList [ ( ExamBonusPoints' , ExamBonusPoints - <$> apreq (checkBool (> 0) MsgExamBonusMaxPointsNonPositive pointsField) (fslI MsgExamBonusMaxPoints) (preview _bonusMaxPoints =<< prev) + <$> apreq (checkBool (> 0) MsgExamBonusMaxPointsNonPositive pointsField) (fslI MsgExamBonusMaxPoints & setTooltip MsgExamBonusMaxPointsTip) (preview _bonusMaxPoints =<< prev) <*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev)) + <*> areq (checkBool (> 0) MsgExamBonusRoundNonPositive pointsField) (fslI MsgExamBonusRound & setTooltip MsgExamBonusRoundTip) (preview _bonusRound =<< prev) ) ] diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index bd957ffe1..8cc786739 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -527,15 +527,9 @@ customMigrations = Map.fromListWith (>>) , whenM (tableExists "exam") $ do oldVersion <- columnExists "exam" "grading_key" if - | oldVersion -> do + | oldVersion -> -- Major changes happend to the structure of exams without appropriate -- migration, try to remedy that here - tableDropEmpty "exam_part_corrector" - tableDropEmpty "exam_corrector" - tableDropEmpty "exam_result" - tableDropEmpty "exam_registration" - tableDropEmpty "exam_occurrence" - tableDropEmpty "exam_part" tableDropEmpty "exam" | otherwise -> [executeQQ| @@ -543,13 +537,19 @@ customMigrations = Map.fromListWith (>>) ALTER TABLE "exam" ALTER COLUMN "bonus_rule" DROP NOT NULL; ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" DROP NOT NULL; - UPDATE "exam" SET "grading_rule" = NULL WHERE "grading_rule" = '{ "rule": "manual" }'; - UPDATE "exam" SET "bonus_rule" = NULL WHERE "bonus_rule" = '{ "rule": "no-bonus"}'; + UPDATE "exam" SET "grading_rule" = NULL WHERE "grading_rule"->>'rule' = 'manual'; + UPDATE "exam" SET "bonus_rule" = NULL WHERE "bonus_rule"->>'rule' = 'no-bonus'; UPDATE "exam" SET "occurrence_rule" = NULL WHERE "occurrence_rule" = '"manual"'; UPDATE "exam" SET "occurrence_rule" = json_build_object('rule', "occurrence_rule"); |] ) + , ( AppliedMigrationKey [migrationVersion|22.0.0|] [version|23.0.0|] + , whenM (tableExists "exam") $ + [executeQQ| + UPDATE "exam" SET "bonus_rule" = jsonb_insert("bonus_rule", '{round}' :: text[], '0.01' :: jsonb) WHERE "bonus_rule"->>'rule' = 'bonus-points'; + |] + ) ] diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index be8e0bf95..53d900584 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -119,6 +119,7 @@ instance Finite res => Finite (ExamResult' res) data ExamBonusRule = ExamBonusPoints { bonusMaxPoints :: Points , bonusOnlyPassed :: Bool + , bonusRound :: Points } deriving (Show, Read, Eq, Ord, Generic, Typeable) deriveJSON defaultOptions diff --git a/templates/widgets/bonusRule.hamlet b/templates/widgets/bonusRule.hamlet index 9c010d735..3a5a2c775 100644 --- a/templates/widgets/bonusRule.hamlet +++ b/templates/widgets/bonusRule.hamlet @@ -1,6 +1,6 @@ $newline never $case bonusRule - $of ExamBonusPoints ps False + $of ExamBonusPoints ps False _ _{MsgExamBonusPoints ps} - $of ExamBonusPoints ps True + $of ExamBonusPoints ps True _ _{MsgExamBonusPointsPassed ps}