refactor(allocation-algo): minor refinements
This commit is contained in:
Gregor Kleen
parent
0fcf48ce66
commit
b4100472e5
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user