The name of the initial branch for new projects is now "main" instead of "master". Existing projects remain unchanged. More information: https://doku.lrz.de/display/PUBLIC/GitLab

Commit 30287c06 authored by Philipp Meyer's avatar Philipp Meyer
Browse files

Used Z3 API for trap constraints

parent 6a216738
......@@ -24,6 +24,9 @@ import qualified Printer.SARA as SARAPrinter
import Property
import Solver
import Solver.StateEquation
import Solver.TrapConstraints
--import Solver.TransitionInvariant
--import Solver.SComponent
data InputFormat = PNET | LOLA | TPN | MIST deriving (Show,Read)
......@@ -221,7 +224,7 @@ transformNet (net, props) TerminationByReachability =
ps = ["'sigma", "'m1", "'m2"] ++
places net ++ map prime (places net)
is = [("'m1", 1)] ++
initials net ++ map (first prime) (initials net)
linitials net ++ map (first prime) (linitials net)
transformTransition t =
let (preT, postT) = context net t
pre' = [("'m1",1)] ++ preT ++ map (first prime) preT
......@@ -245,7 +248,7 @@ transformNet (net, props) TerminationByReachability =
transformNet (net, props) ValidateIdentifiers =
let ps = map validateId $ places net
ts = map validateId $ transitions net
is = map (first validateId) $ initials net
is = map (first validateId) $ linitials net
as = map (\(a,b,x) -> (validateId a, validateId b, x)) $ arcs net
gs = map validateId $ ghostTransitions net
net' = makePetriNet (name net) ps ts as is gs
......@@ -289,6 +292,7 @@ checkProperty verbosity net refine p = do
verbosePut verbosity 3 $ show p
r <- case ptype p of
Safety -> checkSafetyProperty verbosity net refine (pformula p) []
Liveness -> checkLivenessProperty verbosity net refine (pformula p) []
verbosePut verbosity 0 $ showPropertyName p ++
if r then " is satisfied."
else " may not be satisfied."
......@@ -305,7 +309,51 @@ checkSafetyProperty verbosity net refine f traps = do
verbosePut verbosity 1 "Assignment found"
verbosePut verbosity 2 $ "Places marked: " ++ show assigned
verbosePut verbosity 3 $ "Assignment: " ++ show a
return False
if refine then do
rt <- checkSatBool $ checkTrapSat net assigned
case rt of
Nothing -> do
verbosePut verbosity 1 "No trap found."
return False
Just at -> do
let trap = trapFromAssignment at
verbosePut verbosity 1 "Trap found"
verbosePut verbosity 2 $ "Places in trap: " ++
show trap
verbosePut verbosity 3 $ "Trap assignment: " ++
show at
checkSafetyProperty verbosity net refine f
(trap:traps)
else
return False
checkLivenessProperty :: Int -> PetriNet -> Bool ->
Formula -> [([String],[String])] -> IO Bool
checkLivenessProperty verbosity net refine f strans = do
r <- return Nothing -- checkSatInt $ checkTransitionInvariantSat net f strans
case r of
Nothing -> return True
Just ax -> do
let fired = [] -- firedTransitionsFromAssignment ax
verbosePut verbosity 1 "Assignment found"
-- verbosePut verbosity 2 $ "Transitions fired: " ++ show fired
-- verbosePut verbosity 3 $ "Assignment: " ++ show ax
if refine then do
rt <- return Nothing -- checkSat $ checkSComponentSat net fired ax
case rt of
Nothing -> do
verbosePut verbosity 1 "No S-component found"
return False
Just as -> do
let sOutIn = undefined -- getSComponentOutIn net ax as
-- verbosePut verbosity 1 "S-component found"
-- verbosePut verbosity 2 $ "Out/In: " ++ show sOutIn
-- verbosePut verbosity 3 $ "S-Component assignment: " ++
-- show as
checkLivenessProperty verbosity net refine f
(sOutIn:strans)
else
return False
main :: IO ()
main = do
......
......@@ -2,7 +2,7 @@
module PetriNet
(PetriNet,name,showNetName,places,transitions,initial,
pre,lpre,post,lpost,initials,context,arcs,ghostTransitions,
pre,lpre,post,lpost,initials,linitials,context,arcs,ghostTransitions,
makePetriNet,makePetriNetWithTrans)
where
......@@ -39,8 +39,11 @@ post net = map fst . snd . context net
lpost :: PetriNet -> String -> [(String, Integer)]
lpost net = snd . context net
initials :: PetriNet -> [(String,Integer)]
initials net = M.toList (initMap net)
initials :: PetriNet -> [String]
initials net = M.keys (initMap net)
linitials :: PetriNet -> [(String,Integer)]
linitials net = M.toList (initMap net)
showNetName :: PetriNet -> String
showNetName net = "Petri net" ++
......
......@@ -18,7 +18,7 @@ renderNet net =
ps = "PLACE " <> intercalate ","
(map stringUtf8 (places net)) <> ";\n"
is = "MARKING " <> intercalate ","
(map showWeight (initials net)) <> ";\n"
(map showWeight (linitials net)) <> ";\n"
makeTransition t =
let (preT,postT) = context net t
preS = "CONSUME " <> intercalate ","
......
......@@ -50,7 +50,7 @@ renderProperty filename net (Property propname Safety f) =
"FILE " <> stringUtf8 (reverse (takeWhile (/='/') (reverse filename)))
<> " TYPE LOLA;\n" <>
"INITIAL " <> intercalate ","
(map (\(p,i) -> stringUtf8 p <> ":" <> integerDec i) (initials net))
(map (\(p,i) -> stringUtf8 p <> ":" <> integerDec i) (linitials net))
<> ";\n" <>
"FINAL COVER;\n" <>
"CONSTRAINTS " <> renderFormula f <> ";"
......
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
module Solver
(checkSat,checkSatInt,MModelS,MModelI,MModelB,
MModel(..),mVal,mValues,mElemsWith,mElemSum,CModel(..))
(checkSat,checkSatInt,checkSatBool,MModelS,MModelI,MModelB,
MModel(..),mVal,mValues,mElemsWith,mElemSum,CModel(..),
Z3Type(..),mkOr',mkAnd')
where
import Z3.Monad
import qualified Data.Map as M
import Control.Monad
import qualified Data.Map as M
newtype MModel a = MModel { getMap :: M.Map String a }
......@@ -16,15 +17,22 @@ instance Show a => Show (MModel a) where
type MModelS = MModel AST
type MModelI = MModel Integer
type MModelB = MModel Bool
type MModelB = MModel (Maybe Bool)
class Z3Type a where
mkConcrete :: a -> Z3 AST
getConcrete :: AST -> Z3 a
mkVal :: a -> Z3 AST -- TODO: needed?
getVal :: AST -> Z3 a
instance Z3Type Integer where
mkConcrete = mkInt
getConcrete = getInt
mkVal = mkInt
getVal = getInt
instance Z3Type (Maybe Bool) where
mkVal x = case x of
Nothing -> error "can not make undefined constant"
Just True -> mkTrue
Just False -> mkFalse
getVal = getBool
mVal :: MModel a -> String -> a
mVal m x = M.findWithDefault (error ("key not found: " ++ x)) x (getMap m)
......@@ -38,6 +46,14 @@ mElemsWith f m = M.keys $ M.filter f $ getMap m
mElemSum :: (Num a) => MModel a -> [String] -> a
mElemSum m xs = sum $ map (mVal m) xs
mkOr' :: [AST] -> Z3 AST
mkOr' [] = mkFalse
mkOr' xs = mkOr xs
mkAnd' :: [AST] -> Z3 AST
mkAnd' [] = mkTrue
mkAnd' xs = mkAnd xs
--class SMModel a where
-- mElem :: MModel a -> String -> Z3 AST
-- mNotElem :: MModel a -> String -> Z3 AST
......@@ -74,7 +90,7 @@ checkSat mkSort (vars, constraint) = do
ms <- evalT m syms
case ms of
Just xs -> do
vals <- mapM getConcrete xs
vals <- mapM getVal xs
let cmodel = MModel $ M.fromList $ vars `zip` vals
return $ Just cmodel
Nothing -> error "Prover returned incomplete model"
......@@ -83,4 +99,7 @@ checkSat mkSort (vars, constraint) = do
(Sat, Nothing) -> error "Prover returned sat but no model"
checkSatInt :: ([String], MModel AST -> Z3 ()) -> IO (Maybe (MModel Integer))
checkSatInt problem = evalZ3 $ checkSat mkIntSort problem
checkSatInt = evalZ3 . checkSat mkIntSort
checkSatBool :: ([String], MModel AST -> Z3 ()) -> IO (Maybe (MModel (Maybe Bool)))
checkSatBool = evalZ3 . checkSat mkBoolSort
......@@ -9,7 +9,7 @@ import Solver
evaluateTerm :: Term -> MModelS -> Z3 AST
evaluateTerm (Var x) m = return $ mVal m x
evaluateTerm (Const c) _ = mkInt c
evaluateTerm (Const c) _ = mkVal c
evaluateTerm (Minus t) m = mkUnaryMinus =<< evaluateTerm t m
evaluateTerm (t :+: u) m = evalBinaryTerm m mkAdd t u
evaluateTerm (t :-: u) m = evalBinaryTerm m mkSub t u
......
......@@ -16,20 +16,20 @@ placeConstraints net m = mapM_ (assertCnstr <=< checkPlaceEquation) $ places net
where checkPlaceEquation p = do
incoming <- mapM (addTransition 1 ) $ lpre net p
outgoing <- mapM (addTransition (-1)) $ lpost net p
pinit <- mkInt $ initial net p
pinit <- mkVal $ initial net p
sums <- mkAdd (pinit:(incoming ++ outgoing))
mkEq sums (mVal m p)
addTransition fac (t,w) =
mkInt (fac*w) >>= \w' -> mkMul [w', mVal m t]
mkVal (fac*w) >>= \w' -> mkMul [w', mVal m t]
nonnegativityConstraints :: MModelS -> Z3 ()
nonnegativityConstraints m = mapM_ (assertCnstr <=< geZero) $ mValues m
where geZero v = mkGe v =<< mkInt (0::Integer)
where geZero v = mkGe v =<< mkVal (0::Integer)
checkTraps :: [[String]] -> MModelS -> Z3 ()
checkTraps traps m = mapM_ (assertCnstr <=< checkTrap) traps
where checkTrap trap = mkAdd (map (mVal m) trap) >>=
(\v -> mkGe v =<< mkInt (1::Integer))
(\v -> mkGe v =<< mkVal (1::Integer))
checkStateEquation :: PetriNet -> Formula -> [[String]] -> MModelS -> Z3 ()
checkStateEquation net f traps m = do
......
......@@ -4,35 +4,36 @@ module Solver.TrapConstraints
)
where
import Data.SBV
import Z3.Monad
import Control.Monad
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)
trapConstraints :: PetriNet -> MModelS -> Z3 ()
trapConstraints net m = mapM_ (assertCnstr <=< trapConstraint) $ transitions net
where trapConstraint t = do
lhs <- mkOr' (map (mVal m) $ pre net t)
rhs <- mkOr' (map (mVal m) $ post net t)
mkImplies lhs rhs
trapInitiallyMarked :: PetriNet -> ModelSB -> SBool
trapInitiallyMarked net m =
let marked = map fst $ filter (( > 0) . snd) $ initials net
in bOr $ map (mElem m) marked
trapInitiallyMarked :: PetriNet -> MModelS -> Z3 ()
trapInitiallyMarked net m = assertCnstr =<< mkOr' (map (mVal m) (initials net))
trapUnassigned :: [String] -> ModelSB -> SBool
trapUnassigned assigned m = bAnd $ map (mNotElem m) assigned
trapUnassigned :: [String] -> MModelS -> Z3 ()
trapUnassigned assigned m = mapM_ (assertCnstr <=< (mkNot . mVal m)) assigned
checkTrap :: PetriNet -> [String] -> ModelSB -> SBool
checkTrap net assigned m =
trapConstraints net m &&&
trapInitiallyMarked net m &&&
checkTrap :: PetriNet -> [String] -> MModelS -> Z3 ()
checkTrap net assigned m = do
trapConstraints net m
trapInitiallyMarked net m
trapUnassigned assigned m
checkTrapSat :: PetriNet -> [String] -> ([String], ModelSB -> SBool)
checkTrapSat :: PetriNet -> [String] -> ([String], MModelS -> Z3 ())
checkTrapSat net assigned =
(places net, checkTrap net assigned)
trapFromAssignment :: ModelB -> [String]
trapFromAssignment = mElemsWith id
trapFromAssignment :: MModelB -> [String]
trapFromAssignment = mElemsWith (\x -> case x of Just True -> True
_ -> False )
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