Using adjacency lists for representing Petri nets

slapnet.cabal

@@ -23,6 +23,6 @@ executable slapnet
     PetriNet
     Parser
   -- other-extensions:
-  build-depends:       base >=4.6 && <4.7, sbv, parsec
+  build-depends:       base >=4.6 && <4.7, sbv, parsec, containers
   hs-source-dirs:      src
   default-language:    Haskell2010

src/Main.hs

@@ -16,7 +16,7 @@ main = do
         putStrLn "Safety and Liveness Analysis of Petri Nets with SMT solvers"
         putStrLn $ "Reading \"" ++ file ++ "\""
         (net,properties) <- parseFile file
-        putStrLn $ "Analyzing " ++ show net
+        putStrLn $ "Analyzing " ++ showName net
         mapM_ (\p -> do
                   putStrLn $ "Checking " ++ show p
                   putStrLn $ show $ checkProperty net p

src/PetriNet.hs

 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 
 module PetriNet
-    (PetriNet,name,places,transitions,
+    (PetriNet,showName,places,transitions,initial,
+     pre,lpre,post,lpost,
      makePetriNet)
 where
 
+import qualified Data.Map as M
+
 data PetriNet = PetriNet {
         name :: String,
         places :: [String],
         transitions :: [String],
-        arcs :: [(String,String,Integer)],
+        adjacency :: M.Map String ([(String,Integer)], [(String,Integer)]),
         initial :: [(String,Integer)]
 }
 
+context :: PetriNet -> String -> ([(String, Integer)], [(String, Integer)])
+context net x = M.findWithDefault ([],[]) x (adjacency net)
+
+pre :: PetriNet -> String -> [String]
+pre net = map fst . fst . context net
+
+lpre :: PetriNet -> String -> [(String, Integer)]
+lpre net = fst . context net
+
+post :: PetriNet -> String -> [String]
+post net = map fst . snd . context net
+
+lpost :: PetriNet -> String -> [(String, Integer)]
+lpost net = snd . context net
+
+showName :: PetriNet -> String
+showName net = "Petri net" ++
+               (if null (name net) then "" else " " ++ show (name net))
+
 instance Show PetriNet where
-        show net = "Petri net" ++
-                    (if null (name net) then "" else " " ++ show (name net)) ++
+        show net = showName net ++
                    "\nPlaces: " ++ unwords (places net) ++
                    "\nTransitions: " ++ unwords (transitions net) ++
                    "\nArcs:\n" ++ unlines
-                        (map (\(l,r,w) -> l ++ " ->" ++
-                            (if w /= 1 then "[" ++ show w ++ "]" else []) ++
-                            " " ++ r)
-                        (arcs net)) ++
+                        (map (\(s,(l,r)) -> show l ++ " -> " ++
+                            s ++ " -> " ++ show r)
+                        (M.toList (adjacency net))) ++
                    "Initial: " ++ unwords
                         (map (\(n,i) -> n ++
                             (if i /= 1 then "[" ++ show i ++ "]" else []))
                         (initial net))
 
 makePetriNet :: String -> [String] -> [String] ->
-        [(String, String,Integer)] -> [(String, Integer)] -> PetriNet
+        [(String, String, Integer)] -> [(String, Integer)] -> PetriNet
 makePetriNet name places transitions arcs initial =
-        PetriNet { name=name, places=places, transitions=transitions,
-                   arcs=arcs, initial=initial }
+        let adjacency = foldl buildMap M.empty arcs
+        in  PetriNet { name=name, places=places, transitions=transitions,
+                   adjacency=adjacency, initial=initial }
+        where
+            buildMap m (l,r,w) =
+              let m'  = M.insertWith addArc l ([],[(r,w)]) m
+                  m'' = M.insertWith addArc r ([(l,w)],[]) m'
+              in  m''
+            addArc (lNew,rNew) (lOld,rOld) = (lNew ++ lOld,rNew ++ rOld)
+