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
9cd19661
Commit
9cd19661
authored
Dec 22, 2016
by
Philipp J. Meyer
Browse files
Added minimization for unique terminal marking and minimization method messages
parent
e2f7a104
Changes
6
Hide whitespace changes
Inline
Side-by-side
src/Main.hs
View file @
9cd19661
...
...
@@ -470,10 +470,10 @@ refineUniqueTerminalMarkingProperty :: PetriNet ->
[
Trap
]
->
[
Siphon
]
->
UniqueTerminalMarkingCounterExample
->
OptIO
(
Maybe
UniqueTerminalMarkingCounterExample
,
[
Trap
],
[
Siphon
])
refineUniqueTerminalMarkingProperty
net
traps
siphons
m
@
(
m0
,
m1
,
m2
,
x1
,
x2
)
=
do
r1
<-
checkSat
$
checkUnmarkedTrapSat
net
m0
m1
m2
x1
x2
r1
<-
checkSat
Min
$
checkUnmarkedTrapSat
net
m0
m1
m2
x1
x2
case
r1
of
Nothing
->
do
r2
<-
checkSat
$
checkUnmarkedSiphonSat
net
m0
m1
m2
x1
x2
r2
<-
checkSat
Min
$
checkUnmarkedSiphonSat
net
m0
m1
m2
x1
x2
case
r2
of
Nothing
->
return
(
Just
m
,
traps
,
siphons
)
...
...
src/Solver.hs
View file @
9cd19661
...
...
@@ -2,8 +2,7 @@
module
Solver
(
prime
,
checkSat
,
checkSatMin
,
val
,
vals
,
positiveVal
,
zeroVal
,
getNames
,
ConstraintProblem
)
getNames
,
ConstraintProblem
,
MinConstraintProblem
)
where
import
Data.SBV
...
...
@@ -16,6 +15,8 @@ import Control.Applicative
type
ConstraintProblem
a
b
=
(
String
,
String
,
[
String
],
(
String
->
SBV
a
)
->
SBool
,
(
String
->
a
)
->
b
)
type
MinConstraintProblem
a
b
c
=
(
Int
->
c
->
String
,
Maybe
(
Int
,
c
)
->
ConstraintProblem
a
(
b
,
c
))
rebuildModel
::
SymWord
a
=>
[
String
]
->
Either
String
(
Bool
,
[
a
])
->
Maybe
(
Model
a
)
...
...
@@ -48,8 +49,8 @@ checkSat (problemName, resultName, vars, constraint, interpretation) = do
return
$
Just
model
checkSatMin
::
(
SatModel
a
,
SymWord
a
,
Show
a
,
Show
b
,
Show
c
)
=>
(
Maybe
(
Int
,
c
)
->
ConstraintProblem
a
(
b
,
c
))
->
OptIO
(
Maybe
b
)
checkSatMin
minProblem
=
do
Min
ConstraintProblem
a
b
c
->
OptIO
(
Maybe
b
)
checkSatMin
(
minMethod
,
minProblem
)
=
do
optMin
<-
opt
optMinimizeRefinement
r0
<-
checkSat
$
minProblem
Nothing
case
r0
of
...
...
@@ -60,7 +61,7 @@ checkSatMin minProblem = do
else
return
$
Just
result
where
findSmaller
optMin
result
curSize
=
do
verbosePut
2
$
"Checking for
size smaller than "
++
show
curSize
verbosePut
2
$
"Checking for
"
++
minMethod
optMin
curSize
r1
<-
checkSat
$
minProblem
(
Just
(
optMin
,
curSize
))
case
r1
of
Nothing
->
return
result
...
...
src/Solver/SComponent.hs
View file @
9cd19661
...
...
@@ -69,6 +69,9 @@ checkSizeLimit :: SIMap Place -> SIMap Transition -> Maybe (Int, Integer) -> SBo
checkSizeLimit
_
_
Nothing
=
true
checkSizeLimit
p'
_
(
Just
(
_
,
curSize
))
=
(
.<
literal
curSize
)
$
sumVal
p'
minimizeMethod
::
Int
->
Integer
->
String
minimizeMethod
_
curSize
=
"size smaller than"
++
show
curSize
checkSComponent
::
PetriNet
->
FiringVector
->
Maybe
(
Int
,
Integer
)
->
SIMap
Place
->
SIMap
Transition
->
SIMap
Transition
->
SBool
checkSComponent
net
x
sizeLimit
p'
t'
y
=
...
...
@@ -81,17 +84,17 @@ checkSComponent net x sizeLimit p' t' y =
checkTokens
net
p'
&&&
checkBinary
p'
t'
y
checkSComponentSat
::
PetriNet
->
FiringVector
->
Maybe
(
Int
,
Integer
)
->
ConstraintProblem
Integer
(
Cut
,
Integer
)
checkSComponentSat
net
x
sizeLimit
=
checkSComponentSat
::
PetriNet
->
FiringVector
->
MinConstraintProblem
Integer
Cut
Integer
checkSComponentSat
net
x
=
let
fired
=
elems
x
p'
=
makeVarMap
$
places
net
t'
=
makeVarMap
$
transitions
net
y
=
makeVarMapWith
prime
fired
in
(
"S-component constraints"
,
"cut"
,
in
(
minimizeMethod
,
\
sizeLimit
->
(
"S-component constraints"
,
"cut"
,
getNames
p'
++
getNames
t'
++
getNames
y
,
\
fm
->
checkSComponent
net
x
sizeLimit
(
fmap
fm
p'
)
(
fmap
fm
t'
)
(
fmap
fm
y
),
\
fm
->
cutFromAssignment
net
x
(
fmap
fm
p'
)
(
fmap
fm
t'
)
(
fmap
fm
y
))
\
fm
->
cutFromAssignment
net
x
(
fmap
fm
p'
)
(
fmap
fm
t'
)
(
fmap
fm
y
))
)
cutFromAssignment
::
PetriNet
->
FiringVector
->
IMap
Place
->
IMap
Transition
->
IMap
Transition
->
(
Cut
,
Integer
)
...
...
src/Solver/SComponentWithCut.hs
View file @
9cd19661
...
...
@@ -108,6 +108,28 @@ checkSizeLimit p1 p2 t0 t1 t2 (Just (minMethod, (p1Size, p2Size, t0Size, t1Size,
9
->
(
t1SizeNext
+
t2SizeNext
.>
t1SizeNow
+
t2SizeNow
)
_
->
error
$
"minimization method "
++
show
minMethod
++
" not supported"
minimizeMethod
::
Int
->
SizeIndicator
->
String
minimizeMethod
minMethod
(
p1Size
,
p2Size
,
t0Size
,
t1Size
,
t2Size
)
=
case
minMethod
of
1
->
"(|t0| < "
++
show
t0Size
++
") || "
++
"(|t0| = "
++
show
t0Size
++
" && "
++
"|t1| > "
++
show
t1Size
++
" && |t2| >= "
++
show
t2Size
++
") || "
++
"(|t0| = "
++
show
t0Size
++
" && "
++
"|t1| >= "
++
show
t1Size
++
" && |t2| > "
++
show
t2Size
++
")"
2
->
"(|t1| > "
++
show
t1Size
++
" && "
++
"|t2| >= "
++
show
t2Size
++
") || "
++
"(|t1| >= "
++
show
t1Size
++
" && "
++
"|t2| > "
++
show
t2Size
++
") || "
++
"(|t1| = "
++
show
t1Size
++
" && "
++
"|t2| = "
++
show
t2Size
++
" && t0 < "
++
show
t0Size
++
")"
3
->
"(|p1| + |p2| < "
++
show
(
p1Size
+
p2Size
)
++
") || "
++
"(|p1| + |p2| = "
++
show
(
p1Size
+
p2Size
)
++
" && "
++
"|t0| < "
++
show
t0Size
++
")"
4
->
"(|p1| + |p2| > "
++
show
(
p1Size
+
p2Size
)
++
") || "
++
"(|p1| + |p2| = "
++
show
(
p1Size
+
p2Size
)
++
" && "
++
"|t0| < "
++
show
t0Size
++
")"
5
->
"(|p1| + |p2| < "
++
show
(
p1Size
+
p2Size
)
++
")"
6
->
"(|p1| + |p2| > "
++
show
(
p1Size
+
p2Size
)
++
")"
7
->
"(|t1| > "
++
show
t1Size
++
" && |t2| >= "
++
show
t2Size
++
") || "
++
"(|t1| >= "
++
show
t1Size
++
" && |t2| > "
++
show
t2Size
++
")"
8
->
"(|t1| < "
++
show
t1Size
++
" && |t2| <= "
++
show
t2Size
++
") || "
++
"(|t1| <= "
++
show
t1Size
++
" && |t2| < "
++
show
t2Size
++
")"
9
->
"(|t1| + |t2| > "
++
show
(
t1Size
+
t2Size
)
++
")"
_
->
error
$
"minimization method "
++
show
minMethod
++
" not supported"
checkSComponent
::
PetriNet
->
FiringVector
->
Maybe
(
Int
,
SizeIndicator
)
->
SIMap
Place
->
SIMap
Place
->
SIMap
Transition
->
SIMap
Transition
->
SIMap
Transition
->
SBool
...
...
@@ -121,20 +143,20 @@ checkSComponent net x sizeLimit p1 p2 t0 t1 t2 =
checkBinary
p1
p2
t0
t1
t2
&&&
checkDisjunct
net
p1
p2
t0
t1
t2
checkSComponentWithCutSat
::
PetriNet
->
FiringVector
->
Maybe
(
Int
,
SizeIndicator
)
->
ConstraintProblem
Integer
(
Cut
,
SizeIndicator
)
checkSComponentWithCutSat
net
x
sizeLimit
=
checkSComponentWithCutSat
::
PetriNet
->
FiringVector
->
MinConstraintProblem
Integer
Cut
SizeIndicator
checkSComponentWithCutSat
net
x
=
let
p1
=
makeVarMapWith
(
"P1@"
++
)
$
places
net
p2
=
makeVarMapWith
(
"P2@"
++
)
$
places
net
t0
=
makeVarMapWith
(
"T0@"
++
)
$
transitions
net
t1
=
makeVarMapWith
(
"T1@"
++
)
$
transitions
net
t2
=
makeVarMapWith
(
"T2@"
++
)
$
transitions
net
in
(
"general S-component constraints"
,
"cut"
,
in
(
minimizeMethod
,
\
sizeLimit
->
(
"general S-component constraints"
,
"cut"
,
getNames
p1
++
getNames
p2
++
getNames
t0
++
getNames
t1
++
getNames
t2
,
\
fm
->
checkSComponent
net
x
sizeLimit
(
fmap
fm
p1
)
(
fmap
fm
p2
)
(
fmap
fm
t0
)
(
fmap
fm
t1
)
(
fmap
fm
t2
),
\
fm
->
cutFromAssignment
(
fmap
fm
p1
)
(
fmap
fm
p2
)
(
fmap
fm
t0
)
(
fmap
fm
t1
)
(
fmap
fm
t2
))
(
fmap
fm
p1
)
(
fmap
fm
p2
)
(
fmap
fm
t0
)
(
fmap
fm
t1
)
(
fmap
fm
t2
))
)
cutFromAssignment
::
IMap
Place
->
IMap
Place
->
IMap
Transition
->
IMap
Transition
->
IMap
Transition
->
...
...
src/Solver/SubnetEmptyTrap.hs
View file @
9cd19661
...
...
@@ -26,6 +26,9 @@ checkSizeLimit :: SIMap Place -> Maybe (Int, Integer) -> SBool
checkSizeLimit
_
Nothing
=
true
checkSizeLimit
b
(
Just
(
_
,
curSize
))
=
(
.<
literal
curSize
)
$
sumVal
b
minimizeMethod
::
Int
->
Integer
->
String
minimizeMethod
_
curSize
=
"size smaller than "
++
show
curSize
checkBinary
::
SIMap
Place
->
SBool
checkBinary
=
bAnd
.
map
(
\
x
->
x
.==
0
|||
x
.==
1
)
.
vals
...
...
@@ -37,14 +40,14 @@ checkSubnetEmptyTrap net m x b sizeLimit =
checkBinary
b
&&&
properTrap
b
checkSubnetEmptyTrapSat
::
PetriNet
->
Marking
->
FiringVector
->
Maybe
(
Int
,
Integer
)
->
ConstraintProblem
Integer
(
Trap
,
Integer
)
checkSubnetEmptyTrapSat
net
m
x
sizeLimit
=
checkSubnetEmptyTrapSat
::
PetriNet
->
Marking
->
FiringVector
->
MinConstraintProblem
Integer
Trap
Integer
checkSubnetEmptyTrapSat
net
m
x
=
let
b
=
makeVarMap
$
filter
(
\
p
->
val
m
p
==
0
)
$
mpost
net
$
elems
x
in
(
"subnet empty trap constraints"
,
"trap"
,
in
(
minimizeMethod
,
\
sizeLimit
->
(
"subnet empty trap constraints"
,
"trap"
,
getNames
b
,
\
fm
->
checkSubnetEmptyTrap
net
m
x
(
fmap
fm
b
)
sizeLimit
,
\
fm
->
trapFromAssignment
(
fmap
fm
b
))
\
fm
->
trapFromAssignment
(
fmap
fm
b
))
)
trapFromAssignment
::
IMap
Place
->
(
Trap
,
Integer
)
trapFromAssignment
b
=
(
M
.
keys
(
M
.
filter
(
>
0
)
b
),
sum
(
M
.
elems
b
))
...
...
src/Solver/UniqueTerminalMarking.hs
View file @
9cd19661
...
...
@@ -101,67 +101,87 @@ markingsFromAssignment m0 m1 m2 x1 x2 =
-- trap and siphon refinement constraints
siphonConstraints
::
PetriNet
->
S
B
Map
Place
->
SBool
siphonConstraints
::
PetriNet
->
S
I
Map
Place
->
SBool
siphonConstraints
net
b
=
bAnd
$
map
siphonConstraint
$
transitions
net
where
siphonConstraint
t
=
bOr
(
mval
b
(
post
net
t
)
)
==>
bOr
(
mval
b
(
pre
net
t
)
)
sum
(
mval
b
$
post
net
t
)
.>
0
==>
sum
(
mval
b
$
pre
net
t
)
.>
0
trapConstraints
::
PetriNet
->
S
B
Map
Place
->
SBool
trapConstraints
::
PetriNet
->
S
I
Map
Place
->
SBool
trapConstraints
net
b
=
bAnd
$
map
trapConstraint
$
transitions
net
where
trapConstraint
t
=
bOr
(
mval
b
(
pre
net
t
)
)
==>
bOr
(
mval
b
(
post
net
t
)
)
sum
(
mval
b
$
pre
net
t
)
.>
0
==>
sum
(
mval
b
$
post
net
t
)
.>
0
placesMarkedByMarking
::
PetriNet
->
RMarking
->
S
B
Map
Place
->
SBool
placesMarkedByMarking
net
m
b
=
bOr
$
mval
b
$
elems
m
placesMarkedByMarking
::
PetriNet
->
RMarking
->
S
I
Map
Place
->
SBool
placesMarkedByMarking
net
m
b
=
sum
(
mval
b
$
elems
m
)
.>
0
placesUnmarkedByMarking
::
PetriNet
->
RMarking
->
S
B
Map
Place
->
SBool
placesUnmarkedByMarking
net
m
b
=
bAnd
$
map
(
bnot
.
val
b
)
$
elems
m
placesUnmarkedByMarking
::
PetriNet
->
RMarking
->
S
I
Map
Place
->
SBool
placesUnmarkedByMarking
net
m
b
=
sum
(
m
val
b
$
elems
m
)
.==
0
placesPostsetOfSequence
::
PetriNet
->
RFiringVector
->
S
B
Map
Place
->
SBool
placesPostsetOfSequence
net
x
b
=
bOr
$
mval
b
$
mpost
net
$
elems
x
placesPostsetOfSequence
::
PetriNet
->
RFiringVector
->
S
I
Map
Place
->
SBool
placesPostsetOfSequence
net
x
b
=
sum
(
mval
b
$
mpost
net
$
elems
x
)
.>
0
placesPresetOfSequence
::
PetriNet
->
RFiringVector
->
S
B
Map
Place
->
SBool
placesPresetOfSequence
net
x
b
=
bOr
$
mval
b
$
mpre
net
$
elems
x
placesPresetOfSequence
::
PetriNet
->
RFiringVector
->
S
I
Map
Place
->
SBool
placesPresetOfSequence
net
x
b
=
sum
(
mval
b
$
mpre
net
$
elems
x
)
.>
0
nonemptySet
::
(
Ord
a
,
Show
a
)
=>
S
B
Map
a
->
SBool
nonemptySet
b
=
bOr
$
vals
b
nonemptySet
::
(
Ord
a
,
Show
a
)
=>
S
I
Map
a
->
SBool
nonemptySet
b
=
sum
(
vals
b
)
.>
0
checkUnmarkedTrap
::
PetriNet
->
RMarking
->
RMarking
->
RMarking
->
RFiringVector
->
RFiringVector
->
SBMap
Place
->
SBool
checkUnmarkedTrap
net
m0
m1
m2
x1
x2
b
=
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
->
RMarking
->
RFiringVector
->
RFiringVector
->
SIMap
Place
->
Maybe
(
Int
,
Integer
)
->
SBool
checkUnmarkedTrap
net
m0
m1
m2
x1
x2
b
sizeLimit
=
trapConstraints
net
b
&&&
nonemptySet
b
&&&
checkSizeLimit
b
sizeLimit
&&&
checkBinary
b
&&&
(
(
placesMarkedByMarking
net
m0
b
&&&
(
placesUnmarkedByMarking
net
m1
b
|||
placesUnmarkedByMarking
net
m2
b
))
|||
(
placesPostsetOfSequence
net
x1
b
&&&
placesUnmarkedByMarking
net
m1
b
)
|||
(
placesPostsetOfSequence
net
x2
b
&&&
placesUnmarkedByMarking
net
m2
b
)
)
checkUnmarkedTrapSat
::
PetriNet
->
RMarking
->
RMarking
->
RMarking
->
RFiringVector
->
RFiringVector
->
ConstraintProblem
Bool
Trap
checkUnmarkedTrapSat
::
PetriNet
->
RMarking
->
RMarking
->
RMarking
->
RFiringVector
->
RFiringVector
->
Min
ConstraintProblem
Integer
Trap
Integer
checkUnmarkedTrapSat
net
m0
m1
m2
x1
x2
=
let
b
=
makeVarMap
$
places
net
in
(
"trap marked in m and unmarked in m1 or m2, or marked by x1 and unmarked in m1, or marked by x2 and unmarked in m2"
,
"trap"
,
in
(
minimizeMethod
,
\
sizeLimit
->
(
"trap marked in m and unmarked in m1 or m2, or marked by x1 and unmarked in m1, or marked by x2 and unmarked in m2"
,
"trap"
,
getNames
b
,
\
fm
->
checkUnmarkedTrap
net
m0
m1
m2
x1
x2
(
fmap
fm
b
),
\
fm
->
placesFromAssignment
(
fmap
fm
b
))
\
fm
->
checkUnmarkedTrap
net
m0
m1
m2
x1
x2
(
fmap
fm
b
)
sizeLimit
,
\
fm
->
placesFromAssignment
(
fmap
fm
b
))
)
checkUnmarkedSiphon
::
PetriNet
->
RMarking
->
RMarking
->
RMarking
->
RFiringVector
->
RFiringVector
->
S
B
Map
Place
->
SBool
checkUnmarkedSiphon
net
m0
m1
m2
x1
x2
b
=
checkUnmarkedSiphon
::
PetriNet
->
RMarking
->
RMarking
->
RMarking
->
RFiringVector
->
RFiringVector
->
S
I
Map
Place
->
Maybe
(
Int
,
Integer
)
->
SBool
checkUnmarkedSiphon
net
m0
m1
m2
x1
x2
b
sizeLimit
=
siphonConstraints
net
b
&&&
nonemptySet
b
&&&
checkSizeLimit
b
sizeLimit
&&&
checkBinary
b
&&&
(
placesUnmarkedByMarking
net
m0
b
&&&
(
placesMarkedByMarking
net
m1
b
|||
placesMarkedByMarking
net
m2
b
|||
placesPresetOfSequence
net
x1
b
|||
placesPresetOfSequence
net
x2
b
)
)
checkUnmarkedSiphonSat
::
PetriNet
->
RMarking
->
RMarking
->
RMarking
->
RFiringVector
->
RFiringVector
->
ConstraintProblem
Bool
Siphon
checkUnmarkedSiphonSat
::
PetriNet
->
RMarking
->
RMarking
->
RMarking
->
RFiringVector
->
RFiringVector
->
Min
ConstraintProblem
Integer
Siphon
Integer
checkUnmarkedSiphonSat
net
m0
m1
m2
x1
x2
=
let
b
=
makeVarMap
$
places
net
in
(
"siphon unmarked in m0 and marked in m1 or m2 or used as input in x1 or x2"
,
"siphon"
,
in
(
minimizeMethod
,
\
sizeLimit
->
(
"siphon unmarked in m0 and marked in m1 or m2 or used as input in x1 or x2"
,
"siphon"
,
getNames
b
,
\
fm
->
checkUnmarkedSiphon
net
m0
m1
m2
x1
x2
(
fmap
fm
b
),
\
fm
->
placesFromAssignment
(
fmap
fm
b
))
\
fm
->
checkUnmarkedSiphon
net
m0
m1
m2
x1
x2
(
fmap
fm
b
)
sizeLimit
,
\
fm
->
placesFromAssignment
(
fmap
fm
b
))
)
placesFromAssignment
::
B
Map
Place
->
Trap
placesFromAssignment
b
=
M
.
keys
$
M
.
filter
id
b
placesFromAssignment
::
I
Map
Place
->
([
Place
],
Integer
)
placesFromAssignment
b
=
(
M
.
keys
(
M
.
filter
(
>
0
)
b
),
sum
(
M
.
elems
b
))
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