fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor(allocation-algo): minor refinements

Browse Source
This commit is contained in:
Gregor Kleen 2019-10-03 11:26:59 +02:00
parent 0fcf48ce66
commit b4100472e5
2 changed files with 98 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
src/Utils/Allocation.hs
View File

@ -20,9 +20,12 @@ import Control.Monad.Trans.State.Strict (StateT, modify', get, gets, evalStateT)
import Control.Monad.Writer (tell) import Control.Monad.Writer (tell)
import Control.Monad.ST import Control.Monad.ST
import Data.STRef
import Data.List ((!!), elemIndex)
type CourseIndex = Int
type StudentIndex = Int
type CloneIndex = Int type CloneIndex = Int
data MatchingLog student course cloneIndex 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'. computeMatching :: forall randomGen student course cloneCount cloneIndex capacity studentRatingCourse courseRatingStudent courseRatingStudent'.
( RandomGen randomGen ( RandomGen randomGen
, Ord student , Ord student, Ord course
, Show student, Show course , NFData student
, NFData student, Ix course
, Ord studentRatingCourse , Ord studentRatingCourse
, Ord courseRatingStudent , Ord courseRatingStudent
, 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'. computeMatchingLog :: forall randomGen student course cloneCount cloneIndex capacity studentRatingCourse courseRatingStudent courseRatingStudent'.
( RandomGen randomGen ( RandomGen randomGen
, Ord student , Ord student, Ord course
, Show student, Show course , NFData student
, NFData student, Ix course
, Ord studentRatingCourse , Ord studentRatingCourse
, Ord courseRatingStudent , Ord courseRatingStudent
, Ord courseRatingStudent' , Ord courseRatingStudent'
@ -72,10 +73,14 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $
where where
computeMatching' :: forall s. ST s (Set (student, course), Seq (MatchingLog student course cloneIndex)) computeMatching' :: forall s. ST s (Set (student, course), Seq (MatchingLog student course cloneIndex))
computeMatching' = runWriterT . flip evalRandT g $ do 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) 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) 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 let
propose :: StateT (Set (student, CloneIndex)) (WriterT _ (ST s)) () 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 lift . tell . pure . MatchingConsider st $ fromIntegral cn
let markDone = modify' $ Set.delete (st, 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 case options of
Seq.EmptyL -> markDone [] -> markDone
c Seq.:< cs -> do c : cs -> do
lift . lift $ writeSTRef (stPrefs st cn) cs lift . lift $ MArr.writeArray stPrefs (st ^. contStudents, cn) cs
cState <- lift . lift $ MArr.readArray courses' c cState <- lift . lift $ MArr.readArray courses' (c ^. contCourses)
case cState of case cState of
Left pSet Left pSet
| none (\(st', _) -> st == st') pSet -> do | none (\(st', _) -> st == st') pSet -> do
lift . tell . pure $ MatchingApply st (fromIntegral cn) c 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 markDone
Right spots Right spots
| none (\(st', _) -> st == st') spots -> do | none (\(st', _) -> st == st') spots -> do
courseMatchings <- lift . lift $ MArr.getAssocs courses' courseMatchings <- lift . lift $ MArr.getAssocs courses'
let let
matchingCourse s cn' = listToMaybe $ do matchingCourse s cn' = listToMaybe $ do
(course, students) <- courseMatchings (review contCourses -> course, students) <- courseMatchings
student <- case students of student <- case students of
Left pSet -> toList pSet Left pSet -> toList pSet
Right spots' -> toList spots' Right spots' -> toList spots'
@ -126,7 +131,7 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $
| otherwise | otherwise
-> do -> do
lift . tell . pure $ MatchingApply st (fromIntegral cn) c 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 forM_ lostSpots $ \(st', cn') -> do
lift . tell . pure $ MatchingLostSpot st' (fromIntegral cn') c lift . tell . pure $ MatchingLostSpot st' (fromIntegral cn') c
modify' $ Set.insert (st', cn') modify' $ Set.insert (st', cn')
@ -212,7 +217,7 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $
courseMatchings <- lift . lift $ MArr.getAssocs courses' courseMatchings <- lift . lift $ MArr.getAssocs courses'
return . Set.fromList $ do return . Set.fromList $ do
(course, students) <- courseMatchings (review contCourses -> course, students) <- courseMatchings
student <- case students of student <- case students of
Left pSet -> view _1 <$> toList pSet Left pSet -> view _1 <$> toList pSet
Right spots -> view _1 <$> toList spots Right spots -> view _1 <$> toList spots
@ -229,10 +234,29 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $
clone <- [0,1..pred $ fromIntegral clones] clone <- [0,1..pred $ fromIntegral clones]
return (student, clone) 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 course
courses = Set.fromDistinctAscList . map (view _1) . filter (maybe True (> 0) . view _2) $ Map.toAscList capacities courses = Set.fromDistinctAscList . map (view _1) . filter (maybe True (> 0) . view _2) $ Map.toAscList capacities
courseBounds :: (course, course) courseBounds :: (CourseIndex, CourseIndex)
courseBounds = Set.findMin &&& Set.findMax $ courses 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 :: course -> Either (Set (student, CloneIndex)) (Seq (student, CloneIndex))
initCourse c initCourse c
@ -241,8 +265,8 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $
| otherwise | otherwise
= Left Set.empty = Left Set.empty
studentPrefs :: forall a. Ord a => (course -> a) -> (student, CloneIndex) -> Seq course studentPrefs :: forall a. Ord a => (course -> a) -> (student, CloneIndex) -> [course]
studentPrefs cstb (st, _) = Seq.fromList . map (view _1) . sortOn (Down . view _2) . mapMaybe (\c -> (c, ) <$> cPref c) $ Set.toList courses studentPrefs cstb (st, _) = map (view _1) . sortOn (Down . view _2) . mapMaybe (\c -> (c, ) <$> cPref c) $ Set.toList courses
where where
cPref :: course -> Maybe (studentRatingCourse, a) cPref :: course -> Maybe (studentRatingCourse, a)
cPref c = do cPref c = do

64
test/Utils/AllocationSpec.hs
View File

@ -2,22 +2,20 @@ module Utils.AllocationSpec where
import TestImport hiding (Course) import TestImport hiding (Course)
import Handler.Utils.Allocation import Utils.Allocation
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import System.Random (mkStdGen) import System.Random (mkStdGen)
import Data.Ix (Ix)
data Man = Alpha | Beta | Gamma | Delta data Man = Alpha | Beta | Gamma | Delta
deriving (Eq, Ord, Bounded, Enum, Read, Show, Generic, Typeable) deriving (Eq, Ord, Bounded, Enum, Read, Show, Generic, Typeable)
instance NFData Man instance NFData Man
data Woman = Alef | Bet | Gimel | Dalet 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 spec :: Spec
@ -43,7 +41,49 @@ spec = describe "computeMatching" $
expectedResult = Set.fromList [(Alpha, Alef), (Beta, Bet), (Gamma, Gimel)] expectedResult = Set.fromList [(Alpha, Alef), (Beta, Bet), (Gamma, Gimel)]
ourResult = computeMatching (mkStdGen 0) men women preferences centralNudge ourResult = computeMatching (mkStdGen 0) men women preferences centralNudge
ourResult `shouldBe` expectedResult 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 example $ do
let men = Map.fromList $ (, 1) <$> [Alpha .. Delta] let men = Map.fromList $ (, 1) <$> [Alpha .. Delta]
women = Map.fromList $ (, Just 1) <$> [Alef .. Dalet] women = Map.fromList $ (, Just 1) <$> [Alef .. Dalet]
@ -102,19 +142,19 @@ spec = describe "computeMatching" $
example $ do example $ do
let students = Map.fromList $ (, 1) <$> ([1..6] :: [Int]) 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 student_preferences = Map.fromList
[ ((1, 'A'), 3), ((1, 'B'), 2), ((1, 'C'), 1) [ ((1, 'A'), 3), ((1, 'Z'), 2), ((1, 'C'), 1)
, ((2, 'A'), 3), ((2, 'B'), 1), ((2, 'C'), 2) , ((2, 'A'), 3), ((2, 'Z'), 1), ((2, 'C'), 2)
, ((3, 'A'), 3), ((3, 'B'), 2), ((3, 'C'), 1) , ((3, 'A'), 3), ((3, 'Z'), 2), ((3, 'C'), 1)
, ((4, 'A'), 2), ((4, 'B'), 3), ((4, 'C'), 1) , ((4, 'A'), 2), ((4, 'Z'), 3), ((4, 'C'), 1)
, ((5, 'A'), 1), ((5, 'B'), 3), ((5, 'C'), 2) , ((5, 'A'), 1), ((5, 'Z'), 3), ((5, 'C'), 2)
, ((6, 'A'), 2), ((6, 'B'), 1), ((6, 'C'), 6) , ((6, 'A'), 2), ((6, 'Z'), 1), ((6, 'C'), 6)
] ]
preferences = Map.mapWithKey (\(st, _) stPref -> (stPref, 7 - st)) student_preferences preferences = Map.mapWithKey (\(st, _) stPref -> (stPref, 7 - st)) student_preferences
centralNudge _ _ = id 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 = computeMatching (mkStdGen 0) students colleges preferences centralNudge
ourResult `shouldBe` expectedResult ourResult `shouldBe` expectedResult