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 ]