Rewrote trap constraints

src/Main.hs

@@ -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
 {-

src/PetriNet.hs

@@ -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
             }
 

src/Solver.hs

 {-# 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
 

src/Solver/StateEquation.hs

 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)
 

src/Solver/TrapConstraints.hs

 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
 

src/Util.hs

+module Util
+    (verbosePut)
+where
+
+import Control.Monad
+
+verbosePut :: Int -> Int -> String -> IO ()
+verbosePut verbosity level str =
+        when (verbosity >= level) (putStrLn str)
+