Notice to GitKraken users: A vulnerability has been found in the SSH key generation of GitKraken versions 7.6.0 to 8.0.0 (https://www.gitkraken.com/blog/weak-ssh-key-fix). If you use GitKraken and have generated a SSH key using one of these versions, please remove it both from your local workstation and from your LRZ GitLab profile.

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

Commit 3c4fd698 authored by Philipp Meyer's avatar Philipp Meyer
Browse files

Rewrote trap constraints

parent 6456c0fb
......@@ -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
{-
......
......@@ -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 = buildMarking initial,
ghostTransitions = gs
}
......
{-# 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)
--mVal,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
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,
markedPlacesFromAssignment net m)
markingFromAssignment 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)
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
module Util
(verbosePut)
where
import Control.Monad
verbosePut :: Int -> Int -> String -> IO ()
verbosePut verbosity level str =
when (verbosity >= level) (putStrLn str)
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