PetriNet.hs 6.22 KB
Newer Older
1
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
Philipp Meyer's avatar
Philipp Meyer committed
2
3
4
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

module PetriNet
5
6
7
    (PetriNet,Place,Transition,Marking,tokens,buildMarking,
     name,showNetName,places,transitions,initial,initialMarking,
     pre,lpre,post,lpost,initials,context,ghostTransitions,
Philipp Meyer's avatar
Philipp Meyer committed
8
     makePetriNet,makePetriNetWithTrans)
Philipp Meyer's avatar
Philipp Meyer committed
9
10
where

11
import qualified Data.Map as M
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
import Control.Arrow (first)

newtype Place = Place String deriving (Ord,Eq)
newtype Transition = Transition String deriving (Ord,Eq)

instance Show Place where
        show (Place p) = p
instance Show Transition where
        show (Transition t) = t

type ContextMap a b = M.Map a ([(b, Integer)],[(b, Integer)])

class Nodes a b | a -> b where
        pre :: (Ord a) => PetriNet -> a -> [b]
        pre net = map fst . fst . context net
        post :: (Ord a) => PetriNet -> a -> [b]
        post net = map fst . snd . context net
        lpre :: (Ord a) => PetriNet -> a -> [(b, Integer)]
        lpre net = fst . context net
        lpost :: (Ord a) => PetriNet -> a -> [(b, Integer)]
        lpost net = snd . context net
        context :: (Ord a) => PetriNet -> a -> ([(b, Integer)], [(b, Integer)])
        context net x = M.findWithDefault ([],[]) x (contextMap net)
        contextMap :: PetriNet -> ContextMap a b

instance Nodes Place Transition where
        contextMap = adjacencyP
instance Nodes Transition Place where
        contextMap = adjacencyT

newtype Marking = Marking { getMarking :: M.Map Place Integer }
43
44

instance Show Marking where
45
        show (Marking m) = show $ map showPlaceMarking $ M.toList m
46
            where showPlaceMarking (n,i) =
47
                    show n ++ (if i /= 1 then "(" ++ show i ++ ")" else "")
48
49

tokens :: Marking -> Place -> Integer
50
tokens m p = M.findWithDefault 0 p (getMarking m)
51

52
53
buildMarking :: [(String, Integer)] -> Marking
buildMarking xs = Marking $ M.fromList $ map (first Place) $ filter ((/=0) . snd) xs
54

Philipp Meyer's avatar
Philipp Meyer committed
55
56
data PetriNet = PetriNet {
        name :: String,
57
58
        places :: [Place],
        transitions :: [Transition],
59
60
        adjacencyP :: M.Map Place ([(Transition,Integer)], [(Transition,Integer)]),
        adjacencyT :: M.Map Transition ([(Place,Integer)], [(Place,Integer)]),
61
62
        initialMarking :: Marking,
        ghostTransitions :: [Transition]
Philipp Meyer's avatar
Philipp Meyer committed
63
64
}

65
66
initial :: PetriNet -> Place -> Integer
initial net = tokens (initialMarking net)
67

68
initials :: PetriNet -> [(Place,Integer)]
69
initials net = M.toList (getMarking (initialMarking net))
70

71
72
showNetName :: PetriNet -> String
showNetName net = "Petri net" ++
73
74
               (if null (name net) then "" else " " ++ show (name net))

Philipp Meyer's avatar
Philipp Meyer committed
75
instance Show PetriNet where
76
        show net = showNetName net ++
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
                   "\nPlaces: " ++ show (places net) ++
                   "\nTransitions: " ++ show (transitions net) ++
                   "\nPlace arcs:\n" ++ unlines
                        (map showContext (M.toList (adjacencyP net))) ++
                   "\nTransition arcs:\n" ++ unlines
                        (map showContext (M.toList (adjacencyT net))) ++
                   "\nInitial: " ++ show (initialMarking net) ++
                   "\nGhost transitions: " ++ show (ghostTransitions net)
                where showContext (s,(l,r)) =
                          show l ++ " -> " ++ show s ++ " -> " ++ show r

--makePetriNet :: String -> [Place] -> [Transition] ->
--        [(Place, ([(Transition, Integer)], [(Transition, Integer)]))] ->
--        [(Transition, ([(Place, Integer)], [(Place, Integer)]))] ->
--        [(Place, Integer)] -> [Transition] -> PetriNet
--makePetriNet name places transitions placeArcs transitionArcs initial gs =
--            PetriNet { name=name, places=places, transitions=transitions,
--                       adjacencyP=M.fromList (adjacencyFilter placeArcs),
--                       adjacencyT=M.fromList (adjacencyFilter transitionArcs),
--                       initialMarking=buildMarking initial,
--                       ghostTransitions=gs }
--        where
--            adjacencyFilter = filter contextFilter
--            contextFilter (x,pre,post) =
--                (x,filter arcFilter pre, filter arcFilter post)
--            arcFilter (_,w) = w /= 0

makePetriNet :: String -> [String] -> [String] ->
        [(String, String, Integer)] ->
        [(String, Integer)] -> [String] -> PetriNet
107
makePetriNet name places transitions arcs initial gs =
108
109
110
111
112
113
114
115
116
117
118
        let (adP, adT) = foldl buildMaps (M.empty, M.empty)
                            (filter (\(_,_,w) -> w /= 0) arcs)
        in  PetriNet {
                name = name,
                places = map Place places,
                transitions = map Transition transitions,
                adjacencyP = adP,
                adjacencyT = adT,
                initialMarking = buildMarking initial,
                ghostTransitions = map Transition gs
            }
119
        where
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
            buildMaps (mp,mt) (_,_,0) = (mp,mt)
            buildMaps (mp,mt) (l,r,w) | l `elem` places && r `elem` transitions =
                       let mp' = M.insertWith addArc
                                    (Place l) ([],[(Transition r, w)]) mp
                           mt' = M.insertWith addArc
                                    (Transition r) ([(Place l, w)],[]) mt
                       in  (mp',mt')
            buildMaps (mp,mt) (l,r,w) | l `elem` transitions && r `elem` places =
                       let mt' = M.insertWith addArc
                                    (Transition l) ([],[(Place r, w)]) mt
                           mp' = M.insertWith addArc
                                    (Place r) ([(Transition l, w)],[]) mp
                       in  (mp',mt')
            buildMaps _ (l,r,_) = error $ "nodes " ++ l ++ " and " ++ r ++
                                    " both places or transitions"
135
136
            addArc (lNew,rNew) (lOld,rOld) = (lNew ++ lOld,rNew ++ rOld)

137
138
139
makePetriNetWithTrans :: String -> [String] ->
        [(String, [(String, Integer)], [(String, Integer)])] ->
        [(String, Integer)] -> [String] -> PetriNet
140
makePetriNetWithTrans name places ts initial gs =
Philipp Meyer's avatar
Philipp Meyer committed
141
142
143
        let transitions = [ t | (t,_,_) <- ts ]
            arcs = [ (i,t,w) | (t,is,_) <- ts, (i,w) <- is ] ++
                   [ (t,o,w) | (t,_,os) <- ts, (o,w) <- os ]
144
        in  makePetriNet name places transitions arcs initial gs