Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in
Toggle navigation
Menu
Open sidebar
i7
peregrine
Commits
b6c7b4b2
Commit
b6c7b4b2
authored
Dec 11, 2014
by
Philipp Meyer
Browse files
Added first support to generate invariants for liveness properties
parent
9f06fedb
Changes
3
Hide whitespace changes
Inline
Side-by-side
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
$
"
\n
Checking "
++
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"
checkS
afety
P
ropert
yByCommFree
verbosity
net
f
checkSafetyProperty
verbosity
net
refine
invariant
f
=
-- TODO: add invariant generation
if
invariant
then
error
"Invariant generation for s
afety
p
ropert
ies 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
:
stran
s
)
checkLivenessProperty
ByRef
verbosity
net
refine
f
(
sCompsCut
:
comp
s
)
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
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment