Merge branch '155-zentralanmeldungen'

config/settings.yml

@@ -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:"

models/allocations.model

@@ -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

models/courses.model

@@ -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

package.yaml

@@ -139,6 +139,7 @@ dependencies:
   - multiset
   - retry
   - generic-lens
+  - array
 
 other-extensions:
   - GeneralizedNewtypeDeriving

src/Handler/Allocation/Register.hs

@@ -50,6 +50,7 @@ postARegisterR tid ssh ash = do
       { allocationUserAllocation = aId
       , allocationUserUser = uid
       , allocationUserTotalCourses = arfTotalCourses
+      , allocationUserPriority = Nothing
       }
       [ AllocationUserTotalCourses =. arfTotalCourses
       ]

src/Handler/Course/ParticipantInvite.hs

@@ -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

src/Handler/Course/Register.hs

@@ -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
 

src/Handler/Course/User.hs

@@ -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

src/Handler/Exam/AddUser.hs

@@ -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

src/Handler/Exam/RegistrationInvite.hs

@@ -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

src/Handler/Exam/Users.hs

@@ -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

src/Handler/Utils/Allocation.hs

@@ -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 ]

src/Handler/Utils/Csv.hs

@@ -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

src/Model/Migration.hs

@@ -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"
+    )
   ]
 
 

src/Model/Types.hs

@@ -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

src/Model/Types/Allocation.hs

@@ -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

src/Settings.hs

@@ -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"
 

src/Utils/Allocation.hs

@@ -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)

src/Utils/Lens.hs

@@ -207,6 +207,8 @@ makeLenses_ ''CourseUserExamOfficeOptOut
 
 makeLenses_ ''CourseNewsFile
 
+makeLenses_ ''AllocationCourse
+  
 
 -- makeClassy_ ''Load
 

test/Database.hs

@@ -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

test/Utils/AllocationSpec.hs

@@ -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