feat(exam): start work on automatic exam-occurrence assignment

src/Handler/Utils/Exam.hs

@@ -3,9 +3,10 @@ module Handler.Utils.Exam
   , fetchExam, fetchExamId, fetchCourseIdExamId, fetchCourseIdExam
   , examBonus, examBonusPossible, examBonusAchieved
   , examResultBonus, examGrade
+  , examAutoOccurrence
   ) where
 
-import Import.NoFoundation
+import Import.NoFoundation hiding (distribute)
 
 import Database.Persist.Sql (SqlBackendCanRead)
 import qualified Database.Esqueleto as E
@@ -16,8 +17,16 @@ import Database.Esqueleto.Utils.TH
 import qualified Data.Conduit.List as C
 
 import qualified Data.Map as Map
+import qualified Data.Set as Set
 
 import Data.Fixed (Fixed(..))
+import qualified Data.Foldable as F
+
+import qualified Data.CaseInsensitive as CI
+
+import Control.Monad.Trans.Random.Lazy (evalRand)
+import System.Random (mkStdGen)
+import Control.Monad.Random.Class (uniform)
 
 
 fetchExamAux :: ( SqlBackendCanRead backend
@@ -161,3 +170,149 @@ examGrade Exam{..} mBonus (otoList -> results)
             lowerBounds :: [(ExamGrade, Points)]
             lowerBounds = zip [Grade40, Grade37 ..] examGradingKey'
         
+
+examAutoOccurrence :: forall seed.
+                      Hashable seed
+                   => seed
+                   -> ExamOccurrenceRule
+                   -> Map ExamOccurrenceId Natural
+                   -> Map UserId (User, Maybe ExamOccurrenceId)
+                   -> (Maybe (ExamOccurrenceMapping ExamOccurrenceId), Map UserId (Maybe ExamOccurrenceId))
+examAutoOccurrence (hash -> seed) rule occurrences users
+  | sum occurrences < fromIntegral (Map.size users)
+    || Map.null users
+  = nullResult
+  | otherwise
+  = case rule of
+      ExamRoomRandom
+        -> ( Nothing
+           , flip Map.mapWithKey users $ \uid (_, mOcc)
+               -> let randomOcc = flip evalRand (mkStdGen $ hashWithSalt seed uid) $
+                       uniform $ Map.keysSet occurrences
+                   in Just $ fromMaybe randomOcc mOcc
+           )
+      _ | Just (postprocess -> (resMapping, result)) <- bestOption
+          -> ( Just $ ExamOccurrenceMapping rule resMapping
+             , Map.unionWith (<|>) (view _2 <$> users) result
+             )
+      _ -> nullResult
+  where
+    nullResult = (Nothing, view _2 <$> users)
+    
+    users' :: Map [CI Char] (Set UserId)
+    -- ^ Finest partition of users
+    users' = case rule of
+      ExamRoomSurname
+        -> Map.fromListWith Set.union
+           [ (map CI.mk $ unpack userSurname, Set.singleton uid)
+           | (uid, (User{..}, Nothing)) <- Map.toList users
+           , not $ null userSurname
+           ]
+      ExamRoomMatriculation
+        -> let matrUsers
+                 = Map.fromListWith Set.union
+                   [ (map CI.mk . reverse $ unpack matriculation, Set.singleton uid)
+                   | (uid, (User{..}, Nothing)) <- Map.toList users
+                   , 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 partitions
+    usersGroups (fromIntegral -> c) = Map.mapKeysWith Set.union (take c) users' 
+
+    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
+    --
+    -- Prefer occurrences with higher capacity
+    --
+    -- If a single occurrence can accomodate all participants, pick the one with
+    -- the least capacity
+    occurrences'
+      | Just largeEnoughs <- fromNullable . filter ((>= usersCount) . view _2) $ Map.toList occurrences
+      = pure $ minimumBy (comparing $ view _2) largeEnoughs
+      | otherwise
+      = view _2 . foldr accF (0, []) . sortOn (Down . view _2) $ Map.toList occurrences
+      where
+        usersCount = fromIntegral $ Map.size users
+        
+        accF :: (ExamOccurrenceId, Natural)
+             -> (Natural, [(ExamOccurrenceId, Natural)])
+             -> (Natural, [(ExamOccurrenceId, Natural)])
+        accF occ@(_, occSize) acc@(accSize, accOccs)
+          | accSize >= usersCount
+          = acc
+          | otherwise
+          = ( accSize + occSize
+            , accOccs ++ [occ]
+            )
+
+    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 % 20 -- TODO: tweak
+
+
+    distribute :: forall wordId lineId cost.
+                  ( Num cost
+                  , Ord wordId, Ord lineId
+                  )
+               => [(wordId, Natural)]
+               -> [(lineId, Natural)]
+               -> Maybe (cost, Map lineId (Set 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)
+    --
+    -- Return a cost scaled to item-size squared
+    --
+    -- See <https://xxyxyz.org/line-breaking/> under \"Shortest Path\"
+    distribute wordLengths lineLengths
+      | null wordLengths = Just (0, Map.empty)
+      | null lineLengths = Nothing
+      | otherwise        = Just distribute'
+      where
+        _longestLine :: cost
+        -- ^ For scaling costs
+        _longestLine = fromIntegral . maximum . mapNonNull (view _2) $ impureNonNull lineLengths
+
+        distribute' = error "not implemented" -- TODO: implement
+
+
+    options :: [(Natural, (Natural, Map ExamOccurrenceId (Set [CI Char])))]
+    options = do
+      fineness <- [0..maximumFineness]
+      let
+        packets :: [([CI Char], Natural)]
+        packets = Map.toAscList . fmap (fromIntegral . Set.size) $ usersGroups fineness
+      (resultCost, result) <- hoistMaybe $ distribute packets occurrences'
+      return (fineness, (resultCost, result))
+    bestOption :: Maybe (Map ExamOccurrenceId (Set [CI Char]))
+    bestOption = options
+      & takeWhile (\(fineness, (resCost, _)) -> finenessCost fineness < resCost)
+      & map (view $ _2 . _2)
+      & fmap last . fromNullable
+
+    postprocess :: Map ExamOccurrenceId (Set [CI Char])
+                -> ( [(ExamOccurrenceId, [CI Char])]
+                   , Map UserId (Maybe ExamOccurrenceId)
+                   )
+    postprocess result = (resultAscList, resultUsers)
+      where
+        resultAscList = sortOn (view _2) . map (over _2 Set.findMax) $ Map.toList result
+        resultUsers = Map.fromList $ do
+          (occId, buckets) <- Map.toList result
+          user <- Set.toList $ foldMap (flip (Map.findWithDefault Set.empty) users') buckets
+          return (user, Just occId)

src/Model/Types/Exam.hs

@@ -11,6 +11,7 @@ module Model.Types.Exam
   , _examResult
   , ExamBonusRule(..)
   , ExamOccurrenceRule(..)
+  , ExamOccurrenceMapping(..)
   , ExamGrade(..)
   , numberGrade
   , ExamGradeDefCenter(..)
@@ -152,6 +153,18 @@ deriveJSON defaultOptions
   } ''ExamOccurrenceRule
 derivePersistFieldJSON ''ExamOccurrenceRule
 
+data ExamOccurrenceMapping roomId = ExamOccurrenceMapping
+  { examOccurrenceMappingRule :: ExamOccurrenceRule
+  , examOccurrenceMappingMapping :: [(roomId, [CI Char])]
+  } deriving (Eq, Ord, Read, Show, Generic, Typeable)
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 3
+  , constructorTagModifier = camelToPathPiece' 1
+  , tagSingleConstructors = False
+  } ''ExamOccurrenceMapping
+derivePersistFieldJSON ''ExamOccurrenceMapping
+
+
 data ExamGrade
   = Grade50
   | Grade40