{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Text.MPSFile
-- Copyright   :  (c) Masahiro Sakai 2012
-- License     :  BSD-style
-- 
-- Maintainer  :  masahiro.sakai@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
-- A .mps format parser library.
-- 
-- References:
-- 
-- * <http://pic.dhe.ibm.com/infocenter/cosinfoc/v12r4/topic/ilog.odms.cplex.help/CPLEX/File_formats_reference/topics/MPS_synopsis.html>
-- 
-- * <http://pic.dhe.ibm.com/infocenter/cosinfoc/v12r4/topic/ilog.odms.cplex.help/CPLEX/File_formats_reference/topics/MPS_ext_synopsis.html>
-- 
-- * <http://www.gurobi.com/documentation/5.0/reference-manual/node744>
--
-- * <http://en.wikipedia.org/wiki/MPS_(format)>
--
-----------------------------------------------------------------------------
module Text.MPSFile
  ( parseString
  , parseFile
  ) where

import Control.Monad
import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Ratio

import qualified Text.ParserCombinators.Parsec as P
import Text.ParserCombinators.Parsec hiding (spaces, newline, Column)

import Data.OptDir
import qualified Text.LPFile as LPFile

type Column = String
type Row = String

data BoundType
  = LO	-- lower bound
  | UP	-- upper bound
  | FX	-- variable is fixed at the specified value
  | FR	-- free variable (no lower or upper bound)
  | MI	-- infinite lower bound
  | PL	-- infinite upper bound
  | BV	-- variable is binary (equal 0 or 1)
  | LI	-- lower bound for integer variable
  | UI	-- upper bound for integer variable
  | SC	-- upper bound for semi-continuous variable
  deriving (Eq, Ord, Show, Read)

-- ---------------------------------------------------------------------------

-- | Parse a string containing LP file data.
-- The source name is only | used in error messages and may be the empty string.
parseString :: SourceName -> String -> Either ParseError LPFile.LP
parseString = parse mpsfile

-- | Parse a file containing LP file data.
parseFile :: FilePath -> IO (Either ParseError LPFile.LP)
parseFile = parseFromFile mpsfile

-- ---------------------------------------------------------------------------

space' :: Parser Char
space' = oneOf [' ', '\t']

spaces' :: Parser ()
spaces' = skipMany space' >> return ()

spaces1' :: Parser ()
spaces1' = skipMany1 space' >> return ()

commentline :: Parser ()
commentline = do
  _ <- char '*'
  _ <- manyTill anyChar P.newline
  return ()

newline' :: Parser ()
newline' = do
  spaces'
  _ <- P.newline
  skipMany commentline
  return ()

tok :: Parser a -> Parser a
tok p = do
  x <- p
  msum [spaces1', lookAhead (try (char '\n' >> return ())), eof]
  return x

ident :: Parser String
ident = tok $ many1 $ noneOf [' ', '\t', '\n']

stringLn :: String -> Parser ()
stringLn s = string s >> newline'

sign :: Num a => Parser a
sign = (char '+' >> return 1) <|> (char '-' >> return (-1))

number :: Parser Rational
number = tok $ do
  b <- (do{ s <- option 1 sign; x <- nat; y <- option 0 frac; return (s * (fromInteger x + y)) })
    <|> frac
  c <- option 0 e
  return (b*10^^c)
  where
    digits = many1 digit

    nat :: Parser Integer
    nat = liftM read digits

    frac :: Parser Rational
    frac = do
      char '.'
      s <- digits
      return (read s % 10^(length s))

    e :: Parser Integer
    e = do
      oneOf "eE"
      f <- msum [ char '+' >> return id
                , char '-' >> return negate
                , return id
                ]
      liftM f nat

-- ---------------------------------------------------------------------------

mpsfile :: Parser LPFile.LP
mpsfile = do
  many commentline

  _name <- nameSection

  -- http://pic.dhe.ibm.com/infocenter/cosinfoc/v12r4/topic/ilog.odms.cplex.help/CPLEX/File_formats_reference/topics/MPS_ext_objsen.html
  -- CPLEX extends the MPS standard by allowing two additional sections: OBJSEN and OBJNAME.
  -- If these options are used, they must appear in order and as the first and second sections after the NAME section. 
  objsense <- optionMaybe $ objSenseSection
  objname  <- optionMaybe $ objNameSection

  rows <- rowsSection

  -- http://pic.dhe.ibm.com/infocenter/cosinfoc/v12r4/topic/ilog.odms.cplex.help/CPLEX/File_formats_reference/topics/MPS_ext_usercuts.html
  -- The order of sections must be ROWS USERCUTS.  
  usercuts <- option [] userCutsSection

  -- http://pic.dhe.ibm.com/infocenter/cosinfoc/v12r4/topic/ilog.odms.cplex.help/CPLEX/File_formats_reference/topics/MPS_ext_lazycons.html
  -- The order of sections must be ROWS USERCUTS LAZYCONS.
  lazycons <- option [] lazyConsSection

  (cols, intvs1) <- colsSection
  rhss <- rhsSection
  rngs <- option Map.empty rangesSection
  bnds <- option [] boundsSection

  -- http://pic.dhe.ibm.com/infocenter/cosinfoc/v12r4/topic/ilog.odms.cplex.help/CPLEX/File_formats_reference/topics/MPS_ext_quadobj.html
  -- Following the BOUNDS section, a QMATRIX section may be specified.
  qobj <- msum [quadObjSection, qMatrixSection, return []]

  -- http://pic.dhe.ibm.com/infocenter/cosinfoc/v12r4/topic/ilog.odms.cplex.help/CPLEX/File_formats_reference/topics/MPS_ext_sos.html
  -- Note that in an MPS file, the SOS section must follow the BOUNDS section.
  sos <- option [] sosSection

  -- http://pic.dhe.ibm.com/infocenter/cosinfoc/v12r4/topic/ilog.odms.cplex.help/CPLEX/File_formats_reference/topics/MPS_ext_qcmatrix.html
  -- QCMATRIX sections appear after the optional SOS section. 
  qterms <- liftM Map.fromList $ many qcMatrixSection

  -- http://pic.dhe.ibm.com/infocenter/cosinfoc/v12r4/topic/ilog.odms.cplex.help/CPLEX/File_formats_reference/topics/MPS_ext_indicators.html
  -- The INDICATORS section follows any quadratic constraint section and any quadratic objective section.
  inds <- option Map.empty indicatorsSection

  string "ENDATA"

  let objrow =
        case objname of
          Nothing -> head [row | (Nothing, row) <- rows] -- XXX
          Just r  -> r
      objdir =
        case objsense of
          Nothing -> OptMin
          Just d  -> d
      vs     = Map.keysSet cols
      intvs2 = Set.fromList [col | (t,col,_) <- bnds, t `elem` [BV,LI,UI]]
      scvs   = Set.fromList [col | (SC,col,_) <- bnds]

  let explicitBounds = Map.fromListWith f
        [ case typ of
            LO -> (col, (Just (LPFile.Finite val), Nothing))
            UP -> (col, (Nothing, Just (LPFile.Finite val)))
            FX -> (col, (Just (LPFile.Finite val), Just (LPFile.Finite val)))
            FR -> (col, (Just LPFile.NegInf, Just LPFile.PosInf))
            MI -> (col, (Just LPFile.NegInf, Nothing))
            PL -> (col, (Nothing, Just LPFile.PosInf))
            BV -> (col, (Just (LPFile.Finite 0), Just (LPFile.Finite 1)))
            LI -> (col, (Just (LPFile.Finite val), Nothing))
            UI -> (col, (Nothing, Just (LPFile.Finite val)))
            SC -> (col, (Nothing, Just (LPFile.Finite val)))
        | (typ,col,val) <- bnds ]
        where
          f (a1,b1) (a2,b2) = (g a1 a2, g b1 b2)
          g _ (Just x) = Just x
          g x Nothing  = x

  let bounds = Map.fromList
        [ case Map.lookup v explicitBounds of
            Nothing ->
              if v `Set.member` intvs1
              then
                -- http://eaton.math.rpi.edu/cplex90html/reffileformatscplex/reffileformatscplex9.html
                -- If no bounds are specified for the variables within markers, bounds of 0 (zero) and 1 (one) are assumed.
                (v, (LPFile.Finite 0, LPFile.Finite 1))
              else
                (v, (LPFile.Finite 0, LPFile.PosInf))
            Just (Nothing, Just (LPFile.Finite ub)) | ub < 0 ->
              {-
                http://pic.dhe.ibm.com/infocenter/cosinfoc/v12r4/topic/ilog.odms.cplex.help/CPLEX/File_formats_reference/topics/MPS_records.html
                If no bounds are specified, CPLEX assumes a lower
                bound of 0 (zero) and an upper bound of +∞. If only a
                single bound is specified, the unspecified bound
                remains at 0 or +∞, whichever applies, with one
                exception. If an upper bound of less than 0 is
                specified and no other bound is specified, the lower
                bound is automatically set to -∞. CPLEX deviates
                slightly from a convention used by some MPS readers
                when it encounters an upper bound of 0 (zero). Rather
                than automatically set this variable’s lower bound to
                -∞, CPLEX accepts both a lower and upper bound of 0,
                effectively fixing that variable at 0. CPLEX resets
                the lower bound to -∞ only if the upper bound is less
                than 0. A warning message is issued when this
                exception is encountered.
              -}
              (v, (LPFile.NegInf, LPFile.Finite ub))
            {-
              lp_solve uses 1 as default lower bound for semi-continuous variable.
              <http://lpsolve.sourceforge.net/5.5/mps-format.htm>
              But Gurobi Optimizer uses 0 as default lower bound for semi-continuous variable.
              Here we adopt Gurobi's way.
            -}
{-
            Just (Nothing, ub) | v `Set.member` scvs ->
              (v, (LPFile.Finite 1, fromMaybe LPFile.PosInf ub))
-}
            Just (lb,ub) ->
              (v, (fromMaybe (LPFile.Finite 0) lb, fromMaybe LPFile.PosInf ub))
        | v <- Set.toList vs ]

  let lp =
        LPFile.LP
        { LPFile.variables               = vs
        , LPFile.dir                     = objdir
        , LPFile.objectiveFunction       =
            ( Just objrow
            , [LPFile.Term c [col] | (col,m) <- Map.toList cols, c <- maybeToList (Map.lookup objrow m)] ++ qobj
            )
        , LPFile.constraints             =
            [ LPFile.Constraint
              { LPFile.constrType      = typ
              , LPFile.constrLabel     = Just row
              , LPFile.constrIndicator = Map.lookup row inds
              , LPFile.constrBody      = (lhs, op2, rhs2)
              }
            | (typ, (Just op, row)) <- zip (repeat LPFile.NormalConstraint) rows ++
                                       zip (repeat LPFile.UserDefinedCut) usercuts ++
                                       zip (repeat LPFile.LazyConstraint) lazycons
            , let lhs = [LPFile.Term c[col] | (col,m) <- Map.toList cols, c <- maybeToList (Map.lookup row m)]
                        ++ Map.findWithDefault [] row qterms
            , let rhs = Map.findWithDefault 0 row rhss
            , (op2,rhs2) <-
                case Map.lookup row rngs of
                  Nothing  -> return (op, rhs)
                  Just rng ->
                    case op of
                      LPFile.Ge  -> [(LPFile.Ge, rhs), (LPFile.Le, rhs + abs rng)]
                      LPFile.Le  -> [(LPFile.Ge, rhs - abs rng), (LPFile.Le, rhs)]
                      LPFile.Eql ->
                        if rng < 0
                        then [(LPFile.Ge, rhs + rng), (LPFile.Le, rhs)]
                        else [(LPFile.Ge, rhs), (LPFile.Le, rhs + rng)]
            ]
        , LPFile.varInfo                 =
            Map.fromAscList
            [ ( v
              , LPFile.VarInfo
                { LPFile.varName   = v
                , LPFile.varBounds = Map.findWithDefault LPFile.defaultBounds v bounds
                , LPFile.varType   =
                    if v `Set.member` intvs1 || v `Set.member` intvs2 then LPFile.IntegerVariable
                    else if v `Set.member` scvs then LPFile.SemiContinuousVariable
                    else LPFile.ContinuousVariable
                }
              )
            | v <- Set.toAscList vs
            ]
        , LPFile.sos                     = sos
        }

  return lp

nameSection :: Parser (Maybe String)
nameSection = do
  string "NAME"
  n <- optionMaybe $ do
    spaces1'
    ident
  newline'
  return n

objSenseSection :: Parser OptDir
objSenseSection = do
  try $ stringLn "OBJSENSE"
  spaces1'
  d <-  (try (stringLn "MAX") >> return OptMax)
    <|> (stringLn "MIN" >> return OptMin)
  return d

objNameSection :: Parser String
objNameSection = do
  try $ stringLn "OBJNAME"
  spaces1'
  name <- ident
  newline'
  return name

rowsSection :: Parser [(Maybe LPFile.RelOp, Row)]
rowsSection = do
  try $ stringLn "ROWS"
  rowsBody

userCutsSection :: Parser [(Maybe LPFile.RelOp, Row)]
userCutsSection = do
  try $ stringLn "USERCUTS"
  rowsBody

lazyConsSection :: Parser [(Maybe LPFile.RelOp, Row)]
lazyConsSection = do
  try $ stringLn "LAZYCONS"
  rowsBody

rowsBody :: Parser [(Maybe LPFile.RelOp, Row)]
rowsBody = many $ do
  spaces1'
  op <- msum
        [ char 'N' >> return Nothing
        , char 'G' >> return (Just LPFile.Ge)
        , char 'L' >> return (Just LPFile.Le)
        , char 'E' >> return (Just LPFile.Eql)
        ]
  spaces1'
  name <- ident
  newline'
  return (op, name)

colsSection :: Parser (Map.Map Column (Map.Map Row Rational), Set.Set Column)
colsSection = do
  try $ stringLn "COLUMNS"
  body False Map.empty Set.empty
  where
    body :: Bool -> Map.Map Column (Map.Map Row Rational) -> Set.Set Column -> Parser (Map.Map Column (Map.Map Row Rational), Set.Set Column)
    body isInt rs ivs = msum
      [ do isInt' <- try intMarker
           body isInt' rs ivs
      , do (k,v) <- entry
           let rs'  = Map.insertWith Map.union k v rs
               ivs' = if isInt then Set.insert k ivs else ivs
           seq rs' $ seq ivs' $ body isInt rs' ivs'
      , return (rs, ivs)
      ]

    intMarker :: Parser Bool
    intMarker = do
      spaces1'
      _marker <- ident 
      string "'MARKER'"
      spaces1'
      b <-  (try (string "'INTORG'") >> return True)
        <|> (string "'INTEND'" >> return False)
      newline'
      return b

    entry :: Parser (Column, Map.Map Row Rational)
    entry = do
      spaces1'
      col <- ident
      rv1 <- rowAndVal
      opt <- optionMaybe rowAndVal
      newline'
      case opt of
        Nothing -> return (col, rv1)
        Just rv2 ->  return (col, Map.union rv1 rv2)

rowAndVal :: Parser (Map.Map Row Rational)
rowAndVal = do
  row <- ident
  val <- number
  return $ Map.singleton row val

rhsSection :: Parser (Map.Map Row Rational)
rhsSection = do
  try $ stringLn "RHS"
  liftM Map.unions $ many entry
  where
    entry = do
      spaces1'
      _name <- ident
      rv1 <- rowAndVal
      opt <- optionMaybe rowAndVal
      newline'
      case opt of
        Nothing  -> return rv1
        Just rv2 -> return $ Map.union rv1 rv2

rangesSection :: Parser (Map.Map Row Rational)
rangesSection = do
  try $ stringLn "RANGES"
  liftM Map.unions $ many entry
  where
    entry = do
      spaces1'
      _name <- ident
      rv1 <- rowAndVal
      opt <- optionMaybe rowAndVal
      newline'
      case opt of
        Nothing  -> return rv1
        Just rv2 -> return $ Map.union rv1 rv2

boundsSection :: Parser [(BoundType, Column, Rational)]
boundsSection = do
  try $ stringLn "BOUNDS"
  many entry
  where
    entry = do
      spaces1'
      typ   <- boundType
      _name <- ident
      col   <- ident
      val   <- if typ `elem` [FR, BV, MI, PL]
               then return 0
               else number
      newline'
      return (typ, col, val)

boundType :: Parser BoundType
boundType = tok $ do
  let ks = ["LO", "UP", "FX", "FR", "MI", "PL", "BV", "LI", "UI", "SC"]
  msum [try (string k) >> return (read k) | k <- ks]

sosSection :: Parser [(Maybe String, LPFile.SOSType, [(Column, Rational)])]
sosSection = do
  try $ stringLn "SOS"
  many entry
  where
    entry = do
      spaces1'
      typ <-  (try (string "S1") >> return LPFile.S1)
          <|> (string "S2" >> return LPFile.S2)
      spaces1'
      name <- ident
      newline'
      xs <- many (try identAndVal)
      return (Just name, typ, xs)

    identAndVal :: Parser (Row, Rational)
    identAndVal = do
      spaces1'
      row <- ident
      val <- number
      newline'
      return (row, val)

quadObjSection :: Parser [LPFile.Term]
quadObjSection = do
  try $ stringLn "QUADOBJ"
  many entry
  where
    entry = do
      spaces1'
      col1 <- ident
      col2 <- ident
      val  <- number
      newline'
      return $ LPFile.Term (if col1 /= col2 then val else val / 2) [col1, col2]

qMatrixSection :: Parser [LPFile.Term]
qMatrixSection = do
  try $ stringLn "QMATRIX"
  many entry
  where
    entry = do
      spaces1'
      col1 <- ident
      col2 <- ident
      val  <- number
      newline'
      return $ LPFile.Term (val / 2) [col1, col2]

qcMatrixSection :: Parser (Row, [LPFile.Term])
qcMatrixSection = do
  try $ stringLn "QCMATRIX"
  spaces1'
  row <- ident
  xs <- many entry
  return (row, xs)
  where
    entry = do
      spaces1'
      col1 <- ident
      col2 <- ident
      val  <- number
      newline'
      return $ LPFile.Term val [col1, col2]

indicatorsSection :: Parser (Map.Map Row (Column, Rational))
indicatorsSection = do
  try $ stringLn "INDICATORS"
  liftM Map.fromList $ many entry
  where
    entry = do
      spaces1'
      string "IF"
      spaces1'
      row <- ident
      var <- ident
      val <- number
      newline'
      return (row, (var, val))