{- |
Module : Referees.Internal
Description : Core functions for "Referees"
Copyright : (c) Pablo Couto 2014
License : GPL-3
Maintainer : pablo@infty.in
Stability : experimental

This module defines the functions needed to specialize "Referees.Solver" to the
problem of assigning proposals among referees.-}

module Referees.Internal
  ( module Referees.Internal
  , mkBounds )
where

import Referees.Solver
    ( mkProfitMatrix, run_lpGAP, fromGLPKtoList )
import Referees.Solver.Types
    ( Bounds, ProfitFunction, Index(Index, _idx), Copies, Capacity, mkBounds )
import Referees.Types.Internal
    ( CSVentry(_areaCSV, _capacityCSV, _languagesCSV, _nameCSV,
               _subareasCSV),
      CSV_Warning(..),
      Match,
      Proposal,
      Referee,
      Entry(..),
      Language,
      Name,
      StringListParse(..),
      MaybeCapacityParse(..) )

import Control.Applicative ( (<$>) )
import Control.Monad ( forM, guard, join, unless )
import qualified Data.ByteString.Lazy as BL ( readFile )
import qualified Data.ByteString.Lazy.Char8 as BC ( lines )
import Data.Csv ( HasHeader(..), decode )
import Data.List ( nub )
import Data.Matrix ( Matrix, matrix, ncols, nrows, (!) )
import Data.Maybe ( fromMaybe )
import Data.Monoid ( mconcat )
import Data.String.Utils ( rstrip )
import qualified Data.Vector as V ( toList )

-- * Parsing

-- | Parses from a CSV file into 'Entry' 'Referee' values.
--
fromCSVtoReferees :: FilePath -> IO [Entry Referee]
fromCSVtoReferees = fromCSVtoEntry

-- | Parses from a CSV file into 'Entry' 'Proposal' values.
--
fromCSVtoProposals :: FilePath -> IO [Entry Proposal]
fromCSVtoProposals = fromCSVtoEntry

-- | Taking the path to some CSV file in the appropriate format, parses it into
-- values of type 'Entry' @a@. This function is intended to be used with
-- wrappers that specialize @a@ to some concrete type.
--
fromCSVtoEntry :: FilePath -> IO [Entry a]
fromCSVtoEntry fp = do
  entries <- readCSVentries fp

  let names = nub $ map _nameCSV entries

  let capacityByName = map (\ (i, j, _) -> (i, j)) capacityByName'

      capacityByName' :: [(Name, Maybe Capacity, [CSV_Warning])]
      capacityByName' = do
        name <- names
        let caps = nub . filter (Nothing /=)
                 . map (_maybeCapP . _capacityCSV) $ entriesForName name entries
        return $ if length caps > 1
          then (name, minimum caps, [DifferingCapacities name])
          else (name, maximum $ Nothing : caps, [])

  let langsByName = do
        name <- names
        return . (,) name $
          nub . concatMap (_strLstP . _languagesCSV)
          $ entriesForName name entries

  let areasByName = do -- both areas and subareas
        name <- names
        return . (,) name $
          map (\ i -> (,) (_areaCSV i)
                          (filter (not . null) . _strLstP $ _subareasCSV i))
          $ entriesForName name entries

  let finalList = do
        name <- names
        let cap = join $ lookup name capacityByName
            langs = fromMaybe [] $ lookup name langsByName
            areas = fromMaybe [] $ lookup name areasByName
        return (name, cap, langs, areas)

  let warnings = concatMap (\ (_, _, k) -> k) capacityByName'
  unless (null warnings) $ mapM_ (print . ppCSV_Warning) warnings

  return $ map (\ (i, j, k, l) -> Entry i j k l) finalList

  where entriesForName name = filter ((==) name . _nameCSV)

-- | Parses CSV files into 'CSVentry's, according to the format described in
-- "Referees".
--
-- The parser is defined at the 'FromField' instance declarations in
-- "Referees.Types.Internal".
--
readCSVentries :: FilePath -> IO [CSVentry]
readCSVentries fp = do
  csvData <- BL.readFile fp
  (concat <$>) $ forM (BC.lines csvData) $ \ record ->
    either (\ e -> putStrLn e >> return []) (return . V.toList)
    $ decode NoHeader record

-- * Assignment of proposals to referees

-- | 'distributeWith' computes a distribution of proposals among referees,
-- according to the given parameters.
--
distributeWith :: ProfitFunction (Entry Proposal) (Entry Referee) Language
               -> [Entry Referee] -- ^ Referees among which to distribute
               -> Capacity -- ^ Default capacity for referees, if none declared
               -> Bounds Copies -- ^ Min and max number of copies to distribute
               -> Maybe Language -- ^ Optional shared language between referees
                                 -- and proposals
               -> [Entry Proposal] -- ^ Proposals to distribute
               -> IO (Maybe [Match])
distributeWith pFn rs defC bnds lang ps = do
  let profitM = mkProfitMatrix pFn ps rs lang
  matches <-
    fromGLPKtoList <$> run_lpGAP profitM (toCap rs defC) bnds
  return . mconcat $ do
    i <- [1 .. Index $ ncols profitM]
    let props = map snd . filter ((i ==) . fst) <$> matches
    return $ (\ j -> [(rs !! _idx i, map ((ps !!) . _idx) j)]) <$> props

