Skip to content

GitLab

peregrine
peregrine

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

Commit b6c7b4b2 authored by Philipp Meyer's avatar Philipp Meyer
Browse files
Options

Added first support to generate invariants for liveness properties

parent 9f06fedb
Hide whitespace changes
Inline Side-by-side
Showing with 133 additions and 42 deletions
src/Main.hs
View file @ b6c7b4b2
......@@ -29,6 +29,7 @@ import Solver
import Solver.StateEquation
import Solver.TrapConstraints
import Solver.TransitionInvariant
import Solver.LivenessInvariant
import Solver.SComponent
import Solver.CommFreeReachability
......@@ -62,6 +63,7 @@ data Options = Options { inputFormat :: InputFormat
, optProperties :: [ImplicitProperty]
, optTransformations :: [NetTransformation]
, optRefine :: Bool
, optInvariant :: Bool
, optOutput :: Maybe String
, outputFormat :: OutputFormat
, optUseProperties :: Bool
......@@ -76,6 +78,7 @@ startOptions = Options { inputFormat = PNET
, optProperties = []
, optTransformations = []
, optRefine = True
, optInvariant = False
, optOutput = Nothing
, outputFormat = OutLOLA
, optUseProperties = True
......@@ -190,6 +193,10 @@ options =
(NoArg (\opt -> Right opt { optRefine = False }))
"Don't use refinement"
, Option "i" ["invariant"]
(NoArg (\opt -> Right opt { optInvariant = True }))
"Try to generate an invariant"
, Option "o" ["output"]
(ReqArg (\arg opt -> Right opt {
optOutput = Just arg
......@@ -298,11 +305,11 @@ structuralAnalysis net = do
putStrLn $ "Final places : " ++ show (length finalP)
putStrLn $ "Final transitions : " ++ show (length finalT)
checkFile :: Parser (PetriNet,[Property]) -> Int -> Bool ->
checkFile :: Parser (PetriNet,[Property]) -> Int -> Bool -> Bool ->
[ImplicitProperty] -> [NetTransformation] ->
Bool -> Maybe String -> OutputFormat -> Bool -> String ->
IO PropResult
checkFile parser verbosity refine implicitProperties transformations
checkFile parser verbosity refine invariant implicitProperties transformations
useProperties output format printStruct file = do
verbosePut verbosity 0 $ "Reading \"" ++ file ++ "\""
(net,props) <- parseFile parser file
......@@ -320,7 +327,7 @@ checkFile parser verbosity refine implicitProperties transformations
writeFiles verbosity outputfile format net' props'''
Nothing -> return ()
-- TODO: short-circuit?
rs <- mapM (checkProperty verbosity net' refine) props'''
rs <- mapM (checkProperty verbosity net' refine invariant) props'''
verbosePut verbosity 0 ""
return $ resultsAnd rs
......@@ -410,13 +417,13 @@ makeImplicitProperty _ StructFinalPlace =
makeImplicitProperty _ StructCommunicationFree =
Property "communication free" $ Structural CommunicationFree
checkProperty :: Int -> PetriNet -> Bool -> Property -> IO PropResult
checkProperty verbosity net refine p = do
checkProperty :: Int -> PetriNet -> Bool -> Bool -> Property -> IO PropResult
checkProperty verbosity net refine invariant p = do
verbosePut verbosity 1 $ "\nChecking " ++ showPropertyName p
verbosePut verbosity 3 $ show p
r <- case pcont p of
(Safety pf) -> checkSafetyProperty verbosity net refine pf
(Liveness pf) -> checkLivenessProperty verbosity net refine pf []
(Safety pf) -> checkSafetyProperty verbosity net refine invariant pf
(Liveness pf) -> checkLivenessProperty verbosity net refine invariant pf
(Structural ps) -> checkStructuralProperty verbosity net ps
verbosePut verbosity 0 $ showPropertyName p ++ " " ++
case r of
......@@ -425,14 +432,19 @@ checkProperty verbosity net refine p = do
Unknown-> "may not be satisfied."
return r
checkSafetyProperty :: Int -> PetriNet -> Bool ->
checkSafetyProperty :: Int -> PetriNet -> Bool -> Bool ->
Formula -> IO PropResult
checkSafetyProperty verbosity net refine f =
if checkCommunicationFree net then do
verbosePut verbosity 1 "Net found to be communication-free"
checkSafetyPropertyByCommFree verbosity net f
checkSafetyProperty verbosity net refine invariant f =
-- TODO: add invariant generation
if invariant then
error "Invariant generation for safety properties not yet supported"
else
checkSafetyPropertyBySafetyRef verbosity net refine f []
-- TODO: add flag for this kind of structural check
if checkCommunicationFree net then do
verbosePut verbosity 1 "Net found to be communication-free"
checkSafetyPropertyByCommFree verbosity net f
else
checkSafetyPropertyBySafetyRef verbosity net refine f []
checkSafetyPropertyByCommFree :: Int -> PetriNet -> Formula -> IO PropResult
checkSafetyPropertyByCommFree verbosity net f = do
......@@ -473,12 +485,35 @@ checkSafetyPropertyBySafetyRef verbosity net refine f traps = do
else
return Unknown
checkLivenessProperty :: Int -> PetriNet -> Bool ->
checkLivenessProperty :: Int -> PetriNet -> Bool -> Bool ->
Formula -> IO PropResult
checkLivenessProperty verbosity net refine invariant f = do
(r, comps) <- checkLivenessPropertyByRef verbosity net refine f []
if (r == Satisfied && invariant) then
generateLivenessInvariant verbosity net f comps
else
return r
generateLivenessInvariant :: Int -> PetriNet ->
Formula -> [SCompCut] -> IO PropResult
checkLivenessProperty verbosity net refine f strans = do
r <- checkSat $ checkTransitionInvariantSat net f strans
generateLivenessInvariant verbosity net f comps = do
verbosePut verbosity 1 "Generating invariant"
if f /= FTrue then
error "formula not yet supported"
else do
r <- checkSat $ checkLivenessInvariantSat net comps
case r of
Nothing -> return Unsatisfied
Just as -> do
putStrLn $ show as
return Satisfied
checkLivenessPropertyByRef :: Int -> PetriNet -> Bool ->
Formula -> [SCompCut] -> IO (PropResult, [SCompCut])
checkLivenessPropertyByRef verbosity net refine f comps = do
r <- checkSat $ checkTransitionInvariantSat net f comps
case r of
Nothing -> return Satisfied
Nothing -> return (Satisfied, comps)
Just ax -> do
let fired = firedTransitionsFromAssignment ax
verbosePut verbosity 1 "Assignment found"
......@@ -489,17 +524,17 @@ checkLivenessProperty verbosity net refine f strans = do
case rt of
Nothing -> do
verbosePut verbosity 1 "No S-component found"
return Unknown
return (Unknown, comps)
Just as -> do
let sCompsCut = getSComponentCompsCut net ax as
verbosePut verbosity 1 "S-component found"
verbosePut verbosity 2 $ "Comps/Cut: " ++ show sCompsCut
verbosePut verbosity 3 $ "S-Component assignment: " ++
show as
checkLivenessProperty verbosity net refine f
(sCompsCut:strans)
checkLivenessPropertyByRef verbosity net refine f
(sCompsCut:comps)
else
return Unknown
return (Unknown, comps)
checkStructuralProperty :: Int -> PetriNet -> Structure -> IO PropResult
checkStructuralProperty _ net struct =
......@@ -521,6 +556,7 @@ main = do
when (null files) (exitErrorWith "No input file given")
let verbosity = optVerbosity opts
refinement = optRefine opts
invariant = optInvariant opts
let parser = case inputFormat opts of
PNET -> PNET.parseContent
LOLA -> LOLA.parseContent
......@@ -528,9 +564,10 @@ main = do
MIST -> MIST.parseContent
let properties = reverse $ optProperties opts
let transformations = reverse $ optTransformations opts
rs <- mapM (checkFile parser verbosity refinement properties
transformations (optUseProperties opts) (optOutput opts)
(outputFormat opts) (optPrintStructure opts)) files
rs <- mapM (checkFile parser verbosity refinement invariant
properties transformations (optUseProperties opts)
(optOutput opts) (outputFormat opts) (optPrintStructure opts))
files
-- TODO: short-circuit with Control.Monad.Loops?
case resultsAnd rs of
Satisfied ->
......
src/Property.hs
View file @ b6c7b4b2
......@@ -26,6 +26,7 @@ data Term = Var String
| Term :+: Term
| Term :-: Term
| Term :*: Term
deriving (Eq)
instance Show Term where
show (Var x) = x
......@@ -43,7 +44,7 @@ renameTerm f (t :+: u) = renameTerm f t :+: renameTerm f u
renameTerm f (t :-: u) = renameTerm f t :-: renameTerm f u
renameTerm f (t :*: u) = renameTerm f t :*: renameTerm f u
data Op = Gt | Ge | Eq | Ne | Le | Lt
data Op = Gt | Ge | Eq | Ne | Le | Lt deriving (Eq)
instance Show Op where
show Gt = ">"
......@@ -54,7 +55,7 @@ instance Show Op where
show Lt = "<"
-- TODO: merge LinIneq constructor into Formula
data LinearInequation = LinIneq Term Op Term
data LinearInequation = LinIneq Term Op Term deriving (Eq)
instance Show LinearInequation where
show (LinIneq lhs op rhs) = show lhs ++ " " ++ show op ++ " " ++ show rhs
......@@ -68,6 +69,7 @@ data Formula = FTrue | FFalse
| Neg Formula
| Formula :&: Formula
| Formula :|: Formula
deriving (Eq)
infixr 3 :&:
infixr 2 :|:
......@@ -125,7 +127,7 @@ showPropertyName :: Property -> String
showPropertyName p = showPropertyType (pcont p) ++ " property" ++
(if null (pname p) then "" else " " ++ show (pname p))
data PropResult = Satisfied | Unsatisfied | Unknown deriving (Show,Read)
data PropResult = Satisfied | Unsatisfied | Unknown deriving (Show,Read,Eq)
resultAnd :: PropResult -> PropResult -> PropResult
resultAnd Satisfied x = x
......
src/Solver/LivenessInvariant.hs
View file @ b6c7b4b2
......@@ -6,22 +6,74 @@ module Solver.LivenessInvariant (
, LivenessInvariant
) where
type PlaceVector [(String,Integer)]
import Data.SBV
import Solver
import Solver.SComponent
import PetriNet
type PlaceVector = [(String, Integer)]
type LivenessInvariant = [PlaceVector]
checkLivenessInvariant :: PetriNet -> [String] -> ModelI -> ModelSI -> SBool
checkLivenessInvariant net fired ax m =
checkPrePostPlaces net m &&&
checkPrePostTransitions net m &&&
checkSubsetTransitions fired m &&&
checkNotEmpty fired m &&&
checkClosed net ax m &&&
checkTokens net m &&&
checkBinary m
checkLivenessInvariantSat :: PetriNet -> [String] -> ModelI ->
type Cut = ([String], Bool)
type NamedCut = (String, [(String, Cut)])
nameCuts :: [[Cut]] -> [NamedCut]
nameCuts cuts =
map (\(n, c) -> (n, numPref "@comp" `zip` c)) $
numPref "@cut" `zip` cuts
where
numPref s = map (\i -> s ++ show i) [(1::Integer)..]
varNames :: PetriNet -> [NamedCut] -> [String]
varNames net = concatMap cutNames
where
cutNames (n, c) =
[n ++ "@comp0"] ++
map (\p -> n ++ "@p" ++ p) (places net) ++
map (\(n', _) -> n ++ n') c
foldComps :: [SCompCut] -> [[Cut]]
foldComps = foldl combine [[]]
where
combine cuts (t1, t2, u) =
concatMap
(\c -> [(t1, True) : c, (t2, True) : c, (u, False) : c]) cuts
checkCut :: PetriNet -> ModelSI -> NamedCut -> SBool
checkCut net m (n, comps) =
bAnd (map checkTransition (transitions net)) &&&
mVal m (n ++ "@comp0") + sum (map addComp2 comps) .> 0 &&&
bAnd (map (\p -> checkNonNegativity (n ++ "@p" ++ p)) (places net)) &&&
checkNonNegativity (n ++ "@comp0") &&&
bAnd (map (\(n', _) -> checkNonNegativity (n ++ n')) comps)
where checkTransition t =
let incoming = map addPlace $ lpre net t
outgoing = map addPlace $ lpost net t
zeroComp = mVal m (n ++ "@comp0")
addComp1 (n', (ts, xv)) =
if t `elem` ts then
(if xv then 1 else (-1)) * mVal m (n ++ n')
else
0
cutComps = map addComp1 comps
in sum outgoing - sum incoming + zeroComp .<= sum cutComps
addPlace (p,w) = literal w * mVal m (n ++ "@p" ++ p)
addComp2 (n', (_, w)) = if w then 0 else mVal m (n ++ n')
checkNonNegativity x = mVal m x .>= 0
checkLivenessInvariant :: PetriNet -> [NamedCut] ->
ModelSI -> SBool
checkLivenessInvariant net cuts m =
bAnd (map (checkCut net m) cuts)
checkLivenessInvariantSat :: PetriNet -> [SCompCut] ->
([String], ModelSI -> SBool)
checkLivenessInvariantSat net fired ax =
checkLivenessInvariantSat net comps =
let cuts = foldComps comps
namedCuts = nameCuts cuts
names = varNames net namedCuts
in (names, checkLivenessInvariant net namedCuts)
getLivenessInvariant :: PetriNet -> ModelI -> ModelI -> LivenessInvariant
getLivenessInvariant net ax as =
getLivenessInvariant :: PetriNet -> [SCompCut] -> ModelI -> LivenessInvariant
getLivenessInvariant net ax as = undefined
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