Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in
Toggle navigation
peregrine
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Locked Files
Requirements
Requirements
List
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Security & Compliance
Security & Compliance
Dependency List
License Compliance
Operations
Operations
Environments
Analytics
Analytics
CI / CD
Insights
Issue
Repository
Value Stream
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Jobs
Commits
Open sidebar
i7
peregrine
Commits
c9113b43
Commit
c9113b43
authored
May 02, 2017
by
Philipp Meyer
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Rename options and properties
parent
1809caa1
Changes
6
Hide whitespace changes
Inline
Side-by-side
Showing
6 changed files
with
129 additions
and
212 deletions
+129
-212
src/Main.hs
src/Main.hs
+43
-63
src/Options.hs
src/Options.hs
+20
-27
src/Parser/PP.hs
src/Parser/PP.hs
+9
-21
src/Property.hs
src/Property.hs
+12
-56
src/Solver/LayeredTermination.hs
src/Solver/LayeredTermination.hs
+35
-35
src/Solver/StrongConsensus.hs
src/Solver/StrongConsensus.hs
+10
-10
No files found.
src/Main.hs
View file @
c9113b43
...
@@ -21,8 +21,8 @@ import qualified Printer.DOT as DOTPrinter
...
@@ -21,8 +21,8 @@ import qualified Printer.DOT as DOTPrinter
import
Property
import
Property
import
StructuralComputation
import
StructuralComputation
import
Solver
import
Solver
import
Solver.
TerminalMarkingsUniqueConsensus
import
Solver.
LayeredTermination
import
Solver.
TerminalMarkingReachable
import
Solver.
StrongConsensus
writeFiles
::
String
->
PopulationProtocol
->
[
Property
]
->
OptIO
()
writeFiles
::
String
->
PopulationProtocol
->
[
Property
]
->
OptIO
()
writeFiles
basename
pp
props
=
do
writeFiles
basename
pp
props
=
do
...
@@ -47,9 +47,8 @@ checkFile file = do
...
@@ -47,9 +47,8 @@ checkFile file = do
format
<-
opt
inputFormat
format
<-
opt
inputFormat
let
parser
=
case
format
of
let
parser
=
case
format
of
InPP
->
PPParser
.
parseContent
InPP
->
PPParser
.
parseContent
(
pp
,
props
)
<-
liftIO
$
parseFile
parser
file
pp
<-
liftIO
$
parseFile
parser
file
implicitProperties
<-
opt
optProperties
props
<-
opt
optProperties
let
props'
=
props
++
map
(
makeImplicitProperty
pp
)
implicitProperties
verbosePut
1
$
"Analyzing "
++
showNetName
pp
verbosePut
1
$
"Analyzing "
++
showNetName
pp
verbosePut
2
$
verbosePut
2
$
"Number of states: "
++
show
(
length
(
states
pp
))
"Number of states: "
++
show
(
length
(
states
pp
))
...
@@ -65,33 +64,22 @@ checkFile file = do
...
@@ -65,33 +64,22 @@ checkFile file = do
output
<-
opt
optOutput
output
<-
opt
optOutput
case
output
of
case
output
of
Just
outputfile
->
Just
outputfile
->
writeFiles
outputfile
pp
props
'
writeFiles
outputfile
pp
props
Nothing
->
return
()
Nothing
->
return
()
-- TODO: short-circuit? parallel?
-- TODO: short-circuit? parallel?
rs
<-
mapM
(
checkProperty
pp
)
props
'
rs
<-
mapM
(
checkProperty
pp
)
props
verbosePut
0
""
verbosePut
0
""
return
$
resultsAnd
rs
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
::
PopulationProtocol
->
Property
->
OptIO
PropResult
checkProperty
pp
p
=
do
checkProperty
pp
prop
=
do
verbosePut
1
$
"
\n
Checking "
++
showPropertyName
p
verbosePut
1
$
"
\n
Checking "
++
show
prop
verbosePut
3
$
show
p
r
<-
case
prop
of
r
<-
case
pcont
p
of
Correctness
->
error
"not yet implemented"
-- (Safety pf) -> checkSafetyProperty pp pf
LayeredTermination
->
checkLayeredTermination
pp
-- (Liveness pf) -> checkLivenessProperty pp pf
StrongConsensus
->
checkStrongConsensus
pp
(
Constraint
pc
)
->
checkConstraintProperty
pp
pc
verbosePut
0
$
show
prop
++
" "
++
show
r
verbosePut
0
$
showPropertyName
p
++
" "
++
case
r
of
Satisfied
->
"is satisfied."
Unsatisfied
->
"is not satisfied."
Unknown
->
"may not be satisfied."
return
r
return
r
printInvariant
::
(
Show
a
,
Invariant
a
)
=>
(
Maybe
[
a
],
[
a
])
->
OptIO
PropResult
printInvariant
::
(
Show
a
,
Invariant
a
)
=>
(
Maybe
[
a
],
[
a
])
->
OptIO
PropResult
...
@@ -112,66 +100,60 @@ printInvariant (baseInvResult, addedInv) =
...
@@ -112,66 +100,60 @@ printInvariant (baseInvResult, addedInv) =
mapM_
(
putLine
.
show
)
addedInv
mapM_
(
putLine
.
show
)
addedInv
return
Satisfied
return
Satisfied
checkConstraintProperty
::
PopulationProtocol
->
ConstraintProperty
->
OptIO
PropResult
checkStrongConsensus
::
PopulationProtocol
->
OptIO
PropResult
checkConstraintProperty
pp
cp
=
checkStrongConsensus
pp
=
do
case
cp
of
r
<-
checkStrongConsensus'
pp
[]
[]
[]
TerminalMarkingsUniqueConsensusConstraint
->
checkTerminalMarkingsUniqueConsensusProperty
pp
TerminalMarkingReachableConstraint
->
checkTerminalMarkingReachableProperty
pp
checkTerminalMarkingsUniqueConsensusProperty
::
PopulationProtocol
->
OptIO
PropResult
checkTerminalMarkingsUniqueConsensusProperty
pp
=
do
r
<-
checkTerminalMarkingsUniqueConsensusProperty'
pp
[]
[]
[]
case
r
of
case
r
of
(
Nothing
,
_
,
_
,
_
)
->
return
Satisfied
(
Nothing
,
_
,
_
,
_
)
->
return
Satisfied
(
Just
_
,
_
,
_
,
_
)
->
return
Unknown
(
Just
_
,
_
,
_
,
_
)
->
return
Unknown
check
TerminalMarkingsUniqueConsensusProperty
'
::
PopulationProtocol
->
check
StrongConsensus
'
::
PopulationProtocol
->
[
Trap
]
->
[
Siphon
]
->
[
StableInequality
]
->
[
Trap
]
->
[
Siphon
]
->
[
StableInequality
]
->
OptIO
(
Maybe
TerminalMarkingsUnique
ConsensusCounterExample
,
[
Trap
],
[
Siphon
],
[
StableInequality
])
OptIO
(
Maybe
Strong
ConsensusCounterExample
,
[
Trap
],
[
Siphon
],
[
StableInequality
])
check
TerminalMarkingsUniqueConsensusProperty
'
pp
utraps
usiphons
inequalities
=
do
check
StrongConsensus
'
pp
utraps
usiphons
inequalities
=
do
r
<-
checkSat
$
check
TerminalMarkingsUnique
ConsensusSat
pp
utraps
usiphons
inequalities
r
<-
checkSat
$
check
Strong
ConsensusSat
pp
utraps
usiphons
inequalities
case
r
of
case
r
of
Nothing
->
return
(
Nothing
,
utraps
,
usiphons
,
inequalities
)
Nothing
->
return
(
Nothing
,
utraps
,
usiphons
,
inequalities
)
Just
c
->
do
Just
c
->
do
refine
<-
opt
optRefinementType
refine
<-
opt
optRefinementType
if
isJust
refine
then
if
isJust
refine
then
refine
TerminalMarkingsUniqueConsensusProperty
pp
utraps
usiphons
inequalities
c
refine
StrongConsensus
pp
utraps
usiphons
inequalities
c
else
else
return
(
Just
c
,
utraps
,
usiphons
,
inequalities
)
return
(
Just
c
,
utraps
,
usiphons
,
inequalities
)
refine
TerminalMarkingsUniqueConsensusProperty
::
PopulationProtocol
->
refine
StrongConsensus
::
PopulationProtocol
->
[
Trap
]
->
[
Siphon
]
->
[
StableInequality
]
->
TerminalMarkingsUnique
ConsensusCounterExample
->
[
Trap
]
->
[
Siphon
]
->
[
StableInequality
]
->
Strong
ConsensusCounterExample
->
OptIO
(
Maybe
TerminalMarkingsUnique
ConsensusCounterExample
,
[
Trap
],
[
Siphon
],
[
StableInequality
])
OptIO
(
Maybe
Strong
ConsensusCounterExample
,
[
Trap
],
[
Siphon
],
[
StableInequality
])
refine
TerminalMarkingsUniqueConsensusProperty
pp
utraps
usiphons
inequalities
c
@
(
m0
,
m1
,
m2
,
x1
,
x2
)
=
do
refine
StrongConsensus
pp
utraps
usiphons
inequalities
c
@
(
m0
,
m1
,
m2
,
x1
,
x2
)
=
do
r1
<-
checkSatMin
$
Solver
.
TerminalMarkingsUnique
Consensus
.
findTrapConstraintsSat
pp
m0
m1
m2
x1
x2
r1
<-
checkSatMin
$
Solver
.
Strong
Consensus
.
findTrapConstraintsSat
pp
m0
m1
m2
x1
x2
case
r1
of
case
r1
of
Nothing
->
do
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
case
r2
of
Nothing
->
do
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
case
r3
of
Nothing
->
return
(
Just
c
,
utraps
,
usiphons
,
inequalities
)
Nothing
->
return
(
Just
c
,
utraps
,
usiphons
,
inequalities
)
Just
utrap
->
Just
utrap
->
check
TerminalMarkingsUniqueConsensusProperty
'
pp
(
utrap
:
utraps
)
usiphons
inequalities
check
StrongConsensus
'
pp
(
utrap
:
utraps
)
usiphons
inequalities
Just
usiphon
->
Just
usiphon
->
check
TerminalMarkingsUniqueConsensusProperty
'
pp
utraps
(
usiphon
:
usiphons
)
inequalities
check
StrongConsensus
'
pp
utraps
(
usiphon
:
usiphons
)
inequalities
Just
trap
->
Just
trap
->
check
TerminalMarkingsUniqueConsensusProperty
'
pp
(
trap
:
utraps
)
usiphons
inequalities
check
StrongConsensus
'
pp
(
trap
:
utraps
)
usiphons
inequalities
check
TerminalMarkingReachableProperty
::
PopulationProtocol
->
OptIO
PropResult
check
LayeredTermination
::
PopulationProtocol
->
OptIO
PropResult
check
TerminalMarkingReachableProperty
pp
=
do
check
LayeredTermination
pp
=
do
let
nonTrivialTriplets
=
filter
(
not
.
trivialTriplet
)
$
generateTriplets
pp
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
LayeredTermination
'
::
PopulationProtocol
->
[
Triplet
]
->
Integer
->
Integer
->
OptIO
PropResult
check
TerminalMarkingReachableProperty
'
pp
triplets
k
kmax
=
do
check
LayeredTermination
'
pp
triplets
k
kmax
=
do
verbosePut
1
$
"Checking terminal marking reachable with at most "
++
show
k
++
" partitions"
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
case
r
of
Nothing
->
Nothing
->
if
k
<
kmax
then
if
k
<
kmax
then
check
TerminalMarkingReachableProperty
'
pp
triplets
(
k
+
1
)
kmax
check
LayeredTermination
'
pp
triplets
(
k
+
1
)
kmax
else
else
return
Unknown
return
Unknown
Just
inv
->
do
Just
inv
->
do
...
@@ -195,15 +177,13 @@ main = do
...
@@ -195,15 +177,13 @@ main = do
rs
<-
runReaderT
(
mapM
checkFile
files
)
opts'
rs
<-
runReaderT
(
mapM
checkFile
files
)
opts'
-- TODO: short-circuit with Control.Monad.Loops? parallel
-- TODO: short-circuit with Control.Monad.Loops? parallel
-- execution?
-- execution?
case
resultsAnd
rs
of
let
r
=
resultsAnd
rs
case
r
of
Satisfied
->
Satisfied
->
exitSuccessWith
"All properties satisfied."
exitSuccessWith
$
"All properties "
++
show
r
Unsatisfied
->
_
->
exitFailureWith
"Some properties are not satisfied"
exitFailureWith
$
"Some properties "
++
show
r
Unknown
->
exitFailureWith
"Some properties may not be satisfied."
-- TODO: Always exit with exit code 0 unless an error occured
exitSuccessWith
::
String
->
IO
()
exitSuccessWith
::
String
->
IO
()
exitSuccessWith
msg
=
do
exitSuccessWith
msg
=
do
putStrLn
msg
putStrLn
msg
...
...
src/Options.hs
View file @
c9113b43
...
@@ -2,7 +2,7 @@
...
@@ -2,7 +2,7 @@
module
Options
module
Options
(
InputFormat
(
..
),
OutputFormat
(
..
),
RefinementType
(
..
),
(
InputFormat
(
..
),
OutputFormat
(
..
),
RefinementType
(
..
),
ImplicitProperty
(
..
),
Options
(
..
),
startOptions
,
options
,
parseArgs
,
Options
(
..
),
startOptions
,
options
,
parseArgs
,
usageInformation
)
usageInformation
)
where
where
...
@@ -10,6 +10,8 @@ import Control.Applicative ((<$>))
...
@@ -10,6 +10,8 @@ import Control.Applicative ((<$>))
import
System.Console.GetOpt
import
System.Console.GetOpt
import
System.Environment
(
getArgs
)
import
System.Environment
(
getArgs
)
import
Property
(
Property
(
..
))
data
InputFormat
=
InPP
deriving
(
Read
)
data
InputFormat
=
InPP
deriving
(
Read
)
data
OutputFormat
=
OutDOT
deriving
(
Read
)
data
OutputFormat
=
OutDOT
deriving
(
Read
)
...
@@ -18,10 +20,6 @@ instance Show InputFormat where
...
@@ -18,10 +20,6 @@ instance Show InputFormat where
instance
Show
OutputFormat
where
instance
Show
OutputFormat
where
show
OutDOT
=
"DOT"
show
OutDOT
=
"DOT"
data
ImplicitProperty
=
TerminalMarkingsUniqueConsensus
|
TerminalMarkingReachable
deriving
(
Show
,
Read
)
data
RefinementType
=
TrapRefinement
data
RefinementType
=
TrapRefinement
|
SiphonRefinement
|
SiphonRefinement
|
UTrapRefinement
|
UTrapRefinement
...
@@ -32,12 +30,11 @@ data Options = Options { inputFormat :: InputFormat
...
@@ -32,12 +30,11 @@ data Options = Options { inputFormat :: InputFormat
,
optVerbosity
::
Int
,
optVerbosity
::
Int
,
optShowHelp
::
Bool
,
optShowHelp
::
Bool
,
optShowVersion
::
Bool
,
optShowVersion
::
Bool
,
optProperties
::
[
Implicit
Property
]
,
optProperties
::
[
Property
]
,
optRefinementType
::
Maybe
[
RefinementType
]
,
optRefinementType
::
Maybe
[
RefinementType
]
,
optMinimizeRefinement
::
Int
,
optMinimizeRefinement
::
Int
,
optSMTAuto
::
Bool
,
optSMTAuto
::
Bool
,
optInvariant
::
Bool
,
optInvariant
::
Bool
,
optBoolConst
::
Bool
,
optOutput
::
Maybe
String
,
optOutput
::
Maybe
String
,
outputFormat
::
OutputFormat
,
outputFormat
::
OutputFormat
,
optUseProperties
::
Bool
,
optUseProperties
::
Bool
...
@@ -54,7 +51,6 @@ startOptions = Options { inputFormat = InPP
...
@@ -54,7 +51,6 @@ startOptions = Options { inputFormat = InPP
,
optMinimizeRefinement
=
0
,
optMinimizeRefinement
=
0
,
optSMTAuto
=
True
,
optSMTAuto
=
True
,
optInvariant
=
False
,
optInvariant
=
False
,
optBoolConst
=
False
,
optOutput
=
Nothing
,
optOutput
=
Nothing
,
outputFormat
=
OutDOT
,
outputFormat
=
OutDOT
,
optUseProperties
=
True
,
optUseProperties
=
True
...
@@ -63,35 +59,22 @@ startOptions = Options { inputFormat = InPP
...
@@ -63,35 +59,22 @@ startOptions = Options { inputFormat = InPP
options
::
[
OptDescr
(
Options
->
Either
String
Options
)
]
options
::
[
OptDescr
(
Options
->
Either
String
Options
)
]
options
=
options
=
[
Option
""
[
"pp"
]
[
Option
""
[
"layered-termination"
]
(
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"
]
(
NoArg
(
\
opt
->
Right
opt
{
(
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
{
(
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"
]
,
Option
"i"
[
"invariant"
]
(
NoArg
(
\
opt
->
Right
opt
{
optInvariant
=
True
}))
(
NoArg
(
\
opt
->
Right
opt
{
optInvariant
=
True
}))
"Generate an invariant"
"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"
]
,
Option
"r"
[
"refinement"
]
(
ReqArg
(
\
arg
opt
->
(
ReqArg
(
\
arg
opt
->
let
addRef
ref
=
let
addRef
ref
=
...
@@ -111,6 +94,16 @@ options =
...
@@ -111,6 +94,16 @@ options =
"METHOD"
)
"METHOD"
)
(
"Refine with METHOD (trap, siphon, utrap, usiphon)"
)
(
"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"
]
,
Option
"o"
[
"output"
]
(
ReqArg
(
\
arg
opt
->
Right
opt
{
(
ReqArg
(
\
arg
opt
->
Right
opt
{
optOutput
=
Just
arg
optOutput
=
Just
arg
...
...
src/Parser/PP.hs
View file @
c9113b43
...
@@ -187,29 +187,17 @@ formAtom = try linIneq
...
@@ -187,29 +187,17 @@ formAtom = try linIneq
formula
::
Parser
(
Formula
String
)
formula
::
Parser
(
Formula
String
)
formula
=
buildExpressionParser
formOperatorTable
formAtom
<?>
"formula"
formula
=
buildExpressionParser
formOperatorTable
formAtom
<?>
"formula"
propertyType
::
Parser
PropertyType
predicate
::
Parser
(
Formula
PopulationProtocol
.
State
)
propertyType
=
predicate
=
do
(
reserved
"safety"
*>
return
SafetyType
)
<|>
reserved
"predicate"
(
reserved
"liveness"
*>
return
LivenessType
)
property
::
Parser
Property
property
=
do
pt
<-
propertyType
reserved
"property"
name
<-
option
""
ident
name
<-
option
""
ident
case
pt
of
form
<-
braces
formula
SafetyType
->
do
return
(
fmap
PopulationProtocol
.
State
form
)
form
<-
braces
formula
return
Property
parseContent
::
Parser
PopulationProtocol
{
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
])
parseContent
=
do
parseContent
=
do
whiteSpace
whiteSpace
pp
<-
populationProtocol
pp
<-
populationProtocol
properties
<-
many
property
-- properties <- many predicate
eof
eof
return
(
pp
,
properties
)
return
pp
src/Property.hs
View file @
c9113b43
...
@@ -2,11 +2,6 @@
...
@@ -2,11 +2,6 @@
module
Property
module
Property
(
Property
(
..
),
(
Property
(
..
),
showPropertyName
,
renameProperty
,
PropertyType
(
..
),
PropertyContent
(
..
),
ConstraintProperty
(
..
),
Formula
(
..
),
Formula
(
..
),
Op
(
..
),
Op
(
..
),
Term
(
..
),
Term
(
..
),
...
@@ -18,8 +13,6 @@ module Property
...
@@ -18,8 +13,6 @@ module Property
resultsOr
)
resultsOr
)
where
where
import
PopulationProtocol
data
Term
a
=
data
Term
a
=
Var
a
Var
a
|
Const
Integer
|
Const
Integer
...
@@ -84,58 +77,21 @@ instance Functor Formula where
...
@@ -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
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
Property
=
Correctness
|
LayeredTermination
data
PropertyType
=
SafetyType
|
StrongConsensus
|
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
showPropertyType
::
PropertyContent
->
String
instance
Show
Property
where
showPropertyType
(
Safety
_
)
=
"safety"
show
Correctness
=
"correctness"
showPropertyType
(
Liveness
_
)
=
"liveness"
show
LayeredTermination
=
"layered termination"
showPropertyType
(
Constraint
_
)
=
"constraint"
show
StrongConsensus
=
"strong consensus"
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
++
")"
data
Property
=
Property
{
data
PropResult
=
Satisfied
|
Unsatisfied
|
Unknown
deriving
(
Eq
)
pname
::
String
,
pcont
::
PropertyContent
}
instance
Show
Property
where
instance
Show
PropResult
where
show
p
=
show
Satisfied
=
"satisfied"
showPropertyName
p
++
show
Unsatisfied
=
"not satisfied"
" { "
++
showPropertyContent
(
pcont
p
)
++
" }"
show
Unknown
=
"may not be satisfied"
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
)
resultAnd
::
PropResult
->
PropResult
->
PropResult
resultAnd
::
PropResult
->
PropResult
->
PropResult
resultAnd
Satisfied
x
=
x
resultAnd
Satisfied
x
=
x
...
...
src/Solver/
TerminalMarkingReachable
.hs
→
src/Solver/
LayeredTermination
.hs
View file @
c9113b43
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleContexts #-}
module
Solver.
TerminalMarkingReachable
module
Solver.
LayeredTermination
(
check
TerminalMarkingReachable
Sat
,
(
check
LayeredTermination
Sat
,
TerminalMarkingReachable
Invariant
)
LayeredTermination
Invariant
)
where
where
import
Data.SBV
import
Data.SBV
...
@@ -17,15 +17,15 @@ import StructuralComputation
...
@@ -17,15 +17,15 @@ import StructuralComputation
type
InvariantSize
=
([
Int
],
[
Integer
],
[
Int
])
type
InvariantSize
=
([
Int
],
[
Integer
],
[
Int
])
type
TerminalMarkingReachableInvariant
=
[
Block
Invariant
]
type
LayeredTerminationInvariant
=
[
Layer
Invariant
]
data
Block
Invariant
=
data
Layer
Invariant
=
Block
Invariant
(
Integer
,
[
Transition
],
IVector
State
)
Layer
Invariant
(
Integer
,
[
Transition
],
IVector
State
)
instance
Invariant
Block
Invariant
where
instance
Invariant
Layer
Invariant
where
invariantSize
(
Block
Invariant
(
_
,
ti
,
yi
))
=
if
null
ti
then
0
else
size
yi
invariantSize
(
Layer
Invariant
(
_
,
ti
,
yi
))
=
if
null
ti
then
0
else
size
yi
instance
Show
Block
Invariant
where
instance
Show
Layer
Invariant
where
show
(
Block
Invariant
(
i
,
ti
,
yi
))
=
show
(
Layer
Invariant
(
i
,
ti
,
yi
))
=
"T_"
++
show
i
++
":
\n
"
++
unlines
(
map
show
ti
)
++
"T_"
++
show
i
++
":
\n
"
++
unlines
(
map
show
ti
)
++
(
if
null
ti
then
""
else
"
\n
Y_"
++
show
i
++
": "
++
intercalate
" + "
(
map
showWeighted
(
items
yi
))
++
"
\n
"
)
(
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
...
@@ -38,8 +38,8 @@ checkNonNegativityConstraints :: (Ord a, Show a) => [SIMap a] -> SBool
checkNonNegativityConstraints
xs
=
checkNonNegativityConstraints
xs
=
bAnd
$
map
nonNegativityConstraints
xs
bAnd
$
map
nonNegativityConstraints
xs
block
TerminationConstraints
::
PopulationProtocol
->
Integer
->
SIMap
Transition
->
SIMap
State
->
SBool
layer
TerminationConstraints
::
PopulationProtocol
->
Integer
->
SIMap
Transition
->
SIMap
State
->
SBool
block
TerminationConstraints
pp
i
b
y
=
layer
TerminationConstraints
pp
i
b
y
=
bAnd
$
map
checkTransition
$
transitions
pp
bAnd
$
map
checkTransition
$
transitions
pp
where
checkTransition
t
=
where
checkTransition
t
=
let
incoming
=
map
addState
$
lpre
pp
t
let
incoming
=
map
addState
$
lpre
pp
t
...
@@ -49,46 +49,46 @@ blockTerminationConstraints pp i b y =
...
@@ -49,46 +49,46 @@ blockTerminationConstraints pp i b y =
terminationConstraints
::
PopulationProtocol
->
Integer
->
SIMap
Transition
->
[
SIMap
State
]
->
SBool
terminationConstraints
::
PopulationProtocol
->
Integer
->
SIMap
Transition
->
[
SIMap
State
]
->
SBool
terminationConstraints
pp
k
b
ys
=
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
layer
Constraints
::
PopulationProtocol
->
Integer
->
SIMap
Transition
->
SBool
block
Constraints
pp
k
b
=
layer
Constraints
pp
k
b
=
bAnd
$
map
check
Block
$
transitions
pp
bAnd
$
map
check
Layer
$
transitions
pp
where
check
Block
t
=
literal
1
.<=
val
b
t
&&&
val
b
t
.<=
literal
k
where
check
Layer
t
=
literal
1
.<=
val
b
t
&&&
val
b
t
.<=
literal
k
block
OrderConstraints
::
PopulationProtocol
->
[
Triplet
]
->
Integer
->
SIMap
Transition
->
SBool
layer
OrderConstraints
::
PopulationProtocol
->
[
Triplet
]
->
Integer
->
SIMap
Transition
->
SBool
block
OrderConstraints
pp
triplets
k
b
=
layer
OrderConstraints
pp
triplets
k
b
=
bAnd
$
map
checkTriplet
triplets
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
)
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
LayeredTermination
::
PopulationProtocol
->
[
Triplet
]
->
Integer
->
SIMap
Transition
->
[
SIMap
State
]
->
Maybe
(
Int
,
InvariantSize
)
->
SBool
check
TerminalMarkingReachable
pp
triplets
k
b
ys
sizeLimit
=