From 0fcf48ce666b4828a33592e234ad2265d7f22952 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 2 Oct 2019 17:57:17 +0200 Subject: [PATCH] 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