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

Commit 6e12e50e authored by Philipp J. Meyer's avatar Philipp J. Meyer

added option to check reachability of non-consensus states

parent 7a3e1c37
......@@ -38,6 +38,7 @@ import Solver.SComponentWithCut
import Solver.SComponent
import Solver.Simplifier
import Solver.UniqueTerminalMarking
import Solver.NonConsensusState
--import Solver.Interpolant
--import Solver.CommFreeReachability
......@@ -165,7 +166,7 @@ transformNet (net, props) TerminationByReachability =
(places net))
-- TODO: map existing liveness properties
in (makePetriNetWithTrans (name net) ps ts is
(ghostTransitions net) (fixedTraps net) (fixedSiphons net), prop : props)
(ghostTransitions net) (fixedTraps net) (fixedSiphons net) (yesStates net) (noStates net), prop : props)
transformNet (net, props) ValidateIdentifiers =
(renamePetriNetPlacesAndTransitions validateId net,
map (renameProperty validateId) props)
......@@ -217,6 +218,8 @@ makeImplicitProperty _ StructCommunicationFree =
Property "communication free" $ Structural CommunicationFree
makeImplicitProperty _ UniqueTerminalMarking =
Property "unique terminal marking" $ Constraint UniqueTerminalMarkingConstraint
makeImplicitProperty _ NonConsensusState =
Property "non-consensus state" $ Constraint NonConsensusStateConstraint
checkProperty :: PetriNet -> Property -> OptIO PropResult
checkProperty net p = do
......@@ -444,6 +447,7 @@ checkConstraintProperty :: PetriNet -> ConstraintProperty -> OptIO PropResult
checkConstraintProperty net cp =
case cp of
UniqueTerminalMarkingConstraint -> checkUniqueTerminalMarkingProperty net
NonConsensusStateConstraint -> checkNonConsensusStateProperty net
checkUniqueTerminalMarkingProperty :: PetriNet -> OptIO PropResult
checkUniqueTerminalMarkingProperty net = do
......@@ -459,29 +463,66 @@ checkUniqueTerminalMarkingProperty' net traps siphons = do
r <- checkSat $ checkUniqueTerminalMarkingSat net traps siphons
case r of
Nothing -> return (Nothing, traps, siphons)
Just m -> do
Just c -> do
refine <- opt optRefinementType
if isJust refine then
refineUniqueTerminalMarkingProperty net traps siphons m
refineUniqueTerminalMarkingProperty net traps siphons c
else
return (Just m, traps, siphons)
return (Just c, traps, siphons)
refineUniqueTerminalMarkingProperty :: PetriNet ->
[Trap] -> [Siphon] -> UniqueTerminalMarkingCounterExample ->
OptIO (Maybe UniqueTerminalMarkingCounterExample, [Trap], [Siphon])
refineUniqueTerminalMarkingProperty net traps siphons m@(m0, m1, m2, x1, x2) = do
r1 <- checkSatMin $ checkUnmarkedTrapSat net m0 m1 m2 x1 x2
refineUniqueTerminalMarkingProperty net traps siphons c@(m0, m1, m2, x1, x2) = do
r1 <- checkSatMin $ Solver.UniqueTerminalMarking.checkUnmarkedTrapSat net m0 m1 m2 x1 x2
case r1 of
Nothing -> do
r2 <- checkSatMin $ checkUnmarkedSiphonSat net m0 m1 m2 x1 x2
r2 <- checkSatMin $ Solver.UniqueTerminalMarking.checkUnmarkedSiphonSat net m0 m1 m2 x1 x2
case r2 of
Nothing ->
return (Just m, traps, siphons)
return (Just c, traps, siphons)
Just siphon ->
checkUniqueTerminalMarkingProperty' net traps (siphon:siphons)
Just trap ->
checkUniqueTerminalMarkingProperty' net (trap:traps) siphons
checkNonConsensusStateProperty :: PetriNet -> OptIO PropResult
checkNonConsensusStateProperty net = do
r <- checkNonConsensusStateProperty' net (fixedTraps net) (fixedSiphons net)
case r of
(Nothing, _, _) -> return Satisfied
(Just _, _, _) -> return Unknown
checkNonConsensusStateProperty' :: PetriNet ->
[Trap] -> [Siphon] ->
OptIO (Maybe NonConsensusStateCounterExample, [Trap], [Siphon])
checkNonConsensusStateProperty' net traps siphons = do
r <- checkSat $ checkNonConsensusStateSat net traps siphons
case r of
Nothing -> return (Nothing, traps, siphons)
Just c -> do
refine <- opt optRefinementType
if isJust refine then
refineNonConsensusStateProperty net traps siphons c
else
return (Just c, traps, siphons)
refineNonConsensusStateProperty :: PetriNet ->
[Trap] -> [Siphon] -> NonConsensusStateCounterExample ->
OptIO (Maybe NonConsensusStateCounterExample, [Trap], [Siphon])
refineNonConsensusStateProperty net traps siphons c@(m0, m, x) = do
r1 <- checkSatMin $ Solver.NonConsensusState.checkUnmarkedTrapSat net m0 m x
case r1 of
Nothing -> do
r2 <- checkSatMin $ Solver.NonConsensusState.checkUnmarkedSiphonSat net m0 m x
case r2 of
Nothing ->
return (Just c, traps, siphons)
Just siphon ->
checkNonConsensusStateProperty' net traps (siphon:siphons)
Just trap ->
checkNonConsensusStateProperty' net (trap:traps) siphons
main :: IO ()
main = do
putStrLn "SLAPnet - Safety and Liveness Analysis of Petri Nets with SMT solvers\n"
......
......@@ -32,6 +32,7 @@ data ImplicitProperty = Termination
| StructFinalPlace
| StructCommunicationFree
| UniqueTerminalMarking
| NonConsensusState
deriving (Show,Read)
data RefinementType = TrapRefinement | SComponentRefinement | SComponentWithCutRefinement
......@@ -184,6 +185,12 @@ options =
}))
"Prove that all markings of the net have a unique terminal marking"
, Option "" ["non-consensus-state"]
(NoArg (\opt -> Right opt {
optProperties = NonConsensusState : optProperties opt
}))
"Prove that no non-consensus terminal state is reachable from an initial marking"
, Option "i" ["invariant"]
(NoArg (\opt -> Right opt { optInvariant = True }))
"Generate an invariant"
......
......@@ -57,7 +57,7 @@ net = do
initial <- option [] markingList
_ <- semi
ts <- many1 transition
return $ makePetriNetWithTransFromStrings "" ps ts initial [] [] []
return $ makePetriNetWithTransFromStrings "" ps ts initial [] [] [] [] []
placeLists :: Parser [String]
placeLists =
......
......@@ -58,7 +58,7 @@ net = do
reserved "init"
(is,initTrans) <- initial
return $ makePetriNetWithTransFromStrings "" ps (initTrans ++ ts) is
(map fst initTrans) [] []
(map fst initTrans) [] [] [] []
prop :: Parser Property
prop = do
......
......@@ -87,6 +87,12 @@ trap = reserved "trap" *> identList
siphon :: Parser [String]
siphon = reserved "siphon" *> identList
yesStates :: Parser [String]
yesStates = reserved "yes" *> identList
noStates :: Parser [String]
noStates = reserved "no" *> identList
arc :: Parser [(String,String,Integer)]
arc = do
lhs <- identList
......@@ -108,7 +114,8 @@ arcs = do
data Statement = Places [String] | Transitions [String] |
Arcs [(String,String,Integer)] | Initial [(String,Integer)] |
TrapStatement [String] | SiphonStatement [String]
TrapStatement [String] | SiphonStatement [String] |
YesStatement [String] | NoStatement [String]
statement :: Parser Statement
statement = Places <$> places <|>
......@@ -116,7 +123,9 @@ statement = Places <$> places <|>
Arcs <$> arcs <|>
Initial <$> initial <|>
TrapStatement <$> trap <|>
SiphonStatement <$> siphon
SiphonStatement <$> siphon <|>
YesStatement <$> yesStates <|>
NoStatement <$> noStates
petriNet :: Parser PetriNet
petriNet = do
......@@ -124,16 +133,18 @@ petriNet = do
reserved "net"
name <- option "" ident
statements <- braces (many statement)
let (p,t,a,i,traps,siphons) = foldl splitStatement ([],[],[],[],[],[]) statements
return $ makePetriNetFromStrings name p t a i [] traps siphons
let (p,t,a,i,traps,siphons,yesStates,noStates) = foldl splitStatement ([],[],[],[],[],[],[],[]) statements
return $ makePetriNetFromStrings name p t a i [] traps siphons yesStates noStates
where
splitStatement (ps,ts,as,is,traps,siphons) stmnt = case stmnt of
Places p -> (p ++ ps,ts,as,is,traps,siphons)
Transitions t -> (ps,t ++ ts,as,is,traps,siphons)
Arcs a -> (ps,ts,a ++ as,is,traps,siphons)
Initial i -> (ps,ts,as,i ++ is,traps,siphons)
TrapStatement trap -> (ps,ts,as,is,trap:traps,siphons)
SiphonStatement siphon -> (ps,ts,as,is,traps,siphon:siphons)
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)
binary :: String -> (a -> a -> a) -> Assoc -> Operator String () Identity a
binary name fun = Infix ( reservedOp name *> return fun )
......
......@@ -77,7 +77,7 @@ petriNet = do
ts <- many transition
let places = [ p | (p,_) <- ps ]
initial = [ (p,i) | (p,Just i) <- ps ]
return $ makePetriNetWithTransFromStrings "" places ts initial [] [] []
return $ makePetriNetWithTransFromStrings "" places ts initial [] [] [] [] []
parseContent :: Parser (PetriNet,[Property])
parseContent = do
......
......@@ -8,6 +8,7 @@ module PetriNet
name,showNetName,places,transitions,
initialMarking,initial,initials,linitials,
pre,lpre,post,lpost,mpre,mpost,context,ghostTransitions,fixedTraps,fixedSiphons,
yesStates,noStates,
makePetriNet,makePetriNetWithTrans,
makePetriNetFromStrings,makePetriNetWithTransFromStrings,Trap,Siphon,Cut,
constructCut,SimpleCut,Invariant(..))
......@@ -81,7 +82,9 @@ data PetriNet = PetriNet {
initialMarking :: Marking,
ghostTransitions :: [Transition],
fixedTraps :: [Trap],
fixedSiphons :: [Siphon]
fixedSiphons :: [Siphon],
yesStates :: [Place],
noStates :: [Place]
}
initial :: PetriNet -> Place -> Integer
......@@ -108,7 +111,9 @@ instance Show PetriNet where
"\nInitial: " ++ show (initialMarking net) ++
"\nGhost transitions: " ++ show (ghostTransitions net) ++
"\nFixed traps: " ++ show (fixedTraps net) ++
"\nFixed siphons: " ++ show (fixedSiphons net)
"\nFixed siphons: " ++ show (fixedSiphons net) ++
"\nYes states: " ++ show (yesStates net) ++
"\nNo states: " ++ show (noStates net)
where showContext (s,(l,r)) =
show l ++ " -> " ++ show s ++ " -> " ++ show r
......@@ -149,7 +154,9 @@ renamePetriNetPlacesAndTransitions f net =
ghostTransitions =
listSet $ map (renameTransition f) $ ghostTransitions net,
fixedTraps = map (map $ renamePlace f) $ fixedTraps net,
fixedSiphons = map (map $ renamePlace f) $ fixedSiphons net
fixedSiphons = map (map $ renamePlace f) $ fixedSiphons net,
yesStates = map (renamePlace f) $ yesStates net,
noStates = map (renamePlace f) $ noStates net
}
where mapAdjacency f g m = M.mapKeys f (M.map (mapContext g) m)
mapContext f (pre, post) =
......@@ -157,8 +164,8 @@ renamePetriNetPlacesAndTransitions f net =
makePetriNet :: String -> [Place] -> [Transition] ->
[Either (Transition, Place, Integer) (Place, Transition, Integer)] ->
[(Place, Integer)] -> [Transition] -> [Trap] -> [Siphon] -> PetriNet
makePetriNet name places transitions arcs initial gs fixedTraps fixedSiphons =
[(Place, Integer)] -> [Transition] -> [Trap] -> [Siphon] -> [Place] -> [Place] -> PetriNet
makePetriNet name places transitions arcs initial gs fixedTraps fixedSiphons yesStates noStates =
PetriNet {
name = name,
places = listSet places,
......@@ -168,7 +175,9 @@ makePetriNet name places transitions arcs initial gs fixedTraps fixedSiphons =
initialMarking = buildVector initial,
ghostTransitions = listSet gs,
fixedTraps = map listSet fixedTraps,
fixedSiphons = map listSet fixedSiphons
fixedSiphons = map listSet fixedSiphons,
yesStates = listSet yesStates,
noStates = listSet noStates
}
where
(adP, adT) = foldl buildMaps (M.empty, M.empty) arcs
......@@ -190,8 +199,8 @@ makePetriNet name places transitions arcs initial gs fixedTraps fixedSiphons =
makePetriNetFromStrings :: String -> [String] -> [String] ->
[(String, String, Integer)] ->
[(String, Integer)] -> [String] -> [[String]] -> [[String]] -> PetriNet
makePetriNetFromStrings name places transitions arcs initial gs fixedTraps fixedSiphons =
[(String, Integer)] -> [String] -> [[String]] -> [[String]] -> [String] -> [String] -> PetriNet
makePetriNetFromStrings name places transitions arcs initial gs fixedTraps fixedSiphons yesStates noStates =
makePetriNet
name
(map Place (S.toAscList placeSet))
......@@ -201,6 +210,8 @@ makePetriNetFromStrings name places transitions arcs initial gs fixedTraps fixed
(map Transition gs)
(map (map Place) fixedTraps)
(map (map Place) fixedSiphons)
(map Place yesStates)
(map Place noStates)
where
placeSet = S.fromList places
transitionSet = S.fromList transitions
......@@ -225,17 +236,17 @@ makePetriNetFromStrings name places transitions arcs initial gs fixedTraps fixed
makePetriNetWithTrans :: String -> [Place] ->
[(Transition, ([(Place, Integer)], [(Place, Integer)]))] ->
[(Place, Integer)] -> [Transition] -> [Trap] -> [Siphon] ->PetriNet
makePetriNetWithTrans name places ts fixedTraps fixedSiphons =
makePetriNet name places (map fst ts) arcs fixedTraps fixedSiphons
[(Place, Integer)] -> [Transition] -> [Trap] -> [Siphon] -> [Place] -> [Place] -> PetriNet
makePetriNetWithTrans name places ts fixedTraps fixedSiphons yesStates noStates =
makePetriNet name places (map fst ts) arcs fixedTraps fixedSiphons yesStates noStates
where
arcs = [ Right (p,t,w) | (t,(is,_)) <- ts, (p,w) <- is ] ++
[ Left (t,p,w) | (t,(_,os)) <- ts, (p,w) <- os ]
makePetriNetWithTransFromStrings :: String -> [String] ->
[(String, ([(String, Integer)], [(String, Integer)]))] ->
[(String, Integer)] -> [String] -> [[String]] -> [[String]] -> PetriNet
makePetriNetWithTransFromStrings name places arcs initial gs fixedTraps fixedSiphons =
[(String, Integer)] -> [String] -> [[String]] -> [[String]] -> [String] -> [String] -> PetriNet
makePetriNetWithTransFromStrings name places arcs initial gs fixedTraps fixedSiphons yesStates noStates =
makePetriNetWithTrans
name
(map Place places)
......@@ -244,6 +255,8 @@ makePetriNetWithTransFromStrings name places arcs initial gs fixedTraps fixedSip
(map Transition gs)
(map (map Place) fixedTraps)
(map (map Place) fixedSiphons)
(map Place yesStates)
(map Place noStates)
where
toTArc (t, (is, os)) =
(Transition t, (map (first Place) is, map (first Place) os))
......@@ -93,9 +93,11 @@ data PropertyType = SafetyType
| ConstraintType
data ConstraintProperty = UniqueTerminalMarkingConstraint
| NonConsensusStateConstraint
instance Show ConstraintProperty where
show UniqueTerminalMarkingConstraint = "unique terminal marking"
show NonConsensusStateConstraint = "non-consensus state"
data PropertyContent = Safety (Formula Place)
| Liveness (Formula Transition)
......
{-# LANGUAGE FlexibleContexts #-}
module Solver.NonConsensusState
(checkNonConsensusStateSat,
NonConsensusStateCounterExample,
checkUnmarkedTrapSat,
checkUnmarkedSiphonSat)
where
import Data.SBV
import qualified Data.Map as M
import Data.List ((\\))
import Util
import PetriNet
import Property
import Solver
type NonConsensusStateCounterExample = (RMarking, RMarking, RFiringVector)
stateEquationConstraints :: PetriNet -> SRMap Place -> SRMap Place -> SRMap Transition -> SBool
stateEquationConstraints net m0 m x =
bAnd $ map checkStateEquation $ places net
where checkStateEquation p =
let incoming = map addTransition $ lpre net p
outgoing = map addTransition $ lpost net p
in val m0 p + sum incoming - sum outgoing .== val m p
addTransition (t,w) = literal (fromInteger w) * val x t
nonNegativityConstraints :: (Ord a, Show a) => SRMap a -> SBool
nonNegativityConstraints m =
bAnd $ map checkVal $ vals m
where checkVal x = x .>= 0
terminalMarkingConstraints :: PetriNet -> SRMap Place -> SBool
terminalMarkingConstraints net m =
bAnd $ map checkTransition $ transitions net
where checkTransition t = bOr $ map checkPlace $ lpre net t
checkPlace (p,w) = val m p .== 0
initialMarkingConstraints :: PetriNet -> SRMap Place -> SBool
initialMarkingConstraints net m0 =
sum (mval m0 (places net \\ initials net)) .== 0
nonConsensusStateConstraints :: PetriNet -> SRMap Place -> SBool
nonConsensusStateConstraints net m =
sum (mval m (yesStates net)) .> 0 &&&
sum (mval m (noStates net)) .> 0
checkTrap :: PetriNet -> SRMap Place -> SRMap Place -> SRMap Transition -> Trap -> SBool
checkTrap net m0 m x trap =
(markedByMarking m0 ==> markedByMarking m) &&&
(markedBySequence x ==> markedByMarking m)
where markedByMarking m = sum (mval m trap) .> 0
markedBySequence x = sum (mval x (mpre net trap)) .> 0
checkTrapConstraints :: PetriNet -> SRMap Place -> SRMap Place -> SRMap Transition -> [Trap] -> SBool
checkTrapConstraints net m0 m x traps =
bAnd $ map (checkTrap net m0 m x) traps
checkSiphon :: PetriNet -> SRMap Place -> SRMap Place -> SRMap Transition -> Siphon -> SBool
checkSiphon net m0 m x siphon =
unmarkedByMarking m0 ==> (unmarkedByMarking m &&& notPresetOfSequence x)
where unmarkedByMarking m = sum (mval m siphon) .== 0
notPresetOfSequence x = sum (mval x (mpost net siphon)) .== 0
checkSiphonConstraints :: PetriNet -> SRMap Place -> SRMap Place -> SRMap Transition -> [Siphon] -> SBool
checkSiphonConstraints net m0 m x siphons =
bAnd $ map (checkSiphon net m0 m x) siphons
checkNonConsensusState :: PetriNet -> SRMap Place -> SRMap Place -> SRMap Transition -> [Trap] -> [Siphon] -> SBool
checkNonConsensusState net m0 m x traps siphons =
stateEquationConstraints net m0 m x &&&
nonNegativityConstraints m0 &&&
nonNegativityConstraints m &&&
nonNegativityConstraints x &&&
initialMarkingConstraints net m0 &&&
terminalMarkingConstraints net m &&&
nonConsensusStateConstraints net m &&&
checkTrapConstraints net m0 m x traps &&&
checkSiphonConstraints net m0 m x siphons
checkNonConsensusStateSat :: PetriNet -> [Trap] -> [Siphon] -> ConstraintProblem AlgReal NonConsensusStateCounterExample
checkNonConsensusStateSat net traps siphons =
let m0 = makeVarMap $ places net
m = makeVarMapWith prime $ places net
x = makeVarMap $ transitions net
in ("non-consensus state", "(m0, m, x)",
getNames m0 ++ getNames m ++ getNames x,
\fm -> checkNonConsensusState net (fmap fm m0) (fmap fm m) (fmap fm x) traps siphons,
\fm -> markingsFromAssignment (fmap fm m0) (fmap fm m) (fmap fm x))
markingsFromAssignment :: RMap Place -> RMap Place -> RMap Transition -> NonConsensusStateCounterExample
markingsFromAssignment m0 m x =
(makeVector m0, makeVector m, makeVector x)
-- trap and siphon refinement constraints
siphonConstraints :: PetriNet -> SIMap Place -> SBool
siphonConstraints net b =
bAnd $ map siphonConstraint $ transitions net
where siphonConstraint t =
sum (mval b $ post net t) .> 0 ==> sum (mval b $ pre net t) .> 0
trapConstraints :: PetriNet -> SIMap Place -> SBool
trapConstraints net b =
bAnd $ map trapConstraint $ transitions net
where trapConstraint t =
sum (mval b $ pre net t) .> 0 ==> sum (mval b $ post net t) .> 0
placesMarkedByMarking :: PetriNet -> RMarking -> SIMap Place -> SBool
placesMarkedByMarking net m b = sum (mval b $ elems m) .> 0
placesUnmarkedByMarking :: PetriNet -> RMarking -> SIMap Place -> SBool
placesUnmarkedByMarking net m b = sum (mval b $ elems m) .== 0
placesPostsetOfSequence :: PetriNet -> RFiringVector -> SIMap Place -> SBool
placesPostsetOfSequence net x b = sum (mval b $ mpost net $ elems x) .> 0
placesPresetOfSequence :: PetriNet -> RFiringVector -> SIMap Place -> SBool
placesPresetOfSequence net x b = sum (mval b $ mpre net $ elems x) .> 0
nonemptySet :: (Ord a, Show a) => SIMap a -> SBool
nonemptySet b = sum (vals b) .> 0
checkBinary :: SIMap Place -> SBool
checkBinary = bAnd . map (\x -> x .== 0 ||| x .== 1) . vals
checkSizeLimit :: SIMap Place -> Maybe (Int, Integer) -> SBool
checkSizeLimit _ Nothing = true
checkSizeLimit b (Just (1, curSize)) = (.< literal curSize) $ sumVal b
checkSizeLimit b (Just (2, curSize)) = (.> literal curSize) $ sumVal b
checkSizeLimit _ (Just (_, _)) = error "minimization method not supported"
minimizeMethod :: Int -> Integer -> String
minimizeMethod 1 curSize = "size smaller than " ++ show curSize
minimizeMethod 2 curSize = "size larger than " ++ show curSize
minimizeMethod _ _ = error "minimization method not supported"
checkUnmarkedTrap :: PetriNet -> RMarking -> RMarking -> RFiringVector -> SIMap Place -> Maybe (Int, Integer) -> SBool
checkUnmarkedTrap net m0 m x b sizeLimit =
trapConstraints net b &&&
nonemptySet b &&&
checkSizeLimit b sizeLimit &&&
checkBinary b &&&
(
(placesMarkedByMarking net m0 b &&& placesUnmarkedByMarking net m b) |||
(placesPostsetOfSequence net x b &&& placesUnmarkedByMarking net m b)
)
checkUnmarkedTrapSat :: PetriNet -> RMarking -> RMarking -> RFiringVector -> MinConstraintProblem Integer Trap Integer
checkUnmarkedTrapSat net m0 m x =
let b = makeVarMap $ places net
in (minimizeMethod, \sizeLimit ->
("trap marked in m and unmarked in m, or marked by x and unmarked in m", "trap",
getNames b,
\fm -> checkUnmarkedTrap net m0 m x (fmap fm b) sizeLimit,
\fm -> placesFromAssignment (fmap fm b)))
checkUnmarkedSiphon :: PetriNet -> RMarking -> RMarking -> RFiringVector -> SIMap Place -> Maybe (Int, Integer) -> SBool
checkUnmarkedSiphon net m0 m x b sizeLimit =
siphonConstraints net b &&&
nonemptySet b &&&
checkSizeLimit b sizeLimit &&&
checkBinary b &&&
(placesUnmarkedByMarking net m0 b &&& (placesMarkedByMarking net m b ||| placesPresetOfSequence net x b))
checkUnmarkedSiphonSat :: PetriNet -> RMarking -> RMarking -> RFiringVector -> MinConstraintProblem Integer Siphon Integer
checkUnmarkedSiphonSat net m0 m x =
let b = makeVarMap $ places net
in (minimizeMethod, \sizeLimit ->
("siphon unmarked in m0 and marked in m or used as input in x", "siphon",
getNames b,
\fm -> checkUnmarkedSiphon net m0 m x (fmap fm b) sizeLimit,
\fm -> placesFromAssignment (fmap fm b)))
placesFromAssignment :: IMap Place -> ([Place], Integer)
placesFromAssignment b = (M.keys (M.filter (> 0) b), sum (M.elems b))
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