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
c9113b43
Commit
c9113b43
authored
May 02, 2017
by
Philipp Meyer
Browse files
Rename options and properties
parent
1809caa1
Changes
6
Hide whitespace changes
Inline
Side-by-side
src/Main.hs
View file @
c9113b43
...
...
@@ -21,8 +21,8 @@ import qualified Printer.DOT as DOTPrinter
import
Property
import
StructuralComputation
import
Solver
import
Solver.
TerminalMarkingsUniqueConsensus
import
Solver.
TerminalMarkingReachable
import
Solver.
LayeredTermination
import
Solver.
StrongConsensus
writeFiles
::
String
->
PopulationProtocol
->
[
Property
]
->
OptIO
()
writeFiles
basename
pp
props
=
do
...
...
@@ -47,9 +47,8 @@ checkFile file = do
format
<-
opt
inputFormat
let
parser
=
case
format
of
InPP
->
PPParser
.
parseContent
(
pp
,
props
)
<-
liftIO
$
parseFile
parser
file
implicitProperties
<-
opt
optProperties
let
props'
=
props
++
map
(
makeImplicitProperty
pp
)
implicitProperties
pp
<-
liftIO
$
parseFile
parser
file
props
<-
opt
optProperties
verbosePut
1
$
"Analyzing "
++
showNetName
pp
verbosePut
2
$
"Number of states: "
++
show
(
length
(
states
pp
))
...
...
@@ -65,33 +64,22 @@ checkFile file = do
output
<-
opt
optOutput
case
output
of
Just
outputfile
->
writeFiles
outputfile
pp
props
'
writeFiles
outputfile
pp
props
Nothing
->
return
()
-- TODO: short-circuit? parallel?
rs
<-
mapM
(
checkProperty
pp
)
props
'
rs
<-
mapM
(
checkProperty
pp
)
props
verbosePut
0
""
return
$
resultsAnd
rs
makeImplicitProperty
::
PopulationProtocol
->
ImplicitProperty
->
Property
makeImplicitProperty
_
TerminalMarkingsUniqueConsensus
=
Property
"reachable terminal markings have a unique consensus"
$
Constraint
TerminalMarkingsUniqueConsensusConstraint
makeImplicitProperty
_
TerminalMarkingReachable
=
Property
"terminal marking reachable"
$
Constraint
TerminalMarkingReachableConstraint
checkProperty
::
PopulationProtocol
->
Property
->
OptIO
PropResult
checkProperty
pp
p
=
do
verbosePut
1
$
"
\n
Checking "
++
showPropertyName
p
verbosePut
3
$
show
p
r
<-
case
pcont
p
of
-- (Safety pf) -> checkSafetyProperty pp pf
-- (Liveness pf) -> checkLivenessProperty pp pf
(
Constraint
pc
)
->
checkConstraintProperty
pp
pc
verbosePut
0
$
showPropertyName
p
++
" "
++
case
r
of
Satisfied
->
"is satisfied."
Unsatisfied
->
"is not satisfied."
Unknown
->
"may not be satisfied."
checkProperty
pp
prop
=
do
verbosePut
1
$
"
\n
Checking "
++
show
prop
r
<-
case
prop
of
Correctness
->
error
"not yet implemented"
LayeredTermination
->
checkLayeredTermination
pp
StrongConsensus
->
checkStrongConsensus
pp
verbosePut
0
$
show
prop
++
" "
++
show
r
return
r
printInvariant
::
(
Show
a
,
Invariant
a
)
=>
(
Maybe
[
a
],
[
a
])
->
OptIO
PropResult
...
...
@@ -112,66 +100,60 @@ printInvariant (baseInvResult, addedInv) =
mapM_
(
putLine
.
show
)
addedInv
return
Satisfied
checkConstraintProperty
::
PopulationProtocol
->
ConstraintProperty
->
OptIO
PropResult
checkConstraintProperty
pp
cp
=
case
cp
of
TerminalMarkingsUniqueConsensusConstraint
->
checkTerminalMarkingsUniqueConsensusProperty
pp
TerminalMarkingReachableConstraint
->
checkTerminalMarkingReachableProperty
pp
checkTerminalMarkingsUniqueConsensusProperty
::
PopulationProtocol
->
OptIO
PropResult
checkTerminalMarkingsUniqueConsensusProperty
pp
=
do
r
<-
checkTerminalMarkingsUniqueConsensusProperty'
pp
[]
[]
[]
checkStrongConsensus
::
PopulationProtocol
->
OptIO
PropResult
checkStrongConsensus
pp
=
do
r
<-
checkStrongConsensus'
pp
[]
[]
[]
case
r
of
(
Nothing
,
_
,
_
,
_
)
->
return
Satisfied
(
Just
_
,
_
,
_
,
_
)
->
return
Unknown
check
TerminalMarkingsUnique
Consensus
Property
'
::
PopulationProtocol
->
check
Strong
Consensus'
::
PopulationProtocol
->
[
Trap
]
->
[
Siphon
]
->
[
StableInequality
]
->
OptIO
(
Maybe
TerminalMarkingsUnique
ConsensusCounterExample
,
[
Trap
],
[
Siphon
],
[
StableInequality
])
check
TerminalMarkingsUnique
Consensus
Property
'
pp
utraps
usiphons
inequalities
=
do
r
<-
checkSat
$
check
TerminalMarkingsUnique
ConsensusSat
pp
utraps
usiphons
inequalities
OptIO
(
Maybe
Strong
ConsensusCounterExample
,
[
Trap
],
[
Siphon
],
[
StableInequality
])
check
Strong
Consensus'
pp
utraps
usiphons
inequalities
=
do
r
<-
checkSat
$
check
Strong
ConsensusSat
pp
utraps
usiphons
inequalities
case
r
of
Nothing
->
return
(
Nothing
,
utraps
,
usiphons
,
inequalities
)
Just
c
->
do
refine
<-
opt
optRefinementType
if
isJust
refine
then
refine
TerminalMarkingsUnique
Consensus
Property
pp
utraps
usiphons
inequalities
c
refine
Strong
Consensus
pp
utraps
usiphons
inequalities
c
else
return
(
Just
c
,
utraps
,
usiphons
,
inequalities
)
refine
TerminalMarkingsUnique
Consensus
Property
::
PopulationProtocol
->
[
Trap
]
->
[
Siphon
]
->
[
StableInequality
]
->
TerminalMarkingsUnique
ConsensusCounterExample
->
OptIO
(
Maybe
TerminalMarkingsUnique
ConsensusCounterExample
,
[
Trap
],
[
Siphon
],
[
StableInequality
])
refine
TerminalMarkingsUnique
Consensus
Property
pp
utraps
usiphons
inequalities
c
@
(
m0
,
m1
,
m2
,
x1
,
x2
)
=
do
r1
<-
checkSatMin
$
Solver
.
TerminalMarkingsUnique
Consensus
.
findTrapConstraintsSat
pp
m0
m1
m2
x1
x2
refine
Strong
Consensus
::
PopulationProtocol
->
[
Trap
]
->
[
Siphon
]
->
[
StableInequality
]
->
Strong
ConsensusCounterExample
->
OptIO
(
Maybe
Strong
ConsensusCounterExample
,
[
Trap
],
[
Siphon
],
[
StableInequality
])
refine
Strong
Consensus
pp
utraps
usiphons
inequalities
c
@
(
m0
,
m1
,
m2
,
x1
,
x2
)
=
do
r1
<-
checkSatMin
$
Solver
.
Strong
Consensus
.
findTrapConstraintsSat
pp
m0
m1
m2
x1
x2
case
r1
of
Nothing
->
do
r2
<-
checkSatMin
$
Solver
.
TerminalMarkingsUnique
Consensus
.
findUSiphonConstraintsSat
pp
m0
m1
m2
x1
x2
r2
<-
checkSatMin
$
Solver
.
Strong
Consensus
.
findUSiphonConstraintsSat
pp
m0
m1
m2
x1
x2
case
r2
of
Nothing
->
do
r3
<-
checkSatMin
$
Solver
.
TerminalMarkingsUnique
Consensus
.
findUTrapConstraintsSat
pp
m0
m1
m2
x1
x2
r3
<-
checkSatMin
$
Solver
.
Strong
Consensus
.
findUTrapConstraintsSat
pp
m0
m1
m2
x1
x2
case
r3
of
Nothing
->
return
(
Just
c
,
utraps
,
usiphons
,
inequalities
)
Just
utrap
->
check
TerminalMarkingsUnique
Consensus
Property
'
pp
(
utrap
:
utraps
)
usiphons
inequalities
check
Strong
Consensus'
pp
(
utrap
:
utraps
)
usiphons
inequalities
Just
usiphon
->
check
TerminalMarkingsUnique
Consensus
Property
'
pp
utraps
(
usiphon
:
usiphons
)
inequalities
check
Strong
Consensus'
pp
utraps
(
usiphon
:
usiphons
)
inequalities
Just
trap
->
check
TerminalMarkingsUnique
Consensus
Property
'
pp
(
trap
:
utraps
)
usiphons
inequalities
check
Strong
Consensus'
pp
(
trap
:
utraps
)
usiphons
inequalities
check
TerminalMarkingReachableProperty
::
PopulationProtocol
->
OptIO
PropResult
check
TerminalMarkingReachableProperty
pp
=
do
check
LayeredTermination
::
PopulationProtocol
->
OptIO
PropResult
check
LayeredTermination
pp
=
do
let
nonTrivialTriplets
=
filter
(
not
.
trivialTriplet
)
$
generateTriplets
pp
check
TerminalMarkingReachableProperty
'
pp
nonTrivialTriplets
1
$
genericLength
$
transitions
pp
check
LayeredTermination
'
pp
nonTrivialTriplets
1
$
genericLength
$
transitions
pp
check
TerminalMarkingReachableProperty
'
::
PopulationProtocol
->
[
Triplet
]
->
Integer
->
Integer
->
OptIO
PropResult
check
TerminalMarkingReachableProperty
'
pp
triplets
k
kmax
=
do
check
LayeredTermination
'
::
PopulationProtocol
->
[
Triplet
]
->
Integer
->
Integer
->
OptIO
PropResult
check
LayeredTermination
'
pp
triplets
k
kmax
=
do
verbosePut
1
$
"Checking terminal marking reachable with at most "
++
show
k
++
" partitions"
r
<-
checkSatMin
$
check
TerminalMarkingReachable
Sat
pp
triplets
k
r
<-
checkSatMin
$
check
LayeredTermination
Sat
pp
triplets
k
case
r
of
Nothing
->
if
k
<
kmax
then
check
TerminalMarkingReachableProperty
'
pp
triplets
(
k
+
1
)
kmax
check
LayeredTermination
'
pp
triplets
(
k
+
1
)
kmax
else
return
Unknown
Just
inv
->
do
...
...
@@ -195,15 +177,13 @@ main = do
rs
<-
runReaderT
(
mapM
checkFile
files
)
opts'
-- TODO: short-circuit with Control.Monad.Loops? parallel
-- execution?
case
resultsAnd
rs
of
let
r
=
resultsAnd
rs
case
r
of
Satisfied
->
exitSuccessWith
"All properties satisfied."
Unsatisfied
->
exitFailureWith
"Some properties are not satisfied"
Unknown
->
exitFailureWith
"Some properties may not be satisfied."
exitSuccessWith
$
"All properties "
++
show
r
_
->
exitFailureWith
$
"Some properties "
++
show
r
-- TODO: Always exit with exit code 0 unless an error occured
exitSuccessWith
::
String
->
IO
()
exitSuccessWith
msg
=
do
putStrLn
msg
...
...
src/Options.hs
View file @
c9113b43
...
...
@@ -2,7 +2,7 @@
module
Options
(
InputFormat
(
..
),
OutputFormat
(
..
),
RefinementType
(
..
),
ImplicitProperty
(
..
),
Options
(
..
),
startOptions
,
options
,
parseArgs
,
Options
(
..
),
startOptions
,
options
,
parseArgs
,
usageInformation
)
where
...
...
@@ -10,6 +10,8 @@ import Control.Applicative ((<$>))
import
System.Console.GetOpt
import
System.Environment
(
getArgs
)
import
Property
(
Property
(
..
))
data
InputFormat
=
InPP
deriving
(
Read
)
data
OutputFormat
=
OutDOT
deriving
(
Read
)
...
...
@@ -18,10 +20,6 @@ instance Show InputFormat where
instance
Show
OutputFormat
where
show
OutDOT
=
"DOT"
data
ImplicitProperty
=
TerminalMarkingsUniqueConsensus
|
TerminalMarkingReachable
deriving
(
Show
,
Read
)
data
RefinementType
=
TrapRefinement
|
SiphonRefinement
|
UTrapRefinement
...
...
@@ -32,12 +30,11 @@ data Options = Options { inputFormat :: InputFormat
,
optVerbosity
::
Int
,
optShowHelp
::
Bool
,
optShowVersion
::
Bool
,
optProperties
::
[
Implicit
Property
]
,
optProperties
::
[
Property
]
,
optRefinementType
::
Maybe
[
RefinementType
]
,
optMinimizeRefinement
::
Int
,
optSMTAuto
::
Bool
,
optInvariant
::
Bool
,
optBoolConst
::
Bool
,
optOutput
::
Maybe
String
,
outputFormat
::
OutputFormat
,
optUseProperties
::
Bool
...
...
@@ -54,7 +51,6 @@ startOptions = Options { inputFormat = InPP
,
optMinimizeRefinement
=
0
,
optSMTAuto
=
True
,
optInvariant
=
False
,
optBoolConst
=
False
,
optOutput
=
Nothing
,
outputFormat
=
OutDOT
,
optUseProperties
=
True
...
...
@@ -63,35 +59,22 @@ startOptions = Options { inputFormat = InPP
options
::
[
OptDescr
(
Options
->
Either
String
Options
)
]
options
=
[
Option
""
[
"pp"
]
(
NoArg
(
\
opt
->
Right
opt
{
inputFormat
=
InPP
}))
"Use the population protocol input format"
,
Option
""
[
"structure"
]
(
NoArg
(
\
opt
->
Right
opt
{
optPrintStructure
=
True
}))
"Print structural information"
,
Option
""
[
"terminal-markings-unique-consensus"
]
[
Option
""
[
"layered-termination"
]
(
NoArg
(
\
opt
->
Right
opt
{
optProperties
=
optProperties
opt
++
[
TerminalMarkingsUniqueConsensus
]
optProperties
=
optProperties
opt
++
[
LayeredTermination
]
}))
"Prove that t
erminal markings have a unique consensus
"
"Prove that t
he protocol satisfies layered termination
"
,
Option
""
[
"
terminal-marking-reachable
"
]
,
Option
""
[
"
strong-consensus
"
]
(
NoArg
(
\
opt
->
Right
opt
{
optProperties
=
optProperties
opt
++
[
TerminalMarkingReachable
]
optProperties
=
optProperties
opt
++
[
StrongConsensus
]
}))
"Prove that
a terminal marking is reachable
"
"Prove that
the protocol satisfies strong consensus
"
,
Option
"i"
[
"invariant"
]
(
NoArg
(
\
opt
->
Right
opt
{
optInvariant
=
True
}))
"Generate an invariant"
,
Option
""
[
"bool-const"
]
(
NoArg
(
\
opt
->
Right
opt
{
optBoolConst
=
True
}))
(
"Use boolean constraints instead of integer ones
\n
"
++
" for transition invariant"
)
,
Option
"r"
[
"refinement"
]
(
ReqArg
(
\
arg
opt
->
let
addRef
ref
=
...
...
@@ -111,6 +94,16 @@ options =
"METHOD"
)
(
"Refine with METHOD (trap, siphon, utrap, usiphon)"
)
,
Option
"s"
[
"structure"
]
(
NoArg
(
\
opt
->
Right
opt
{
optPrintStructure
=
True
}))
"Print structural information"
,
Option
""
[
"in-pp"
]
(
NoArg
(
\
opt
->
Right
opt
{
inputFormat
=
InPP
}))
"Use the population protocol input format"
,
Option
"o"
[
"output"
]
(
ReqArg
(
\
arg
opt
->
Right
opt
{
optOutput
=
Just
arg
...
...
src/Parser/PP.hs
View file @
c9113b43
...
...
@@ -187,29 +187,17 @@ formAtom = try linIneq
formula
::
Parser
(
Formula
String
)
formula
=
buildExpressionParser
formOperatorTable
formAtom
<?>
"formula"
propertyType
::
Parser
PropertyType
propertyType
=
(
reserved
"safety"
*>
return
SafetyType
)
<|>
(
reserved
"liveness"
*>
return
LivenessType
)
property
::
Parser
Property
property
=
do
pt
<-
propertyType
reserved
"property"
predicate
::
Parser
(
Formula
PopulationProtocol
.
State
)
predicate
=
do
reserved
"predicate"
name
<-
option
""
ident
case
pt
of
SafetyType
->
do
form
<-
braces
formula
return
Property
{
pname
=
name
,
pcont
=
Safety
(
fmap
PopulationProtocol
.
State
form
)
}
LivenessType
->
do
form
<-
braces
formula
return
Property
{
pname
=
name
,
pcont
=
Liveness
(
fmap
Transition
form
)
}
parseContent
::
Parser
(
PopulationProtocol
,[
Property
])
form
<-
braces
formula
return
(
fmap
PopulationProtocol
.
State
form
)
parseContent
::
Parser
PopulationProtocol
parseContent
=
do
whiteSpace
pp
<-
populationProtocol
properties
<-
many
pr
operty
--
properties <- many pr
edicate
eof
return
(
pp
,
properties
)
return
pp
src/Property.hs
View file @
c9113b43
...
...
@@ -2,11 +2,6 @@
module
Property
(
Property
(
..
),
showPropertyName
,
renameProperty
,
PropertyType
(
..
),
PropertyContent
(
..
),
ConstraintProperty
(
..
),
Formula
(
..
),
Op
(
..
),
Term
(
..
),
...
...
@@ -18,8 +13,6 @@ module Property
resultsOr
)
where
import
PopulationProtocol
data
Term
a
=
Var
a
|
Const
Integer
...
...
@@ -84,58 +77,21 @@ instance Functor Formula where
fmap
f
(
p
:&:
q
)
=
fmap
f
p
:&:
fmap
f
q
fmap
f
(
p
:|:
q
)
=
fmap
f
p
:|:
fmap
f
q
-- TODO: add functions to transform formula to CNF/DNF
data
PropertyType
=
SafetyType
|
LivenessType
|
ConstraintType
data
ConstraintProperty
=
TerminalMarkingsUniqueConsensusConstraint
|
TerminalMarkingReachableConstraint
instance
Show
ConstraintProperty
where
show
TerminalMarkingsUniqueConsensusConstraint
=
"reachable terminal markings have a unique consensus"
show
TerminalMarkingReachableConstraint
=
"terminal marking reachable"
data
PropertyContent
=
Safety
(
Formula
State
)
|
Liveness
(
Formula
Transition
)
|
Constraint
ConstraintProperty
data
Property
=
Correctness
|
LayeredTermination
|
StrongConsensus
showPropertyType
::
PropertyContent
->
String
showPropertyType
(
Safety
_
)
=
"safety"
showPropertyType
(
Liveness
_
)
=
"liveness"
showPropertyType
(
Constraint
_
)
=
"constraint"
showPropertyContent
::
PropertyContent
->
String
showPropertyContent
(
Safety
f
)
=
show
f
showPropertyContent
(
Liveness
f
)
=
show
f
showPropertyContent
(
Constraint
c
)
=
show
c
instance
Show
PropertyContent
where
show
pc
=
showPropertyType
pc
++
" ("
++
showPropertyContent
pc
++
")"
instance
Show
Property
where
show
Correctness
=
"correctness"
show
LayeredTermination
=
"layered termination"
show
StrongConsensus
=
"strong consensus"
data
Property
=
Property
{
pname
::
String
,
pcont
::
PropertyContent
}
data
PropResult
=
Satisfied
|
Unsatisfied
|
Unknown
deriving
(
Eq
)
instance
Show
Property
where
show
p
=
showPropertyName
p
++
" { "
++
showPropertyContent
(
pcont
p
)
++
" }"
renameProperty
::
(
String
->
String
)
->
Property
->
Property
renameProperty
f
(
Property
pn
(
Safety
pf
))
=
Property
pn
(
Safety
(
fmap
(
renameState
f
)
pf
))
renameProperty
f
(
Property
pn
(
Liveness
pf
))
=
Property
pn
(
Liveness
(
fmap
(
renameTransition
f
)
pf
))
renameProperty
_
p
=
p
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
,
Eq
)
instance
Show
PropResult
where
show
Satisfied
=
"satisfied"
show
Unsatisfied
=
"not satisfied"
show
Unknown
=
"may not be satisfied"
resultAnd
::
PropResult
->
PropResult
->
PropResult
resultAnd
Satisfied
x
=
x
...
...
src/Solver/
TerminalMarkingReachable
.hs
→
src/Solver/
LayeredTermination
.hs
View file @
c9113b43
{-# LANGUAGE FlexibleContexts #-}
module
Solver.
TerminalMarkingReachable
(
check
TerminalMarkingReachable
Sat
,
TerminalMarkingReachable
Invariant
)
module
Solver.
LayeredTermination
(
check
LayeredTermination
Sat
,
LayeredTermination
Invariant
)
where
import
Data.SBV
...
...
@@ -17,15 +17,15 @@ import StructuralComputation
type
InvariantSize
=
([
Int
],
[
Integer
],
[
Int
])
type
TerminalMarkingReachable
Invariant
=
[
Block
Invariant
]
data
Block
Invariant
=
Block
Invariant
(
Integer
,
[
Transition
],
IVector
State
)
type
LayeredTermination
Invariant
=
[
Layer
Invariant
]
data
Layer
Invariant
=
Layer
Invariant
(
Integer
,
[
Transition
],
IVector
State
)
instance
Invariant
Block
Invariant
where
invariantSize
(
Block
Invariant
(
_
,
ti
,
yi
))
=
if
null
ti
then
0
else
size
yi
instance
Invariant
Layer
Invariant
where
invariantSize
(
Layer
Invariant
(
_
,
ti
,
yi
))
=
if
null
ti
then
0
else
size
yi
instance
Show
Block
Invariant
where
show
(
Block
Invariant
(
i
,
ti
,
yi
))
=
instance
Show
Layer
Invariant
where
show
(
Layer
Invariant
(
i
,
ti
,
yi
))
=
"T_"
++
show
i
++
":
\n
"
++
unlines
(
map
show
ti
)
++
(
if
null
ti
then
""
else
"
\n
Y_"
++
show
i
++
": "
++
intercalate
" + "
(
map
showWeighted
(
items
yi
))
++
"
\n
"
)
...
...
@@ -38,8 +38,8 @@ checkNonNegativityConstraints :: (Ord a, Show a) => [SIMap a] -> SBool
checkNonNegativityConstraints
xs
=
bAnd
$
map
nonNegativityConstraints
xs
block
TerminationConstraints
::
PopulationProtocol
->
Integer
->
SIMap
Transition
->
SIMap
State
->
SBool
block
TerminationConstraints
pp
i
b
y
=
layer
TerminationConstraints
::
PopulationProtocol
->
Integer
->
SIMap
Transition
->
SIMap
State
->
SBool
layer
TerminationConstraints
pp
i
b
y
=
bAnd
$
map
checkTransition
$
transitions
pp
where
checkTransition
t
=
let
incoming
=
map
addState
$
lpre
pp
t
...
...
@@ -49,46 +49,46 @@ blockTerminationConstraints pp i b y =
terminationConstraints
::
PopulationProtocol
->
Integer
->
SIMap
Transition
->
[
SIMap
State
]
->
SBool
terminationConstraints
pp
k
b
ys
=
bAnd
$
[
block
TerminationConstraints
pp
i
b
y
|
(
i
,
y
)
<-
zip
[
1
..
]
ys
]
bAnd
$
[
layer
TerminationConstraints
pp
i
b
y
|
(
i
,
y
)
<-
zip
[
1
..
]
ys
]
block
Constraints
::
PopulationProtocol
->
Integer
->
SIMap
Transition
->
SBool
block
Constraints
pp
k
b
=
bAnd
$
map
check
Block
$
transitions
pp
where
check
Block
t
=
literal
1
.<=
val
b
t
&&&
val
b
t
.<=
literal
k
layer
Constraints
::
PopulationProtocol
->
Integer
->
SIMap
Transition
->
SBool
layer
Constraints
pp
k
b
=
bAnd
$
map
check
Layer
$
transitions
pp
where
check
Layer
t
=
literal
1
.<=
val
b
t
&&&
val
b
t
.<=
literal
k
block
OrderConstraints
::
PopulationProtocol
->
[
Triplet
]
->
Integer
->
SIMap
Transition
->
SBool
block
OrderConstraints
pp
triplets
k
b
=
layer
OrderConstraints
::
PopulationProtocol
->
[
Triplet
]
->
Integer
->
SIMap
Transition
->
SBool
layer
OrderConstraints
pp
triplets
k
b
=
bAnd
$
map
checkTriplet
triplets
where
checkTriplet
(
s
,
t
,
ts
)
=
(
val
b
s
.>
val
b
t
)
==>
bOr
(
map
(
\
t'
->
val
b
t'
.==
val
b
t
)
ts
)
check
TerminalMarkingReachable
::
PopulationProtocol
->
[
Triplet
]
->
Integer
->
SIMap
Transition
->
[
SIMap
State
]
->
Maybe
(
Int
,
InvariantSize
)
->
SBool
check
TerminalMarkingReachable
pp
triplets
k
b
ys
sizeLimit
=
block
Constraints
pp
k
b
&&&
check
LayeredTermination
::
PopulationProtocol
->
[
Triplet
]
->
Integer
->
SIMap
Transition
->
[
SIMap
State
]
->
Maybe
(
Int
,
InvariantSize
)
->
SBool
check
LayeredTermination
pp
triplets
k
b
ys
sizeLimit
=
layer
Constraints
pp
k
b
&&&
terminationConstraints
pp
k
b
ys
&&&
block
OrderConstraints
pp
triplets
k
b
&&&
layer
OrderConstraints
pp
triplets
k
b
&&&
checkNonNegativityConstraints
ys
&&&
checkSizeLimit
k
b
ys
sizeLimit
check
TerminalMarkingReachable
Sat
::
PopulationProtocol
->
[
Triplet
]
->
Integer
->
MinConstraintProblem
Integer
TerminalMarkingReachable
Invariant
InvariantSize
check
TerminalMarkingReachable
Sat
pp
triplets
k
=
check
LayeredTermination
Sat
::
PopulationProtocol
->
[
Triplet
]
->
Integer
->
MinConstraintProblem
Integer
LayeredTermination
Invariant
InvariantSize
check
LayeredTermination
Sat
pp
triplets
k
=
let
makeYName
i
=
(
++
)
(
genericReplicate
i
'
\'
'
)
ys
=
[
makeVarMapWith
(
makeYName
i
)
$
states
pp
|
i
<-
[
1
..
k
]]
b
=
makeVarMap
$
transitions
pp
in
(
minimizeMethod
,
\
sizeLimit
->
(
"terminal marking reachable"
,
"invariant"
,
concat
(
map
getNames
ys
)
++
getNames
b
,
\
fm
->
check
TerminalMarkingReachable
pp
triplets
k
(
fmap
fm
b
)
(
map
(
fmap
fm
)
ys
)
sizeLimit
,
\
fm
->
check
LayeredTermination
pp
triplets
k
(
fmap
fm
b
)
(
map
(
fmap
fm
)
ys
)
sizeLimit
,
\
fm
->
invariantFromAssignment
pp
k
(
fmap
fm
b
)
(
map
(
fmap
fm
)
ys
)))
minimizeMethod
::
Int
->
InvariantSize
->
String
minimizeMethod
1
(
curYSize
,
_
,
_
)
=
"number of states in y less than "
++
show
(
sum
curYSize
)
minimizeMethod
2
(
_
,
_
,
curTSize
)
=
"number of transitions in last
block
less than "
++
show
(
last
curTSize
)
minimizeMethod
3
(
curYSize
,
_
,
curTSize
)
=
"number of transitions in last
block
less than "
++
show
(
last
curTSize
)
++
minimizeMethod
2
(
_
,
_
,
curTSize
)
=
"number of transitions in last
layer
less than "
++
show
(
last
curTSize
)
minimizeMethod
3
(
curYSize
,
_
,
curTSize
)
=
"number of transitions in last
layer
less than "
++
show
(
last
curTSize
)
++
" or same number of transitions and number of states in y less than "
++
show
curYSize
minimizeMethod
4
(
_
,
curYMax
,
_
)
=
"maximum coefficient in y is less than "
++
show
(
maximum
curYMax
)
minimizeMethod
5
(
curYSize
,
curYMax
,
_
)
=
"number of states in y less than "
++
show
(
sum
curYSize
)
++
" or same number of states and maximum coefficient in y is less than "
++
show
(
maximum
curYMax
)
minimizeMethod
6
(
curYSize
,
curYMax
,
curTSize
)
=
"number of transitions in last
block
less than "
++
show
(
last
curTSize
)
++
minimizeMethod
6
(
curYSize
,
curYMax
,
curTSize
)
=
"number of transitions in last
layer
less than "
++
show
(
last
curTSize
)
++
" or same number of transitions and number of states in y less than "
++
show
(
sum
curYSize
)
++
" or same number of transitions and same number of states and maximum coefficient in y less than "
++
show
(
maximum
curYMax
)
minimizeMethod
_
_
=
error
"minimization method not supported"
...
...
@@ -115,11 +115,11 @@ checkSizeLimit k b ys (Just (6, (curYSize, curYMax, curTSize))) =
((
foldl
smax
0
(
concatMap
vals
ys
))
.<
literal
(
fromIntegral
(
maximum
curYMax
))))))
checkSizeLimit
_
_
_
(
Just
(
_
,
_
))
=
error
"minimization method not supported"
invariantFromAssignment
::
PopulationProtocol
->
Integer
->
IMap
Transition
->
[
IMap
State
]
->
(
TerminalMarkingReachable
Invariant
,
InvariantSize
)
invariantFromAssignment
::
PopulationProtocol
->
Integer
->
IMap
Transition
->
[
IMap
State
]
->
(
LayeredTermination
Invariant
,
InvariantSize
)
invariantFromAssignment
pp
k
b
ys
=
(
invariant
,
(
map
invariantLength
invariant
,
map
invariantMaxCoefficient
invariant
,
map
block
Size
invariant
))
(
invariant
,
(
map
invariantLength
invariant
,
map
invariantMaxCoefficient
invariant
,
map
layer
Size
invariant
))
where
invariant
=
[
Block
Invariant
(
i
,
M
.
keys
(
M
.
filter
(
==
i
)
b
),
makeVector
y
)
|
(
i
,
y
)
<-
zip
[
1
..
]
ys
]
invariantMaxCoefficient
(
Block
Invariant
(
_
,
_
,
yi
))
=
maximum
$
vals
yi
invariantLength
(
Block
Invariant
(
_
,
_
,
yi
))
=
size
yi
block
Size
(
Block
Invariant
(
_
,
ti
,
_
))
=
length
ti
invariant
=
[
Layer
Invariant
(
i
,
M
.
keys
(
M
.
filter
(
==
i
)
b
),
makeVector
y
)
|
(
i
,
y
)
<-
zip
[
1
..
]
ys
]
invariantMaxCoefficient
(
Layer
Invariant
(
_
,
_
,
yi
))
=
maximum
$
vals
yi
invariantLength
(
Layer
Invariant
(
_
,
_
,
yi
))
=
size
yi
layer
Size
(
Layer
Invariant
(
_
,
ti
,
_
))
=
length
ti
src/Solver/
TerminalMarkingsUnique
Consensus.hs
→
src/Solver/
Strong
Consensus.hs
View file @
c9113b43
{-# LANGUAGE FlexibleContexts #-}
module
Solver.
TerminalMarkingsUnique
Consensus
(
check
TerminalMarkingsUnique
ConsensusSat
,
TerminalMarkingsUnique
ConsensusCounterExample
,
module
Solver.
Strong
Consensus
(
check
Strong
ConsensusSat
,
Strong
ConsensusCounterExample
,
findTrapConstraintsSat
,
findUTrapConstraintsSat
,
findUSiphonConstraintsSat
,
...
...
@@ -19,7 +19,7 @@ import PopulationProtocol
import
Property
import
Solver
type
TerminalMarkingsUnique
ConsensusCounterExample
=
(
Marking
,
Marking
,
Marking
,
FiringVector
,
FiringVector
)
type
Strong
ConsensusCounterExample
=
(
Marking
,
Marking
,
Marking
,
FiringVector
,
FiringVector
)
type
StableInequality
=
(
IMap
State
,
Integer
)
...
...
@@ -96,9 +96,9 @@ checkInequalityConstraints :: PopulationProtocol -> SIMap State -> SIMap State -
checkInequalityConstraints
pp
m0
m1
m2
inequalities
=
bAnd
[
checkInequalityConstraint
pp
m0
m1
m2
i
|
i
<-
inequalities
]
check
TerminalMarkingsUnique
Consensus
::
PopulationProtocol
->
SIMap
State
->
SIMap
State
->
SIMap
State
->
SIMap
Transition
->
SIMap
Transition
->
check
Strong
Consensus
::
PopulationProtocol
->
SIMap
State
->
SIMap
State
->
SIMap
State
->
SIMap
Transition
->
SIMap
Transition
->
[
Trap
]
->
[
Siphon
]
->
[
StableInequality
]
->
SBool
check
TerminalMarkingsUnique
Consensus
pp
m0
m1
m2
x1
x2
utraps
usiphons
inequalities
=
check
Strong
Consensus
pp
m0
m1
m2
x1
x2
utraps
usiphons
inequalities
=
stateEquationConstraints
pp
m0
m1
x1
&&&
stateEquationConstraints
pp
m0
m2
x2
&&&
initialMarkingConstraints
pp
m0
&&&
...
...
@@ -114,8 +114,8 @@ checkTerminalMarkingsUniqueConsensus pp m0 m1 m2 x1 x2 utraps usiphons inequalit
checkUSiphonConstraints
pp
m0
m1
m2
x1
x2
usiphons
&&&
checkInequalityConstraints
pp
m0
m1
m2
inequalities
check
TerminalMarkingsUnique
ConsensusSat
::
PopulationProtocol
->
[
Trap
]
->
[
Siphon
]
->
[
StableInequality
]
->
ConstraintProblem
Integer
TerminalMarkingsUnique
ConsensusCounterExample
check
TerminalMarkingsUnique
ConsensusSat
pp
utraps
usiphons
inequalities
=
check
Strong
ConsensusSat
::
PopulationProtocol
->
[
Trap
]
->
[
Siphon
]
->
[
StableInequality
]
->
ConstraintProblem
Integer
Strong
ConsensusCounterExample
check
Strong
ConsensusSat
pp
utraps
usiphons
inequalities
=
let
m0
=
makeVarMap
$
states
pp
m1
=
makeVarMapWith
prime
$
states
pp
m2
=
makeVarMapWith
(
prime
.
prime
)
$
states
pp
...
...
@@ -123,10 +123,10 @@ checkTerminalMarkingsUniqueConsensusSat pp utraps usiphons inequalities =
x2
=
makeVarMapWith
prime
$
transitions
pp
in
(
"unique terminal marking"
,
"(m0, m1, m2, x1, x2)"
,
getNames
m0
++
getNames
m1
++
getNames
m2
++
getNames
x1
++
getNames
x2
,
\
fm
->
check
TerminalMarkingsUnique
Consensus
pp
(
fmap
fm
m0
)
(
fmap
fm
m1
)
(
fmap
fm
m2
)
(
fmap
fm
x1
)
(
fmap
fm
x2
)
utraps
usiphons
inequalities
,
\
fm
->
check
Strong
Consensus
pp
(
fmap
fm
m0
)
(
fmap
fm
m1
)
(
fmap
fm
m2
)
(
fmap
fm
x1
)
(
fmap
fm
x2
)
utraps
usiphons
inequalities
,
\
fm
->
markingsFromAssignment
(
fmap
fm
m0
)
(
fmap
fm
m1
)
(
fmap
fm
m2
)
(
fmap
fm
x1
)
(
fmap
fm
x2
))
markingsFromAssignment
::
IMap
State
->
IMap
State
->
IMap
State
->
IMap
Transition
->
IMap
Transition
->
TerminalMarkingsUnique
ConsensusCounterExample
markingsFromAssignment
::
IMap
State
->
IMap
State
->
IMap
State
->
IMap
Transition
->
IMap
Transition
->
Strong
ConsensusCounterExample
markingsFromAssignment
m0
m1
m2
x1
x2
=
(
makeVector
m0
,
makeVector
m1
,
makeVector
m2
,
makeVector
x1
,
makeVector
x2
)
...
...
Write
Preview