Merge branch '155-zentralanmeldungen'
This commit is contained in:
Gregor Kleen
commit
6d8743fe15
@ -130,5 +130,11 @@ user-defaults:
|
||||
download-files: false
|
||||
warning-days: 1209600
|
||||
|
||||
# During central allocations lecturer-given ratings of applications (as
|
||||
# ExamGrades) are combined with a central priority.
|
||||
# This encodes the weight of the lecturer ratings on the same scale as the
|
||||
# centrally supplied priorities.
|
||||
allocation-grade-scale: 25
|
||||
|
||||
instance-id: "_env:INSTANCE_ID:instance"
|
||||
ribbon: "_env:RIBBON:"
|
||||
|
||||
@ -21,6 +21,7 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
|
||||
registerByCourse UTCTime Maybe -- course registration dates are ignored until this day has passed or always prohibited
|
||||
overrideDeregister UTCTime Maybe -- course deregistration enforced to be this date, i.e. students may disenrol from course after or never
|
||||
-- overrideVisible not needed, since courses are always visible
|
||||
matchingLog FileId Maybe
|
||||
TermSchoolAllocationShort term school shorthand -- shorthand must be unique within school and semester
|
||||
TermSchoolAllocationName term school name -- name must be unique within school and semester
|
||||
deriving Show Eq Ord Generic
|
||||
@ -35,6 +36,7 @@ AllocationUser
|
||||
allocation AllocationId
|
||||
user UserId
|
||||
totalCourses Natural -- number of total allocated courses for this user must be <= than this number
|
||||
priority AllocationPriority Maybe
|
||||
UniqueAllocationUser allocation user
|
||||
|
||||
AllocationDeregister -- self-inflicted user-deregistrations from an allocated course
|
||||
|
||||
@ -45,7 +45,7 @@ CourseParticipant -- course enrolement
|
||||
user UserId
|
||||
registration UTCTime -- time of last enrolement for this course
|
||||
field StudyFeaturesId Maybe -- associated degree course, user-defined; required for communicating grades
|
||||
allocated Bool default=false -- participant was centrally allocated
|
||||
allocated AllocationId Maybe -- participant was centrally allocated
|
||||
UniqueParticipant user course
|
||||
-- Replace the last two by the following, once an audit log is available
|
||||
-- CourseUserNote -- lecturers of a specific course may share a text note on each enrolled student
|
||||
|
||||
@ -139,6 +139,7 @@ dependencies:
|
||||
- multiset
|
||||
- retry
|
||||
- generic-lens
|
||||
- array
|
||||
|
||||
other-extensions:
|
||||
- GeneralizedNewtypeDeriving
|
||||
|
||||
@ -50,6 +50,7 @@ postARegisterR tid ssh ash = do
|
||||
{ allocationUserAllocation = aId
|
||||
, allocationUserUser = uid
|
||||
, allocationUserTotalCourses = arfTotalCourses
|
||||
, allocationUserPriority = Nothing
|
||||
}
|
||||
[ AllocationUserTotalCourses =. arfTotalCourses
|
||||
]
|
||||
|
||||
@ -38,7 +38,7 @@ instance IsInvitableJunction CourseParticipant where
|
||||
data InvitableJunction CourseParticipant = JunctionParticipant
|
||||
{ jParticipantRegistration :: UTCTime
|
||||
, jParticipantField :: Maybe StudyFeaturesId
|
||||
, jParticipantAllocated :: Bool
|
||||
, jParticipantAllocated :: Maybe AllocationId
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationDBData CourseParticipant = InvDBDataParticipant
|
||||
-- no data needed in DB to manage participant invitation
|
||||
@ -90,7 +90,7 @@ participantInvitationConfig = InvitationConfig{..}
|
||||
now <- liftIO getCurrentTime
|
||||
studyFeatures <- wreq (studyFeaturesFieldFor Nothing False [] $ Just uid)
|
||||
(fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTip) Nothing
|
||||
return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure False
|
||||
return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures <*> pure Nothing
|
||||
invitationInsertHook _ _ CourseParticipant{..} _ act = do
|
||||
res <- act
|
||||
audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser
|
||||
@ -193,7 +193,7 @@ registerUser cid uid = exceptT tell tell $ do
|
||||
void . lift . lift . insert $ CourseParticipant
|
||||
{ courseParticipantCourse = cid
|
||||
, courseParticipantUser = uid
|
||||
, courseParticipantAllocated = False
|
||||
, courseParticipantAllocated = Nothing
|
||||
, ..
|
||||
}
|
||||
lift . lift . audit $ TransactionCourseParticipantEdit cid uid
|
||||
|
||||
@ -197,7 +197,7 @@ postCRegisterR tid ssh csh = do
|
||||
= return $ Just ()
|
||||
mkRegistration = do
|
||||
audit $ TransactionCourseParticipantEdit cid uid
|
||||
insertUnique $ CourseParticipant cid uid cTime crfStudyFeatures False
|
||||
insertUnique $ CourseParticipant cid uid cTime crfStudyFeatures Nothing
|
||||
|
||||
deleteApplications = do
|
||||
appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
|
||||
@ -222,7 +222,7 @@ postCRegisterR tid ssh csh = do
|
||||
delete $ partId
|
||||
audit $ TransactionCourseParticipantDeleted cid uid
|
||||
|
||||
when courseParticipantAllocated $ do
|
||||
when (is _Just courseParticipantAllocated) $ do
|
||||
now <- liftIO getCurrentTime
|
||||
insert_ $ AllocationDeregister courseParticipantUser (Just courseParticipantCourse) now Nothing
|
||||
|
||||
|
||||
@ -150,7 +150,7 @@ postCUserR tid ssh csh uCId = do
|
||||
| otherwise
|
||||
= Nothing
|
||||
pId <- runDB $ do
|
||||
pId <- insertUnique $ CourseParticipant cid uid now field False
|
||||
pId <- insertUnique $ CourseParticipant cid uid now field Nothing
|
||||
when (is _Just pId) $
|
||||
audit $ TransactionCourseParticipantEdit cid uid
|
||||
return pId
|
||||
|
||||
@ -147,7 +147,7 @@ postEAddUserR tid ssh csh examn = do
|
||||
{ courseParticipantCourse = cid
|
||||
, courseParticipantUser = uid
|
||||
, courseParticipantRegistration = now
|
||||
, courseParticipantAllocated = False
|
||||
, courseParticipantAllocated = Nothing
|
||||
, ..
|
||||
}
|
||||
lift . lift . audit $ TransactionCourseParticipantEdit cid uid
|
||||
|
||||
@ -97,7 +97,7 @@ examRegistrationInvitationConfig = InvitationConfig{..}
|
||||
(True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing)
|
||||
invitationInsertHook (Entity eid Exam{..}) _ ExamRegistration{..} mField act = do
|
||||
whenIsJust mField $ \cpField -> do
|
||||
insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField False
|
||||
insert_ $ CourseParticipant examCourse examRegistrationUser examRegistrationTime cpField Nothing
|
||||
audit $ TransactionCourseParticipantEdit examCourse examRegistrationUser
|
||||
|
||||
let doAudit = audit $ TransactionExamRegister eid examRegistrationUser
|
||||
|
||||
@ -742,7 +742,7 @@ postEUsersR tid ssh csh examn = do
|
||||
, courseParticipantUser = examUserCsvActUser
|
||||
, courseParticipantRegistration = now
|
||||
, courseParticipantField = examUserCsvActCourseField
|
||||
, courseParticipantAllocated = False
|
||||
, courseParticipantAllocated = Nothing
|
||||
}
|
||||
audit $ TransactionCourseParticipantEdit examCourse examUserCsvActUser
|
||||
insert_ ExamRegistration
|
||||
|
||||
133
src/Handler/Utils/Allocation.hs
Normal file
133
src/Handler/Utils/Allocation.hs
Normal file
@ -0,0 +1,133 @@
|
||||
module Handler.Utils.Allocation
|
||||
( sinkAllocationPriorities
|
||||
, computeAllocation
|
||||
, doAllocation
|
||||
, ppMatchingLog, storeMatchingLog
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Data.List (genericLength, elemIndex)
|
||||
import qualified Data.Vector as Vector
|
||||
import Data.Vector.Lens (vector)
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import System.Random (newStdGen)
|
||||
|
||||
import Utils.Allocation
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import Data.Generics.Product.Param
|
||||
|
||||
|
||||
sinkAllocationPriorities :: AllocationId
|
||||
-> ConduitT (Map UserMatriculation AllocationPriority) Void DB ()
|
||||
sinkAllocationPriorities allocId = C.mapM_ . imapM_ $ \matr prio ->
|
||||
E.update $ \allocationUser -> do
|
||||
E.set allocationUser [ AllocationUserPriority E.=. E.val (Just prio) ]
|
||||
E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val allocId
|
||||
E.where_ . E.exists . E.from $ \user ->
|
||||
E.where_ $ user E.^. UserId E.==. allocationUser E.^. AllocationUserUser
|
||||
E.&&. user E.^. UserMatrikelnummer E.==. E.val (Just matr)
|
||||
|
||||
|
||||
computeAllocation :: AllocationId
|
||||
-> DB (Set (UserId, CourseId), Seq (MatchingLog UserId CourseId Natural))
|
||||
computeAllocation allocId = do
|
||||
users' <- selectList [ AllocationUserAllocation ==. allocId ] []
|
||||
let cloneCounts = Map.filter (> 0) . Map.fromList $ (allocationUserUser . entityVal &&& allocationUserTotalCourses . entityVal) <$> users'
|
||||
|
||||
courses' <- E.select . E.from $ \(allocationCourse `E.InnerJoin` course) -> do
|
||||
E.on $ allocationCourse E.^. AllocationCourseCourse E.==. course E.^. CourseId
|
||||
E.&&. allocationCourse E.^. AllocationCourseAllocation E.==. E.val allocId
|
||||
|
||||
let participants = E.sub_select . E.from $ \participant -> do
|
||||
E.where_ $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
|
||||
E.where_ . E.not_ . E.exists . E.from $ \lecturer -> do
|
||||
E.where_ $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
||||
E.&&. lecturer E.^. LecturerUser E.==. participant E.^. CourseParticipantUser
|
||||
return E.countRows
|
||||
|
||||
return ( allocationCourse
|
||||
, E.maybe E.nothing (\c -> E.just $ c E.-. participants) (course E.^. CourseCapacity)
|
||||
, allocationCourse E.^. AllocationCourseMinCapacity E.-. participants
|
||||
)
|
||||
let capacities = Map.filter (maybe True (> 0)) . Map.fromList $ (view (_1 . _entityVal . _allocationCourseCourse) &&& view (_2 . _Value)) <$> courses'
|
||||
|
||||
applications' <- selectList [ CourseApplicationAllocation ==. Just allocId ] []
|
||||
let applications'' = applications' & filter ((\CourseApplication{..} -> not courseApplicationRatingVeto && fromMaybe True (courseApplicationRatingPoints ^? _Just . passingGrade . _Wrapped)) . entityVal)
|
||||
preferences = Map.fromList $ do
|
||||
Entity _ CourseApplication{..} <- applications''
|
||||
return ((courseApplicationUser, courseApplicationCourse), (courseApplicationAllocationPriority, courseApplicationRatingPoints))
|
||||
|
||||
gradeScale <- getsYesod $ view _appAllocationGradeScale
|
||||
let centralNudge user (fromIntegral -> cloneIndex) grade
|
||||
| Just AllocationPriorityNumeric{..} <- allocationPrio
|
||||
= let allocationPriorities' = under vector (sortOn Down) allocationPriorities
|
||||
minPrio | Vector.null allocationPriorities' = 0
|
||||
| otherwise = Vector.last allocationPriorities'
|
||||
in withNumericGrade . fromMaybe minPrio $ allocationPriorities Vector.!? cloneIndex
|
||||
| otherwise
|
||||
= withNumericGrade 0
|
||||
where
|
||||
allocationPrio = allocationUserPriority . entityVal =<< listToMaybe (filter ((== user) . allocationUserUser . entityVal) users')
|
||||
|
||||
withNumericGrade
|
||||
| Just grade' <- grade
|
||||
= let numberGrade' = fromMaybe (error "non-passing grade") (fromIntegral <$> elemIndex grade' passingGrades) / pred (genericLength passingGrades)
|
||||
passingGrades = sort $ filter (view $ passingGrade . _Wrapped) universeF
|
||||
numericGrade = -gradeScale + numberGrade' * 2 * gradeScale
|
||||
in (+) numericGrade . fromInteger
|
||||
| otherwise
|
||||
= fromInteger
|
||||
|
||||
g <- liftIO newStdGen
|
||||
|
||||
let
|
||||
doAllocationWithout cs = runWriter $ computeMatchingLog g cloneCounts capacities' preferences' centralNudge
|
||||
where
|
||||
capacities' = Map.filterWithKey (\ c _ -> Set.notMember c cs) capacities
|
||||
preferences' = Map.filterWithKey (\(_, c) _ -> Set.notMember c cs) preferences
|
||||
|
||||
allocationLoop cs
|
||||
| not $ null belowMin = doAllocationWithout $ cs <> Set.fromList belowMin
|
||||
| otherwise = (allocs, mLog)
|
||||
where
|
||||
(allocs, mLog) = doAllocationWithout cs
|
||||
belowMin = catMaybes . flip map courses' $ \(Entity _ AllocationCourse{..}, _, E.Value minCap) ->
|
||||
guardOn (Set.size (Set.filter (\(_, c) -> c == allocationCourseCourse) allocs) < minCap) allocationCourseCourse
|
||||
|
||||
return $!! allocationLoop Set.empty
|
||||
|
||||
doAllocation :: AllocationId
|
||||
-> Set (UserId, CourseId)
|
||||
-> DB ()
|
||||
doAllocation allocId regs = do
|
||||
now <- liftIO getCurrentTime
|
||||
forM_ regs $ \(uid, cid) -> do
|
||||
mField <- (courseApplicationField . entityVal =<<) . listToMaybe <$> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Just allocId] []
|
||||
void . insertUnique $ CourseParticipant cid uid now mField (Just allocId)
|
||||
|
||||
ppMatchingLog :: ( MonoFoldable mono
|
||||
, Element mono ~ MatchingLog UserId CourseId Natural
|
||||
)
|
||||
=> mono -> Text
|
||||
ppMatchingLog = unlines . map (tshow . pretty) . otoList
|
||||
where
|
||||
pretty = over (param @1) fromSqlKey
|
||||
. over (param @2) fromSqlKey
|
||||
|
||||
storeMatchingLog :: ( MonoFoldable mono
|
||||
, Element mono ~ MatchingLog UserId CourseId Natural
|
||||
)
|
||||
=> AllocationId -> mono -> DB ()
|
||||
storeMatchingLog allocationId (ppMatchingLog -> matchingLog) = do
|
||||
now <- liftIO getCurrentTime
|
||||
fId <- insert $ File "matchings.log" (Just $ encodeUtf8 matchingLog) now
|
||||
update allocationId [ AllocationMatchingLog =. Just fId ]
|
||||
@ -1,7 +1,7 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.Utils.Csv
|
||||
( decodeCsv
|
||||
( decodeCsv, decodeCsvPositional
|
||||
, encodeCsv
|
||||
, encodeDefaultOrderedCsv
|
||||
, respondCsv, respondCsvDB
|
||||
@ -35,9 +35,17 @@ import qualified Data.ByteString.Lazy as LBS
|
||||
|
||||
import qualified Data.Attoparsec.ByteString.Lazy as A
|
||||
|
||||
import Control.Monad.Except (ExceptT)
|
||||
|
||||
|
||||
decodeCsv :: (MonadThrow m, FromNamedRecord csv, MonadLogger m) => ConduitT ByteString csv m ()
|
||||
decodeCsv = transPipe throwExceptT $ do
|
||||
decodeCsv = decodeCsv' fromNamedCsv
|
||||
|
||||
decodeCsvPositional :: (MonadThrow m, FromRecord csv, MonadLogger m) => HasHeader -> ConduitT ByteString csv m ()
|
||||
decodeCsvPositional hdr = decodeCsv' (\opts -> fromCsv opts hdr)
|
||||
|
||||
decodeCsv' :: (MonadThrow m, MonadLogger m) => (forall m'. Monad m' => DecodeOptions -> ConduitT ByteString csv (ExceptT CsvParseError m') ()) -> ConduitT ByteString csv m ()
|
||||
decodeCsv' fromCsv' = transPipe throwExceptT $ do
|
||||
testBuffer <- accumTestBuffer LBS.empty
|
||||
mapM_ leftover $ LBS.toChunks testBuffer
|
||||
|
||||
@ -45,7 +53,7 @@ decodeCsv = transPipe throwExceptT $ do
|
||||
& guessDelimiter testBuffer
|
||||
$logInfoS "decodeCsv" [st|Guessed Csv.DecodeOptions from buffer of size #{tshow (LBS.length testBuffer)}/#{tshow testBufferSize}: #{tshow decodeOptions}|]
|
||||
|
||||
fromNamedCsv decodeOptions
|
||||
fromCsv' decodeOptions
|
||||
where
|
||||
testBufferSize = 4096
|
||||
accumTestBuffer acc
|
||||
|
||||
@ -557,6 +557,17 @@ customMigrations = Map.fromListWith (>>)
|
||||
ALTER TABLE "course_favourite" ADD COLUMN "reason" jsonb DEFAULT '"visited"'::jsonb;
|
||||
|]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|24.0.0|] [version|25.0.0|]
|
||||
, whenM (tableExists "course_participant") $ do
|
||||
queryRes <- [sqlQQ|SELECT (EXISTS (SELECT 1 FROM "course_participant" WHERE "allocated" <> false))|]
|
||||
case queryRes of
|
||||
[Single False] ->
|
||||
[executeQQ|
|
||||
ALTER TABLE "course_participant" DROP COLUMN "allocated";
|
||||
ALTER TABLE "course_participant" ADD COLUMN "allocated" bigint;
|
||||
|]
|
||||
_other -> error "Cannot reconstruct course_participant.allocated"
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
|
||||
@ -13,3 +13,4 @@ import Model.Types.Sheet as Types
|
||||
import Model.Types.Submission as Types
|
||||
import Model.Types.Misc as Types
|
||||
import Model.Types.School as Types
|
||||
import Model.Types.Allocation as Types
|
||||
|
||||
34
src/Model/Types/Allocation.hs
Normal file
34
src/Model/Types/Allocation.hs
Normal file
@ -0,0 +1,34 @@
|
||||
module Model.Types.Allocation
|
||||
( AllocationPriority(..)
|
||||
, module Utils.Allocation
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
import Utils.Allocation (MatchingLog(..))
|
||||
import Model.Types.Common
|
||||
|
||||
import qualified Data.Csv as Csv
|
||||
import qualified Data.Vector as Vector
|
||||
|
||||
import qualified Data.Map.Strict as Map
|
||||
|
||||
|
||||
data AllocationPriority
|
||||
= AllocationPriorityNumeric { allocationPriorities :: Vector Integer }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
, constructorTagModifier = camelToPathPiece' 2
|
||||
, allNullaryToStringTag = False
|
||||
, sumEncoding = TaggedObject "mode" "value"
|
||||
, unwrapUnaryRecords = False
|
||||
, tagSingleConstructors = True
|
||||
} ''AllocationPriority
|
||||
derivePersistFieldJSON ''AllocationPriority
|
||||
|
||||
instance Csv.FromRecord (Map UserMatriculation AllocationPriority) where
|
||||
parseRecord v = parseNumeric
|
||||
where
|
||||
parseNumeric
|
||||
| Vector.length v >= 1 = Map.singleton <$> v Csv..! 0 <*> (AllocationPriorityNumeric <$> mapM Csv.parseField (Vector.tail v))
|
||||
| otherwise = mzero
|
||||
@ -38,7 +38,7 @@ import qualified Yesod.Auth.Util.PasswordStore as PWStore
|
||||
|
||||
import Data.Time (NominalDiffTime, nominalDay)
|
||||
|
||||
import Data.Scientific (toBoundedInteger)
|
||||
import Data.Scientific (Scientific, toBoundedInteger)
|
||||
import Data.Word (Word16)
|
||||
|
||||
import qualified Data.Text as Text
|
||||
@ -130,6 +130,8 @@ data AppSettings = AppSettings
|
||||
|
||||
, appTransactionLogIPRetentionTime :: NominalDiffTime
|
||||
|
||||
, appAllocationGradeScale :: Rational
|
||||
|
||||
, appReloadTemplates :: Bool
|
||||
-- ^ Use the reload version of templates
|
||||
, appMutableStatic :: Bool
|
||||
@ -426,6 +428,8 @@ instance FromJSON AppSettings where
|
||||
|
||||
appTransactionLogIPRetentionTime <- o .: "ip-retention-time"
|
||||
|
||||
appAllocationGradeScale <- o .: "allocation-grade-scale" <|> fmap toRational (o .: "allocation-grade-scale" :: Aeson.Parser Scientific)
|
||||
|
||||
appUserDefaults <- o .: "user-defaults"
|
||||
appAuthPWHash <- o .: "auth-pw-hash"
|
||||
|
||||
|
||||
278
src/Utils/Allocation.hs
Normal file
278
src/Utils/Allocation.hs
Normal file
@ -0,0 +1,278 @@
|
||||
module Utils.Allocation
|
||||
( computeMatching
|
||||
, MatchingLog(..)
|
||||
, computeMatchingLog
|
||||
) where
|
||||
|
||||
import Import.NoModel hiding (StateT, st, get)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Sequence as Seq
|
||||
|
||||
import Data.Array.ST (STArray)
|
||||
import qualified Data.Array.MArray as MArr
|
||||
|
||||
import System.Random (RandomGen)
|
||||
import Control.Monad.Random.Class (getRandom)
|
||||
import Control.Monad.Trans.Random.Strict (evalRandT, RandT)
|
||||
import Control.Monad.Trans.State.Strict (StateT, modify', get, gets, evalStateT)
|
||||
import Control.Monad.Writer (tell)
|
||||
|
||||
import Control.Monad.ST
|
||||
|
||||
import Data.List ((!!), elemIndex)
|
||||
|
||||
|
||||
type CourseIndex = Int
|
||||
type StudentIndex = Int
|
||||
type CloneIndex = Int
|
||||
|
||||
data MatchingLog student course cloneIndex
|
||||
= MatchingConsider
|
||||
{ mlStudent :: student, mlClone :: cloneIndex }
|
||||
| MatchingApply
|
||||
{ mlStudent :: student, mlClone :: cloneIndex, mlCourse :: course }
|
||||
| MatchingNoApplyCloneInstability
|
||||
{ mlStudent :: student, mlClone :: cloneIndex, mlCourse :: course }
|
||||
| MatchingLostSpot
|
||||
{ mlStudent :: student, mlClone :: cloneIndex, mlCourse :: course }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
instance (NFData student, NFData course, NFData cloneIndex) => NFData (MatchingLog student course cloneIndex)
|
||||
|
||||
computeMatching :: forall randomGen student course cloneCount cloneIndex capacity studentRatingCourse courseRatingStudent courseRatingStudent'.
|
||||
( RandomGen randomGen
|
||||
, Ord student, Ord course
|
||||
, NFData student
|
||||
, Ord studentRatingCourse
|
||||
, Ord courseRatingStudent
|
||||
, Ord courseRatingStudent'
|
||||
, Integral cloneCount, Integral capacity, Num cloneIndex
|
||||
)
|
||||
=> randomGen -- ^ Source of randomness
|
||||
-> Map student 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)
|
||||
-> Set (student, course) -- ^ Stable matching
|
||||
computeMatching g cloneCounts capacities preferences centralNudge
|
||||
= view _1 . runWriter $ computeMatchingLog g cloneCounts capacities preferences centralNudge
|
||||
|
||||
computeMatchingLog :: forall randomGen student course cloneCount cloneIndex capacity studentRatingCourse courseRatingStudent courseRatingStudent'.
|
||||
( RandomGen randomGen
|
||||
, Ord student, Ord course
|
||||
, NFData student
|
||||
, Ord studentRatingCourse
|
||||
, Ord courseRatingStudent
|
||||
, Ord courseRatingStudent'
|
||||
, Integral cloneCount, Integral capacity, Num cloneIndex
|
||||
)
|
||||
=> randomGen -- ^ Source of randomness
|
||||
-> Map student 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)
|
||||
-> Writer (Seq (MatchingLog student course cloneIndex)) (Set (student, course)) -- ^ Stable matching
|
||||
computeMatchingLog g cloneCounts capacities preferences centralNudge = writer $ runST computeMatching'
|
||||
where
|
||||
computeMatching' :: forall s. ST s (Set (student, course), Seq (MatchingLog student course cloneIndex))
|
||||
computeMatching' = runWriterT . flip evalRandT g $ do
|
||||
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)
|
||||
|
||||
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)) ()
|
||||
propose = (=<< get) . mapM_ $ \(st, cn) -> do
|
||||
lift . tell . pure . MatchingConsider st $ fromIntegral cn
|
||||
let markDone = modify' $ Set.delete (st, cn)
|
||||
|
||||
options <- lift . lift $ MArr.readArray stPrefs (st ^. contStudents, cn)
|
||||
case options of
|
||||
[] -> 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 ^. 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
|
||||
(review contCourses -> course, students) <- courseMatchings
|
||||
student <- case students of
|
||||
Left pSet -> toList pSet
|
||||
Right spots' -> toList spots'
|
||||
guard $ (s, cn') == student
|
||||
return course
|
||||
|
||||
let capacity = maybe (error "course without capacity treated as one") fromIntegral $ capacities Map.! c
|
||||
(worseSpots, betterSpots) = Seq.spanr isWorseSpot spots
|
||||
isWorseSpot existing = case (comparing $ courseRating c &&& stb) existing (st, cn) of
|
||||
EQ -> error "Two student-clones compared equal in the face of stb"
|
||||
GT -> False
|
||||
LT -> True
|
||||
(newSpots, lostSpots) = force . Seq.splitAt capacity $ betterSpots <> Seq.singleton (st, cn) <> worseSpots
|
||||
|
||||
isUnstableWith :: CloneIndex -> (student, CloneIndex) -> Bool
|
||||
isUnstableWith cn' (stO, cnO) = fromMaybe False $ matchingCourse st cn' <&> \c' ->
|
||||
LT == (comparing $ courseRating c' &&& stb) (st, cn') (stO, cnO)
|
||||
|
||||
if | any (uncurry isUnstableWith) $ (,) <$> [0,1..pred cn] <*> toList lostSpots
|
||||
-> lift . tell . pure $ MatchingNoApplyCloneInstability st (fromIntegral cn) c
|
||||
| Seq.length betterSpots >= capacity
|
||||
-> return ()
|
||||
| otherwise
|
||||
-> do
|
||||
lift . tell . pure $ MatchingApply st (fromIntegral cn) c
|
||||
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')
|
||||
markDone
|
||||
_other -> return ()
|
||||
|
||||
proposeLoop = do
|
||||
propose
|
||||
done <- gets Set.null
|
||||
unless done
|
||||
proposeLoop
|
||||
|
||||
lift $ evalStateT proposeLoop clonedStudents
|
||||
|
||||
|
||||
-- let
|
||||
-- pairwiseExchange :: ST s ()
|
||||
-- pairwiseExchange = do
|
||||
-- let possiblePairs = do
|
||||
-- (s:ss) <- tails . sortOn stb $ toList clonedStudents
|
||||
-- s' <- ss
|
||||
-- return (s, s')
|
||||
-- matchingCourse (s, c) = do
|
||||
-- courseMatchings <- MArr.getAssocs courses'
|
||||
-- return . listToMaybe $ do
|
||||
-- (course, students) <- courseMatchings
|
||||
-- student <- case students of
|
||||
-- Left pSet -> toList pSet
|
||||
-- Right spots -> toList spots
|
||||
-- guard $ (s, c) == student
|
||||
-- return course
|
||||
-- forM_ possiblePairs $ \((a, cna), (b, cnb)) -> void . runMaybeT $ do
|
||||
-- ca <- MaybeT $ matchingCourse (a, cna)
|
||||
-- cb <- MaybeT $ matchingCourse (b, cnb)
|
||||
|
||||
-- let rank (s, cn) c = Seq.elemIndexL c $ studentPrefs cstb (s, cn)
|
||||
-- caRa <- hoistMaybe $ rank (a, cna) ca
|
||||
-- caRb <- hoistMaybe $ rank (b, cnb) ca
|
||||
-- cbRa <- hoistMaybe $ rank (a, cna) cb
|
||||
-- cbRb <- hoistMaybe $ rank (b, cnb) cb
|
||||
|
||||
-- let currentRanks cop = caRa `cop` cbRb
|
||||
-- newRanks cop = cbRa `cop` caRb
|
||||
|
||||
-- swapImproves = or
|
||||
-- [ currentRanks (+) > newRanks (+)
|
||||
-- , currentRanks (+) == newRanks (+)
|
||||
-- && currentRanks min > newRanks min
|
||||
-- ]
|
||||
-- lift . when swapImproves $ do
|
||||
-- traceM $ show (a, cna) <> " `swap` " <> show (b, cnb)
|
||||
-- let
|
||||
-- addCourseUser :: course -> (student, CloneIndex) -> ST s ()
|
||||
-- addCourseUser c (st, cn) = do
|
||||
-- cState <- MArr.readArray courses' c
|
||||
-- case cState of
|
||||
-- Left pSet ->
|
||||
-- MArr.writeArray courses' c $!! Left (Set.insert (st, cn) pSet)
|
||||
-- Right spots ->
|
||||
-- let (worseSpots, betterSpots) = Seq.spanr isWorseSpot spots
|
||||
-- isWorseSpot existing = case (comparing $ courseRating c &&& stb) existing (st, cn) of
|
||||
-- EQ -> error "Two student-clones compared equal in the face of stb"
|
||||
-- GT -> False
|
||||
-- LT -> True
|
||||
-- newSpots = force $ betterSpots <> Seq.singleton (st, cn) <> worseSpots
|
||||
-- in MArr.writeArray courses' c $ Right newSpots
|
||||
-- remCourseUser :: course -> (student, CloneIndex) -> ST s ()
|
||||
-- remCourseUser c (st, cn) = do
|
||||
-- cState <- MArr.readArray courses' c
|
||||
-- case cState of
|
||||
-- Left pSet ->
|
||||
-- MArr.writeArray courses' c $!! Left (Set.delete (st, cn) pSet)
|
||||
-- Right spots ->
|
||||
-- MArr.writeArray courses' c $!! Right (Seq.filter (/= (st, cn)) spots)
|
||||
|
||||
-- remCourseUser ca (a, cna)
|
||||
-- remCourseUser cb (b, cnb)
|
||||
-- addCourseUser cb (a, cna)
|
||||
-- addCourseUser ca (b, cnb)
|
||||
|
||||
-- lift pairwiseExchange
|
||||
|
||||
|
||||
courseMatchings <- lift . lift $ MArr.getAssocs courses'
|
||||
return . Set.fromList $ do
|
||||
(review contCourses -> course, students) <- courseMatchings
|
||||
student <- case students of
|
||||
Left pSet -> view _1 <$> toList pSet
|
||||
Right spots -> view _1 <$> toList spots
|
||||
return (student, course)
|
||||
|
||||
courseRating :: course -> (student, CloneIndex) -> courseRatingStudent'
|
||||
courseRating c (st, cn) = centralNudge st (fromIntegral cn) courseRating'
|
||||
where
|
||||
(_, courseRating') = preferences Map.! (st, c)
|
||||
|
||||
clonedStudents :: Set (student, CloneIndex)
|
||||
clonedStudents = Set.fromDistinctAscList $ do
|
||||
(student, clones) <- Map.toAscList cloneCounts
|
||||
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 :: (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
|
||||
| is _Just . join $ Map.lookup c capacities
|
||||
= Right Seq.empty
|
||||
| otherwise
|
||||
= Left Set.empty
|
||||
|
||||
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
|
||||
(cPref', _) <- Map.lookup (st, c) preferences
|
||||
return (cPref', cstb c)
|
||||
@ -206,6 +206,8 @@ makeLenses_ ''UserFunction
|
||||
makeLenses_ ''CourseUserExamOfficeOptOut
|
||||
|
||||
makeLenses_ ''CourseNewsFile
|
||||
|
||||
makeLenses_ ''AllocationCourse
|
||||
|
||||
|
||||
-- makeClassy_ ''Load
|
||||
|
||||
@ -469,7 +469,7 @@ fillDb = do
|
||||
insert_ $ SheetEdit gkleen now feste
|
||||
keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ UploadAny True Nothing) False
|
||||
insert_ $ SheetEdit gkleen now keine
|
||||
void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf False)
|
||||
void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf Nothing)
|
||||
[(fhamann , Nothing)
|
||||
,(maxMuster , Just sfMMs)
|
||||
,(tinaTester, Just sfTTc)
|
||||
@ -592,7 +592,7 @@ fillDb = do
|
||||
insert_ $ CourseEdit jost now pmo
|
||||
void . insert $ DegreeCourse pmo sdBsc sdInf
|
||||
void . insert $ Lecturer jost pmo CourseAssistant
|
||||
void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf False)
|
||||
void . insertMany $ map (\(u,sf) -> CourseParticipant pmo u now sf Nothing)
|
||||
[(fhamann , Nothing)
|
||||
,(maxMuster , Just sfMMp)
|
||||
,(tinaTester, Just sfTTb)
|
||||
@ -779,6 +779,7 @@ fillDb = do
|
||||
, allocationRegisterByStaffTo = Nothing
|
||||
, allocationRegisterByCourse = Nothing
|
||||
, allocationOverrideDeregister = Just now
|
||||
, allocationMatchingLog = Nothing
|
||||
}
|
||||
insert_ $ AllocationCourse funAlloc pmo 100
|
||||
insert_ $ AllocationCourse funAlloc ffp 2
|
||||
|
||||
160
test/Utils/AllocationSpec.hs
Normal file
160
test/Utils/AllocationSpec.hs
Normal file
@ -0,0 +1,160 @@
|
||||
module Utils.AllocationSpec where
|
||||
|
||||
import TestImport hiding (Course)
|
||||
|
||||
import Utils.Allocation
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import System.Random (mkStdGen)
|
||||
|
||||
|
||||
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, Read, Show, Generic, Typeable)
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "computeMatching" $
|
||||
it "produces some expected known matchings" $ do
|
||||
example $ do
|
||||
let men = Map.fromList $ (, 1) <$> [Alpha .. Gamma]
|
||||
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))
|
||||
, ((Gamma, Alef ), (2, 2))
|
||||
, ((Gamma, Bet ), (3, 1))
|
||||
, ((Gamma, Gimel), (1, 3))
|
||||
]
|
||||
|
||||
centralNudge _ _ = id
|
||||
|
||||
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]
|
||||
preferences = fmap ((4 -) *** (4 -)) $ Map.fromList
|
||||
[ ((Alpha, Alef ), (1, 3))
|
||||
, ((Alpha, Bet ), (2, 3))
|
||||
, ((Alpha, Gimel), (3, 2))
|
||||
, ((Alpha, Dalet), (4, 3))
|
||||
, ((Beta , Alef ), (1, 4))
|
||||
, ((Beta , Bet ), (4, 1))
|
||||
, ((Beta , Gimel), (3, 3))
|
||||
, ((Beta , Dalet), (2, 2))
|
||||
, ((Gamma, Alef ), (2, 2))
|
||||
, ((Gamma, Bet ), (1, 4))
|
||||
, ((Gamma, Gimel), (3, 4))
|
||||
, ((Gamma, Dalet), (4, 1))
|
||||
, ((Delta, Alef ), (4, 1))
|
||||
, ((Delta, Bet ), (2, 2))
|
||||
, ((Delta, Gimel), (3, 1))
|
||||
, ((Delta, Dalet), (1, 4))
|
||||
]
|
||||
|
||||
centralNudge _ _ = id
|
||||
|
||||
expectedResult = Set.fromList [(Alpha, Gimel), (Beta, Dalet), (Gamma, Alef), (Delta, Bet)]
|
||||
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]
|
||||
preferences = fmap ((4 -) *** (4 -)) $ Map.fromList
|
||||
[ ((Alpha, Alef ), (1, 3))
|
||||
, ((Alpha, Bet ), (2, 2))
|
||||
, ((Alpha, Gimel), (3, 1))
|
||||
, ((Alpha, Dalet), (4, 3))
|
||||
, ((Beta , Alef ), (1, 4))
|
||||
, ((Beta , Bet ), (2, 3))
|
||||
, ((Beta , Gimel), (3, 2))
|
||||
, ((Beta , Dalet), (4, 4))
|
||||
, ((Gamma, Alef ), (3, 1))
|
||||
, ((Gamma, Bet ), (1, 4))
|
||||
, ((Gamma, Gimel), (2, 3))
|
||||
, ((Gamma, Dalet), (4, 2))
|
||||
, ((Delta, Alef ), (2, 2))
|
||||
, ((Delta, Bet ), (3, 1))
|
||||
, ((Delta, Gimel), (1, 4))
|
||||
, ((Delta, Dalet), (4, 1))
|
||||
]
|
||||
|
||||
centralNudge _ _ = id
|
||||
|
||||
expectedResult = Set.fromList [(Alpha, Gimel), (Beta, Dalet), (Gamma, Alef), (Delta, Bet)]
|
||||
ourResult = computeMatching (mkStdGen 0) men women preferences centralNudge
|
||||
ourResult `shouldBe` expectedResult
|
||||
|
||||
example $ do
|
||||
let students = Map.fromList $ (, 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)
|
||||
, ((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, '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