From e1c6fd43b807abd3126b7ae8b948f585416f883c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 26 Apr 2020 13:21:56 +0200 Subject: [PATCH] fix(allocation): don't restart cloneCount when allocating successors --- src/Handler/Utils/Allocation.hs | 2 +- src/Utils/Allocation.hs | 17 ++++++++++------- test/Utils/AllocationSpec.hs | 12 ++++++------ 3 files changed, 17 insertions(+), 14 deletions(-) diff --git a/src/Handler/Utils/Allocation.hs b/src/Handler/Utils/Allocation.hs index 1b7d90e63..ee5036802 100644 --- a/src/Handler/Utils/Allocation.hs +++ b/src/Handler/Utils/Allocation.hs @@ -105,7 +105,7 @@ computeAllocation allocId cRestr = do guard $ totalCourses > allocated - return (user, (totalCourses - allocated, priority)) + return (user, ((allocated, totalCourses - allocated), priority)) ) & Map.fromList cloneCounts = Map.map (view _1) users'' diff --git a/src/Utils/Allocation.hs b/src/Utils/Allocation.hs index 0fc994407..323985f6a 100644 --- a/src/Utils/Allocation.hs +++ b/src/Utils/Allocation.hs @@ -50,10 +50,10 @@ computeMatching :: forall randomGen student course cloneCount cloneIndex capacit , NFData student , Ord studentRatingCourse , Ord courseRatingStudent' - , Integral cloneCount, Integral capacity, Num cloneIndex + , Integral cloneCount, Integral capacity, Integral cloneIndex ) => 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 (student, course) (studentRatingCourse, courseRatingStudent) -- ^ Mutual preference ordering @(studentRatingCourse, courseRatingStudent)@ -> (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 , Ord studentRatingCourse , Ord courseRatingStudent' - , Integral cloneCount, Integral capacity, Num cloneIndex + , Integral cloneCount, Integral capacity, Integral cloneIndex ) => 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 (student, course) (studentRatingCourse, courseRatingStudent) -- ^ Mutual preference ordering @(studentRatingCourse, courseRatingStudent)@ -> (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') <- preferences Map.!? (st, c) 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.fromDistinctAscList $ do - (student, clones) <- Map.toAscList cloneCounts - clone <- [0,1..pred $ fromIntegral clones] + (student, (firstClone, clones)) <- Map.toAscList cloneCounts + clone <- Set.toAscList $ cloneIndices firstClone clones return (student, clone) contStudents :: Iso' student StudentIndex @@ -252,7 +255,7 @@ computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $ fromInt = (!!) students' 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.fromDistinctAscList . map (view _1) . filter (maybe True (> 0) . view _2) $ Map.toAscList capacities diff --git a/test/Utils/AllocationSpec.hs b/test/Utils/AllocationSpec.hs index 361763b4d..93aed0e2c 100644 --- a/test/Utils/AllocationSpec.hs +++ b/test/Utils/AllocationSpec.hs @@ -22,7 +22,7 @@ spec :: Spec spec = describe "computeMatching" $ it "produces some expected known matchings" $ 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] preferences = fmap ((3 -) *** (3 -)) $ Map.fromList [ ((Alpha, Alef ), (1, 3)) @@ -43,7 +43,7 @@ spec = describe "computeMatching" $ ourResult `shouldBe` expectedResult 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] preferences = fmap ((3 -) *** (3 -)) $ Map.fromList [ ((Alpha, Alef ), (1, 3)) @@ -64,7 +64,7 @@ spec = describe "computeMatching" $ ourResult `shouldBe` expectedResult example $ do - let men = Map.fromList $ (, 2) <$> [Alpha .. Gamma] + let men = Map.fromList $ (, (0, 2)) <$> [Alpha .. Gamma] women = Map.fromList $ (, Just 2) <$> [Alef .. Gimel] preferences = fmap ((3 -) *** (3 -)) $ Map.fromList [ ((Alpha, Alef ), (1, 3)) @@ -85,7 +85,7 @@ spec = describe "computeMatching" $ ourResult `shouldBe` expectedResult example $ do - let men = Map.fromList $ (, 1) <$> [Alpha .. Delta] + let men = Map.fromList $ (, (0, 1)) <$> [Alpha .. Delta] women = Map.fromList $ (, Just 1) <$> [Alef .. Dalet] preferences = fmap ((4 -) *** (4 -)) $ Map.fromList [ ((Alpha, Alef ), (1, 3)) @@ -113,7 +113,7 @@ spec = describe "computeMatching" $ ourResult `shouldBe` expectedResult example $ do - let men = Map.fromList $ (, 1) <$> [Alpha .. Delta] + let men = Map.fromList $ (, (0, 1)) <$> [Alpha .. Delta] women = Map.fromList $ (, Just 1) <$> [Alef .. Dalet] preferences = fmap ((4 -) *** (4 -)) $ Map.fromList [ ((Alpha, Alef ), (1, 3)) @@ -141,7 +141,7 @@ spec = describe "computeMatching" $ ourResult `shouldBe` expectedResult 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]) student_preferences = Map.fromList [ ((1, 'A'), 3), ((1, 'Z'), 2), ((1, 'C'), 1)