From 0fcf48ce666b4828a33592e234ad2265d7f22952 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 2 Oct 2019 17:57:17 +0200 Subject: [PATCH 1/3] feat(allocations): prototype assignment-algorithm --- package.yaml | 1 + src/Utils/Allocation.hs | 250 +++++++++++++++++++++++++++++++++++ test/Utils/AllocationSpec.hs | 120 +++++++++++++++++ 3 files changed, 371 insertions(+) create mode 100644 src/Utils/Allocation.hs create mode 100644 test/Utils/AllocationSpec.hs diff --git a/package.yaml b/package.yaml index c46557ba0..b530c6306 100644 --- a/package.yaml +++ b/package.yaml @@ -139,6 +139,7 @@ dependencies: - multiset - retry - generic-lens + - array other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Utils/Allocation.hs b/src/Utils/Allocation.hs new file mode 100644 index 000000000..d7fc75022 --- /dev/null +++ b/src/Utils/Allocation.hs @@ -0,0 +1,250 @@ +module Utils.Allocation + ( computeMatching + , MatchingLog(..) + , computeMatchingLog + ) where + +import Import.NoModel hiding (StateT, st, get) + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Sequence as Seq + +import Data.Array.ST (STArray) +import qualified Data.Array.MArray as MArr + +import System.Random (RandomGen) +import Control.Monad.Random.Class (getRandom) +import Control.Monad.Trans.Random.Strict (evalRandT, RandT) +import Control.Monad.Trans.State.Strict (StateT, modify', get, gets, evalStateT) +import Control.Monad.Writer (tell) + +import Control.Monad.ST +import Data.STRef + + +type CloneIndex = Int + +data MatchingLog student course cloneIndex + = MatchingConsider student cloneIndex + | MatchingApply student cloneIndex course + | MatchingNoApplyCloneInstability student cloneIndex course + | MatchingLostSpot student cloneIndex course + deriving (Eq, Ord, Read, Show, Generic, Typeable) + + +computeMatching :: forall randomGen student course cloneCount cloneIndex capacity studentRatingCourse courseRatingStudent courseRatingStudent'. + ( RandomGen randomGen + , Ord student + , Show student, Show course + , NFData student, Ix course + , Ord studentRatingCourse + , Ord courseRatingStudent + , Ord courseRatingStudent' + , Integral cloneCount, Integral capacity, Num cloneIndex + ) + => randomGen -- ^ Source of randomness + -> Map student cloneCount -- ^ requested number of placements per student + -> Map course (Maybe capacity) -- ^ capacity of courses + -> Map (student, course) (studentRatingCourse, courseRatingStudent) -- ^ Mutual preference ordering @(studentRatingCourse, courseRatingStudent)@ + -> (student -> cloneIndex -> courseRatingStudent -> courseRatingStudent') -- ^ Adjust preference ordering of courses (incorporate central priority) + -> Set (student, course) -- ^ Stable matching +computeMatching g cloneCounts capacities preferences centralNudge + = view _1 . runWriter $ computeMatchingLog g cloneCounts capacities preferences centralNudge + +computeMatchingLog :: forall randomGen student course cloneCount cloneIndex capacity studentRatingCourse courseRatingStudent courseRatingStudent'. + ( RandomGen randomGen + , Ord student + , Show student, Show course + , NFData student, Ix course + , Ord studentRatingCourse + , Ord courseRatingStudent + , Ord courseRatingStudent' + , Integral cloneCount, Integral capacity, Num cloneIndex + ) + => randomGen -- ^ Source of randomness + -> Map student cloneCount -- ^ requested number of placements per student + -> Map course (Maybe capacity) -- ^ capacity of courses + -> Map (student, course) (studentRatingCourse, courseRatingStudent) -- ^ Mutual preference ordering @(studentRatingCourse, courseRatingStudent)@ + -> (student -> cloneIndex -> courseRatingStudent -> courseRatingStudent') -- ^ Adjust preference ordering of courses (incorporate central priority) + -> Writer (Seq (MatchingLog student course cloneIndex)) (Set (student, course)) -- ^ Stable matching +computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $ runST computeMatching' + where + computeMatching' :: forall s. ST s (Set (student, course), Seq (MatchingLog student course cloneIndex)) + computeMatching' = runWriterT . flip evalRandT g $ do + courses' <- lift . lift . MArr.newListArray courseBounds . map initCourse $ Set.toAscList courses :: RandT randomGen (WriterT _ (ST s)) (STArray s course (Either (Set (student, CloneIndex)) (Seq (student, CloneIndex)))) + stb <- (Map.!) <$> sequence (Map.fromSet (const getRandom) clonedStudents) :: RandT randomGen (WriterT _ (ST s)) ((student, CloneIndex) -> UUID) + cstb <- (Map.!) <$> sequence (Map.fromSet (const getRandom) courses) :: RandT randomGen (WriterT _ (ST s)) (course -> UUID) + stPrefs <- lift . lift . fmap curry $ (Map.!) <$> sequence (Map.fromSet (newSTRef . studentPrefs cstb) clonedStudents) :: RandT randomGen (WriterT _ (ST s)) (student -> CloneIndex -> STRef _ (Seq course)) + + let + propose :: StateT (Set (student, CloneIndex)) (WriterT _ (ST s)) () + propose = (=<< get) . mapM_ $ \(st, cn) -> do + lift . tell . pure . MatchingConsider st $ fromIntegral cn + let markDone = modify' $ Set.delete (st, cn) + + options <- fmap Seq.viewl . lift . lift . readSTRef $ stPrefs st cn + case options of + Seq.EmptyL -> markDone + c Seq.:< cs -> do + lift . lift $ writeSTRef (stPrefs st cn) cs + cState <- lift . lift $ MArr.readArray courses' c + case cState of + Left pSet + | none (\(st', _) -> st == st') pSet -> do + lift . tell . pure $ MatchingApply st (fromIntegral cn) c + lift . lift . MArr.writeArray courses' c $!! Left (Set.insert (st, cn) pSet) + markDone + Right spots + | none (\(st', _) -> st == st') spots -> do + courseMatchings <- lift . lift $ MArr.getAssocs courses' + let + matchingCourse s cn' = listToMaybe $ do + (course, students) <- courseMatchings + student <- case students of + Left pSet -> toList pSet + Right spots' -> toList spots' + guard $ (s, cn') == student + return course + + let capacity = maybe (error "course without capacity treated as one") fromIntegral $ capacities Map.! c + (worseSpots, betterSpots) = Seq.spanr isWorseSpot spots + isWorseSpot existing = case (comparing $ courseRating c &&& stb) existing (st, cn) of + EQ -> error "Two student-clones compared equal in the face of stb" + GT -> False + LT -> True + (newSpots, lostSpots) = force . Seq.splitAt capacity $ betterSpots <> Seq.singleton (st, cn) <> worseSpots + + isUnstableWith :: CloneIndex -> (student, CloneIndex) -> Bool + isUnstableWith cn' (stO, cnO) = fromMaybe False $ matchingCourse st cn' <&> \c' -> + LT == (comparing $ courseRating c' &&& stb) (st, cn') (stO, cnO) + + if | any (uncurry isUnstableWith) $ (,) <$> [0,1..pred cn] <*> toList lostSpots + -> lift . tell . pure $ MatchingNoApplyCloneInstability st (fromIntegral cn) c + | Seq.length betterSpots >= capacity + -> return () + | otherwise + -> do + lift . tell . pure $ MatchingApply st (fromIntegral cn) c + lift . lift . MArr.writeArray courses' c $ Right newSpots + forM_ lostSpots $ \(st', cn') -> do + lift . tell . pure $ MatchingLostSpot st' (fromIntegral cn') c + modify' $ Set.insert (st', cn') + markDone + _other -> return () + + proposeLoop = do + propose + done <- gets Set.null + unless done + proposeLoop + + lift $ evalStateT proposeLoop clonedStudents + + + -- let + -- pairwiseExchange :: ST s () + -- pairwiseExchange = do + -- let possiblePairs = do + -- (s:ss) <- tails . sortOn stb $ toList clonedStudents + -- s' <- ss + -- return (s, s') + -- matchingCourse (s, c) = do + -- courseMatchings <- MArr.getAssocs courses' + -- return . listToMaybe $ do + -- (course, students) <- courseMatchings + -- student <- case students of + -- Left pSet -> toList pSet + -- Right spots -> toList spots + -- guard $ (s, c) == student + -- return course + -- forM_ possiblePairs $ \((a, cna), (b, cnb)) -> void . runMaybeT $ do + -- ca <- MaybeT $ matchingCourse (a, cna) + -- cb <- MaybeT $ matchingCourse (b, cnb) + + -- let rank (s, cn) c = Seq.elemIndexL c $ studentPrefs cstb (s, cn) + -- caRa <- hoistMaybe $ rank (a, cna) ca + -- caRb <- hoistMaybe $ rank (b, cnb) ca + -- cbRa <- hoistMaybe $ rank (a, cna) cb + -- cbRb <- hoistMaybe $ rank (b, cnb) cb + + -- let currentRanks cop = caRa `cop` cbRb + -- newRanks cop = cbRa `cop` caRb + + -- swapImproves = or + -- [ currentRanks (+) > newRanks (+) + -- , currentRanks (+) == newRanks (+) + -- && currentRanks min > newRanks min + -- ] + -- lift . when swapImproves $ do + -- traceM $ show (a, cna) <> " `swap` " <> show (b, cnb) + -- let + -- addCourseUser :: course -> (student, CloneIndex) -> ST s () + -- addCourseUser c (st, cn) = do + -- cState <- MArr.readArray courses' c + -- case cState of + -- Left pSet -> + -- MArr.writeArray courses' c $!! Left (Set.insert (st, cn) pSet) + -- Right spots -> + -- let (worseSpots, betterSpots) = Seq.spanr isWorseSpot spots + -- isWorseSpot existing = case (comparing $ courseRating c &&& stb) existing (st, cn) of + -- EQ -> error "Two student-clones compared equal in the face of stb" + -- GT -> False + -- LT -> True + -- newSpots = force $ betterSpots <> Seq.singleton (st, cn) <> worseSpots + -- in MArr.writeArray courses' c $ Right newSpots + -- remCourseUser :: course -> (student, CloneIndex) -> ST s () + -- remCourseUser c (st, cn) = do + -- cState <- MArr.readArray courses' c + -- case cState of + -- Left pSet -> + -- MArr.writeArray courses' c $!! Left (Set.delete (st, cn) pSet) + -- Right spots -> + -- MArr.writeArray courses' c $!! Right (Seq.filter (/= (st, cn)) spots) + + -- remCourseUser ca (a, cna) + -- remCourseUser cb (b, cnb) + -- addCourseUser cb (a, cna) + -- addCourseUser ca (b, cnb) + + -- lift pairwiseExchange + + + courseMatchings <- lift . lift $ MArr.getAssocs courses' + return . Set.fromList $ do + (course, students) <- courseMatchings + student <- case students of + Left pSet -> view _1 <$> toList pSet + Right spots -> view _1 <$> toList spots + return (student, course) + + courseRating :: course -> (student, CloneIndex) -> courseRatingStudent' + courseRating c (st, cn) = centralNudge st (fromIntegral cn) courseRating' + where + (_, courseRating') = preferences Map.! (st, c) + + clonedStudents :: Set (student, CloneIndex) + clonedStudents = Set.fromDistinctAscList $ do + (student, clones) <- Map.toAscList cloneCounts + clone <- [0,1..pred $ fromIntegral clones] + return (student, clone) + + courses :: Set course + courses = Set.fromDistinctAscList . map (view _1) . filter (maybe True (> 0) . view _2) $ Map.toAscList capacities + courseBounds :: (course, course) + courseBounds = Set.findMin &&& Set.findMax $ courses + + initCourse :: course -> Either (Set (student, CloneIndex)) (Seq (student, CloneIndex)) + initCourse c + | is _Just . join $ Map.lookup c capacities + = Right Seq.empty + | otherwise + = Left Set.empty + + studentPrefs :: forall a. Ord a => (course -> a) -> (student, CloneIndex) -> Seq course + studentPrefs cstb (st, _) = Seq.fromList . map (view _1) . sortOn (Down . view _2) . mapMaybe (\c -> (c, ) <$> cPref c) $ Set.toList courses + where + cPref :: course -> Maybe (studentRatingCourse, a) + cPref c = do + (cPref', _) <- Map.lookup (st, c) preferences + return (cPref', cstb c) diff --git a/test/Utils/AllocationSpec.hs b/test/Utils/AllocationSpec.hs new file mode 100644 index 000000000..2e8c81854 --- /dev/null +++ b/test/Utils/AllocationSpec.hs @@ -0,0 +1,120 @@ +module Utils.AllocationSpec where + +import TestImport hiding (Course) + +import Handler.Utils.Allocation + +import qualified Data.Map as Map +import qualified Data.Set as Set + +import System.Random (mkStdGen) + +import Data.Ix (Ix) + + +data Man = Alpha | Beta | Gamma | Delta + deriving (Eq, Ord, Bounded, Enum, Read, Show, Generic, Typeable) +instance NFData Man + +data Woman = Alef | Bet | Gimel | Dalet + deriving (Eq, Ord, Bounded, Enum, Ix, Read, Show, Generic, Typeable) + + +spec :: Spec +spec = describe "computeMatching" $ + it "produces some expected known matchings" $ do + example $ do + let men = Map.fromList $ (, 1) <$> [Alpha .. Gamma] + women = Map.fromList $ (, Just 1) <$> [Alef .. Gimel] + preferences = fmap ((3 -) *** (3 -)) $ Map.fromList + [ ((Alpha, Alef ), (1, 3)) + , ((Alpha, Bet ), (2, 2)) + , ((Alpha, Gimel), (3, 1)) + , ((Beta , Alef ), (3, 1)) + , ((Beta , Bet ), (1, 3)) + , ((Beta , Gimel), (2, 2)) + , ((Gamma, Alef ), (2, 2)) + , ((Gamma, Bet ), (3, 1)) + , ((Gamma, Gimel), (1, 3)) + ] + + centralNudge _ _ = id + + expectedResult = Set.fromList [(Alpha, Alef), (Beta, Bet), (Gamma, Gimel)] + ourResult = computeMatching (mkStdGen 0) men women preferences centralNudge + ourResult `shouldBe` expectedResult + + example $ do + let men = Map.fromList $ (, 1) <$> [Alpha .. Delta] + women = Map.fromList $ (, Just 1) <$> [Alef .. Dalet] + preferences = fmap ((4 -) *** (4 -)) $ Map.fromList + [ ((Alpha, Alef ), (1, 3)) + , ((Alpha, Bet ), (2, 3)) + , ((Alpha, Gimel), (3, 2)) + , ((Alpha, Dalet), (4, 3)) + , ((Beta , Alef ), (1, 4)) + , ((Beta , Bet ), (4, 1)) + , ((Beta , Gimel), (3, 3)) + , ((Beta , Dalet), (2, 2)) + , ((Gamma, Alef ), (2, 2)) + , ((Gamma, Bet ), (1, 4)) + , ((Gamma, Gimel), (3, 4)) + , ((Gamma, Dalet), (4, 1)) + , ((Delta, Alef ), (4, 1)) + , ((Delta, Bet ), (2, 2)) + , ((Delta, Gimel), (3, 1)) + , ((Delta, Dalet), (1, 4)) + ] + + centralNudge _ _ = id + + expectedResult = Set.fromList [(Alpha, Gimel), (Beta, Dalet), (Gamma, Alef), (Delta, Bet)] + ourResult = computeMatching (mkStdGen 0) men women preferences centralNudge + ourResult `shouldBe` expectedResult + + example $ do + let men = Map.fromList $ (, 1) <$> [Alpha .. Delta] + women = Map.fromList $ (, Just 1) <$> [Alef .. Dalet] + preferences = fmap ((4 -) *** (4 -)) $ Map.fromList + [ ((Alpha, Alef ), (1, 3)) + , ((Alpha, Bet ), (2, 2)) + , ((Alpha, Gimel), (3, 1)) + , ((Alpha, Dalet), (4, 3)) + , ((Beta , Alef ), (1, 4)) + , ((Beta , Bet ), (2, 3)) + , ((Beta , Gimel), (3, 2)) + , ((Beta , Dalet), (4, 4)) + , ((Gamma, Alef ), (3, 1)) + , ((Gamma, Bet ), (1, 4)) + , ((Gamma, Gimel), (2, 3)) + , ((Gamma, Dalet), (4, 2)) + , ((Delta, Alef ), (2, 2)) + , ((Delta, Bet ), (3, 1)) + , ((Delta, Gimel), (1, 4)) + , ((Delta, Dalet), (4, 1)) + ] + + centralNudge _ _ = id + + expectedResult = Set.fromList [(Alpha, Gimel), (Beta, Dalet), (Gamma, Alef), (Delta, Bet)] + ourResult = computeMatching (mkStdGen 0) men women preferences centralNudge + ourResult `shouldBe` expectedResult + + example $ do + let students = Map.fromList $ (, 1) <$> ([1..6] :: [Int]) + colleges = Map.fromList $ (, Just 2) <$> (['A'..'C'] :: [Char]) + student_preferences = Map.fromList + [ ((1, 'A'), 3), ((1, 'B'), 2), ((1, 'C'), 1) + , ((2, 'A'), 3), ((2, 'B'), 1), ((2, 'C'), 2) + , ((3, 'A'), 3), ((3, 'B'), 2), ((3, 'C'), 1) + , ((4, 'A'), 2), ((4, 'B'), 3), ((4, 'C'), 1) + , ((5, 'A'), 1), ((5, 'B'), 3), ((5, 'C'), 2) + , ((6, 'A'), 2), ((6, 'B'), 1), ((6, 'C'), 6) + ] + preferences = Map.mapWithKey (\(st, _) stPref -> (stPref, 7 - st)) student_preferences + + centralNudge _ _ = id + + expectedResult = Set.fromList [(1, 'A'), (2, 'A'), (3, 'B'), (4, 'B'), (5, 'C'), (6, 'C')] + ourResult = computeMatching (mkStdGen 0) students colleges preferences centralNudge + ourResult `shouldBe` expectedResult From b4100472e5a28b5b2aa5d92174fdd6a40aaf169f Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 3 Oct 2019 11:26:59 +0200 Subject: [PATCH 2/3] refactor(allocation-algo): minor refinements --- src/Utils/Allocation.hs | 68 ++++++++++++++++++++++++------------ test/Utils/AllocationSpec.hs | 64 ++++++++++++++++++++++++++------- 2 files changed, 98 insertions(+), 34 deletions(-) diff --git a/src/Utils/Allocation.hs b/src/Utils/Allocation.hs index d7fc75022..a00b0deb1 100644 --- a/src/Utils/Allocation.hs +++ b/src/Utils/Allocation.hs @@ -20,9 +20,12 @@ import Control.Monad.Trans.State.Strict (StateT, modify', get, gets, evalStateT) import Control.Monad.Writer (tell) import Control.Monad.ST -import Data.STRef + +import Data.List ((!!), elemIndex) +type CourseIndex = Int +type StudentIndex = Int type CloneIndex = Int data MatchingLog student course cloneIndex @@ -35,9 +38,8 @@ data MatchingLog student course cloneIndex computeMatching :: forall randomGen student course cloneCount cloneIndex capacity studentRatingCourse courseRatingStudent courseRatingStudent'. ( RandomGen randomGen - , Ord student - , Show student, Show course - , NFData student, Ix course + , Ord student, Ord course + , NFData student , Ord studentRatingCourse , Ord courseRatingStudent , Ord courseRatingStudent' @@ -54,9 +56,8 @@ computeMatching g cloneCounts capacities preferences centralNudge computeMatchingLog :: forall randomGen student course cloneCount cloneIndex capacity studentRatingCourse courseRatingStudent courseRatingStudent'. ( RandomGen randomGen - , Ord student - , Show student, Show course - , NFData student, Ix course + , Ord student, Ord course + , NFData student , Ord studentRatingCourse , Ord courseRatingStudent , Ord courseRatingStudent' @@ -72,10 +73,14 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $ where computeMatching' :: forall s. ST s (Set (student, course), Seq (MatchingLog student course cloneIndex)) computeMatching' = runWriterT . flip evalRandT g $ do - courses' <- lift . lift . MArr.newListArray courseBounds . map initCourse $ Set.toAscList courses :: RandT randomGen (WriterT _ (ST s)) (STArray s course (Either (Set (student, CloneIndex)) (Seq (student, CloneIndex)))) stb <- (Map.!) <$> sequence (Map.fromSet (const getRandom) clonedStudents) :: RandT randomGen (WriterT _ (ST s)) ((student, CloneIndex) -> UUID) cstb <- (Map.!) <$> sequence (Map.fromSet (const getRandom) courses) :: RandT randomGen (WriterT _ (ST s)) (course -> UUID) - stPrefs <- lift . lift . fmap curry $ (Map.!) <$> sequence (Map.fromSet (newSTRef . studentPrefs cstb) clonedStudents) :: RandT randomGen (WriterT _ (ST s)) (student -> CloneIndex -> STRef _ (Seq course)) + + courses' <- lift . lift . MArr.newListArray courseBounds . map initCourse $ Set.toAscList courses :: RandT randomGen (WriterT _ (ST s)) (STArray s CourseIndex (Either (Set (student, CloneIndex)) (Seq (student, CloneIndex)))) + + stPrefs <- lift . lift $ MArr.newArray studentBounds [] :: RandT randomGen (WriterT _ (ST s)) (STArray s (StudentIndex, CloneIndex) [course]) + forM_ clonedStudents $ \(st, cn) -> + lift . lift . MArr.writeArray stPrefs (st ^. contStudents, cn) $ studentPrefs cstb (st, cn) let propose :: StateT (Set (student, CloneIndex)) (WriterT _ (ST s)) () @@ -83,24 +88,24 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $ lift . tell . pure . MatchingConsider st $ fromIntegral cn let markDone = modify' $ Set.delete (st, cn) - options <- fmap Seq.viewl . lift . lift . readSTRef $ stPrefs st cn + options <- lift . lift $ MArr.readArray stPrefs (st ^. contStudents, cn) case options of - Seq.EmptyL -> markDone - c Seq.:< cs -> do - lift . lift $ writeSTRef (stPrefs st cn) cs - cState <- lift . lift $ MArr.readArray courses' c + [] -> markDone + c : cs -> do + lift . lift $ MArr.writeArray stPrefs (st ^. contStudents, cn) cs + cState <- lift . lift $ MArr.readArray courses' (c ^. contCourses) case cState of Left pSet | none (\(st', _) -> st == st') pSet -> do lift . tell . pure $ MatchingApply st (fromIntegral cn) c - lift . lift . MArr.writeArray courses' c $!! Left (Set.insert (st, cn) pSet) + lift . lift . MArr.writeArray courses' (c ^. contCourses) $!! Left (Set.insert (st, cn) pSet) markDone Right spots | none (\(st', _) -> st == st') spots -> do courseMatchings <- lift . lift $ MArr.getAssocs courses' let matchingCourse s cn' = listToMaybe $ do - (course, students) <- courseMatchings + (review contCourses -> course, students) <- courseMatchings student <- case students of Left pSet -> toList pSet Right spots' -> toList spots' @@ -126,7 +131,7 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $ | otherwise -> do lift . tell . pure $ MatchingApply st (fromIntegral cn) c - lift . lift . MArr.writeArray courses' c $ Right newSpots + lift . lift . MArr.writeArray courses' (c ^. contCourses) $ Right newSpots forM_ lostSpots $ \(st', cn') -> do lift . tell . pure $ MatchingLostSpot st' (fromIntegral cn') c modify' $ Set.insert (st', cn') @@ -212,7 +217,7 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $ courseMatchings <- lift . lift $ MArr.getAssocs courses' return . Set.fromList $ do - (course, students) <- courseMatchings + (review contCourses -> course, students) <- courseMatchings student <- case students of Left pSet -> view _1 <$> toList pSet Right spots -> view _1 <$> toList spots @@ -229,10 +234,29 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $ clone <- [0,1..pred $ fromIntegral clones] return (student, clone) + contStudents :: Iso' student StudentIndex + contStudents = iso toInt fromInt + where + students' = Map.keys cloneCounts + + toInt = fromMaybe (error "trying to resolve unknown student") . flip elemIndex students' + fromInt = (!!) students' + + studentBounds :: ((StudentIndex, CloneIndex), (StudentIndex, CloneIndex)) + studentBounds = ((0, 0), (pred $ Map.size cloneCounts, maybe 0 maximum . fromNullable $ pred . fromIntegral <$> cloneCounts)) + courses :: Set course courses = Set.fromDistinctAscList . map (view _1) . filter (maybe True (> 0) . view _2) $ Map.toAscList capacities - courseBounds :: (course, course) - courseBounds = Set.findMin &&& Set.findMax $ courses + courseBounds :: (CourseIndex, CourseIndex) + courseBounds = (0, pred $ Set.size courses) + + contCourses :: Iso' course CourseIndex + contCourses = iso toInt fromInt + where + courses' = Set.toAscList courses + + toInt = fromMaybe (error "trying to resolve unknown course") . flip elemIndex courses' + fromInt = (!!) courses' initCourse :: course -> Either (Set (student, CloneIndex)) (Seq (student, CloneIndex)) initCourse c @@ -241,8 +265,8 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $ | otherwise = Left Set.empty - studentPrefs :: forall a. Ord a => (course -> a) -> (student, CloneIndex) -> Seq course - studentPrefs cstb (st, _) = Seq.fromList . map (view _1) . sortOn (Down . view _2) . mapMaybe (\c -> (c, ) <$> cPref c) $ Set.toList courses + studentPrefs :: forall a. Ord a => (course -> a) -> (student, CloneIndex) -> [course] + studentPrefs cstb (st, _) = map (view _1) . sortOn (Down . view _2) . mapMaybe (\c -> (c, ) <$> cPref c) $ Set.toList courses where cPref :: course -> Maybe (studentRatingCourse, a) cPref c = do diff --git a/test/Utils/AllocationSpec.hs b/test/Utils/AllocationSpec.hs index 2e8c81854..361763b4d 100644 --- a/test/Utils/AllocationSpec.hs +++ b/test/Utils/AllocationSpec.hs @@ -2,22 +2,20 @@ module Utils.AllocationSpec where import TestImport hiding (Course) -import Handler.Utils.Allocation +import Utils.Allocation import qualified Data.Map as Map import qualified Data.Set as Set import System.Random (mkStdGen) -import Data.Ix (Ix) - data Man = Alpha | Beta | Gamma | Delta deriving (Eq, Ord, Bounded, Enum, Read, Show, Generic, Typeable) instance NFData Man data Woman = Alef | Bet | Gimel | Dalet - deriving (Eq, Ord, Bounded, Enum, Ix, Read, Show, Generic, Typeable) + deriving (Eq, Ord, Bounded, Enum, Read, Show, Generic, Typeable) spec :: Spec @@ -43,7 +41,49 @@ spec = describe "computeMatching" $ expectedResult = Set.fromList [(Alpha, Alef), (Beta, Bet), (Gamma, Gimel)] ourResult = computeMatching (mkStdGen 0) men women preferences centralNudge ourResult `shouldBe` expectedResult + + example $ do + let men = Map.fromList $ (, 2) <$> [Alpha,Beta,Delta] + women = Map.fromList $ (, Just 1) <$> [Alef .. Gimel] + preferences = fmap ((3 -) *** (3 -)) $ Map.fromList + [ ((Alpha, Alef ), (1, 3)) + , ((Alpha, Bet ), (2, 2)) + , ((Alpha, Gimel), (3, 1)) + , ((Beta , Alef ), (3, 1)) + , ((Beta , Bet ), (1, 3)) + , ((Beta , Gimel), (2, 2)) + , ((Delta, Alef ), (2, 2)) + , ((Delta, Bet ), (3, 1)) + , ((Delta, Gimel), (1, 3)) + ] + + centralNudge _ _ = id + + expectedResult = Set.fromList [(Alpha, Alef), (Beta, Bet), (Delta, Gimel)] + ourResult = computeMatching (mkStdGen 0) men women preferences centralNudge + ourResult `shouldBe` expectedResult + example $ do + let men = Map.fromList $ (, 2) <$> [Alpha .. Gamma] + women = Map.fromList $ (, Just 2) <$> [Alef .. Gimel] + preferences = fmap ((3 -) *** (3 -)) $ Map.fromList + [ ((Alpha, Alef ), (1, 3)) + , ((Alpha, Bet ), (2, 2)) + , ((Alpha, Gimel), (3, 1)) + , ((Beta , Alef ), (3, 1)) + , ((Beta , Bet ), (1, 3)) + , ((Beta , Gimel), (2, 2)) + , ((Gamma, Alef ), (2, 2)) + , ((Gamma, Bet ), (3, 1)) + , ((Gamma, Gimel), (1, 3)) + ] + + centralNudge _ _ = id + + expectedResult = Set.fromList [(Alpha, Alef), (Gamma, Alef), (Beta, Bet), (Alpha, Bet), (Beta, Gimel), (Gamma, Gimel)] + ourResult = computeMatching (mkStdGen 0) men women preferences centralNudge + ourResult `shouldBe` expectedResult + example $ do let men = Map.fromList $ (, 1) <$> [Alpha .. Delta] women = Map.fromList $ (, Just 1) <$> [Alef .. Dalet] @@ -102,19 +142,19 @@ spec = describe "computeMatching" $ example $ do let students = Map.fromList $ (, 1) <$> ([1..6] :: [Int]) - colleges = Map.fromList $ (, Just 2) <$> (['A'..'C'] :: [Char]) + colleges = Map.fromList $ (, Just 2) <$> (['A', 'Z', 'C'] :: [Char]) student_preferences = Map.fromList - [ ((1, 'A'), 3), ((1, 'B'), 2), ((1, 'C'), 1) - , ((2, 'A'), 3), ((2, 'B'), 1), ((2, 'C'), 2) - , ((3, 'A'), 3), ((3, 'B'), 2), ((3, 'C'), 1) - , ((4, 'A'), 2), ((4, 'B'), 3), ((4, 'C'), 1) - , ((5, 'A'), 1), ((5, 'B'), 3), ((5, 'C'), 2) - , ((6, 'A'), 2), ((6, 'B'), 1), ((6, 'C'), 6) + [ ((1, 'A'), 3), ((1, 'Z'), 2), ((1, 'C'), 1) + , ((2, 'A'), 3), ((2, 'Z'), 1), ((2, 'C'), 2) + , ((3, 'A'), 3), ((3, 'Z'), 2), ((3, 'C'), 1) + , ((4, 'A'), 2), ((4, 'Z'), 3), ((4, 'C'), 1) + , ((5, 'A'), 1), ((5, 'Z'), 3), ((5, 'C'), 2) + , ((6, 'A'), 2), ((6, 'Z'), 1), ((6, 'C'), 6) ] preferences = Map.mapWithKey (\(st, _) stPref -> (stPref, 7 - st)) student_preferences centralNudge _ _ = id - expectedResult = Set.fromList [(1, 'A'), (2, 'A'), (3, 'B'), (4, 'B'), (5, 'C'), (6, 'C')] + expectedResult = Set.fromList [(1, 'A'), (2, 'A'), (3, 'Z'), (4, 'Z'), (5, 'C'), (6, 'C')] ourResult = computeMatching (mkStdGen 0) students colleges preferences centralNudge ourResult `shouldBe` expectedResult From 47bfd8d4ea3e5ef9f5270c08c70346cd29aa44aa Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 3 Oct 2019 15:18:36 +0200 Subject: [PATCH 3/3] feat(allocations): auxilliaries for allocation-algo --- config/settings.yml | 6 ++ models/allocations.model | 2 + models/courses.model | 2 +- src/Handler/Allocation/Register.hs | 1 + src/Handler/Course/ParticipantInvite.hs | 6 +- src/Handler/Course/Register.hs | 4 +- src/Handler/Course/User.hs | 2 +- src/Handler/Exam/AddUser.hs | 2 +- src/Handler/Exam/RegistrationInvite.hs | 2 +- src/Handler/Exam/Users.hs | 2 +- src/Handler/Utils/Allocation.hs | 133 ++++++++++++++++++++++++ src/Handler/Utils/Csv.hs | 14 ++- src/Model/Migration.hs | 11 ++ src/Model/Types.hs | 1 + src/Model/Types/Allocation.hs | 34 ++++++ src/Settings.hs | 6 +- src/Utils/Allocation.hs | 14 ++- src/Utils/Lens.hs | 2 + test/Database.hs | 5 +- 19 files changed, 228 insertions(+), 21 deletions(-) create mode 100644 src/Handler/Utils/Allocation.hs create mode 100644 src/Model/Types/Allocation.hs diff --git a/config/settings.yml b/config/settings.yml index 12150c38e..0f439d9d6 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -130,5 +130,11 @@ user-defaults: download-files: false warning-days: 1209600 +# During central allocations lecturer-given ratings of applications (as +# ExamGrades) are combined with a central priority. +# This encodes the weight of the lecturer ratings on the same scale as the +# centrally supplied priorities. +allocation-grade-scale: 25 + instance-id: "_env:INSTANCE_ID:instance" ribbon: "_env:RIBBON:" diff --git a/models/allocations.model b/models/allocations.model index 9ddbd59bd..dbca97b85 100644 --- a/models/allocations.model +++ b/models/allocations.model @@ -21,6 +21,7 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis registerByCourse UTCTime Maybe -- course registration dates are ignored until this day has passed or always prohibited overrideDeregister UTCTime Maybe -- course deregistration enforced to be this date, i.e. students may disenrol from course after or never -- overrideVisible not needed, since courses are always visible + matchingLog FileId Maybe TermSchoolAllocationShort term school shorthand -- shorthand must be unique within school and semester TermSchoolAllocationName term school name -- name must be unique within school and semester deriving Show Eq Ord Generic @@ -35,6 +36,7 @@ AllocationUser allocation AllocationId user UserId totalCourses Natural -- number of total allocated courses for this user must be <= than this number + priority AllocationPriority Maybe UniqueAllocationUser allocation user AllocationDeregister -- self-inflicted user-deregistrations from an allocated course diff --git a/models/courses.model b/models/courses.model index 5cdecddd6..ebdf6e62a 100644 --- a/models/courses.model +++ b/models/courses.model @@ -51,7 +51,7 @@ CourseParticipant -- course enrolement user UserId registration UTCTime -- time of last enrolement for this course field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades - allocated Bool default=false -- participant was centrally allocated + allocated AllocationId Maybe -- participant was centrally allocated UniqueParticipant user course -- Replace the last two by the following, once an audit log is available -- CourseUserNote -- lecturers of a specific course may share a text note on each enrolled student diff --git a/src/Handler/Allocation/Register.hs b/src/Handler/Allocation/Register.hs index eb5e55255..c502ab48a 100644 --- a/src/Handler/Allocation/Register.hs +++ b/src/Handler/Allocation/Register.hs @@ -50,6 +50,7 @@ postARegisterR tid ssh ash = do { allocationUserAllocation = aId , allocationUserUser = uid , allocationUserTotalCourses = arfTotalCourses + , allocationUserPriority = Nothing } [ AllocationUserTotalCourses =. arfTotalCourses ] diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 9459346a3..fe9b96804 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -38,7 +38,7 @@ instance IsInvitableJunction CourseParticipant where data InvitableJunction CourseParticipant = JunctionParticipant { jParticipantRegistration :: UTCTime , jParticipantField :: Maybe StudyFeaturesId - , jParticipantAllocated :: Bool + , jParticipantAllocated :: Maybe AllocationId } deriving (Eq, Ord, Read, Show, Generic, Typeable) data InvitationDBData CourseParticipant = InvDBDataParticipant -- no data needed in DB to manage participant invitation @@ -90,7 +90,7 @@ participantInvitationConfig = InvitationConfig{..} now <- liftIO getCurrentTime studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid) (fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing - return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure False + return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure Nothing invitationInsertHook _ _ CourseParticipant{..} _ act = do res <- act audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser @@ -193,7 +193,7 @@ registerUser cid uid = exceptT tell tell $ do void . lift . lift . insert $ CourseParticipant { courseParticipantCourse = cid , courseParticipantUser = uid - , courseParticipantAllocated = False + , courseParticipantAllocated = Nothing , .. } lift . lift . audit $ TransactionCourseParticipantEdit cid uid diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index abef977ae..3cbc7e2e8 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -197,7 +197,7 @@ postCRegisterR tid ssh csh = do = return $ Just () mkRegistration = do audit $ TransactionCourseParticipantEdit cid uid - insertUnique $ CourseParticipant cid uid cTime crfStudyFeatures False + insertUnique $ CourseParticipant cid uid cTime crfStudyFeatures Nothing deleteApplications = do appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] [] @@ -222,7 +222,7 @@ postCRegisterR tid ssh csh = do delete $ partId audit $ TransactionCourseParticipantDeleted cid uid - when courseParticipantAllocated $ do + when (is _Just courseParticipantAllocated) $ do now <- liftIO getCurrentTime insert_ $ AllocationDeregister courseParticipantUser (Just courseParticipantCourse) now Nothing diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index bd222d966..d60b3821e 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -150,7 +150,7 @@ postCUserR tid ssh csh uCId = do | otherwise = Nothing pId <- runDB $ do - pId <- insertUnique $ CourseParticipant cid uid now field False + pId <- insertUnique $ CourseParticipant cid uid now field Nothing when (is _Just pId) $ audit $ TransactionCourseParticipantEdit cid uid return pId diff --git a/src/Handler/Exam/AddUser.hs b/src/Handler/Exam/AddUser.hs index 23203d2f2..a475e7ef6 100644 --- a/src/Handler/Exam/AddUser.hs +++ b/src/Handler/Exam/AddUser.hs @@ -147,7 +147,7 @@ postEAddUserR tid ssh csh examn = do { courseParticipantCourse = cid , courseParticipantUser = uid , courseParticipantRegistration = now - , courseParticipantAllocated = False + , courseParticipantAllocated = Nothing , .. } lift . lift . audit $ TransactionCourseParticipantEdit cid uid diff --git a/src/Handler/Exam/RegistrationInvite.hs b/src/Handler/Exam/RegistrationInvite.hs index ff707cf04..483071cad 100644 --- a/src/Handler/Exam/RegistrationInvite.hs +++ b/src/Handler/Exam/RegistrationInvite.hs @@ -97,7 +97,7 @@ examRegistrationInvitationConfig = InvitationConfig{..} (True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing) invitationInsertHook (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do whenIsJust mField $ \cpField -> do - insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField False + insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField Nothing audit $ TransactionCourseParticipantEdit examCourse examRegistrationUser let doAudit = audit $ TransactionExamRegister eid examRegistrationUser diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index 87f8e1cb5..084263183 100644 --- a/src/Handler/Exam/Users.hs +++ b/src/Handler/Exam/Users.hs @@ -742,7 +742,7 @@ postEUsersR tid ssh csh examn = do , courseParticipantUser = examUserCsvActUser , courseParticipantRegistration = now , courseParticipantField = examUserCsvActCourseField - , courseParticipantAllocated = False + , courseParticipantAllocated = Nothing } audit $ TransactionCourseParticipantEdit examCourse examUserCsvActUser insert_ ExamRegistration diff --git a/src/Handler/Utils/Allocation.hs b/src/Handler/Utils/Allocation.hs new file mode 100644 index 000000000..d5fe3fb72 --- /dev/null +++ b/src/Handler/Utils/Allocation.hs @@ -0,0 +1,133 @@ +module Handler.Utils.Allocation + ( sinkAllocationPriorities + , computeAllocation + , doAllocation + , ppMatchingLog, storeMatchingLog + ) where + +import Import + +import qualified Data.Map.Strict as Map + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + +import Data.List (genericLength, elemIndex) +import qualified Data.Vector as Vector +import Data.Vector.Lens (vector) +import qualified Data.Set as Set + +import System.Random (newStdGen) + +import Utils.Allocation + +import qualified Data.Conduit.List as C + +import Data.Generics.Product.Param + + +sinkAllocationPriorities :: AllocationId + -> ConduitT (Map UserMatriculation AllocationPriority) Void DB () +sinkAllocationPriorities allocId = C.mapM_ . imapM_ $ \matr prio -> + E.update $ \allocationUser -> do + E.set allocationUser [ AllocationUserPriority E.=. E.val (Just prio) ] + E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val allocId + E.where_ . E.exists . E.from $ \user -> + E.where_ $ user E.^. UserId E.==. allocationUser E.^. AllocationUserUser + E.&&. user E.^. UserMatrikelnummer E.==. E.val (Just matr) + + +computeAllocation :: AllocationId + -> DB (Set (UserId, CourseId), Seq (MatchingLog UserId CourseId Natural)) +computeAllocation allocId = do + users' <- selectList [ AllocationUserAllocation ==. allocId ] [] + let cloneCounts = Map.filter (> 0) . Map.fromList $ (allocationUserUser . entityVal &&& allocationUserTotalCourses . entityVal) <$> users' + + courses' <- E.select . E.from $ \(allocationCourse `E.InnerJoin` course) -> do + E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId + E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val allocId + + let participants = E.sub_select . E.from $ \participant -> do + E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId + E.where_ . E.not_ . E.exists . E.from $ \lecturer -> do + E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId + E.&&. lecturer E.^. LecturerUser E.==. participant E.^. CourseParticipantUser + return E.countRows + + return ( allocationCourse + , E.maybe E.nothing (\c -> E.just $ c E.-. participants) (course E.^. CourseCapacity) + , allocationCourse E.^. AllocationCourseMinCapacity E.-. participants + ) + let capacities = Map.filter (maybe True (> 0)) . Map.fromList $ (view (_1 . _entityVal . _allocationCourseCourse) &&& view (_2 . _Value)) <$> courses' + + applications' <- selectList [ CourseApplicationAllocation ==. Just allocId ] [] + let applications'' = applications' & filter ((\CourseApplication{..} -> not courseApplicationRatingVeto && fromMaybe True (courseApplicationRatingPoints ^? _Just . passingGrade . _Wrapped)) . entityVal) + preferences = Map.fromList $ do + Entity _ CourseApplication{..} <- applications'' + return ((courseApplicationUser, courseApplicationCourse), (courseApplicationAllocationPriority, courseApplicationRatingPoints)) + + gradeScale <- getsYesod $ view _appAllocationGradeScale + let centralNudge user (fromIntegral -> cloneIndex) grade + | Just AllocationPriorityNumeric{..} <- allocationPrio + = let allocationPriorities' = under vector (sortOn Down) allocationPriorities + minPrio | Vector.null allocationPriorities' = 0 + | otherwise = Vector.last allocationPriorities' + in withNumericGrade . fromMaybe minPrio $ allocationPriorities Vector.!? cloneIndex + | otherwise + = withNumericGrade 0 + where + allocationPrio = allocationUserPriority . entityVal =<< listToMaybe (filter ((== user) . allocationUserUser . entityVal) users') + + withNumericGrade + | Just grade' <- grade + = let numberGrade' = fromMaybe (error "non-passing grade") (fromIntegral <$> elemIndex grade' passingGrades) / pred (genericLength passingGrades) + passingGrades = sort $ filter (view $ passingGrade . _Wrapped) universeF + numericGrade = -gradeScale + numberGrade' * 2 * gradeScale + in (+) numericGrade . fromInteger + | otherwise + = fromInteger + + g <- liftIO newStdGen + + let + doAllocationWithout cs = runWriter $ computeMatchingLog g cloneCounts capacities' preferences' centralNudge + where + capacities' = Map.filterWithKey (\ c _ -> Set.notMember c cs) capacities + preferences' = Map.filterWithKey (\(_, c) _ -> Set.notMember c cs) preferences + + allocationLoop cs + | not $ null belowMin = doAllocationWithout $ cs <> Set.fromList belowMin + | otherwise = (allocs, mLog) + where + (allocs, mLog) = doAllocationWithout cs + belowMin = catMaybes . flip map courses' $ \(Entity _ AllocationCourse{..}, _, E.Value minCap) -> + guardOn (Set.size (Set.filter (\(_, c) -> c == allocationCourseCourse) allocs) < minCap) allocationCourseCourse + + return $!! allocationLoop Set.empty + +doAllocation :: AllocationId + -> Set (UserId, CourseId) + -> DB () +doAllocation allocId regs = do + now <- liftIO getCurrentTime + forM_ regs $ \(uid, cid) -> do + mField <- (courseApplicationField . entityVal =<<) . listToMaybe <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] [] + void . insertUnique $ CourseParticipant cid uid now mField (Just allocId) + +ppMatchingLog :: ( MonoFoldable mono + , Element mono ~ MatchingLog UserId CourseId Natural + ) + => mono -> Text +ppMatchingLog = unlines . map (tshow . pretty) . otoList + where + pretty = over (param @1) fromSqlKey + . over (param @2) fromSqlKey + +storeMatchingLog :: ( MonoFoldable mono + , Element mono ~ MatchingLog UserId CourseId Natural + ) + => AllocationId -> mono -> DB () +storeMatchingLog allocationId (ppMatchingLog -> matchingLog) = do + now <- liftIO getCurrentTime + fId <- insert $ File "matchings.log" (Just $ encodeUtf8 matchingLog) now + update allocationId [ AllocationMatchingLog =. Just fId ] diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index bc0617d29..00ae7af49 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.Utils.Csv - ( decodeCsv + ( decodeCsv, decodeCsvPositional , encodeCsv , encodeDefaultOrderedCsv , respondCsv, respondCsvDB @@ -35,9 +35,17 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.Attoparsec.ByteString.Lazy as A +import Control.Monad.Except (ExceptT) + decodeCsv :: (MonadThrow m, FromNamedRecord csv, MonadLogger m) => ConduitT ByteString csv m () -decodeCsv = transPipe throwExceptT $ do +decodeCsv = decodeCsv' fromNamedCsv + +decodeCsvPositional :: (MonadThrow m, FromRecord csv, MonadLogger m) => HasHeader -> ConduitT ByteString csv m () +decodeCsvPositional hdr = decodeCsv' (\opts -> fromCsv opts hdr) + +decodeCsv' :: (MonadThrow m, MonadLogger m) => (forall m'. Monad m' => DecodeOptions -> ConduitT ByteString csv (ExceptT CsvParseError m') ()) -> ConduitT ByteString csv m () +decodeCsv' fromCsv' = transPipe throwExceptT $ do testBuffer <- accumTestBuffer LBS.empty mapM_ leftover $ LBS.toChunks testBuffer @@ -45,7 +53,7 @@ decodeCsv = transPipe throwExceptT $ do & guessDelimiter testBuffer $logInfoS "decodeCsv" [st|Guessed Csv.DecodeOptions from buffer of size #{tshow (LBS.length testBuffer)}/#{tshow testBufferSize}: #{tshow decodeOptions}|] - fromNamedCsv decodeOptions + fromCsv' decodeOptions where testBufferSize = 4096 accumTestBuffer acc diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 2c033b534..869db73e5 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -550,6 +550,17 @@ customMigrations = Map.fromListWith (>>) UPDATE "exam" SET "bonus_rule" = jsonb_insert("bonus_rule", '{round}' :: text[], '0.01' :: jsonb) WHERE "bonus_rule"->>'rule' = 'bonus-points'; |] ) + , ( AppliedMigrationKey [migrationVersion|23.0.0|] [version|24.0.0|] + , whenM (tableExists "course_participant") $ do + queryRes <- [sqlQQ|SELECT (EXISTS (SELECT 1 FROM "course_participant" WHERE "allocated" <> false))|] + case queryRes of + [Single False] -> + [executeQQ| + ALTER TABLE "course_participant" DROP COLUMN "allocated"; + ALTER TABLE "course_participant" ADD COLUMN "allocated" bigint; + |] + _other -> error "Cannot reconstruct course_participant.allocated" + ) ] diff --git a/src/Model/Types.hs b/src/Model/Types.hs index f6cc46755..2dff836fe 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -13,3 +13,4 @@ import Model.Types.Sheet as Types import Model.Types.Submission as Types import Model.Types.Misc as Types import Model.Types.School as Types +import Model.Types.Allocation as Types diff --git a/src/Model/Types/Allocation.hs b/src/Model/Types/Allocation.hs new file mode 100644 index 000000000..26fbaa6ad --- /dev/null +++ b/src/Model/Types/Allocation.hs @@ -0,0 +1,34 @@ +module Model.Types.Allocation + ( AllocationPriority(..) + , module Utils.Allocation + ) where + +import Import.NoModel +import Utils.Allocation (MatchingLog(..)) +import Model.Types.Common + +import qualified Data.Csv as Csv +import qualified Data.Vector as Vector + +import qualified Data.Map.Strict as Map + + +data AllocationPriority + = AllocationPriorityNumeric { allocationPriorities :: Vector Integer } + deriving (Eq, Ord, Read, Show, Generic, Typeable) +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + , constructorTagModifier = camelToPathPiece' 2 + , allNullaryToStringTag = False + , sumEncoding = TaggedObject "mode" "value" + , unwrapUnaryRecords = False + , tagSingleConstructors = True + } ''AllocationPriority +derivePersistFieldJSON ''AllocationPriority + +instance Csv.FromRecord (Map UserMatriculation AllocationPriority) where + parseRecord v = parseNumeric + where + parseNumeric + | Vector.length v >= 1 = Map.singleton <$> v Csv..! 0 <*> (AllocationPriorityNumeric <$> mapM Csv.parseField (Vector.tail v)) + | otherwise = mzero diff --git a/src/Settings.hs b/src/Settings.hs index 48d70d396..46cd62a3f 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -38,7 +38,7 @@ import qualified Yesod.Auth.Util.PasswordStore as PWStore import Data.Time (NominalDiffTime, nominalDay) -import Data.Scientific (toBoundedInteger) +import Data.Scientific (Scientific, toBoundedInteger) import Data.Word (Word16) import qualified Data.Text as Text @@ -130,6 +130,8 @@ data AppSettings = AppSettings , appTransactionLogIPRetentionTime :: NominalDiffTime + , appAllocationGradeScale :: Rational + , appReloadTemplates :: Bool -- ^ Use the reload version of templates , appMutableStatic :: Bool @@ -426,6 +428,8 @@ instance FromJSON AppSettings where appTransactionLogIPRetentionTime <- o .: "ip-retention-time" + appAllocationGradeScale <- o .: "allocation-grade-scale" <|> fmap toRational (o .: "allocation-grade-scale" :: Aeson.Parser Scientific) + appUserDefaults <- o .: "user-defaults" appAuthPWHash <- o .: "auth-pw-hash" diff --git a/src/Utils/Allocation.hs b/src/Utils/Allocation.hs index a00b0deb1..716faa2f2 100644 --- a/src/Utils/Allocation.hs +++ b/src/Utils/Allocation.hs @@ -29,12 +29,16 @@ type StudentIndex = Int type CloneIndex = Int data MatchingLog student course cloneIndex - = MatchingConsider student cloneIndex - | MatchingApply student cloneIndex course - | MatchingNoApplyCloneInstability student cloneIndex course - | MatchingLostSpot student cloneIndex course + = MatchingConsider + { mlStudent :: student, mlClone :: cloneIndex } + | MatchingApply + { mlStudent :: student, mlClone :: cloneIndex, mlCourse :: course } + | MatchingNoApplyCloneInstability + { mlStudent :: student, mlClone :: cloneIndex, mlCourse :: course } + | MatchingLostSpot + { mlStudent :: student, mlClone :: cloneIndex, mlCourse :: course } deriving (Eq, Ord, Read, Show, Generic, Typeable) - +instance (NFData student, NFData course, NFData cloneIndex) => NFData (MatchingLog student course cloneIndex) computeMatching :: forall randomGen student course cloneCount cloneIndex capacity studentRatingCourse courseRatingStudent courseRatingStudent'. ( RandomGen randomGen diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index c094419a1..234ab1075 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -206,6 +206,8 @@ makeLenses_ ''UserFunction makeLenses_ ''CourseUserExamOfficeOptOut makeLenses_ ''CourseNewsFile + +makeLenses_ ''AllocationCourse -- makeClassy_ ''Load diff --git a/test/Database.hs b/test/Database.hs index 78416f2fe..92d2a1473 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -469,7 +469,7 @@ fillDb = do insert_ $ SheetEdit gkleen now feste keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ UploadAny True Nothing) False insert_ $ SheetEdit gkleen now keine - void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf False) + void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf Nothing) [(fhamann , Nothing) ,(maxMuster , Just sfMMs) ,(tinaTester, Just sfTTc) @@ -592,7 +592,7 @@ fillDb = do insert_ $ CourseEdit jost now pmo void . insert $ DegreeCourse pmo sdBsc sdInf void . insert $ Lecturer jost pmo CourseAssistant - void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf False) + void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf Nothing) [(fhamann , Nothing) ,(maxMuster , Just sfMMp) ,(tinaTester, Just sfTTb) @@ -779,6 +779,7 @@ fillDb = do , allocationRegisterByStaffTo = Nothing , allocationRegisterByCourse = Nothing , allocationOverrideDeregister = Just now + , allocationMatchingLog = Nothing } insert_ $ AllocationCourse funAlloc pmo 100 insert_ $ AllocationCourse funAlloc ffp 2