Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in
Toggle navigation
Menu
9.2.2023: Due to updates GitLab will be unavailable for some minutes between 9:00 and 11:00.
Open sidebar
i7
peregrine
Commits
3c4fd698
Commit
3c4fd698
authored
Dec 16, 2014
by
Philipp Meyer
Browse files
Rewrote trap constraints
parent
6456c0fb
Changes
6
Hide whitespace changes
Inline
Side-by-side
src/Main.hs
View file @
3c4fd698
...
...
@@ -12,6 +12,7 @@ import Control.Arrow (first)
import
Data.List
(
partition
)
import
qualified
Data.ByteString.Lazy
as
L
import
Util
import
Parser
import
qualified
Parser.PNET
as
PNET
import
qualified
Parser.LOLA
as
LOLA
...
...
@@ -27,7 +28,7 @@ import Property
import
Structure
import
Solver
import
Solver.StateEquation
--
import Solver.TrapConstraints
import
Solver.TrapConstraints
--import Solver.TransitionInvariant
--import Solver.LivenessInvariant
--import Solver.SComponent
...
...
@@ -243,10 +244,6 @@ options =
"Show help"
]
verbosePut
::
Int
->
Int
->
String
->
IO
()
verbosePut
verbosity
level
str
=
when
(
verbosity
>=
level
)
(
putStrLn
str
)
parseArgs
::
IO
(
Either
String
(
Options
,
[
String
]))
parseArgs
=
do
args
<-
getArgs
...
...
@@ -461,26 +458,19 @@ checkSafetyPropertyByCommFree verbosity net f = do
checkSafetyPropertyBySafetyRef
::
Int
->
PetriNet
->
Bool
->
Formula
Place
->
[
Trap
]
->
IO
PropResult
checkSafetyPropertyBySafetyRef
verbosity
net
refine
f
traps
=
do
r
<-
checkSat
$
checkStateEquationSat
net
f
traps
r
<-
checkSat
verbosity
$
checkStateEquationSat
net
f
traps
case
r
of
Nothing
->
return
Satisfied
Just
assigned
->
do
verbosePut
verbosity
1
"Assignment found"
verbosePut
verbosity
2
$
"Places marked: "
++
show
assigned
Just
marking
->
do
if
refine
then
do
rt
<-
return
Nothing
-- checkSat
$ checkTrapSat net
assigned
rt
<-
checkSat
verbosity
$
checkTrapSat
net
marking
case
rt
of
Nothing
->
do
verbosePut
verbosity
1
"No trap found."
return
Unknown
Just
trap
->
do
-- let trap = trapFromAssignment at
verbosePut
verbosity
1
"Trap found"
--verbosePut verbosity 2 $ "Places in trap: " ++
-- show trap
return
Unknown
--checkSafetyPropertyBySafetyRef verbosity net
-- refine f (trap:traps)
checkSafetyPropertyBySafetyRef
verbosity
net
refine
f
(
trap
:
traps
)
else
return
Unknown
{-
...
...
src/PetriNet.hs
View file @
3c4fd698
...
...
@@ -3,13 +3,15 @@
module
PetriNet
(
PetriNet
,
Place
(
..
),
Transition
(
..
),
Marking
,
tokens
,
buildMarking
,
marked
,
lmarked
,
makeMarking
,
renamePlace
,
renameTransition
,
renamePetriNetPlacesAndTransitions
,
name
,
showNetName
,
places
,
transitions
,
initial
,
initialMarking
,
pre
,
lpre
,
post
,
lpost
,
initials
,
context
,
ghostTransitions
,
makePetriNet
,
makePetriNetWithTrans
,
makePetriNetWith
)
makePetriNet
,
makePetriNetWithTrans
,
makePetriNetWith
,
Trap
)
where
import
qualified
Data.Map
as
M
import
Data.List
(
intercalate
)
import
Control.Arrow
(
first
)
newtype
Place
=
Place
String
deriving
(
Ord
,
Eq
)
...
...
@@ -43,15 +45,27 @@ instance Nodes Transition Place where
newtype
Marking
=
Marking
{
getMarking
::
M
.
Map
Place
Integer
}
instance
Show
Marking
where
show
(
Marking
m
)
=
show
$
map
showPlaceMarking
$
M
.
toList
m
show
(
Marking
m
)
=
"["
++
intercalate
","
(
map
showPlaceMarking
(
M
.
toList
m
))
++
"]"
where
showPlaceMarking
(
n
,
i
)
=
show
n
++
(
if
i
/=
1
then
"("
++
show
i
++
")"
else
""
)
tokens
::
Marking
->
Place
->
Integer
tokens
m
p
=
M
.
findWithDefault
0
p
(
getMarking
m
)
buildMarking
::
[(
String
,
Integer
)]
->
Marking
buildMarking
xs
=
Marking
$
M
.
fromList
$
map
(
first
Place
)
$
filter
((
/=
0
)
.
snd
)
xs
buildMarking
::
[(
Place
,
Integer
)]
->
Marking
buildMarking
=
makeMarking
.
M
.
fromList
makeMarking
::
M
.
Map
Place
Integer
->
Marking
makeMarking
=
Marking
.
M
.
filter
(
/=
0
)
marked
::
Marking
->
[
Place
]
marked
=
M
.
keys
.
getMarking
lmarked
::
Marking
->
[(
Place
,
Integer
)]
lmarked
=
M
.
toList
.
getMarking
type
Trap
=
[
Place
]
data
PetriNet
=
PetriNet
{
name
::
String
,
...
...
@@ -121,7 +135,7 @@ makePetriNet name places transitions arcs initial gs =
transitions
=
map
Transition
transitions
,
adjacencyP
=
adP
,
adjacencyT
=
adT
,
initialMarking
=
buildMarking
initial
,
initialMarking
=
buildMarking
(
map
(
first
Place
)
initial
)
,
ghostTransitions
=
map
Transition
gs
}
where
...
...
@@ -159,7 +173,7 @@ makePetriNetWith name places ts initial gs =
transitions
=
transitions
,
adjacencyP
=
placeMap
,
adjacencyT
=
M
.
fromList
ts
,
initialMarking
=
Marking
(
M
.
fromList
initial
)
,
initialMarking
=
build
Marking
initial
,
ghostTransitions
=
gs
}
...
...
src/Solver.hs
View file @
3c4fd698
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
module
Solver
(
prime
,
checkSat
,
ModelReader
,
val
,
VarMap
,
getNames
,
makeVarMap
,
makeVarMapWith
,
varMapNames
,
(
prime
,
checkSat
,
ModelReader
,
val
,
vals
,
VarMap
,
getNames
,
makeVarMap
,
makeVarMapWith
,
IntConstraint
,
BoolConstraint
,
IntResult
,
BoolResult
,
Model
(
..
),
mVal
,
mValues
,
mElemsWith
,
mElemSum
,
SModel
(
..
),
CModel
(
..
))
Model
,
ConstraintProblem
)
--m
Val
,
mValues
,
mElemsWith
,
mElemSum
,
SModel
(
..
),
CModel
(
..
))
where
import
Data.SBV
import
qualified
Data.Map
as
M
import
Control.Monad.Reader
import
Control.Applicative
newtype
Model
a
=
Model
{
getMap
::
M
.
Map
String
a
}
newtype
VarMap
a
=
VarMap
{
getVarMap
::
M
.
Map
a
String
}
import
Util
getNames
::
VarMap
a
->
[
String
]
getNames
=
M
.
elems
.
getVarMap
type
Model
a
=
M
.
Map
String
a
type
VarMap
a
=
M
.
Map
a
String
instance
Show
a
=
>
Show
(
Model
a
)
where
show
=
show
.
M
.
toList
.
getMap
getNames
::
VarMap
a
-
>
[
String
]
getNames
=
M
.
elems
type
ModelReader
a
b
=
Reader
(
Model
a
)
b
type
IntConstraint
=
ModelReader
SInteger
SBool
...
...
@@ -27,31 +26,36 @@ type BoolConstraint = ModelReader SBool SBool
type
IntResult
a
=
ModelReader
Integer
a
type
BoolResult
a
=
ModelReader
Bool
a
type
ConstraintProblem
a
b
=
(
String
,
String
,
[
String
],
ModelReader
(
SBV
a
)
SBool
,
ModelReader
a
b
)
val
::
(
Ord
a
)
=>
VarMap
a
->
a
->
ModelReader
b
b
val
ma
x
=
do
mb
<-
ask
return
$
getMap
mb
M
.!
(
getVarMap
ma
M
.!
x
)
return
$
mb
M
.!
(
ma
M
.!
x
)
vals
::
(
Ord
a
)
=>
VarMap
a
->
ModelReader
b
(
M
.
Map
a
b
)
vals
ma
=
do
mb
<-
ask
return
$
fmap
(
mb
M
.!
)
ma
makeVarMap
::
(
Show
a
,
Ord
a
)
=>
[
a
]
->
VarMap
a
makeVarMap
=
makeVarMapWith
id
makeVarMapWith
::
(
Show
a
,
Ord
a
)
=>
(
String
->
String
)
->
[
a
]
->
VarMap
a
makeVarMapWith
f
xs
=
VarMap
$
M
.
fromList
$
xs
`
zip
`
map
(
f
.
show
)
xs
varMapNames
::
VarMap
a
->
[
String
]
varMapNames
=
M
.
elems
.
getVarMap
makeVarMapWith
f
xs
=
M
.
fromList
$
xs
`
zip
`
map
(
f
.
show
)
xs
prime
::
String
->
String
prime
=
(
'
\'
'
:
)
{-
mVal :: Model a -> String -> a
mVal
m
x
=
M
.
findWithDefault
(
error
(
"key not found: "
++
x
))
x
(
getMap
m
)
mVal m x = M.findWithDefault (error ("key not found: " ++ x)) x
m
mValues :: Model a -> [a]
mValues
m
=
M
.
elems
$
getMap
m
mValues = M.elems
mElemsWith :: (a -> Bool) -> Model a -> [String]
mElemsWith
f
m
=
M
.
keys
$
M
.
filter
f
$
getMap
m
mElemsWith f m = M.keys $ M.filter f m
mElemSum :: (Num a) => Model a -> [String] -> a
mElemSum m xs = sum $ map (mVal m) xs
...
...
@@ -77,23 +81,32 @@ instance CModel Integer where
instance CModel Bool where
cElem = mVal
cNotElem m x = not $ mVal m x
-}
symConstraints
::
SymWord
a
=>
[
String
]
->
ModelReader
(
SBV
a
)
SBool
->
Symbolic
SBool
symConstraints
vars
constraint
=
do
syms
<-
mapM
exists
vars
return
$
runReader
constraint
$
Model
$
M
.
fromList
$
vars
`
zip
`
syms
return
$
runReader
constraint
$
M
.
fromList
$
vars
`
zip
`
syms
rebuildModel
::
SymWord
a
=>
[
String
]
->
Either
String
(
Bool
,
[
a
])
->
Maybe
(
Model
a
)
rebuildModel
_
(
Left
_
)
=
Nothing
rebuildModel
_
(
Right
(
True
,
_
))
=
error
"Prover returned unknown"
rebuildModel
vars
(
Right
(
False
,
m
))
=
Just
$
Model
$
M
.
fromList
$
vars
`
zip
`
m
checkSat
::
(
SatModel
a
,
SymWord
a
)
=>
([
String
],
ModelReader
(
SBV
a
)
SBool
,
ModelReader
a
b
)
->
IO
(
Maybe
b
)
checkSat
(
vars
,
constraint
,
interpretation
)
=
do
result
<-
satWith
z3
{
verbose
=
False
}
$
symConstraints
vars
constraint
return
$
runReader
interpretation
<$>
rebuildModel
vars
(
getModel
result
)
rebuildModel
vars
(
Right
(
False
,
m
))
=
Just
$
M
.
fromList
$
vars
`
zip
`
m
checkSat
::
(
SatModel
a
,
SymWord
a
,
Show
a
,
Show
b
)
=>
Int
->
ConstraintProblem
a
b
->
IO
(
Maybe
b
)
checkSat
verbosity
(
problemName
,
resultName
,
vars
,
constraint
,
interpretation
)
=
do
verbosePut
verbosity
1
$
"Checking SAT of "
++
problemName
result
<-
satWith
z3
{
verbose
=
verbosity
>=
4
}
$
symConstraints
vars
constraint
case
rebuildModel
vars
(
getModel
result
)
of
Nothing
->
do
verbosePut
verbosity
2
"- unsat"
return
Nothing
Just
rawModel
->
do
verbosePut
verbosity
2
"- sat"
let
model
=
runReader
interpretation
rawModel
verbosePut
verbosity
3
$
"- "
++
resultName
++
": "
++
show
model
return
$
Just
model
src/Solver/StateEquation.hs
View file @
3c4fd698
module
Solver.StateEquation
(
checkStateEquation
,
checkStateEquationSat
,
markedPlacesFromAssignment
,
Trap
)
(
checkStateEquationSat
)
where
import
Data.SBV
...
...
@@ -11,8 +10,6 @@ import Property
import
Solver
import
Solver.Formula
type
Trap
=
[
Place
]
placeConstraints
::
PetriNet
->
VarMap
Place
->
VarMap
Transition
->
IntConstraint
placeConstraints
net
m
x
=
liftM
bAnd
$
mapM
checkPlaceEquation
$
places
net
...
...
@@ -55,16 +52,16 @@ checkStateEquation net f m x traps = do
return
$
c1
&&&
c2
&&&
c3
&&&
c4
checkStateEquationSat
::
PetriNet
->
Formula
Place
->
[
Trap
]
->
([
String
],
IntConstraint
,
IntResult
Trap
)
ConstraintProblem
Integer
Marking
checkStateEquationSat
net
f
traps
=
let
m
=
makeVarMap
$
places
net
x
=
makeVarMap
$
transitions
net
in
(
getNames
m
++
getNames
x
,
in
(
"state equation"
,
"marking"
,
getNames
m
++
getNames
x
,
checkStateEquation
net
f
m
x
traps
,
mark
edPlaces
FromAssignment
net
m
)
mark
ing
FromAssignment
m
)
markedPlacesFromAssignment
::
PetriNet
->
VarMap
Place
->
IntResult
[
Place
]
markedPlacesFromAssignment
net
m
=
filterM
(
liftM
(
>
0
)
.
val
m
)
$
places
net
markingFromAssignment
::
VarMap
Place
->
IntResult
Marking
markingFromAssignment
m
=
liftM
makeMarking
(
vals
m
)
src/Solver/TrapConstraints.hs
View file @
3c4fd698
module
Solver.TrapConstraints
(
checkTrap
,
checkTrapSat
,
trapFromAssignment
)
(
checkTrapSat
)
where
import
Data.SBV
import
Control.Monad
import
qualified
Data.Map
as
M
import
PetriNet
import
Solver
trapConstraints
::
PetriNet
->
ModelSB
->
SBool
trapConstraints
net
m
=
bAnd
$
map
trapConstraint
$
transitions
net
where
trapConstraint
t
=
bOr
(
map
(
mElem
m
)
$
pre
net
t
)
==>
bOr
(
map
(
mElem
m
)
$
post
net
t
)
trapInitiallyMarked
::
PetriNet
->
ModelSB
->
SBool
trapInitiallyMarked
net
m
=
let
marked
=
map
fst
$
filter
((
>
0
)
.
snd
)
$
initials
net
in
bOr
$
map
(
mElem
m
)
marked
trapUnassigned
::
[
String
]
->
ModelSB
->
SBool
trapUnassigned
assigned
m
=
bAnd
$
map
(
mNotElem
m
)
assigned
checkTrap
::
PetriNet
->
[
String
]
->
ModelSB
->
SBool
checkTrap
net
assigned
m
=
trapConstraints
net
m
&&&
trapInitiallyMarked
net
m
&&&
trapUnassigned
assigned
m
checkTrapSat
::
PetriNet
->
[
String
]
->
([
String
],
ModelSB
->
SBool
)
checkTrapSat
net
assigned
=
(
places
net
,
checkTrap
net
assigned
)
trapFromAssignment
::
ModelB
->
[
String
]
trapFromAssignment
=
mElemsWith
id
trapConstraints
::
PetriNet
->
VarMap
Place
->
BoolConstraint
trapConstraints
net
b
=
liftM
bAnd
$
mapM
trapConstraint
$
transitions
net
where
trapConstraint
t
=
do
cPre
<-
mapM
(
val
b
)
$
pre
net
t
cPost
<-
mapM
(
val
b
)
$
post
net
t
return
$
bOr
cPre
==>
bOr
cPost
trapInitiallyMarked
::
PetriNet
->
VarMap
Place
->
BoolConstraint
trapInitiallyMarked
net
b
=
liftM
bOr
$
mapM
(
val
b
)
$
marked
$
initialMarking
net
trapUnassigned
::
Marking
->
VarMap
Place
->
BoolConstraint
trapUnassigned
m
b
=
liftM
bAnd
$
mapM
(
liftM
bnot
.
val
b
)
$
marked
m
checkTrap
::
PetriNet
->
Marking
->
VarMap
Place
->
BoolConstraint
checkTrap
net
m
b
=
do
c1
<-
trapConstraints
net
b
c2
<-
trapInitiallyMarked
net
b
c3
<-
trapUnassigned
m
b
return
$
c1
&&&
c2
&&&
c3
checkTrapSat
::
PetriNet
->
Marking
->
ConstraintProblem
Bool
Trap
checkTrapSat
net
m
=
let
b
=
makeVarMap
$
places
net
in
(
"trap constraints"
,
"trap"
,
getNames
b
,
checkTrap
net
m
b
,
trapFromAssignment
b
)
trapFromAssignment
::
VarMap
Place
->
BoolResult
Trap
trapFromAssignment
b
=
do
ps
<-
vals
b
return
$
M
.
keys
$
M
.
filter
id
ps
src/Util.hs
0 → 100644
View file @
3c4fd698
module
Util
(
verbosePut
)
where
import
Control.Monad
verbosePut
::
Int
->
Int
->
String
->
IO
()
verbosePut
verbosity
level
str
=
when
(
verbosity
>=
level
)
(
putStrLn
str
)
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