Commit f0373636 authored by Philipp Meyer's avatar Philipp Meyer
Browse files

Added ghost transitions and added filter for zero entries

parent 769f3e09
...@@ -224,35 +224,42 @@ transformNet (net, props) TerminationByReachability = ...@@ -224,35 +224,42 @@ transformNet (net, props) TerminationByReachability =
places net ++ map prime (places net) places net ++ map prime (places net)
is = [("'m1", 1)] ++ is = [("'m1", 1)] ++
initials net ++ map (first prime) (initials net) initials net ++ map (first prime) (initials net)
ts = ("'switch", [("'m1",1)], [("'m2",1)]) : transformTransition t =
concatMap (\t ->
let (preT, postT) = context net t let (preT, postT) = context net t
pre' = [("'m1",1)] ++ preT ++ map (first prime) preT pre' = [("'m1",1)] ++ preT ++ map (first prime) preT
post' = [("'m1",1)] ++ postT ++ map (first prime) postT post' = [("'m1",1)] ++ postT ++ map (first prime) postT
pre'' = ("'m2",1) : map (first prime) preT pre'' = ("'m2",1) : map (first prime) preT
post'' = [("'m2",1), ("'sigma",1)] ++ map (first prime) postT post'' = [("'m2",1), ("'sigma",1)] ++ map (first prime) postT
in [(t, pre', post'), (prime t, pre'', post'')] in if t `elem` ghostTransitions net then
) [(t, pre', post')]
(transitions net) else
[(t, pre', post'), (prime t, pre'', post'')]
ts = ("'switch", [("'m1",1)], [("'m2",1)]) :
concatMap transformTransition (transitions net)
gs = ghostTransitions net
prop = Property "termination by reachability" Safety $ prop = Property "termination by reachability" Safety $
foldl (:&:) (Atom (LinIneq (Var "'sigma") Ge (Const 1))) foldl (:&:) (Atom (LinIneq (Var "'sigma") Ge (Const 1)))
(map (\p -> Atom (LinIneq (map (\p -> Atom (LinIneq
(Var (prime p) :-: Var p) Ge (Const 0))) (Var (prime p) :-: Var p) Ge (Const 0)))
(places net)) (places net))
-- TODO: map existing liveness properties -- TODO: map existing liveness properties
in (makePetriNetWithTrans (name net) ps ts is, prop : props) in (makePetriNetWithTrans (name net) ps ts is gs, prop : props)
transformNet (net, props) ValidateIdentifiers = transformNet (net, props) ValidateIdentifiers =
let ps = map validateId $ places net let ps = map validateId $ places net
ts = map validateId $ transitions net ts = map validateId $ transitions net
is = map (first validateId) $ initials net is = map (first validateId) $ initials net
as = map (\(a,b,x) -> (validateId a, validateId b, x)) $ arcs net as = map (\(a,b,x) -> (validateId a, validateId b, x)) $ arcs net
net' = makePetriNet (name net) ps ts as is gs = map validateId $ ghostTransitions net
net' = makePetriNet (name net) ps ts as is gs
props' = map (rename validateId) props props' = map (rename validateId) props
in (net', props') in (net', props')
makeImplicitProperty :: PetriNet -> ImplicitProperty -> Property makeImplicitProperty :: PetriNet -> ImplicitProperty -> Property
makeImplicitProperty _ Termination = makeImplicitProperty net Termination =
Property "termination" Liveness FTrue Property "termination" Liveness $
foldl (:&:) FTrue
(map (\t -> Atom (LinIneq (Var t) Eq (Const 0)))
(ghostTransitions net))
makeImplicitProperty net ProperTermination = makeImplicitProperty net ProperTermination =
let (finals, nonfinals) = partition (null . lpost net) (places net) let (finals, nonfinals) = partition (null . lpost net) (places net)
in Property "proper termination" Safety in Property "proper termination" Safety
......
...@@ -57,7 +57,7 @@ net = do ...@@ -57,7 +57,7 @@ net = do
initial <- option [] markingList initial <- option [] markingList
_ <- semi _ <- semi
ts <- many1 transition ts <- many1 transition
return $ makePetriNetWithTrans "" ps ts initial return $ makePetriNetWithTrans "" ps ts initial []
placeLists :: Parser [String] placeLists :: Parser [String]
placeLists = placeLists =
......
...@@ -58,6 +58,7 @@ net = do ...@@ -58,6 +58,7 @@ net = do
reserved "init" reserved "init"
(is,initTrans) <- initial (is,initTrans) <- initial
return $ makePetriNetWithTrans "" ps (initTrans ++ ts) is return $ makePetriNetWithTrans "" ps (initTrans ++ ts) is
[t | (t,_,_) <- initTrans]
prop :: Parser Property prop :: Parser Property
prop = do prop = do
...@@ -85,8 +86,7 @@ transition = do ...@@ -85,8 +86,7 @@ transition = do
lhs <- commaSep ((,) <$> identifier <* reservedOp ">=" <*> integer) lhs <- commaSep ((,) <$> identifier <* reservedOp ">=" <*> integer)
reservedOp "->" reservedOp "->"
rhs <- commaSep transitionAssignment rhs <- commaSep transitionAssignment
let rhs' = filter ((/=0) . snd) $ let rhs' = map (\xs -> (fst (head xs), sum (map snd xs))) $
map (\xs -> (fst (head xs), sum (map snd xs))) $
groupBy ((==) `on` fst) $ groupBy ((==) `on` fst) $
sortBy (comparing fst) $ sortBy (comparing fst) $
lhs ++ rhs lhs ++ rhs
...@@ -112,7 +112,7 @@ initial = do ...@@ -112,7 +112,7 @@ initial = do
let covered = [x | (x,_,True) <- xs] let covered = [x | (x,_,True) <- xs]
let initTrans = map (\(i,x) -> ("'init" ++ show i, [], [(x,1)])) let initTrans = map (\(i,x) -> ("'init" ++ show i, [], [(x,1)]))
([(1::Integer)..] `zip` covered) ([(1::Integer)..] `zip` covered)
return (filter ((/=0) . snd) inits, initTrans) return (inits, initTrans)
initState :: Parser (String, Integer, Bool) initState :: Parser (String, Integer, Bool)
initState = do initState = do
......
...@@ -116,7 +116,7 @@ petriNet = do ...@@ -116,7 +116,7 @@ petriNet = do
name <- option "" ident name <- option "" ident
statements <- braces (many statement) statements <- braces (many statement)
let (p,t,a,i) = foldl splitStatement ([],[],[],[]) statements let (p,t,a,i) = foldl splitStatement ([],[],[],[]) statements
return $ makePetriNet name p t a i return $ makePetriNet name p t a i []
where where
splitStatement (ps,ts,as,is) stmnt = case stmnt of splitStatement (ps,ts,as,is) stmnt = case stmnt of
Places p -> (p ++ ps,ts,as,is) Places p -> (p ++ ps,ts,as,is)
......
...@@ -77,7 +77,7 @@ petriNet = do ...@@ -77,7 +77,7 @@ petriNet = do
ts <- many transition ts <- many transition
let places = [ p | (p,_) <- ps ] let places = [ p | (p,_) <- ps ]
initial = [ (p,i) | (p,Just i) <- ps ] initial = [ (p,i) | (p,Just i) <- ps ]
return $ makePetriNetWithTrans "" places ts initial return $ makePetriNetWithTrans "" places ts initial []
parseContent :: Parser (PetriNet,[Property]) parseContent :: Parser (PetriNet,[Property])
parseContent = do parseContent = do
......
...@@ -2,7 +2,7 @@ ...@@ -2,7 +2,7 @@
module PetriNet module PetriNet
(PetriNet,name,showNetName,places,transitions,initial, (PetriNet,name,showNetName,places,transitions,initial,
pre,lpre,post,lpost,initials,context,arcs, pre,lpre,post,lpost,initials,context,arcs,ghostTransitions,
makePetriNet,makePetriNetWithTrans) makePetriNet,makePetriNetWithTrans)
where where
...@@ -13,7 +13,8 @@ data PetriNet = PetriNet { ...@@ -13,7 +13,8 @@ data PetriNet = PetriNet {
places :: [String], places :: [String],
transitions :: [String], transitions :: [String],
adjacency :: M.Map String ([(String,Integer)], [(String,Integer)]), adjacency :: M.Map String ([(String,Integer)], [(String,Integer)]),
initMap :: M.Map String Integer initMap :: M.Map String Integer,
ghostTransitions :: [String]
} }
initial :: PetriNet -> String -> Integer initial :: PetriNet -> String -> Integer
...@@ -56,15 +57,17 @@ instance Show PetriNet where ...@@ -56,15 +57,17 @@ instance Show PetriNet where
"Initial: " ++ unwords "Initial: " ++ unwords
(map (\(n,i) -> n ++ (map (\(n,i) -> n ++
(if i /= 1 then "[" ++ show i ++ "]" else [])) (if i /= 1 then "[" ++ show i ++ "]" else []))
(M.toList (initMap net))) (M.toList (initMap net))) ++
"\nGhost transitions: " ++ unwords (ghostTransitions net)
makePetriNet :: String -> [String] -> [String] -> makePetriNet :: String -> [String] -> [String] ->
[(String, String, Integer)] -> [(String, Integer)] -> PetriNet [(String, String, Integer)] -> [(String, Integer)] -> [String] -> PetriNet
makePetriNet name places transitions arcs initial = makePetriNet name places transitions arcs initial gs =
let adjacency = foldl buildMap M.empty arcs let adjacency = foldl buildMap M.empty $ filter (\(_,_,w) -> w /= 0) arcs
initMap = M.fromList initial initMap = M.fromList $ filter ((/=0) . snd) initial
in PetriNet { name=name, places=places, transitions=transitions, in PetriNet { name=name, places=places, transitions=transitions,
adjacency=adjacency, initMap=initMap } adjacency=adjacency, initMap=initMap,
ghostTransitions=gs }
where where
buildMap m (l,r,w) = buildMap m (l,r,w) =
let m' = M.insertWith addArc l ([],[(r,w)]) m let m' = M.insertWith addArc l ([],[(r,w)]) m
...@@ -74,9 +77,9 @@ makePetriNet name places transitions arcs initial = ...@@ -74,9 +77,9 @@ makePetriNet name places transitions arcs initial =
makePetriNetWithTrans :: String -> [String] -> makePetriNetWithTrans :: String -> [String] ->
[(String, [(String, Integer)], [(String, Integer)])] -> [(String, [(String, Integer)], [(String, Integer)])] ->
[(String, Integer)] -> PetriNet [(String, Integer)] -> [String] -> PetriNet
makePetriNetWithTrans name places ts initial = makePetriNetWithTrans name places ts initial gs =
let transitions = [ t | (t,_,_) <- ts ] let transitions = [ t | (t,_,_) <- ts ]
arcs = [ (i,t,w) | (t,is,_) <- ts, (i,w) <- is ] ++ arcs = [ (i,t,w) | (t,is,_) <- ts, (i,w) <- is ] ++
[ (t,o,w) | (t,_,os) <- ts, (o,w) <- os ] [ (t,o,w) | (t,_,os) <- ts, (o,w) <- os ]
in makePetriNet name places transitions arcs initial in makePetriNet name places transitions arcs initial gs
...@@ -5,6 +5,6 @@ where ...@@ -5,6 +5,6 @@ where
import Data.Char import Data.Char
validateId :: String -> String validateId :: String -> String
validateId "" = "" validateId "" = "_"
validateId (x:xs) = (if isAlpha x then x else '_') : validateId (x:xs) = (if isAlpha x then x else '_') :
map (\c -> if isAlphaNum c then c else '_') xs map (\c -> if isAlphaNum c then c else '_') xs
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