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
| UP
| FX
| FR
| MI
| PL
| BV
| LI
| UI
| SC
deriving (Eq, Ord, Show, Read)
parseString :: SourceName -> String -> Either ParseError LPFile.LP
parseString = parse mpsfile
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
objsense <- optionMaybe $ objSenseSection
objname <- optionMaybe $ objNameSection
rows <- rowsSection
usercuts <- option [] userCutsSection
lazycons <- option [] lazyConsSection
(cols, intvs1) <- colsSection
rhss <- rhsSection
rngs <- option Map.empty rangesSection
bnds <- option [] boundsSection
qobj <- msum [quadObjSection, qMatrixSection, return []]
sos <- option [] sosSection
qterms <- liftM Map.fromList $ many qcMatrixSection
inds <- option Map.empty indicatorsSection
string "ENDATA"
let objrow =
case objname of
Nothing -> head [row | (Nothing, row) <- rows]
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
(v, (LPFile.Finite 0, LPFile.Finite 1))
else
(v, (LPFile.Finite 0, LPFile.PosInf))
Just (Nothing, Just (LPFile.Finite ub)) | ub < 0 ->
(v, (LPFile.NegInf, LPFile.Finite 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))