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