2.12.2021, 9:00 - 11:00: Due to updates GitLab may be unavailable for some minutes between 09:00 and 11:00.

Commit 5d587025 authored by Philipp J. Meyer's avatar Philipp J. Meyer
Browse files

Added trap refinement constraints to unique terminal marking constraints

parent 01e1cc92
...@@ -441,13 +441,43 @@ checkStructuralProperty net struct = ...@@ -441,13 +441,43 @@ checkStructuralProperty net struct =
return Unsatisfied return Unsatisfied
checkConstraintProperty :: PetriNet -> ConstraintProperty -> OptIO PropResult checkConstraintProperty :: PetriNet -> ConstraintProperty -> OptIO PropResult
checkConstraintProperty net cp = do checkConstraintProperty net cp =
let c = case cp of case cp of
UniqueTerminalMarkingConstraint -> checkUniqueTerminalMarkingSat UniqueTerminalMarkingConstraint -> checkUniqueTerminalMarkingProperty net
r <- checkSat $ c net
checkUniqueTerminalMarkingProperty :: PetriNet -> OptIO PropResult
checkUniqueTerminalMarkingProperty net = do
r <- checkUniqueTerminalMarkingProperty' net []
case r of
(Nothing, _) -> return Satisfied
(Just _, _) -> return Unknown
checkUniqueTerminalMarkingProperty' :: PetriNet ->
[Trap] -> OptIO (Maybe (Marking, Marking, Marking, FiringVector, FiringVector), [Trap])
checkUniqueTerminalMarkingProperty' net traps = do
r <- checkSat $ checkUniqueTerminalMarkingSat net traps
case r of case r of
Nothing -> return Satisfied Nothing -> return (Nothing, traps)
Just _ -> return Unknown Just m -> do
refine <- opt optRefinementType
if isJust refine then
refineUniqueTerminalMarkingProperty net traps m
else
return (Just m, traps)
refineUniqueTerminalMarkingProperty :: PetriNet ->
[Trap] -> (Marking, Marking, Marking, FiringVector, FiringVector) -> OptIO (Maybe (Marking, Marking, Marking, FiringVector, FiringVector), [Trap])
refineUniqueTerminalMarkingProperty net traps m@(m0, m1, m2, x1, x2) = do
r1 <- checkSat $ checkUnmarkedTrapSat net m0 m1 x1
case r1 of
Nothing -> do
r2 <- checkSat $ checkUnmarkedTrapSat net m0 m2 x2
case r2 of
Nothing -> return (Just m, traps)
Just trap ->
checkUniqueTerminalMarkingProperty' net (trap:traps)
Just trap ->
checkUniqueTerminalMarkingProperty' net (trap:traps)
main :: IO () main :: IO ()
main = do main = do
......
{-# LANGUAGE FlexibleContexts #-}
module Solver.UniqueTerminalMarking module Solver.UniqueTerminalMarking
(checkUniqueTerminalMarkingSat) (checkUniqueTerminalMarkingSat,
checkUnmarkedTrapSat)
where where
import Data.SBV import Data.SBV
import qualified Data.Map as M
import Util import Util
import PetriNet import PetriNet
...@@ -10,50 +14,111 @@ import Property ...@@ -10,50 +14,111 @@ import Property
import Solver import Solver
stateEquationConstraints :: PetriNet -> SIMap Place -> SIMap Place -> SIMap Transition -> SBool stateEquationConstraints :: PetriNet -> SIMap Place -> SIMap Place -> SIMap Transition -> SBool
stateEquationConstraints net m1 m2 x = stateEquationConstraints net m0 m x =
bAnd $ map checkStateEquation $ places net bAnd $ map checkStateEquation $ places net
where checkStateEquation p = where checkStateEquation p =
let incoming = map addTransition $ lpre net p let incoming = map addTransition $ lpre net p
outgoing = map addTransition $ lpost net p outgoing = map addTransition $ lpost net p
in val m1 p + sum incoming - sum outgoing .== val m2 p in val m0 p + sum incoming - sum outgoing .== val m p
addTransition (t,w) = literal w * val x t addTransition (t,w) = literal w * val x t
nonNegativityConstraints :: PetriNet -> SIMap Place -> SBool nonNegativityConstraints :: (Ord a, Show a) => SIMap a -> SBool
nonNegativityConstraints net m = nonNegativityConstraints m =
bAnd $ map checkVal $ places net bAnd $ map checkVal $ vals m
where checkVal p = val m p .>= 0 where checkVal x = x .>= 0
terminalConstraints :: PetriNet -> SIMap Place -> SBool terminalConstraints :: PetriNet -> SIMap Place -> SBool
terminalConstraints net m = terminalConstraints net m =
bAnd $ map checkTransition $ transitions net bAnd $ map checkTransition $ transitions net
where checkTransition :: Transition -> SBool where checkTransition t = bOr $ map checkPlace $ lpre net t
checkTransition t = bOr $ map checkPlace $ lpre net t
checkPlace (p,w) = val m p .< literal w checkPlace (p,w) = val m p .< literal w
nonEqualityConstraints :: PetriNet -> SIMap Place -> SIMap Place -> SBool nonEqualityConstraints :: (Ord a, Show a) => PetriNet -> SIMap a -> SIMap a -> SBool
nonEqualityConstraints net m1 m2 = nonEqualityConstraints net m1 m2 =
bOr $ map checkNonEquality $ places net if elemsSet m1 /= elemsSet m2 then
where checkNonEquality p = val m1 p ./= val m2 p false
else
bOr $ map checkNonEquality $ elems m1
where checkNonEquality x = val m1 x ./= val m2 x
checkTrap :: PetriNet -> SIMap Place -> SIMap Place -> SIMap Place -> SIMap Transition -> SIMap Transition -> Trap -> SBool
checkTrap net m0 m1 m2 x1 x2 trap =
checkMarkingDelta m0 m1 &&&
checkMarkingDelta m0 m2 &&&
checkSequenceDelta x1 m1 &&&
checkSequenceDelta x2 m2
where checkMarkingDelta m0 m =
sum (map (val m0) trap) .>= 1 ==> sum (map (val m) trap) .>= 1
checkSequenceDelta x m =
sum (map (val x) (mpre net trap)) .>= 1 ==> sum (map (val m) trap) .>= 1
checkTrapConstraints :: PetriNet -> SIMap Place -> SIMap Place -> SIMap Place -> SIMap Transition -> SIMap Transition -> [Trap] -> SBool
checkTrapConstraints net m0 m1 m2 x1 x2 traps =
bAnd $ map (checkTrap net m0 m1 m2 x1 x2) traps
checkUniqueTerminalMarking :: PetriNet -> SIMap Place -> SIMap Place -> SIMap Transition -> SBool checkUniqueTerminalMarking :: PetriNet -> SIMap Place -> SIMap Place -> SIMap Place -> SIMap Transition -> SIMap Transition -> [Trap] -> SBool
checkUniqueTerminalMarking net m1 m2 x = checkUniqueTerminalMarking net m0 m1 m2 x1 x2 traps =
nonEqualityConstraints net m1 m2 &&& nonEqualityConstraints net m1 m2 &&&
stateEquationConstraints net m1 m2 x &&& stateEquationConstraints net m0 m1 x1 &&&
nonNegativityConstraints net m1 &&& stateEquationConstraints net m0 m2 x2 &&&
nonNegativityConstraints net m2 &&& nonNegativityConstraints m0 &&&
nonNegativityConstraints m1 &&&
nonNegativityConstraints m2 &&&
nonNegativityConstraints x1 &&&
nonNegativityConstraints x2 &&&
terminalConstraints net m1 &&& terminalConstraints net m1 &&&
terminalConstraints net m2 terminalConstraints net m2 &&&
checkTrapConstraints net m0 m1 m2 x1 x2 traps
checkUniqueTerminalMarkingSat :: PetriNet -> [Trap] -> ConstraintProblem Integer (Marking, Marking, Marking, FiringVector, FiringVector)
checkUniqueTerminalMarkingSat net traps =
let m0 = makeVarMap $ places net
m1 = makeVarMapWith prime $ places net
m2 = makeVarMapWith (prime . prime) $ places net
x1 = makeVarMap $ transitions net
x2 = makeVarMapWith prime $ transitions net
in ("unique terminal marking", "(m0, m1, m2, x1, x2)",
getNames m0 ++ getNames m1 ++ getNames m2 ++ getNames x1 ++ getNames x2,
\fm -> checkUniqueTerminalMarking net (fmap fm m0) (fmap fm m1) (fmap fm m2) (fmap fm x1) (fmap fm x2) traps,
\fm -> markingsFromAssignment (fmap fm m0) (fmap fm m1) (fmap fm m2) (fmap fm x1) (fmap fm x2))
markingsFromAssignment :: IMap Place -> IMap Place -> IMap Place -> IMap Transition -> IMap Transition -> (Marking, Marking, Marking, FiringVector, FiringVector)
markingsFromAssignment m0 m1 m2 x1 x2 = (makeVector m0, makeVector m1, makeVector m2, makeVector x1, makeVector x2)
-- trap refinement constraints
trapConstraints :: PetriNet -> SBMap 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))
trapMarkedByMarking :: PetriNet -> Marking -> SBMap Place -> SBool
trapMarkedByMarking net m b = bOr $ mval b $ elems m
trapMarkedBySequence :: PetriNet -> FiringVector -> SBMap Place -> SBool
trapMarkedBySequence net x b = bOr $ mval b $ mpost net $ elems x
trapUnassigned :: Marking -> SBMap Place -> SBool
trapUnassigned m b = bAnd $ map (bnot . val b) $ elems m
properTrap :: SBMap Place -> SBool
properTrap b = bOr $ vals b
checkUniqueTerminalMarkingSat :: PetriNet -> ConstraintProblem Integer (Marking, Marking, FiringVector) checkUnmarkedTrap :: PetriNet -> Marking -> Marking -> FiringVector -> SBMap Place -> SBool
checkUniqueTerminalMarkingSat net = checkUnmarkedTrap net m0 m x b =
let m1 = makeVarMap $ places net trapConstraints net b &&&
m2 = makeVarMapWith prime $ places net (trapMarkedByMarking net m0 b ||| trapMarkedBySequence net x b) &&&
x = makeVarMap $ transitions net trapUnassigned m b &&&
in ("unique terminal marking", "pair of markings and firing vector", properTrap b
getNames m1 ++ getNames m2 ++ getNames x,
\fm -> checkUniqueTerminalMarking net (fmap fm m1) (fmap fm m2) (fmap fm x),
\fm -> markingsFromAssignment (fmap fm m1) (fmap fm m2) (fmap fm x))
markingsFromAssignment :: IMap Place -> IMap Place -> IMap Transition -> (Marking, Marking, FiringVector) checkUnmarkedTrapSat :: PetriNet -> Marking -> Marking -> FiringVector -> ConstraintProblem Bool Trap
markingsFromAssignment m1 m2 x = (makeVector m1, makeVector m2, makeVector x) checkUnmarkedTrapSat net m0 m x =
let b = makeVarMap $ places net
in ("unmarked trap marked by sequence or initial marking", "trap",
getNames b,
\fm -> checkUnmarkedTrap net m0 m x (fmap fm b),
\fm -> trapFromAssignment (fmap fm b))
trapFromAssignment :: BMap Place -> Trap
trapFromAssignment b = M.keys $ M.filter id b
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies #-}
module Util module Util
(elems,items,size,emap,prime,numPref, (elems,elemsSet,items,size,emap,prime,numPref,
listSet,listMap,val,vals,mval,zeroVal,positiveVal,sumVal, listSet,listMap,val,vals,mval,zeroVal,positiveVal,sumVal,
makeVarMap,makeVarMapWith,buildVector,makeVector,getNames, makeVarMap,makeVarMapWith,buildVector,makeVector,getNames,
Vector,Model,VarMap,SIMap,SBMap,IMap,BMap,showWeighted, Vector,Model,VarMap,SIMap,SBMap,IMap,BMap,showWeighted,
...@@ -10,6 +10,7 @@ where ...@@ -10,6 +10,7 @@ where
import Data.SBV import Data.SBV
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Set as S
import Data.List import Data.List
import Data.Ord import Data.Ord
import Data.Function import Data.Function
...@@ -36,6 +37,7 @@ class MapLike c a b | c -> a, c -> b where ...@@ -36,6 +37,7 @@ class MapLike c a b | c -> a, c -> b where
val :: c -> a -> b val :: c -> a -> b
vals :: c -> [b] vals :: c -> [b]
elems :: c -> [a] elems :: c -> [a]
elemsSet :: c -> S.Set a
items :: c -> [(a,b)] items :: c -> [(a,b)]
size :: c -> Int size :: c -> Int
...@@ -51,6 +53,7 @@ instance (Ord a, Show a, Show b) => MapLike (M.Map a b) a b where ...@@ -51,6 +53,7 @@ instance (Ord a, Show a, Show b) => MapLike (M.Map a b) a b where
vals = M.elems vals = M.elems
items = M.toList items = M.toList
elems = M.keys elems = M.keys
elemsSet = M.keysSet
size = M.size size = M.size
instance (Ord a, Show a) => MapLike (Vector a) a Integer where instance (Ord a, Show a) => MapLike (Vector a) a Integer where
...@@ -58,6 +61,7 @@ instance (Ord a, Show a) => MapLike (Vector a) a Integer where ...@@ -58,6 +61,7 @@ instance (Ord a, Show a) => MapLike (Vector a) a Integer where
vals = vals . getVector vals = vals . getVector
items = M.toList . getVector items = M.toList . getVector
elems = M.keys . getVector elems = M.keys . getVector
elemsSet = M.keysSet . getVector
size = M.size . getVector size = M.size . getVector
instance (Show a) => Show (Vector a) where instance (Show a) => Show (Vector a) where
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment