feat(allocations): prototype assignment-algorithm
This commit is contained in:
Gregor Kleen
parent
a79e63a963
commit
0fcf48ce66
@ -139,6 +139,7 @@ dependencies:
|
||||
- multiset
|
||||
- retry
|
||||
- generic-lens
|
||||
- array
|
||||
|
||||
other-extensions:
|
||||
- GeneralizedNewtypeDeriving
|
||||
|
||||
250
src/Utils/Allocation.hs
Normal file
250
src/Utils/Allocation.hs
Normal file
@ -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)
|
||||
120
test/Utils/AllocationSpec.hs
Normal file
120
test/Utils/AllocationSpec.hs
Normal file
@ -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
|
||||
Loading…
Reference in New Issue
Block a user