From 282df86bc20b5ec884379c6c81f232abfb4631c3 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 19 Sep 2019 17:36:22 +0200 Subject: [PATCH] feat(exam): start work on automatic exam-occurrence assignment --- src/Handler/Utils/Exam.hs | 157 +++++++++++++++++++++++++++++++++++++- src/Model/Types/Exam.hs | 13 ++++ 2 files changed, 169 insertions(+), 1 deletion(-) diff --git a/src/Handler/Utils/Exam.hs b/src/Handler/Utils/Exam.hs index dd9742e39..d3cdd4278 100644 --- a/src/Handler/Utils/Exam.hs +++ b/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 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) diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 7e7ce52bc..e6186c2b0 100644 --- a/src/Model/Types/Exam.hs +++ b/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