-- | Computes the profit for an assignment between the given 'Entry' 'Proposal'
-- and 'Entry' 'Referee'. The scale is continuous in [0,2]. Takes understood
-- languages into account.
--
profitRefProp :: ProfitFunction (Entry Proposal) (Entry Referee) Language
profitRefProp p r lang
  | langsMatch =
      sum $ do
        let areasP = _areas p

        (areaP, subareasAreaP) <- areasP

        let areasR =
              filter (\ ((a, _), _) -> areaP == a) $ zip (_areas r) logBias

        ((_, subareasAreaR), aRbias) <- areasR

        let subareasMatch =
              sum $ do
                (subareaAP) <- subareasAreaP
                (subareaAR, sARbias) <- zip subareasAreaR logBias
                guard $ subareaAP == subareaAR
                return . (/ sARbias) $ 1.0 / fromIntegral (length subareasAreaP)

        return $ (/ aRbias) (1.0 / fromIntegral (length areasP)) + subareasMatch
  | otherwise =
      0.0
  where
    langsMatch =
      let langDef = fromMaybe "" lang
          langsRnoDef = filter (/= langDef) $ _languages r
          langsPnoDef = filter (/= langDef) $ _languages p
      in if (null langsPnoDef || null langsRnoDef)
              && (not (null langsRnoDef) || null langsPnoDef)
            then True
            else any (`elem` langDef : _languages r) $ _languages p

-- | This list is used to bias the profit associated with 'Area's and 'Subarea's
-- matches according to their order in the corresponding 'Entry's.
--
logBias :: [Double]
logBias = map (logBase 2) [2..]

-- | 'toCap' @rs def@ builds a list of capacities matching the 'Referee's in
-- @rs@, while assigning default capacity @def@ to those 'Referee's that don’t
-- have one defined.
--
toCap :: [Entry Referee] -> Capacity -> [Capacity]
toCap rs def = map (fromMaybe def . _capacity) rs

-- * Querying

-- | Provides a list of all 'Referee's suited for a 'Proposal', regardless of
-- any distribution.
--
whichRefereesForProposal :: Entry Proposal
                         -> [Entry Referee]
                         -> Maybe Language -- ^ Optional shared language between
                                           -- the proposal and referees
                         -> [Entry Referee]
whichRefereesForProposal p rs lang = filter matching rs
  where
    matching r = profitRefProp p r lang > 0

-- | Provides a list of all 'Proposal's suited for a 'Referee', regardless of
-- any distribution.
--
whichProposalsForReferee :: Entry Referee
                         -> [Entry Proposal]
                         -> Maybe Language -- ^ Optional shared language between
                                           -- the referee and proposals
                         -> [Entry Proposal]
whichProposalsForReferee r ps lang = filter matching ps
  where
    matching p = profitRefProp p r lang > 0

-- * Pretty printing

-- | Concise printing of assignments. Ignores 'Entry' 'Referee's for which there
-- are no assigned 'Entry' 'Proposal's.
--
ppDistribution :: Maybe [Match] -> String
ppDistribution ms =
  case ms of
    Nothing -> nodist
    Just ms'
      | not . null $ output -> output
      | otherwise -> nodist
      where
        output =
          rstrip . unlines $ do
            (ref, props) <- ms'
            guard $ not . null $ props
            return $ _name ref ++ ": " ++ ppNames (map _name props)
  where
    nodist = "No suitable distribution found."

ppReferee :: Entry Referee -> String
ppReferee = ppEntry

ppProposal :: Entry Proposal -> String
ppProposal = ppEntry

ppEntry :: Entry a -> String
ppEntry x =
  _name x
    ++ case _capacity x of
         Just c -> " (cap: " ++ show c
         Nothing -> " (cap: default"
    ++ case _languages x of
         [] -> ""
         ls -> ", langs: " ++ show ls ++ "):\n"
               ++ "  " ++ drop 2 (concatMap showArea $ _areas x)
  where
    showArea (area, subareas) =
      "  " ++ area ++ showSubareas subareas
    showSubareas [] =
      "\n"
    showSubareas ss =
      " (" ++ drop 2 (concatMap (", " ++) ss) ++ ")\n"

-- | Pretty prints the given matrix, converting its values to 2-digit precision.
-- This is currently used only in debug.
--
ppMatrix :: Matrix Double -> String
ppMatrix m =
  show $ matrix (nrows m) (ncols m) (\ (i, j) -> precs 2 $ m ! (i, j))
  where
    precs :: Int -> Double -> Double
    precs p d = (fromInteger . round $ (d * 10^p)) / 10.0^^p

ppCSV_Warning :: CSV_Warning -> String
ppCSV_Warning (DifferingCapacities name) =
    "Warning: Multiple capacities declared for author “" ++ name ++ "”. \
    \Choosing the least one."

ppNames :: [Name] -> String
ppNames [] = ""
ppNames [x] = x
ppNames (x:xs) = x ++ ", " ++ ppNames xs