PetriNet.hs 2.19 KB
Newer Older
Philipp Meyer's avatar
Philipp Meyer committed
1 2 3
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

module PetriNet
4 5
    (PetriNet,showName,places,transitions,initial,
     pre,lpre,post,lpost,
Philipp Meyer's avatar
Philipp Meyer committed
6 7 8
     makePetriNet)
where

9 10
import qualified Data.Map as M

Philipp Meyer's avatar
Philipp Meyer committed
11 12 13 14
data PetriNet = PetriNet {
        name :: String,
        places :: [String],
        transitions :: [String],
15
        adjacency :: M.Map String ([(String,Integer)], [(String,Integer)]),
Philipp Meyer's avatar
Philipp Meyer committed
16 17 18
        initial :: [(String,Integer)]
}

19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37
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))

Philipp Meyer's avatar
Philipp Meyer committed
38
instance Show PetriNet where
39
        show net = showName net ++
40 41 42
                   "\nPlaces: " ++ unwords (places net) ++
                   "\nTransitions: " ++ unwords (transitions net) ++
                   "\nArcs:\n" ++ unlines
43 44 45
                        (map (\(s,(l,r)) -> show l ++ " -> " ++
                            s ++ " -> " ++ show r)
                        (M.toList (adjacency net))) ++
Philipp Meyer's avatar
Philipp Meyer committed
46 47 48 49 50 51
                   "Initial: " ++ unwords
                        (map (\(n,i) -> n ++
                            (if i /= 1 then "[" ++ show i ++ "]" else []))
                        (initial net))

makePetriNet :: String -> [String] -> [String] ->
52
        [(String, String, Integer)] -> [(String, Integer)] -> PetriNet
Philipp Meyer's avatar
Philipp Meyer committed
53
makePetriNet name places transitions arcs initial =
54 55 56 57 58 59 60 61 62 63
        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)