134 lines
6.1 KiB
Haskell
134 lines
6.1 KiB
Haskell
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 ]
|