Skip to content

GitLab

peregrine
peregrine
Commit ad3b64e6 authored by Philipp Meyer's avatar Philipp Meyer
Browse files
Options

Remove petri net only code and rename terminology for population protocols

parent 3cc46d66
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 553 additions and 3215 deletions
src/Main.hs
View file @ ad3b64e6
This diff is collapsed.
src/Options.hs
View file @ ad3b64e6
This diff is collapsed.
src/Parser/LOLA.hs deleted 100644 → 0
View file @ 3cc46d66
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, [])
src/Parser/LOLAFormula.hs deleted 100644 → 0
View file @ 3cc46d66
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
src/Parser/MIST.hs deleted 100644 → 0
View file @ 3cc46d66
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])
src/Parser/PNET.hs → src/Parser/PP.hs
View file @ ad3b64e6
module Parser.PNET
module Parser.PP
(parseContent)
where
......@@ -10,7 +10,7 @@ import Text.Parsec.Language (LanguageDef, emptyDef)
import qualified Text.Parsec.Token as Token
import Parser
import PetriNet (PetriNet,makePetriNetFromStrings,Place(..),Transition(..))
import PopulationProtocol (PopulationProtocol,makePopulationProtocolFromStrings,State(..),Transition(..))
import Property
languageDef :: LanguageDef ()
......@@ -68,24 +68,14 @@ ident = (identifier <|> stringLiteral) <?> "identifier"
identList :: Parser [String]
identList = singleOrList ident
places :: Parser [String]
places = reserved "places" *> identList
states :: Parser [String]
states = reserved "states" *> identList
transitions :: Parser [String]
transitions = reserved "transitions" *> identList
initial :: Parser [(String,Integer)]
initial = reserved "initial" *> singleOrList (do
n <- ident
i <- numberOption
return (n,i)
)
trap :: Parser [String]
trap = reserved "trap" *> identList
siphon :: Parser [String]
siphon = reserved "siphon" *> identList
initial :: Parser [String]
initial = reserved "initial" *> identList
yesStates :: Parser [String]
yesStates = reserved "yes" *> identList
......@@ -112,39 +102,37 @@ arcs = do
as <- singleOrList arc
return $ concat as
data Statement = Places [String] | Transitions [String] |
Arcs [(String,String,Integer)] | Initial [(String,Integer)] |
TrapStatement [String] | SiphonStatement [String] |
YesStatement [String] | NoStatement [String]
data Statement = States [String]
| Transitions [String]
| Initial [String]
| YesStatement [String]
| NoStatement [String]
| Arcs [(String,String,Integer)]
statement :: Parser Statement
statement = Places <$> places <|>
statement = States <$> states <|>
Transitions <$> transitions <|>
Arcs <$> arcs <|>
Initial <$> initial <|>
TrapStatement <$> trap <|>
SiphonStatement <$> siphon <|>
YesStatement <$> yesStates <|>
NoStatement <$> noStates
petriNet :: Parser PetriNet
petriNet = do
reserved "petri"
reserved "net"
populationProtocol :: Parser PopulationProtocol
populationProtocol = do
reserved "population"
reserved "protocol"
name <- option "" ident
statements <- braces (many statement)
let (p,t,a,i,traps,siphons,yesStates,noStates) = foldl splitStatement ([],[],[],[],[],[],[],[]) statements
return $ makePetriNetFromStrings name p t a i [] traps siphons yesStates noStates
let (qs,ts,is,ys,ns,as) = foldl splitStatement ([],[],[],[],[],[]) statements
return $ makePopulationProtocolFromStrings name qs ts is ys ns as
where
splitStatement (ps,ts,as,is,traps,siphons,ys,ns) stmnt = case stmnt of
Places p -> (p ++ ps,ts,as,is,traps,siphons,ys,ns)
Transitions t -> (ps,t ++ ts,as,is,traps,siphons,ys,ns)
Arcs a -> (ps,ts,a ++ as,is,traps,siphons,ys,ns)
Initial i -> (ps,ts,as,i ++ is,traps,siphons,ys,ns)
TrapStatement trap -> (ps,ts,as,is,trap:traps,siphons,ys,ns)
SiphonStatement siphon -> (ps,ts,as,is,traps,siphon:siphons,ys,ns)
YesStatement y -> (ps,ts,as,is,traps,siphons,y ++ ys,ns)
NoStatement n -> (ps,ts,as,is,traps,siphons,ys,n ++ ns)
splitStatement (qs,ts,is,ys,ns,as) stmnt = case stmnt of
States q -> (q ++ qs,ts,is,ys,ns,as)
Transitions t -> (qs,t ++ ts,is,ys,ns,as)
Initial i -> (qs,ts,i ++ is,ys,ns,as)
YesStatement y -> (qs,ts,is,y ++ ys,ns,as)
NoStatement n -> (qs,ts,is,ys,n ++ ns,as)
Arcs a -> (qs,ts,is,ys,ns,a ++ as)
binary :: String -> (a -> a -> a) -> Assoc -> Operator String () Identity a
binary name fun = Infix ( reservedOp name *> return fun )
......@@ -202,9 +190,7 @@ formula = buildExpressionParser formOperatorTable formAtom <?> "formula"
propertyType :: Parser PropertyType
propertyType =
(reserved "safety" *> return SafetyType) <|>
(reserved "liveness" *> return LivenessType) <|>
(reserved "structural" *> return StructuralType)
(reserved "liveness" *> return LivenessType)
property :: Parser Property
property = do
......@@ -215,16 +201,15 @@ property = do
SafetyType -> do
form <- braces formula
return Property
{ pname=name, pcont=Safety (fmap Place form) }
{ pname=name, pcont=Safety (fmap PopulationProtocol.State form) }
LivenessType -> do
form <- braces formula
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
whiteSpace
net <- petriNet
pp <- populationProtocol
properties <- many property
eof
return (net, properties)
return (pp, properties)
src/Parser/TPN.hs deleted 100644 → 0
View file @ 3cc46d66
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, [])
src/PetriNet.hs deleted 100644 → 0
View file @ 3cc46d66
This diff is collapsed.
src/PopulationProtocol.hs 0 → 100644
View file @ ad3b64e6
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module PopulationProtocol
(PopulationProtocol,State(..),Transition(..),Marking,FiringVector,
RMarking,RFiringVector,
renameState,renameTransition,renameStatesAndTransitions,
name,showNetName,states,transitions,
initialStates,
pre,lpre,post,lpost,mpre,mpost,context,
yesStates,noStates,
makePopulationProtocol,makePopulationProtocolWithTrans,
makePopulationProtocolFromStrings,makePopulationProtocolWithTransFromStrings,Trap,Siphon,
Invariant(..))
where
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Arrow (first,(***))
import Data.List (sort,(\\))
import Util
newtype State = State String deriving (Ord,Eq)
newtype Transition = Transition String deriving (Ord,Eq)
instance Show State where
show (State q) = q
instance Show Transition where
show (Transition t) = t
type SimpleCut = (S.Set Transition, [S.Set Transition])
type ContextMap a b = M.Map a ([(b, Integer)],[(b, Integer)])
class (Ord a, Ord b) => Nodes a b | a -> b where
lpre :: PopulationProtocol -> a -> [(b, Integer)]
lpre pp = fst . context pp
lpost :: PopulationProtocol -> a -> [(b, Integer)]
lpost pp = snd . context pp
pre :: PopulationProtocol -> a -> [b]
pre pp = map fst . lpre pp
post :: PopulationProtocol -> a -> [b]
post pp = map fst . lpost pp
lmpre :: PopulationProtocol -> [a] -> [(b, Integer)]
lmpre pp = listMap . concatMap (lpre pp)
lmpost :: PopulationProtocol -> [a] -> [(b, Integer)]
lmpost pp = listMap . concatMap (lpost pp)
mpre :: PopulationProtocol -> [a] -> [b]
mpre pp = map fst . lmpre pp
mpost :: PopulationProtocol -> [a] -> [b]
mpost pp = map fst . lmpost pp
context :: PopulationProtocol -> a -> ([(b, Integer)], [(b, Integer)])
context pp x = M.findWithDefault ([],[]) x (contextMap pp)
contextMap :: PopulationProtocol -> ContextMap a b
instance Nodes State Transition where
contextMap = adjacencyQ
instance Nodes Transition State where
contextMap = adjacencyT
type Marking = IVector State
type FiringVector = IVector Transition
type RMarking = RVector State
type RFiringVector = RVector Transition
type Trap = [State]
type Siphon = [State]
-- TODO: generalize cut type
type Cut = ([([State], [Transition])], [Transition])
class Invariant a where
invariantSize :: a -> Int