10.12., 9:00 - 11:00: Due to updates GitLab may be unavailable for some minutes between 09:00 and 11:00.

Commit ad3b64e6 authored by Philipp Meyer's avatar Philipp Meyer

Remove petri net only code and rename terminology for population protocols

parent 3cc46d66
This diff is collapsed.
This diff is collapsed.
module Parser.LOLA
(module Parser.LOLAFormula,
parseContent)
where
import Control.Applicative ((*>),(<*))
import Text.Parsec
import Text.Parsec.Language (LanguageDef, emptyDef)
import qualified Text.Parsec.Token as Token
import Parser
import Parser.LOLAFormula
import PetriNet (PetriNet,makePetriNetWithTransFromStrings)
import Property
languageDef :: LanguageDef ()
languageDef =
emptyDef {
Token.commentStart = "{",
Token.commentEnd = "}",
Token.commentLine = "",
Token.identStart = noneOf ",;:(){}\t \n\r",
Token.identLetter = noneOf ",;:(){}\t \n\r",
Token.reservedNames = ["PLACE", "MARKING", "SAFE",
"TRANSITION", "CONSUME", "PRODUCE",
"STRONG", "WEAK", "FAIR"],
Token.reservedOpNames = []
}
lexer :: Token.TokenParser ()
lexer = Token.makeTokenParser languageDef
identifier :: Parser String
identifier = Token.identifier lexer -- parses an identifier
reserved :: String -> Parser ()
reserved = Token.reserved lexer -- parses a reserved name
integer :: Parser Integer
integer = Token.integer lexer -- parses an integer
colon :: Parser String
colon = Token.colon lexer -- parses a colon
semi :: Parser String
semi = Token.semi lexer -- parses a semicolon
commaSep1 :: Parser a -> Parser [a]
commaSep1 = Token.commaSep1 lexer -- parses a comma separated list
whiteSpace :: Parser ()
whiteSpace = Token.whiteSpace lexer -- parses whitespace
ident :: Parser String
ident = (identifier <|> fmap show integer) <?> "identifier"
net :: Parser PetriNet
net = do
reserved "PLACE"
ps <- placeLists
reserved "MARKING"
initial <- option [] markingList
_ <- semi
ts <- many1 transition
return $ makePetriNetWithTransFromStrings "" ps ts initial [] [] [] [] []
placeLists :: Parser [String]
placeLists =
fmap concat (many1 (do
_ <- optionMaybe (reserved "SAFE" *> option 1 integer <* colon)
ps <- placeList
_ <- semi
return ps
))
placeList :: Parser [String]
placeList = commaSep1 ident
markingList :: Parser [(String, Integer)]
markingList = commaSep1 marking
marking :: Parser (String, Integer)
marking = do
s <- ident
i <- option 1 (colon *> integer)
return (s, i)
transition :: Parser (String, ([(String, Integer)], [(String, Integer)]))
transition = do
reserved "TRANSITION"
t <- ident
_ <- optionMaybe ((reserved "STRONG" <|> reserved "WEAK") <*
reserved "FAIR")
reserved "CONSUME"
input <- option [] arcList
_ <- semi
reserved "PRODUCE"
output <- option [] arcList
_ <- semi
return (t, (input, output))
arcList :: Parser [(String, Integer)]
arcList = commaSep1 arc
arc :: Parser (String, Integer)
arc = do
x <- ident
w <- option 1 (colon *> integer)
return (x, w)
parseContent :: Parser (PetriNet,[Property])
parseContent = do
whiteSpace
n <- net
eof
return (n, [])
module Parser.LOLAFormula
(parseFormula)
where
import Control.Applicative ((*>),(<$>))
import Data.Functor.Identity
import Text.Parsec
import Text.Parsec.Expr
import Text.Parsec.Language (LanguageDef, emptyDef)
import qualified Text.Parsec.Token as Token
import Parser
import Property
languageDef :: LanguageDef ()
languageDef =
emptyDef {
Token.commentStart = "{",
Token.commentEnd = "}",
Token.commentLine = "",
Token.identStart = noneOf ",;:(){}\t \n\r0123456789-",
Token.identLetter = noneOf ",;:(){}\t \n\r",
Token.reservedNames = ["FORMULA", "TRUE", "FALSE",
"NOT", "AND", "OR"],
Token.reservedOpNames = ["<", "<=", "=", "!=", ">=", ">",
"+", "-", "*"]
}
lexer :: Token.TokenParser ()
lexer = Token.makeTokenParser languageDef
identifier :: Parser String
identifier = Token.identifier lexer -- parses an identifier
reserved :: String -> Parser ()
reserved = Token.reserved lexer -- parses a reserved name
reservedOp :: String -> Parser ()
reservedOp = Token.reservedOp lexer -- parses an operator
parens :: Parser a -> Parser a
parens = Token.parens lexer -- parses p surrounded by parenthesis
integer :: Parser Integer
integer = Token.integer lexer -- parses an integer
whiteSpace :: Parser ()
whiteSpace = Token.whiteSpace lexer -- parses whitespace
binary :: String -> (a -> a -> a) -> Assoc -> Operator String () Identity a
binary name fun = Infix ( reservedOp name *> return fun )
prefix :: String -> (a -> a) -> Operator String () Identity a
prefix name fun = Prefix ( reservedOp name *> return fun )
termOperatorTable :: [[Operator String () Identity (Term String)]]
termOperatorTable =
[ [ prefix "-" Minus ]
, [ binary "*" (:*:) AssocLeft ]
, [ binary "+" (:+:) AssocLeft, binary "-" (:-:) AssocLeft ]
]
termAtom :: Parser (Term String)
termAtom = (Var <$> identifier)
<|> (Const <$> integer)
<|> parens term
<?> "basic term"
term :: Parser (Term String)
term = buildExpressionParser termOperatorTable termAtom <?> "term"
parseOp :: Parser Op
parseOp = (reservedOp "<" *> return Lt) <|>
(reservedOp "<=" *> return Le) <|>
(reservedOp "=" *> return Eq) <|>
(reservedOp "!=" *> return Ne) <|>
(reservedOp ">" *> return Gt) <|>
(reservedOp ">=" *> return Ge)
linIneq :: Parser (Formula String)
linIneq = do
lhs <- term
op <- parseOp
rhs <- term
return (LinearInequation lhs op rhs)
binaryName :: String -> (a -> a -> a) -> Assoc -> Operator String () Identity a
binaryName name fun = Infix ( reserved name *> return fun )
prefixName :: String -> (a -> a) -> Operator String () Identity a
prefixName name fun = Prefix ( reserved name *> return fun )
formOperatorTable :: [[Operator String () Identity (Formula String)]]
formOperatorTable =
[ [ prefixName "NOT" Neg ]
, [ binaryName "AND" (:&:) AssocRight ]
, [ binaryName "OR" (:|:) AssocRight ]
]
formAtom :: Parser (Formula String)
formAtom = try linIneq
<|> (reserved "TRUE" *> return FTrue)
<|> (reserved "FALSE" *> return FFalse)
<|> parens formula
<?> "basic formula"
formula :: Parser (Formula String)
formula = buildExpressionParser formOperatorTable formAtom <?> "formula"
parseFormula :: Parser (Formula String)
parseFormula = do
whiteSpace
reserved "FORMULA"
f <- formula
eof
return f
module Parser.MIST
(parseContent)
where
import Control.Applicative ((<$>),(*>),(<*),(<*>))
import Control.Monad (when)
import Data.List (sortBy, groupBy)
import Data.Function (on)
import Data.Ord (comparing)
import Text.Parsec
import Text.Parsec.Language (LanguageDef, emptyDef)
import qualified Text.Parsec.Token as Token
import Parser
import PetriNet (PetriNet,makePetriNetWithTransFromStrings,Place(..))
import Property
languageDef :: LanguageDef ()
languageDef =
emptyDef {
Token.commentStart = "",
Token.commentEnd = "",
Token.commentLine = "#",
Token.identStart = letter <|> char '_',
Token.identLetter = alphaNum <|> oneOf "'_",
Token.reservedNames = ["vars", "rules", "init",
"target", "invariants"],
Token.reservedOpNames = ["->", "+", "-", "=", ">="]
}
lexer :: Token.TokenParser ()
lexer = Token.makeTokenParser languageDef
identifier :: Parser String
identifier = Token.identifier lexer -- parses an identifier
reserved :: String -> Parser ()
reserved = Token.reserved lexer -- parses a reserved name
reservedOp :: String -> Parser ()
reservedOp = Token.reservedOp lexer -- parses an operator
integer :: Parser Integer
integer = Token.integer lexer -- parses an integer
semi :: Parser String
semi = Token.semi lexer -- parses a semicolon
commaSep :: Parser a -> Parser [a]
commaSep = Token.commaSep lexer -- parses a comma separated list
commaSep1 :: Parser a -> Parser [a]
commaSep1 = Token.commaSep1 lexer -- parses a comma separated list
whiteSpace :: Parser ()
whiteSpace = Token.whiteSpace lexer -- parses whitespace
net :: Parser PetriNet
net = do
reserved "vars"
ps <- many1 identifier
reserved "rules"
ts <- transitions
reserved "init"
(is,initTrans) <- initial
return $ makePetriNetWithTransFromStrings "" ps (initTrans ++ ts) is
(map fst initTrans) [] [] [] []
prop :: Parser Property
prop = do
reserved "target"
ineqs <- many1 (commaSep1 ineq)
_ <- optionMaybe (reserved "invariants" *> invariants)
return $ Property "" $ Safety $
foldl1 (:|:) $ map (foldl1 (:&:)) ineqs
ineq :: Parser (Formula Place)
ineq = do
x <- identifier
reservedOp ">="
c <- integer
return $ LinearInequation (Var (Place x)) Ge (Const c)
transitions :: Parser [(String, ([(String, Integer)], [(String, Integer)]))]
transitions = do
ts <- many1 transition
return $ map (\(i,(l,r)) -> ("'t" ++ show i,(l,r)))
([(1::Integer)..] `zip` ts)
transition :: Parser ([(String, Integer)], [(String, Integer)])
transition = do
lhs <- commaSep ((,) <$> identifier <* reservedOp ">=" <*> integer)
reservedOp "->"
rhs <- commaSep transitionAssignment
let rhs' = map (\xs -> (fst (head xs), sum (map snd xs))) $
groupBy ((==) `on` fst) $
sortBy (comparing fst) $
lhs ++ rhs
_ <- semi
return (lhs, rhs')
transitionAssignment :: Parser (String, Integer)
transitionAssignment = do
i1 <- identifier
reservedOp "="
i2 <- identifier
when (i1 /= i2 ++ "'")
(error ("identifiers not equal: " ++ i1 ++ " /= " ++ i2))
fac <- (reservedOp "-" *> return (-1)) <|> (reservedOp "+" *> return 1)
n <- integer
return (i2,fac*n)
initial :: Parser ([(String, Integer)],
[(String, ([(String, Integer)], [(String, Integer)]))])
initial = do
xs <- commaSep1 initState
let inits = [(x,i) | (x,i,_) <- xs]
let covered = [x | (x,_,True) <- xs]
let initTrans = map (\(i,x) -> ("'init" ++ show i, ([], [(x,1)])))
([(1::Integer)..] `zip` covered)
return (inits, initTrans)
initState :: Parser (String, Integer, Bool)
initState = do
s <- identifier
cover <- reservedOp "=" *> return False <|>
reservedOp ">=" *> return True
i <- integer
return (s,i,cover)
invariants :: Parser [[(String, Integer)]]
invariants = many1 (commaSep1 ((,) <$> identifier <* reservedOp "=" <*> integer))
parseContent :: Parser (PetriNet,[Property])
parseContent = do
whiteSpace
n <- net
p <- prop
eof
return (n, [p])
module Parser.PNET module Parser.PP
(parseContent) (parseContent)
where where
...@@ -10,7 +10,7 @@ import Text.Parsec.Language (LanguageDef, emptyDef) ...@@ -10,7 +10,7 @@ import Text.Parsec.Language (LanguageDef, emptyDef)
import qualified Text.Parsec.Token as Token import qualified Text.Parsec.Token as Token
import Parser import Parser
import PetriNet (PetriNet,makePetriNetFromStrings,Place(..),Transition(..)) import PopulationProtocol (PopulationProtocol,makePopulationProtocolFromStrings,State(..),Transition(..))
import Property import Property
languageDef :: LanguageDef () languageDef :: LanguageDef ()
...@@ -68,24 +68,14 @@ ident = (identifier <|> stringLiteral) <?> "identifier" ...@@ -68,24 +68,14 @@ ident = (identifier <|> stringLiteral) <?> "identifier"
identList :: Parser [String] identList :: Parser [String]
identList = singleOrList ident identList = singleOrList ident
places :: Parser [String] states :: Parser [String]
places = reserved "places" *> identList states = reserved "states" *> identList
transitions :: Parser [String] transitions :: Parser [String]
transitions = reserved "transitions" *> identList transitions = reserved "transitions" *> identList
initial :: Parser [(String,Integer)] initial :: Parser [String]
initial = reserved "initial" *> singleOrList (do initial = reserved "initial" *> identList
n <- ident
i <- numberOption
return (n,i)
)
trap :: Parser [String]
trap = reserved "trap" *> identList
siphon :: Parser [String]
siphon = reserved "siphon" *> identList
yesStates :: Parser [String] yesStates :: Parser [String]
yesStates = reserved "yes" *> identList yesStates = reserved "yes" *> identList
...@@ -112,39 +102,37 @@ arcs = do ...@@ -112,39 +102,37 @@ arcs = do
as <- singleOrList arc as <- singleOrList arc
return $ concat as return $ concat as
data Statement = Places [String] | Transitions [String] | data Statement = States [String]
Arcs [(String,String,Integer)] | Initial [(String,Integer)] | | Transitions [String]
TrapStatement [String] | SiphonStatement [String] | | Initial [String]
YesStatement [String] | NoStatement [String] | YesStatement [String]
| NoStatement [String]
| Arcs [(String,String,Integer)]
statement :: Parser Statement statement :: Parser Statement
statement = Places <$> places <|> statement = States <$> states <|>
Transitions <$> transitions <|> Transitions <$> transitions <|>
Arcs <$> arcs <|> Arcs <$> arcs <|>
Initial <$> initial <|> Initial <$> initial <|>
TrapStatement <$> trap <|>
SiphonStatement <$> siphon <|>
YesStatement <$> yesStates <|> YesStatement <$> yesStates <|>
NoStatement <$> noStates NoStatement <$> noStates
petriNet :: Parser PetriNet populationProtocol :: Parser PopulationProtocol
petriNet = do populationProtocol = do
reserved "petri" reserved "population"
reserved "net" reserved "protocol"
name <- option "" ident name <- option "" ident
statements <- braces (many statement) statements <- braces (many statement)
let (p,t,a,i,traps,siphons,yesStates,noStates) = foldl splitStatement ([],[],[],[],[],[],[],[]) statements let (qs,ts,is,ys,ns,as) = foldl splitStatement ([],[],[],[],[],[]) statements
return $ makePetriNetFromStrings name p t a i [] traps siphons yesStates noStates return $ makePopulationProtocolFromStrings name qs ts is ys ns as
where where
splitStatement (ps,ts,as,is,traps,siphons,ys,ns) stmnt = case stmnt of splitStatement (qs,ts,is,ys,ns,as) stmnt = case stmnt of
Places p -> (p ++ ps,ts,as,is,traps,siphons,ys,ns) States q -> (q ++ qs,ts,is,ys,ns,as)
Transitions t -> (ps,t ++ ts,as,is,traps,siphons,ys,ns) Transitions t -> (qs,t ++ ts,is,ys,ns,as)
Arcs a -> (ps,ts,a ++ as,is,traps,siphons,ys,ns) Initial i -> (qs,ts,i ++ is,ys,ns,as)
Initial i -> (ps,ts,as,i ++ is,traps,siphons,ys,ns) YesStatement y -> (qs,ts,is,y ++ ys,ns,as)
TrapStatement trap -> (ps,ts,as,is,trap:traps,siphons,ys,ns) NoStatement n -> (qs,ts,is,ys,n ++ ns,as)
SiphonStatement siphon -> (ps,ts,as,is,traps,siphon:siphons,ys,ns) Arcs a -> (qs,ts,is,ys,ns,a ++ as)
YesStatement y -> (ps,ts,as,is,traps,siphons,y ++ ys,ns)
NoStatement n -> (ps,ts,as,is,traps,siphons,ys,n ++ ns)
binary :: String -> (a -> a -> a) -> Assoc -> Operator String () Identity a binary :: String -> (a -> a -> a) -> Assoc -> Operator String () Identity a
binary name fun = Infix ( reservedOp name *> return fun ) binary name fun = Infix ( reservedOp name *> return fun )
...@@ -202,9 +190,7 @@ formula = buildExpressionParser formOperatorTable formAtom <?> "formula" ...@@ -202,9 +190,7 @@ formula = buildExpressionParser formOperatorTable formAtom <?> "formula"
propertyType :: Parser PropertyType propertyType :: Parser PropertyType
propertyType = propertyType =
(reserved "safety" *> return SafetyType) <|> (reserved "safety" *> return SafetyType) <|>
(reserved "liveness" *> return LivenessType) <|> (reserved "liveness" *> return LivenessType)
(reserved "structural" *> return StructuralType)
property :: Parser Property property :: Parser Property
property = do property = do
...@@ -215,16 +201,15 @@ property = do ...@@ -215,16 +201,15 @@ property = do
SafetyType -> do SafetyType -> do
form <- braces formula form <- braces formula
return Property return Property
{ pname=name, pcont=Safety (fmap Place form) } { pname=name, pcont=Safety (fmap PopulationProtocol.State form) }
LivenessType -> do LivenessType -> do
form <- braces formula form <- braces formula
return Property { pname=name, pcont=Liveness (fmap Transition form) } return Property { pname=name, pcont=Liveness (fmap Transition form) }
StructuralType -> error "structural property not supported for pnet"
parseContent :: Parser (PetriNet,[Property]) parseContent :: Parser (PopulationProtocol,[Property])
parseContent = do parseContent = do
whiteSpace whiteSpace
net <- petriNet pp <- populationProtocol
properties <- many property properties <- many property
eof eof
return (net, properties) return (pp, properties)
module Parser.TPN
(parseContent)
where
import Control.Applicative ((*>))
import Control.Arrow ((&&&))
import Text.Parsec
import Text.Parsec.Language (LanguageDef, emptyDef)
import qualified Text.Parsec.Token as Token
import Data.List (group,sort,genericLength)
import Parser
import PetriNet (PetriNet,makePetriNetWithTransFromStrings)
import Property
languageDef :: LanguageDef ()
languageDef =
emptyDef {
Token.commentStart = "",
Token.commentEnd = "",
Token.commentLine = "--",
Token.identStart = letter <|> char '_',
Token.identLetter = alphaNum <|> char '_',
Token.reservedNames = ["place", "trans", "init",
"in", "out"],
Token.reservedOpNames = ["~"]
}
lexer :: Token.TokenParser ()
lexer = Token.makeTokenParser languageDef
identifier :: Parser String
identifier = Token.identifier lexer -- parses an identifier
stringLiteral :: Parser String
stringLiteral = Token.stringLiteral lexer -- parses a string literal
reserved :: String -> Parser ()
reserved = Token.reserved lexer -- parses a reserved name
reservedOp :: String -> Parser ()
reservedOp = Token.reservedOp lexer -- parses an operator
natural :: Parser Integer
natural = Token.natural lexer -- parses a natural number
semi :: Parser String
semi = Token.semi lexer -- parses a semicolon
whiteSpace :: Parser ()
whiteSpace = Token.whiteSpace lexer -- parses whitespace
ident :: Parser String
ident = (identifier <|> stringLiteral) <?> "identifier"
place :: Parser (String, Maybe Integer)
place = do
reserved "place"
p <- ident
initial <- optionMaybe (reserved "init" *> natural)
_ <- semi
return (p, initial)
adjacencyList :: Parser [(String, Integer)]
adjacencyList = do
xs <- many1 ident
return $ map (head &&& genericLength) $ group $ sort xs
transition :: Parser (String, ([(String, Integer)], [(String, Integer)]))
transition = do
reserved "trans"
t <- ident
_ <- optionMaybe (reservedOp "~" *> ident)
input <- option [] (reserved "in" *> adjacencyList)
output <- option [] (reserved "out" *> adjacencyList)
_ <- semi
return (t, (input, output))
petriNet :: Parser PetriNet
petriNet = do
ps <- many place
ts <- many transition
let places = [ p | (p,_) <- ps ]
initial = [ (p,i) | (p,Just i) <- ps ]
return $ makePetriNetWithTransFromStrings "" places ts initial [] [] [] [] []
parseContent :: Parser (PetriNet,[Property])
parseContent = do
whiteSpace
net <- petriNet
eof
return (net, [])
This diff is collapsed.
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module PopulationProtocol