feat(exams): implement rounding of exambonus

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.

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

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

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';
+      |]
+    )
   ]
 
 

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

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}