diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,7 @@ +0.1.4.0 +------- +* add Megaparsec-based parsers + 0.1.3.0 ------- * relax the grammer of OPB/WBO files to allow ommitng spaces at the end of weighted terms. diff --git a/pseudo-boolean.cabal b/pseudo-boolean.cabal --- a/pseudo-boolean.cabal +++ b/pseudo-boolean.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: pseudo-boolean -version: 0.1.3.0 +version: 0.1.4.0 synopsis: Reading/Writing OPB/WBO files used in pseudo boolean competition description: Reading\/Writing OPB\/WBO files used in pseudo boolean competition homepage: https://github.com/msakai/pseudo-boolean @@ -32,6 +32,7 @@ Data.PseudoBoolean.Builder Data.PseudoBoolean.ByteStringBuilder Data.PseudoBoolean.Parsec + Data.PseudoBoolean.Megaparsec Data.PseudoBoolean.Attoparsec Data.PseudoBoolean.Internal.TextUtil other-modules: @@ -47,6 +48,7 @@ base >=4.6.0.1 && <4.9, containers >=0.4.2.1, parsec >=3.1.2 && <4, + megaparsec >=4 && <5, bytestring >=0.9.2.1 && <0.11, bytestring-builder, dlist >=0.7.0 && <0.8.0, diff --git a/src/Data/PseudoBoolean/Megaparsec.hs b/src/Data/PseudoBoolean/Megaparsec.hs new file mode 100644 --- /dev/null +++ b/src/Data/PseudoBoolean/Megaparsec.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE BangPatterns, FlexibleContexts #-} +{-# OPTIONS_GHC -Wall #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.PseudoBoolean.Megaparsec +-- Copyright : (c) Masahiro Sakai 2011-2016 +-- License : BSD-style +-- +-- Maintainer : masahiro.sakai@gmail.com +-- Portability : non-portable (BangPatterns, FlexibleContexts) +-- +-- A parser library for OPB file and WBO files used in pseudo boolean competition. +-- +-- References: +-- +-- * Input/Output Format and Solver Requirements for the Competitions of +-- Pseudo-Boolean Solvers +-- +-- +----------------------------------------------------------------------------- + +module Data.PseudoBoolean.Megaparsec + ( + -- * Parsing OPB files + opbParser + , parseOPBString + , parseOPBByteString + , parseOPBFile + + -- * Parsing WBO files + , wboParser + , parseWBOString + , parseWBOByteString + , parseWBOFile + ) where + +import Prelude hiding (sum) +import Control.Applicative ((<*)) +import Control.Monad +import Data.ByteString.Lazy (ByteString) +import Data.Maybe +import Text.Megaparsec +import Data.PseudoBoolean.Types +import Data.PseudoBoolean.Internal.TextUtil + +-- | Parser for OPB files +opbParser :: Stream s Char => ParsecT s m Formula +opbParser = formula + +-- | Parser for WBO files +wboParser :: Stream s Char => ParsecT s m SoftFormula +wboParser = softformula + +-- ::= [] +formula :: Stream s Char => ParsecT s m Formula +formula = do + h <- optional hint + sequence_of_comments + obj <- optional objective + cs <- sequence_of_comments_or_constraints + return $ + Formula + { pbObjectiveFunction = obj + , pbConstraints = cs + , pbNumVars = fromMaybe (pbComputeNumVars obj cs) (fmap fst h) + , pbNumConstraints = fromMaybe (length cs) (fmap snd h) + } + +hint :: Stream s Char => ParsecT s m (Int,Int) +hint = try $ do + _ <- char '*' + zeroOrMoreSpace + _ <- string "#variable=" + zeroOrMoreSpace + nv <- unsigned_integer + oneOrMoreSpace + _ <- string "#constraint=" + zeroOrMoreSpace + nc <- unsigned_integer + _ <- manyTill anyChar eol + return (fromIntegral nv, fromIntegral nc) + +-- ::= [] +sequence_of_comments :: Stream s Char => ParsecT s m () +sequence_of_comments = skipMany comment -- XXX: we allow empty sequence + +-- ::= "*" +comment :: Stream s Char => ParsecT s m () +comment = do + _ <- char '*' + _ <- manyTill anyChar eol + space -- We relax the grammer and allow spaces in the beggining of next component. + return () + +-- ::= [] +sequence_of_comments_or_constraints :: Stream s Char => ParsecT s m [Constraint] +sequence_of_comments_or_constraints = do + xs <- many comment_or_constraint -- We relax the grammer and allow spaces in the beginning of next component. + return $ catMaybes xs + +-- ::= | +comment_or_constraint :: Stream s Char => ParsecT s m (Maybe Constraint) +comment_or_constraint = + (comment >> return Nothing) <|> (liftM Just constraint) + +-- ::= "min:" ";" +objective :: Stream s Char => ParsecT s m Sum +objective = do + _ <- string "min:" + zeroOrMoreSpace + obj <- sum + semi + return obj + +-- ::= ";" +constraint :: Stream s Char => ParsecT s m Constraint +constraint = do + lhs <- sum + op <- relational_operator + zeroOrMoreSpace + rhs <- integer + zeroOrMoreSpace + semi + return (lhs, op, rhs) + +-- ::= | +sum :: Stream s Char => ParsecT s m Sum +sum = some weightedterm + +-- ::= +weightedterm :: Stream s Char => ParsecT s m WeightedTerm +weightedterm = do + w <- integer + oneOrMoreSpace + t <- term + zeroOrMoreSpace -- we relax the grammar to allow omitting spaces at the end of . + return (w,t) + +-- ::= | "+" | "-" +integer :: Stream s Char => ParsecT s m Integer +integer = msum + [ unsigned_integer + , char '+' >> unsigned_integer + , char '-' >> liftM negate unsigned_integer + ] + +-- ::= | +unsigned_integer :: Stream s Char => ParsecT s m Integer +unsigned_integer = do + ds <- some digitChar + return $! readUnsignedInteger ds + +-- ::= ">=" | "=" +relational_operator :: Stream s Char => ParsecT s m Op +relational_operator = (string ">=" >> return Ge) <|> (string "=" >> return Eq) + +-- ::= "x" +variablename :: Stream s Char => ParsecT s m Var +variablename = do + _ <- char 'x' + i <- unsigned_integer + return $! fromIntegral i + +-- ::= " " [] +oneOrMoreSpace :: Stream s Char => ParsecT s m () +oneOrMoreSpace = skipSome (char ' ') + +-- ::= [" " ] +zeroOrMoreSpace :: Stream s Char => ParsecT s m () +-- zeroOrMoreSpace = skipMany (char ' ') +zeroOrMoreSpace = space +-- We relax the grammer and allow more type of spacing + +semi :: Stream s Char => ParsecT s m () +semi = char ';' >> space +-- We relax the grammer and allow spaces in the beginning of next component. + +{- +For linear pseudo-Boolean instances, is defined as +::= + +For non-linear instances, is defined as +::= +-} +term :: Stream s Char => ParsecT s m Term +term = oneOrMoreLiterals + +-- ::= | +oneOrMoreLiterals :: Stream s Char => ParsecT s m [Lit] +oneOrMoreLiterals = do + l <- literal + mplus (try $ oneOrMoreSpace >> liftM (l:) (oneOrMoreLiterals)) (return [l]) +-- Note that we cannot use sepBy1. +-- In "p `sepBy1` q", p should success whenever q success. +-- But it's not the case here. + +-- ::= | "~" +literal :: Stream s Char => ParsecT s m Lit +literal = variablename <|> (char '~' >> liftM negate variablename) + +-- | Parse a OPB format string containing pseudo boolean problem. +parseOPBString :: String -> String -> Either ParseError Formula +parseOPBString = parse (formula <* eof) + +-- | Parse a OPB format lazy bytestring containing pseudo boolean problem. +parseOPBByteString :: String -> ByteString -> Either ParseError Formula +parseOPBByteString = parse (formula <* eof) + +-- | Parse a OPB file containing pseudo boolean problem. +parseOPBFile :: FilePath -> IO (Either ParseError Formula) +parseOPBFile = parseFromFile ((formula <* eof) :: Parsec ByteString Formula) + + +-- ::= +softformula :: Stream s Char => ParsecT s m SoftFormula +softformula = do + h <- optional hint + sequence_of_comments + top <- softheader + cs <- wbo_sequence_of_comments_or_constraints + return $ + SoftFormula + { wboTopCost = top + , wboConstraints = cs + , wboNumVars = fromMaybe (wboComputeNumVars cs) (fmap fst h) + , wboNumConstraints = fromMaybe (length cs) (fmap snd h) + } + +-- ::= "soft:" [] ";" +softheader :: Stream s Char => ParsecT s m (Maybe Integer) +softheader = do + _ <- string "soft:" + zeroOrMoreSpace -- XXX + top <- optional unsigned_integer + zeroOrMoreSpace -- XXX + semi + return top + +-- ::= [] +wbo_sequence_of_comments_or_constraints :: Stream s Char => ParsecT s m [SoftConstraint] +wbo_sequence_of_comments_or_constraints = do + xs <- many wbo_comment_or_constraint -- XXX: we relax the grammer to allow empty sequence + return $ catMaybes xs + +-- ::= || +wbo_comment_or_constraint :: Stream s Char => ParsecT s m (Maybe SoftConstraint) +wbo_comment_or_constraint = (comment >> return Nothing) <|> m + where + m = liftM Just $ (constraint >>= \c -> return (Nothing, c)) <|> softconstraint + +-- ::= "[" "]" +softconstraint :: Stream s Char => ParsecT s m SoftConstraint +softconstraint = do + _ <- char '[' + zeroOrMoreSpace + cost <- unsigned_integer + zeroOrMoreSpace + _ <- char ']' + zeroOrMoreSpace -- XXX + c <- constraint + return (Just cost, c) + +-- | Parse a WBO format string containing weighted boolean optimization problem. +parseWBOString :: String -> String -> Either ParseError SoftFormula +parseWBOString = parse (softformula <* eof) + +-- | Parse a WBO format lazy bytestring containing pseudo boolean problem. +parseWBOByteString :: String -> ByteString -> Either ParseError SoftFormula +parseWBOByteString = parse (softformula <* eof) + +-- | Parse a WBO file containing weighted boolean optimization problem. +parseWBOFile :: FilePath -> IO (Either ParseError SoftFormula) +parseWBOFile = parseFromFile ((softformula <* eof) :: Parsec ByteString SoftFormula) diff --git a/test/TestPBFile.hs b/test/TestPBFile.hs --- a/test/TestPBFile.hs +++ b/test/TestPBFile.hs @@ -12,6 +12,7 @@ import Test.Tasty.TH import Data.PseudoBoolean import qualified Data.PseudoBoolean.Attoparsec as A +import qualified Data.PseudoBoolean.Megaparsec as M import Data.PseudoBoolean.Internal.TextUtil case_exampleLIN = checkOPBString "exampleLIN" exampleLIN @@ -42,7 +43,9 @@ case_trailing_junk = do isError (parseOPBString "" trailingJunk) @?= True + isError (M.parseOPBString "" trailingJunk) @?= True isError (parseOPBByteString "" (BSChar8.pack trailingJunk)) @?= True + isError (M.parseOPBByteString "" (BSChar8.pack trailingJunk)) @?= True isError (A.parseOPBByteString (BSChar8.pack trailingJunk)) @?= True where -- isLeft is available only on base >=4.7.0.0. @@ -66,7 +69,9 @@ case_min_eol = do isOk (parseOPBString "" opb) @?= True + isOk (M.parseOPBString "" opb) @?= True isOk (parseOPBByteString "" (BSChar8.pack opb)) @?= True + isOk (M.parseOPBByteString "" (BSChar8.pack opb)) @?= True isOk (A.parseOPBByteString (BSChar8.pack opb)) @?= True where -- isLeft is available only on base >=4.7.0.0. @@ -90,7 +95,9 @@ case_empty_constraints = do isOk (parseOPBString "" opb) @?= True + isOk (M.parseOPBString "" opb) @?= True isOk (parseOPBByteString "" (BSChar8.pack opb)) @?= True + isOk (M.parseOPBByteString "" (BSChar8.pack opb)) @?= True isOk (A.parseOPBByteString (BSChar8.pack opb)) @?= True where -- isRight is available only on base >=4.7.0.0. @@ -105,7 +112,9 @@ case_wbo_empty_constraints = do isOk (parseWBOString "" wbo) @?= True + isOk (M.parseWBOString "" wbo) @?= True isOk (parseWBOByteString "" (BSChar8.pack wbo)) @?= True + isOk (M.parseWBOByteString "" (BSChar8.pack wbo)) @?= True isOk (A.parseWBOByteString (BSChar8.pack wbo)) @?= True where -- isRight is available only on base >=4.7.0.0. @@ -120,7 +129,9 @@ case_trailing_spaces_before_eol = do isOk (parseOPBString "" opb) @?= True + isOk (M.parseOPBString "" opb) @?= True isOk (parseOPBByteString "" (BSChar8.pack opb)) @?= True + isOk (M.parseOPBByteString "" (BSChar8.pack opb)) @?= True isOk (A.parseOPBByteString (BSChar8.pack opb)) @?= True where -- isRight is available only on base >=4.7.0.0. @@ -143,7 +154,9 @@ case_trailing_spaces_before_eof = do isOk (parseOPBString "" opb) @?= True + isOk (M.parseOPBString "" opb) @?= True isOk (parseOPBByteString "" (BSChar8.pack opb)) @?= True + isOk (M.parseOPBByteString "" (BSChar8.pack opb)) @?= True isOk (A.parseOPBByteString (BSChar8.pack opb)) @?= True where -- isRight is available only on base >=4.7.0.0. @@ -167,7 +180,9 @@ case_leading_spaces = do isOk (parseOPBString "" opb) @?= True + isOk (M.parseOPBString "" opb) @?= True isOk (parseOPBByteString "" (BSChar8.pack opb)) @?= True + isOk (M.parseOPBByteString "" (BSChar8.pack opb)) @?= True isOk (A.parseOPBByteString (BSChar8.pack opb)) @?= True where -- isRight is available only on base >=4.7.0.0. @@ -284,17 +299,22 @@ case r of Left err -> assertFailure $ show err Right opb -> do - r2 <- A.parseOPBFile fname + r2 <- M.parseOPBFile fname case r2 of Left err2 -> assertFailure $ show err2 Right opb2 -> opb2 @?= opb + r3 <- A.parseOPBFile fname + case r3 of + Left err2 -> assertFailure $ show err2 + Right opb2 -> opb2 @?= opb + withSystemTempFile "TestPBFile.opb" $ \tmppath h -> do hClose h writeOPBFile tmppath opb - r3 <- parseOPBFile tmppath - case r3 of - Left err3 -> assertFailure $ show err3 - Right opb3 -> opb3 @?= opb + r4 <- parseOPBFile tmppath + case r4 of + Left err2 -> assertFailure $ show err2 + Right opb2 -> opb2 @?= opb checkOPBString :: String -> String -> IO () checkOPBString name str = do @@ -304,12 +324,21 @@ let s = toOPBString opb bs = toOPBByteString opb BSChar8.unpack bs @?= s + case parseOPBString name s of Left err -> assertFailure $ show err Right opb2 -> opb2 @?= opb case parseOPBByteString name bs of Left err -> assertFailure $ show err Right opb2 -> opb2 @?= opb + + case M.parseOPBString name s of + Left err -> assertFailure $ show err + Right opb2 -> opb2 @?= opb + case M.parseOPBByteString name bs of + Left err -> assertFailure $ show err + Right opb2 -> opb2 @?= opb + case A.parseOPBByteString bs of Left err -> assertFailure err Right opb2 -> opb2 @?= opb @@ -320,17 +349,22 @@ case r of Left err -> assertFailure $ show err Right wbo -> do - r2 <- A.parseWBOFile fname + r2 <- M.parseWBOFile fname case r2 of Left err2 -> assertFailure $ show err2 Right wbo2 -> wbo2 @?= wbo + r3 <- A.parseWBOFile fname + case r3 of + Left err2 -> assertFailure $ show err2 + Right wbo2 -> wbo2 @?= wbo + withSystemTempFile "TestPBFile.wbo" $ \tmppath h -> do hClose h writeWBOFile tmppath wbo - r3 <- parseWBOFile tmppath - case r3 of - Left err3 -> assertFailure $ show err3 - Right wbo3 -> wbo3 @?= wbo + r4 <- parseWBOFile tmppath + case r4 of + Left err2 -> assertFailure $ show err2 + Right wbo2 -> wbo2 @?= wbo checkWBOString :: String -> String -> IO () checkWBOString name str = do @@ -340,12 +374,21 @@ let s = toWBOString wbo bs = toWBOByteString wbo BSChar8.unpack bs @?= s + case parseWBOString name s of Left err -> assertFailure $ show err Right wbo2 -> wbo2 @?= wbo case parseWBOByteString name bs of Left err -> assertFailure $ show err Right wbo2 -> wbo2 @?= wbo + + case M.parseWBOString name s of + Left err -> assertFailure $ show err + Right wbo2 -> wbo2 @?= wbo + case M.parseWBOByteString name bs of + Left err -> assertFailure $ show err + Right wbo2 -> wbo2 @?= wbo + case A.parseWBOByteString bs of Left err -> assertFailure err Right wbo2 -> wbo2 @?= wbo