Commit 1cca0e05 authored by Philipp Meyer's avatar Philipp Meyer

Extended parser and grammar to allow more liberal terms

parent c06c711e
...@@ -137,13 +137,14 @@ checkFile parser verbosity refine implicitProperties file = do ...@@ -137,13 +137,14 @@ checkFile parser verbosity refine implicitProperties file = do
"Places: " ++ show (length $ places net) ++ "\n" ++ "Places: " ++ show (length $ places net) ++ "\n" ++
"Transitions: " ++ show (length $ transitions net) "Transitions: " ++ show (length $ transitions net)
let addedProperties = map (makeImplicitProperty net) implicitProperties let addedProperties = map (makeImplicitProperty net) implicitProperties
print properties
rs <- mapM (checkProperty verbosity net refine) rs <- mapM (checkProperty verbosity net refine)
(addedProperties ++ properties) (addedProperties ++ properties)
verbosePut verbosity 0 "" verbosePut verbosity 0 ""
return $ and rs return $ and rs
placeOp :: Op -> (String, Integer) -> Formula placeOp :: Op -> (String, Integer) -> Formula
placeOp op (p,w) = Atom $ LinIneq (Term [Var 1 p]) op (Term [Const w]) placeOp op (p,w) = Atom $ LinIneq (Var p) op (Const w)
makeImplicitProperty :: PetriNet -> ImplicitProperty -> Property makeImplicitProperty :: PetriNet -> ImplicitProperty -> Property
makeImplicitProperty _ Termination = Property "termination" Liveness FTrue makeImplicitProperty _ Termination = Property "termination" Liveness FTrue
......
...@@ -2,8 +2,10 @@ module Parser.PNET ...@@ -2,8 +2,10 @@ module Parser.PNET
(parseContent) (parseContent)
where where
import Control.Applicative ((<*),(*>),(<*>),(<$>)) import Control.Applicative ((<*),(*>),(<$>))
import Data.Functor.Identity
import Text.Parsec import Text.Parsec
import Text.Parsec.Expr
import Text.Parsec.Language (LanguageDef, emptyDef) import Text.Parsec.Language (LanguageDef, emptyDef)
import qualified Text.Parsec.Token as Token import qualified Text.Parsec.Token as Token
...@@ -20,7 +22,7 @@ languageDef = ...@@ -20,7 +22,7 @@ languageDef =
Token.identStart = letter <|> char '_', Token.identStart = letter <|> char '_',
Token.identLetter = alphaNum <|> char '_', Token.identLetter = alphaNum <|> char '_',
Token.reservedNames = ["true", "false"], Token.reservedNames = ["true", "false"],
Token.reservedOpNames = ["->", "<", "<=", "=", ">=", ">", Token.reservedOpNames = ["->", "<", "<=", "=", "!=", ">=", ">",
"+", "-", "*", "&&", "||", "!"] "+", "-", "*", "&&", "||", "!"]
} }
...@@ -122,23 +124,31 @@ petriNet = do ...@@ -122,23 +124,31 @@ petriNet = do
Arcs a -> (ps,ts,a ++ as,is) Arcs a -> (ps,ts,a ++ as,is)
Initial i -> (ps,ts,as,i ++ is) Initial i -> (ps,ts,as,i ++ is)
preFactor :: Parser Integer binary :: String -> (a -> a -> a) -> Assoc -> Operator String () Identity a
preFactor = (reservedOp "-" *> return (-1)) <|> binary name fun = Infix ( reservedOp name *> return fun )
(reservedOp "+" *> return 1) prefix :: String -> (a -> a) -> Operator String () Identity a
prefix name fun = Prefix ( reservedOp name *> return fun )
linAtom :: Integer -> Parser LinAtom termOperatorTable :: [[Operator String () Identity Term]]
linAtom fac = ( integer >>= \lhs -> termOperatorTable =
option (Const (fac*lhs)) $ Var (fac*lhs) <$> (reservedOp "*" *> ident) [ [ prefix "-" Minus ]
) <|> Var fac <$> ident , [ binary "*" (:*:) AssocLeft ]
, [ binary "+" (:+:) AssocLeft, binary "-" (:-:) AssocLeft ]
]
termAtom :: Parser Term
termAtom = parens term
<|> (Const <$> integer)
<|> (Var <$> ident)
term :: Parser Term term :: Parser Term
term = Term <$> ((:) <$> (option 1 preFactor >>= linAtom) <*> term = buildExpressionParser termOperatorTable termAtom <?> "term"
many (preFactor >>= linAtom))
parseOp :: Parser Op parseOp :: Parser Op
parseOp = (reservedOp "<" *> return Lt) <|> parseOp = (reservedOp "<" *> return Lt) <|>
(reservedOp "<=" *> return Le) <|> (reservedOp "<=" *> return Le) <|>
(reservedOp "=" *> return Eq) <|> (reservedOp "=" *> return Eq) <|>
(reservedOp "!=" *> return Ne) <|>
(reservedOp ">" *> return Gt) <|> (reservedOp ">" *> return Gt) <|>
(reservedOp ">=" *> return Ge) (reservedOp ">=" *> return Ge)
...@@ -149,29 +159,21 @@ linIneq = do ...@@ -149,29 +159,21 @@ linIneq = do
rhs <- term rhs <- term
return (Atom (LinIneq lhs op rhs)) return (Atom (LinIneq lhs op rhs))
atom :: Parser Formula formOperatorTable :: [[Operator String () Identity Formula]]
atom = (reserved "true" *> return FTrue) <|> formOperatorTable =
(reserved "false" *> return FFalse) <|> [ [ prefix "!" Neg ]
linIneq , [ binary "&&" (:&:) AssocRight ]
, [ binary "||" (:|:) AssocRight ]
parensForm :: Parser Formula ]
parensForm = atom <|> parens formula
negation :: Parser Formula
negation = (Neg <$> (reservedOp "!" *> negation)) <|> parensForm
conjunction :: Parser Formula
conjunction = do
lhs <- negation
option lhs ((lhs :&:) <$> (reservedOp "&&" *> conjunction))
disjunction :: Parser Formula formAtom :: Parser Formula
disjunction = do formAtom = parens formula
lhs <- conjunction <|> (reserved "true" *> return FTrue)
option lhs ((lhs :|:) <$> (reservedOp "||" *> disjunction)) <|> (reserved "false" *> return FFalse)
<|> linIneq
formula :: Parser Formula formula :: Parser Formula
formula = disjunction formula = buildExpressionParser formOperatorTable formAtom <?> "formula"
propertyType :: Parser PropertyType propertyType :: Parser PropertyType
propertyType = propertyType =
......
...@@ -7,31 +7,31 @@ module Property ...@@ -7,31 +7,31 @@ module Property
Formula(..), Formula(..),
LinearInequation(..), LinearInequation(..),
Op(..), Op(..),
Term(..), Term(..))
LinAtom(..))
where where
import Data.List (intercalate) data Term = Var String
| Const Integer
data LinAtom = Var Integer String | Const Integer | Minus Term
| Term :+: Term
instance Show LinAtom where | Term :-: Term
show (Var c x) | c == 1 = x | Term :*: Term
show (Var c x) | c == -1 = "-" ++ x
show (Var c x) = show c ++ "*" ++ x
show (Const c) = show c
data Term = Term [LinAtom]
instance Show Term where instance Show Term where
show (Term xs) = intercalate " + " (map show xs) show (Var x) = x
show (Const c) = show c
show (Minus t) = "-(" ++ show t ++ ")"
show (t :+: u) = show t ++ " + " ++ show u
show (t :-: u) = show t ++ " - " ++ show u
show (t :*: u) = "(" ++ show t ++ ") * (" ++ show u ++ ")"
data Op = Gt | Ge | Eq | Le | Lt data Op = Gt | Ge | Eq | Ne | Le | Lt
instance Show Op where instance Show Op where
show Gt = ">" show Gt = ">"
show Ge = "≥" show Ge = "≥"
show Eq = "=" show Eq = "="
show Ne = "≠"
show Le = "≤" show Le = "≤"
show Lt = "<" show Lt = "<"
......
...@@ -8,14 +8,18 @@ import Property ...@@ -8,14 +8,18 @@ import Property
import Solver import Solver
evaluateTerm :: Term -> ModelSI -> SInteger evaluateTerm :: Term -> ModelSI -> SInteger
evaluateTerm (Term xs) m = sum $ map evaluateLinAtom xs evaluateTerm (Var x) m = mVal m x
where evaluateLinAtom (Var c x) = literal c * mVal m x evaluateTerm (Const c) _ = literal c
evaluateLinAtom (Const c) = literal c evaluateTerm (Minus t) m = - evaluateTerm t m
evaluateTerm (t :+: u) m = evaluateTerm t m + evaluateTerm u m
evaluateTerm (t :-: u) m = evaluateTerm t m - evaluateTerm u m
evaluateTerm (t :*: u) m = evaluateTerm t m * evaluateTerm u m
opToFunction :: Op -> SInteger -> SInteger -> SBool opToFunction :: Op -> SInteger -> SInteger -> SBool
opToFunction Gt = (.>) opToFunction Gt = (.>)
opToFunction Ge = (.>=) opToFunction Ge = (.>=)
opToFunction Eq = (.==) opToFunction Eq = (.==)
opToFunction Ne = (./=)
opToFunction Le = (.<=) opToFunction Le = (.<=)
opToFunction Lt = (.<) opToFunction Lt = (.<)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment