feat(allocations): prototype assignment-algorithm

package.yaml

@@ -139,6 +139,7 @@ dependencies:
   - multiset
   - retry
   - generic-lens
+  - array
 
 other-extensions:
   - GeneralizedNewtypeDeriving

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)

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