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

fix(allocation): don't restart cloneCount when allocating successors

Browse Source
This commit is contained in:
Gregor Kleen 2020-04-26 13:21:56 +02:00
parent 71559c9302
commit e1c6fd43b8
3 changed files with 17 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Handler/Utils/Allocation.hs
View File

@ -105,7 +105,7 @@ computeAllocation allocId cRestr = do
guard $ totalCourses > allocated guard $ totalCourses > allocated
return (user, (totalCourses - allocated, priority)) return (user, ((allocated, totalCourses - allocated), priority))
) )
& Map.fromList & Map.fromList
cloneCounts = Map.map (view _1) users'' cloneCounts = Map.map (view _1) users''

17
src/Utils/Allocation.hs
View File

@ -50,10 +50,10 @@ computeMatching :: forall randomGen student course cloneCount cloneIndex capacit
, NFData student , NFData student
, Ord studentRatingCourse , Ord studentRatingCourse
, Ord courseRatingStudent' , Ord courseRatingStudent'
, Integral cloneCount, Integral capacity, Num cloneIndex , Integral cloneCount, Integral capacity, Integral cloneIndex
) )
=> randomGen -- ^ Source of randomness => randomGen -- ^ Source of randomness
-> Map student cloneCount -- ^ requested number of placements per student -> Map student (cloneIndex, cloneCount) -- ^ requested number of placements per student
-> Map course (Maybe capacity) -- ^ capacity of courses -> Map course (Maybe capacity) -- ^ capacity of courses
-> Map (student, course) (studentRatingCourse, courseRatingStudent) -- ^ Mutual preference ordering @(studentRatingCourse, courseRatingStudent)@ -> Map (student, course) (studentRatingCourse, courseRatingStudent) -- ^ Mutual preference ordering @(studentRatingCourse, courseRatingStudent)@
-> (student -> cloneIndex -> courseRatingStudent -> courseRatingStudent') -- ^ Adjust preference ordering of courses (incorporate central priority) -> (student -> cloneIndex -> courseRatingStudent -> courseRatingStudent') -- ^ Adjust preference ordering of courses (incorporate central priority)
@ -67,10 +67,10 @@ computeMatchingLog :: forall randomGen student course cloneCount cloneIndex capa
, NFData student , NFData student
, Ord studentRatingCourse , Ord studentRatingCourse
, Ord courseRatingStudent' , Ord courseRatingStudent'
, Integral cloneCount, Integral capacity, Num cloneIndex , Integral cloneCount, Integral capacity, Integral cloneIndex
) )
=> randomGen -- ^ Source of randomness => randomGen -- ^ Source of randomness
-> Map student cloneCount -- ^ requested number of placements per student -> Map student (cloneIndex, cloneCount) -- ^ requested number of placements and first cloneIndex per student
-> Map course (Maybe capacity) -- ^ capacity of courses -> Map course (Maybe capacity) -- ^ capacity of courses
-> Map (student, course) (studentRatingCourse, courseRatingStudent) -- ^ Mutual preference ordering @(studentRatingCourse, courseRatingStudent)@ -> Map (student, course) (studentRatingCourse, courseRatingStudent) -- ^ Mutual preference ordering @(studentRatingCourse, courseRatingStudent)@
-> (student -> cloneIndex -> courseRatingStudent -> courseRatingStudent') -- ^ Adjust preference ordering of courses (incorporate central priority) -> (student -> cloneIndex -> courseRatingStudent -> courseRatingStudent') -- ^ Adjust preference ordering of courses (incorporate central priority)
@ -236,11 +236,14 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $
courseRating c (st, cn) = do courseRating c (st, cn) = do
(_, courseRating') <- preferences Map.!? (st, c) (_, courseRating') <- preferences Map.!? (st, c)
return $ centralNudge st (fromIntegral cn) courseRating' return $ centralNudge st (fromIntegral cn) courseRating'
cloneIndices :: cloneIndex -> cloneCount -> Set CloneIndex
cloneIndices firstClone clones = Set.fromList $ map fromIntegral [firstClone, pred $ firstClone + fromIntegral clones]
clonedStudents :: Set (student, CloneIndex) clonedStudents :: Set (student, CloneIndex)
clonedStudents = Set.fromDistinctAscList $ do clonedStudents = Set.fromDistinctAscList $ do
(student, clones) <- Map.toAscList cloneCounts (student, (firstClone, clones)) <- Map.toAscList cloneCounts
clone <- [0,1..pred $ fromIntegral clones] clone <- Set.toAscList $ cloneIndices firstClone clones
return (student, clone) return (student, clone)
contStudents :: Iso' student StudentIndex contStudents :: Iso' student StudentIndex
@ -252,7 +255,7 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $
fromInt = (!!) students' fromInt = (!!) students'
studentBounds :: ((StudentIndex, CloneIndex), (StudentIndex, CloneIndex)) studentBounds :: ((StudentIndex, CloneIndex), (StudentIndex, CloneIndex))
studentBounds = ((0, 0), (pred $ Map.size cloneCounts, maybe 0 maximum . fromNullable $ pred . fromIntegral <$> cloneCounts)) studentBounds = ((0, 0), (pred $ Map.size cloneCounts, fromMaybe 0 $ maximumOf (folded . to (uncurry cloneIndices) . folded) 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

12
test/Utils/AllocationSpec.hs
View File

@ -22,7 +22,7 @@ spec :: Spec
spec = describe "computeMatching" $ spec = describe "computeMatching" $
it "produces some expected known matchings" $ do it "produces some expected known matchings" $ do
example $ do example $ do
let men = Map.fromList $ (, 1) <$> [Alpha .. Gamma] let men = Map.fromList $ (, (0, 1)) <$> [Alpha .. Gamma]
women = Map.fromList $ (, Just 1) <$> [Alef .. Gimel] women = Map.fromList $ (, Just 1) <$> [Alef .. Gimel]
preferences = fmap ((3 -) *** (3 -)) $ Map.fromList preferences = fmap ((3 -) *** (3 -)) $ Map.fromList
[ ((Alpha, Alef ), (1, 3)) [ ((Alpha, Alef ), (1, 3))
@ -43,7 +43,7 @@ spec = describe "computeMatching" $
ourResult `shouldBe` expectedResult ourResult `shouldBe` expectedResult
example $ do example $ do
let men = Map.fromList $ (, 2) <$> [Alpha,Beta,Delta] let men = Map.fromList $ (, (0, 2)) <$> [Alpha,Beta,Delta]
women = Map.fromList $ (, Just 1) <$> [Alef .. Gimel] women = Map.fromList $ (, Just 1) <$> [Alef .. Gimel]
preferences = fmap ((3 -) *** (3 -)) $ Map.fromList preferences = fmap ((3 -) *** (3 -)) $ Map.fromList
[ ((Alpha, Alef ), (1, 3)) [ ((Alpha, Alef ), (1, 3))
@ -64,7 +64,7 @@ spec = describe "computeMatching" $
ourResult `shouldBe` expectedResult ourResult `shouldBe` expectedResult
example $ do example $ do
let men = Map.fromList $ (, 2) <$> [Alpha .. Gamma] let men = Map.fromList $ (, (0, 2)) <$> [Alpha .. Gamma]
women = Map.fromList $ (, Just 2) <$> [Alef .. Gimel] women = Map.fromList $ (, Just 2) <$> [Alef .. Gimel]
preferences = fmap ((3 -) *** (3 -)) $ Map.fromList preferences = fmap ((3 -) *** (3 -)) $ Map.fromList
[ ((Alpha, Alef ), (1, 3)) [ ((Alpha, Alef ), (1, 3))
@ -85,7 +85,7 @@ spec = describe "computeMatching" $
ourResult `shouldBe` expectedResult ourResult `shouldBe` expectedResult
example $ do example $ do
let men = Map.fromList $ (, 1) <$> [Alpha .. Delta] let men = Map.fromList $ (, (0, 1)) <$> [Alpha .. Delta]
women = Map.fromList $ (, Just 1) <$> [Alef .. Dalet] women = Map.fromList $ (, Just 1) <$> [Alef .. Dalet]
preferences = fmap ((4 -) *** (4 -)) $ Map.fromList preferences = fmap ((4 -) *** (4 -)) $ Map.fromList
[ ((Alpha, Alef ), (1, 3)) [ ((Alpha, Alef ), (1, 3))
@ -113,7 +113,7 @@ spec = describe "computeMatching" $
ourResult `shouldBe` expectedResult ourResult `shouldBe` expectedResult
example $ do example $ do
let men = Map.fromList $ (, 1) <$> [Alpha .. Delta] let men = Map.fromList $ (, (0, 1)) <$> [Alpha .. Delta]
women = Map.fromList $ (, Just 1) <$> [Alef .. Dalet] women = Map.fromList $ (, Just 1) <$> [Alef .. Dalet]
preferences = fmap ((4 -) *** (4 -)) $ Map.fromList preferences = fmap ((4 -) *** (4 -)) $ Map.fromList
[ ((Alpha, Alef ), (1, 3)) [ ((Alpha, Alef ), (1, 3))
@ -141,7 +141,7 @@ spec = describe "computeMatching" $
ourResult `shouldBe` expectedResult ourResult `shouldBe` expectedResult
example $ do example $ do
let students = Map.fromList $ (, 1) <$> ([1..6] :: [Int]) let students = Map.fromList $ (, (0, 1)) <$> ([1..6] :: [Int])
colleges = Map.fromList $ (, Just 2) <$> (['A', 'Z', 'C'] :: [Char]) colleges = Map.fromList $ (, Just 2) <$> (['A', 'Z', 'C'] :: [Char])
student_preferences = Map.fromList student_preferences = Map.fromList
[ ((1, 'A'), 3), ((1, 'Z'), 2), ((1, 'C'), 1) [ ((1, 'A'), 3), ((1, 'Z'), 2), ((1, 'C'), 1)