5 , NodeNr, EdgeNr, ViaNr
6 , networkNodes -- dangerous
7 , networkEdges -- dangerous
9 -- * Creating and printing a network
15 , getNodeAssocs, setNodeAssocs
16 , getEdgeAssocs, setEdgeAssocs
17 , getCanvasSize, setCanvasSize
18 , getGlobalInfo, setGlobalInfo
19 -- ** Get usefull information from 'Network'
26 , getParentMap, ParentMap
28 , nodeExists, edgeExists
29 , findEdge, findNodeNrsByName
31 , otherExtremeOfEdgeConnectedOnPort
32 -- ** update network elements
38 -- ** add and remove network elements
39 , addNode, addNodes, removeNode, addNodeEx, addExistingNode
40 , addEdge, addEdges, removeEdge
42 , newViaEdge, removeVia
46 -- ** get and set node data in a network by 'NodeNr'
47 , getNodeInfo, getNodeName, getNodePosition, getNodeNameAbove, getNodeShape
48 , setNodeInfo, setNodeName, setNodePosition, setNodeNameAbove, setNodeShape
49 -- ** get\'s and set\'s of a node
50 , getInfo, getName, getPosition, getNameAbove, getShape
51 , setInfo, setName, setPosition, setNameAbove, setShape
54 , getEdgeFrom, getPortFrom, getEdgeTo, getPortTo, getEdgeVia, getEdgeInfo, getFullPortFrom, getFullPortTo
55 , setEdgeFrom, setPortFrom, setEdgeTo, setPortTo, setEdgeVia, setEdgeInfo
56 -- * Interaction Nets functionality
68 import Palette (Palette, shapes, ShapeName, getSymbol)
70 import Data.IntMap as IntMap hiding (map)
71 import qualified Data.List as List
74 data Network g n e = Network
75 { networkNodes :: !(IntMap (Node n)) -- ^ maps node numbers to nodes
76 , networkEdges :: !(IntMap (Edge e)) -- ^ maps edge numbers to edges
77 , networkCanvasSize :: (Double, Double)
82 { edgeFrom :: !NodeNr -- ^ the number of the node where the edge starts
83 , portFrom :: PortName --
84 , edgeTo :: !NodeNr -- ^ the number of the node the edge points to
85 , portTo :: PortName --
86 , edgeVia :: [DoublePoint] -- ^ intermediate vertices when drawing
88 } deriving (Show, Read, Eq)
90 showEdge :: Edge e -> String
92 "Node " ++ show (edgeFrom edge) ++ showPort (portFrom edge)
94 "Node " ++ show (edgeTo edge) ++ showPort (portTo edge)
96 showPort name = '@' : name
99 { nodePosition :: DoublePoint -- ^ the position of the node on screen
100 , nodeName :: !String
101 , nodeNameAbove :: Bool -- ^ should the name be displayed above (True) of below (False)
102 , nodeShape :: ShapeName -- ^ symbol name from palette,
104 } deriving (Show, Read)
110 -- | Create an empty network
111 empty :: (InfoKind n g, InfoKind e g) => g -> n -> e -> Network g n e
112 empty g _ _ = Network
113 { networkNodes = IntMap.empty
114 , networkEdges = IntMap.empty
115 , networkCanvasSize = (15, 9)
119 -- | Map a function over the nodes, possibly changes the type
120 -- of the Network (i.e. the kind of values stored in the
121 -- probability tables)
122 mapNodeNetwork :: InfoKind m g =>
123 (Node n->Node m) -> Network g n e -> Network g m e
124 mapNodeNetwork nodeFun network =
125 let numberedNodes = getNodeAssocs network
126 newNodes = [ (nr, nodeFun node) | (nr, node) <- numberedNodes ]
128 { networkNodes = IntMap.fromList newNodes
129 , networkEdges = networkEdges network
130 , networkCanvasSize = networkCanvasSize network
131 , networkInfo = networkInfo network
134 constructEdge :: NodeNr -> PortName -> NodeNr -> PortName -> [DoublePoint] -> e -> Edge e
135 constructEdge fromNr fromPort toNr toPort via info =
138 , portFrom = fromPort
145 getEdgeFrom :: Edge e -> NodeNr
146 getEdgeFrom = edgeFrom
148 getPortFrom :: Edge e -> PortName
149 getPortFrom = portFrom
151 getFullPortFrom :: Edge e -> (NodeNr, PortName)
152 getFullPortFrom e = (edgeFrom e, portFrom e)
154 getEdgeTo :: Edge e -> NodeNr
157 getPortTo :: Edge e -> PortName
160 getFullPortTo :: Edge e -> (NodeNr, PortName)
161 getFullPortTo e = (edgeTo e, portTo e)
163 getEdgeVia :: Edge e -> [DoublePoint]
166 getEdgeInfo :: Edge e -> e
167 getEdgeInfo = edgeInfo
169 setEdgeFrom :: NodeNr -> Edge e -> Edge e
170 setEdgeFrom fromNr edge = edge { edgeFrom = fromNr }
172 setPortFrom :: NodeNr -> PortName -> Edge e -> Edge e
173 setPortFrom fromNr fromPort edge = edge { edgeFrom = fromNr, portFrom = fromPort }
175 setEdgeTo :: NodeNr -> Edge e -> Edge e
176 setEdgeTo toNr edge = edge { edgeTo = toNr }
178 setPortTo :: NodeNr -> PortName -> Edge e -> Edge e
179 setPortTo toNr toPort edge = edge { edgeTo = toNr, portTo = toPort }
181 setEdgeVia :: [DoublePoint] -> Edge e -> Edge e
182 setEdgeVia via edge = edge { edgeVia = via }
184 setEdgeInfo :: e -> Edge oldInfo -> Edge e
185 setEdgeInfo info edge =
186 constructEdge (getEdgeFrom edge) (portFrom edge)
187 (getEdgeTo edge) (portTo edge)
188 (getEdgeVia edge) info
190 constructNode :: (InfoKind n g) => String -> DoublePoint -> Bool
191 -> ShapeName -> n -> Node n
192 constructNode name position nameAbove shape info =
195 , nodePosition = position
196 , nodeNameAbove = nameAbove
201 getNodeName :: Network g n e -> NodeNr -> String
202 getNodeName network nodeNr = nodeName (networkNodes network ! nodeNr)
204 setNodeName :: NodeNr -> String -> Network g n e -> Network g n e
205 setNodeName nodeNr name network =
206 network { networkNodes = insert nodeNr (node { nodeName = name }) (networkNodes network) }
207 where node = networkNodes network ! nodeNr
209 getNodePosition :: Network g n e -> NodeNr -> DoublePoint
210 getNodePosition network nodeNr = nodePosition (networkNodes network ! nodeNr)
212 setNodePosition :: NodeNr -> DoublePoint -> Network g n e -> Network g n e
213 setNodePosition nodeNr position network =
214 network { networkNodes = insert nodeNr (node { nodePosition = position }) (networkNodes network) }
215 where node = networkNodes network ! nodeNr
217 getNodeNameAbove :: Network g n e -> NodeNr -> Bool
218 getNodeNameAbove network nodeNr = nodeNameAbove (networkNodes network ! nodeNr)
220 setNodeNameAbove :: NodeNr -> Bool -> Network g n e -> Network g n e
221 setNodeNameAbove nodeNr nameAbove network =
222 network { networkNodes = insert nodeNr (node { nodeNameAbove = nameAbove }) (networkNodes network) }
223 where node = networkNodes network ! nodeNr
225 getNodeShape :: Network g n e -> NodeNr -> ShapeName
226 getNodeShape network nodeNr = nodeShape (networkNodes network ! nodeNr)
228 setNodeShape :: NodeNr -> ShapeName -> Network g n e -> Network g n e
229 setNodeShape nodeNr shape network =
230 network { networkNodes = insert nodeNr (node { nodeShape = shape })
231 (networkNodes network) }
232 where node = networkNodes network ! nodeNr
234 getNodeInfo :: Network g n e -> NodeNr -> n
235 getNodeInfo network nodeNr = nodeInfo (networkNodes network ! nodeNr)
237 setNodeInfo :: NodeNr -> n -> Network g n e -> Network g n e
238 setNodeInfo nodeNr info network =
239 network { networkNodes = insert nodeNr (node { nodeInfo = info }) (networkNodes network) }
240 where node = networkNodes network ! nodeNr
242 getNameAbove :: Node a -> Bool
243 getNameAbove node = nodeNameAbove node
245 getName :: Node a -> String
246 getName node = nodeName node
248 getShape :: Node a -> ShapeName
249 getShape node = nodeShape node
251 getPosition :: Node a -> DoublePoint
252 getPosition node = nodePosition node
254 getInfo :: Node a -> a
255 getInfo node = nodeInfo node
257 -- | Set whether the name should appear above (True) or below (False) the node
258 setNameAbove :: Bool -> Node a -> Node a
259 setNameAbove above node = node { nodeNameAbove = above }
261 setName :: String -> Node a -> Node a
262 setName name node = node { nodeName = name }
264 setShape :: ShapeName -> Node a -> Node a
265 setShape s node = node { nodeShape = s }
267 setPosition :: DoublePoint -> Node a -> Node a
268 setPosition position node = node { nodePosition = position }
270 setInfo :: a -> Node a -> Node a
271 setInfo info node = node { nodeInfo = info }
273 -- | Get the next unused node number
274 getUnusedNodeNr :: Network g n e -> NodeNr
275 getUnusedNodeNr network | List.null used = 1
276 | otherwise = maximum used + 1
278 used = keys (networkNodes network)
280 -- | Get the next unused edge number
281 getUnusedEdgeNr :: Network g n e -> EdgeNr
282 getUnusedEdgeNr network | List.null used = 1
283 | otherwise = maximum used + 1
285 used = keys (networkEdges network)
287 -- | Get the node numbers of the parents of a given node
288 getParents :: Network g n e -> NodeNr -> [NodeNr]
289 getParents network child =
291 | edge <- getEdges network
292 , edgeTo edge == child
293 , let parent = edgeFrom edge
296 type ParentMap = IntMap.IntMap [NodeNr]
298 -- | getParents is quite expensive (see above) and so
299 -- we store the parent relationship in an IntMap
300 getParentMap :: Network g n e -> ParentMap
301 getParentMap network =
303 [ (nodeNr, getParents network nodeNr)
304 | nodeNr <- getNodeNrs network
307 -- | Get the node numbers of the children of a given node
308 getChildren :: Network g n e -> NodeNr -> [NodeNr]
309 getChildren network parent =
311 | edge <- getEdges network
312 , edgeFrom edge == parent
313 , let child = edgeTo edge
317 -- | Get node with given index, raises exception if node number does not exist
318 getNode :: NodeNr -> Network g n e -> Node n
319 getNode nodeNr network
320 | member nodeNr nodesMap = nodesMap ! nodeNr
321 | otherwise = internalError "Network" "getNode" "illegal node number"
323 nodesMap = networkNodes network
325 -- | Get edge with given index, raises exception if edge number does not exist
326 getEdge :: EdgeNr -> Network g n e -> Edge e
327 getEdge edgeNr network = networkEdges network ! edgeNr
329 -- | Get all of the nodes in the network
330 getNodes :: Network g n e -> [Node n]
331 getNodes network = elems (networkNodes network)
333 -- | Get all of the edges in the network
334 getEdges :: Network g n e -> [Edge e]
335 getEdges network = elems (networkEdges network)
337 -- | Get all of the node numbers in the network
338 getNodeNrs :: Network g n e -> [NodeNr]
339 getNodeNrs network = keys (networkNodes network)
341 getCanvasSize :: Network g n e -> (Double, Double)
342 getCanvasSize network = networkCanvasSize network
344 getGlobalInfo :: Network g n e -> g
345 getGlobalInfo network = networkInfo network
347 -- | Find the number of an edge given start and end node number
348 findEdge :: NodeNr -> PortName -> NodeNr -> PortName -> Network g n e -> Maybe EdgeNr
349 findEdge fromNodeNr fromPort toNodeNr toPort network =
350 let hits = IntMap.filter
352 sameFromAndTo (Edge { edgeFrom = fromNodeNr
353 , portFrom = fromPort
356 , edgeVia = undefined
357 , edgeInfo = undefined }) edge
358 || sameFromAndTo (Edge { edgeFrom = toNodeNr
360 , edgeTo = fromNodeNr
362 , edgeVia = undefined
363 , edgeInfo = undefined }) edge)
364 (networkEdges network)
365 in case IntMap.keys hits of
369 -- | Find node numbers given a node name
370 findNodeNrsByName :: String -> Network g n e -> [NodeNr]
371 findNodeNrsByName theNodeName network =
373 | nodeNr <- getNodeNrs network
374 , getNodeName network nodeNr == theNodeName
377 -- | Get a list of pairs where each pair contains a node number and the corresponding node
378 getNodeAssocs :: Network g n e -> [(NodeNr, Node n)]
379 getNodeAssocs network = assocs (networkNodes network)
381 setNodeAssocs :: [(NodeNr, Node n)] -> Network g n e -> Network g n e
382 setNodeAssocs nodeAssocs network =
383 network { networkNodes = IntMap.fromList nodeAssocs }
385 -- | Get a list of pairs where each pair contains a edge number and the corresponding edge
386 getEdgeAssocs :: Network g n e -> [(EdgeNr, Edge e)]
387 getEdgeAssocs network = assocs (networkEdges network)
389 setEdgeAssocs :: [(EdgeNr, Edge e)] -> Network g n e -> Network g n e
390 setEdgeAssocs edgeAssocs network =
391 network { networkEdges = IntMap.fromList edgeAssocs }
393 -- | Check if a network is empty. A network is empty is it has no nodes.
394 isEmpty :: Network g n e -> Bool
395 isEmpty = IntMap.null . networkNodes
397 -- | Create a string that describes the network
398 dumpNetwork :: InfoKind e g => Network g String e -> String
399 dumpNetwork network = show (getNodeAssocs network) ++ "\n" ++ show (getEdgeAssocs network)
401 -- | Test for existence of a node number
402 nodeExists :: NodeNr -> Network g n e -> Bool
403 nodeExists nodeNr network =
404 member nodeNr (networkNodes network)
406 -- | Test for existence of an edge number
407 edgeExists :: EdgeNr -> Network g n e -> Bool
408 edgeExists edgeNr network =
409 member edgeNr (networkEdges network)
411 {-----------------------------------
412 Functions that change the network
413 -----------------------------------}
415 -- | Add a node to the network
416 addNode :: InfoKind n g
417 => ShapeName -- ^ the current shape's name
418 -> Palette n -- ^ the palette
419 -> Network g n e -- ^ the network to add the node to
420 -> (NodeNr, Network g n e) -- ^ the number of the new node and
421 -- the extended network
422 addNode shape palette network =
423 addNodeEx ("Node " ++ show nodeNr)
424 (DoublePoint 0.0 0.0)
430 nodeNr = getUnusedNodeNr network
431 palette' = shapes palette
434 addNodes :: InfoKind n g => ShapeName -> Palette n -> Int -> Network g n e -> ([NodeNr], Network g n e)
435 addNodes _ _ 0 network = ([], network)
436 addNodes shapeName palette n network1 =
437 let (nodeNr, network2) = addNode shapeName palette network1
438 (nodeNrs, network3) = addNodes shapeName palette (n-1) network2
439 in (nodeNr:nodeNrs, network3)
441 addNodeEx :: InfoKind n g =>
442 String -> DoublePoint -> Bool -> ShapeName -> n
443 -> Network g n e -> (NodeNr, Network g n e)
444 addNodeEx name position labelAbove shape info network =
446 , network { networkNodes = insert nodeNr node (networkNodes network) }
449 nodeNr = getUnusedNodeNr network
450 node = constructNode name position labelAbove shape info
452 addExistingNode :: InfoKind n g => Node n -> Network g n e -> (NodeNr, Network g n e)
453 addExistingNode node network =
455 , network { networkNodes = insert nodeNr node' (networkNodes network) }
458 nodeNr = getUnusedNodeNr network
459 node' = setName ("Node " ++ show nodeNr) node
461 -- | Add an edge to the network. The probability table of the target node is updated:
462 -- a dimension is added and all values are zeroed.
463 addEdge :: InfoKind e g => Palette n -> NodeNr -> PortName -> NodeNr -> PortName -> Network g n e -> Network g n e
464 addEdge palette fromNodeNr fromPort toNodeNr toPort network
465 | any (sameFromAndTo edge) edgesList || -- prohibit double edges
466 any (sameFromAndTo (reverseEdge edge)) edgesList || -- prohibit edges in opposite direction
467 anyPortAlreadyUsed edge edgesList -- only one connection per port is allowed
468 || (fromNodeNr, fromPort) == (toNodeNr, toPort) -- prohibit edges from a port to itself
471 let edgeNr = getUnusedEdgeNr network
472 networkPlusEdge = network { networkEdges = insert edgeNr edge (networkEdges network) }
475 edge = Edge { edgeFrom = fromNodeNr, portFrom = fromPort
476 , edgeTo = toNodeNr, portTo = toPort
477 , edgeVia = if fromNodeNr /= toNodeNr then [] else [point2EdgeInNode palette fromNodeNr fromPort toPort network]
479 edgesList = elems (networkEdges network)
481 addEdges :: InfoKind e g => Palette n -> [( (NodeNr, PortName), (NodeNr, PortName) )]
482 -> Network g n e -> Network g n e
483 addEdges palette edgeTuples network =
484 foldr (\((fromNr, fromMPort), (toNr, toMPort)) net -> addEdge palette fromNr fromMPort toNr toMPort net)
487 -- | Insert a new 'via' control point in the middle of an edge.
488 newViaEdge :: EdgeNr -> ViaNr -> DoublePoint
489 -> Network g n e -> Network g n e
490 newViaEdge edgeNr viaNr point network =
491 network { networkEdges = adjust (\e->e{ edgeVia= take viaNr (edgeVia e)
493 ++drop viaNr (edgeVia e) })
495 (networkEdges network) }
497 -- | Remove node with given index, raises exception if node number does not exist.
498 -- This function also removes all edges that start or end in this node.
499 removeNode :: NodeNr -> Network g n e -> Network g n e
500 removeNode nodeNr network =
501 let involvedEdges = [ i
502 | (i, edge) <- getEdgeAssocs network
503 , edgeFrom edge == nodeNr || edgeTo edge == nodeNr
505 networkWithoutEdges = foldr removeEdge network involvedEdges
506 networkWithoutNode = networkWithoutEdges { networkNodes = delete nodeNr (networkNodes networkWithoutEdges) }
507 in networkWithoutNode
509 -- | Remove an edge from the network. The probability table of the target node is updated:
510 -- the corresponding dimension is removed and all values are zeroed.
511 -- An exception is raised if edge number does not exist.
512 removeEdge :: EdgeNr -> Network g n e -> Network g n e
513 removeEdge edgeNr network =
514 network { networkEdges = delete edgeNr (networkEdges network) }
516 -- | Remove all edges from the network. The probability tables of all node are zeroed.
517 removeAllEdges :: Network g n e -> Network g n e
518 removeAllEdges network =
519 let networkWithoutEdges = network { networkEdges = IntMap.empty }
520 in networkWithoutEdges
522 -- | Remove a control point from an edge.
523 removeVia :: EdgeNr -> ViaNr -> Network g n e -> Network g n e
524 removeVia edgeNr viaNr network =
525 let remove n e = e { edgeVia = take n (edgeVia e)
526 ++ drop (n+1) (edgeVia e) } in
527 network { networkEdges = adjust (remove viaNr)
528 edgeNr (networkEdges network) }
530 setCanvasSize :: (Double, Double) -> Network g n e -> Network g n e
531 setCanvasSize canvasSize network = network { networkCanvasSize = canvasSize }
533 setGlobalInfo :: g -> Network g n e -> Network g n e
534 setGlobalInfo info network = network { networkInfo = info }
536 {-----------------------------------
538 -----------------------------------}
540 {- | Checks if two edges are equal. Equality in edges is:
541 * if the edges have information of ports then the edges are equal when the pairs
542 (node,port) from and to of the two edges are the same
543 * otherwise the edges are equal if the from and to Nodes are the same
545 sameFromAndTo :: Edge e -> Edge e -> Bool
546 sameFromAndTo edge1 edge2 =
547 getFullPortFrom edge1 == getFullPortFrom edge2 && getFullPortTo edge1 == getFullPortTo edge2 -- equality on nodes and ports
549 reverseEdge :: Edge e -> Edge e
551 edge { edgeFrom = edgeTo edge
552 , portFrom = portTo edge
553 , edgeTo = edgeFrom edge
554 , portTo = portFrom edge}
556 -- | Avoid the introduction of connections on ports that already are used.
557 -- So only one connection per port is allowed.
558 anyPortAlreadyUsed :: Edge e -> [Edge e] -> Bool
559 anyPortAlreadyUsed edge edgesList =
560 (edgeFrom edge, portFrom edge) `elem` portsList
561 || (edgeTo edge, portTo edge) `elem` portsList
562 where portsList = concatMap f edgesList
563 f e = [(edgeFrom e, portFrom e), (edgeTo e, portTo e)]
565 -- | Update node with given number by applying the function to it
566 -- Dangerous (wrt network consistency, do not export)
567 updateNode :: NodeNr -> (Node n -> Node n) -> Network g n e -> Network g n e
568 updateNode nodeNr nodeFunction network =
569 let node = getNode nodeNr network in
570 network { networkNodes = insert nodeNr (nodeFunction node)
571 (networkNodes network) }
573 updateEdge :: EdgeNr -> (Edge e -> Edge e) -> Network g n e -> Network g n e
574 updateEdge edgeNr edgeFunction network =
575 network { networkEdges = adjust edgeFunction edgeNr
576 (networkEdges network) }
578 updateVia :: EdgeNr -> ViaNr -> DoublePoint -> Network g n e -> Network g n e
579 updateVia edgeNr viaNr v network =
580 network { networkEdges =
581 adjust (\e-> e { edgeVia = take viaNr (edgeVia e)
582 ++[v]++drop (viaNr+1) (edgeVia e) })
583 edgeNr (networkEdges network) }
585 edgeConnectedOnPort :: Network g n e -> NodeNr -> PortName -> Maybe EdgeNr
586 edgeConnectedOnPort network nodeNr port =
587 case IntMap.keys (IntMap.filter f (networkEdges network) ) of
588 [edgeNr] -> Just edgeNr
590 where f :: Edge e -> Bool
592 getFullPortFrom edge == (nodeNr, port)
593 || getFullPortTo edge == (nodeNr, port)
595 otherExtremeOfEdgeConnectedOnPort :: Network g n e -> NodeNr -> PortName
596 -> Maybe (NodeNr, PortName)
597 otherExtremeOfEdgeConnectedOnPort network nodeNr port =
598 case edgeConnectedOnPort network nodeNr port of
599 Just edgeNr | getFullPortFrom (getEdge edgeNr network) == (nodeNr, port) -> Just $ getFullPortTo (getEdge edgeNr network)
600 Just edgeNr | getFullPortTo (getEdge edgeNr network) == (nodeNr, port) -> Just $ getFullPortFrom (getEdge edgeNr network)
603 point2EdgeInNode :: Palette n -> NodeNr -> PortName -> PortName -> Network g n e -> DoublePoint
604 point2EdgeInNode palette nodeNr fromPort toPort network =
605 case getPorts palette network nodeNr of
607 case (Prelude.lookup fromPort ports, Prelude.lookup toPort ports) of
608 (Just fromPortPos, Just toPortPos) ->
609 g (portZone (fromPort,fromPortPos)) (portZone (toPort,toPortPos))
610 _ -> error "unexpected situation"
612 where g Ztop Ztop = top
613 g Zbottom Zbottom = bottom
615 g Zright Zright = right
616 g Ztop Zbottom = right
617 g Zbottom Ztop = right
623 g Zbottom Zright = q4
627 g Zright Zbottom = q4
630 f x y = translate (getNodePosition network nodeNr) $ DoublePoint (x * param) (y * param)
641 isPrincipalPort :: Palette n -> Network g n e -> NodeNr -> PortName -> Bool
642 isPrincipalPort palette network nodeNr port =
643 maybe False f $ getPorts palette network nodeNr
645 f ((port2,_):_) = port2 == port
648 getPorts :: Palette n -> Network g n e -> NodeNr -> Maybe Ports
649 getPorts palette network nodeNr =
650 case getSymbol (getNodeShape network nodeNr) palette of
651 Just (_,ports,_) -> Just ports
654 getPort :: Palette n -> Network g n e -> (NodeNr,PortName) -> Maybe Port
655 getPort palette network (nodeNr,portName) =
656 case getSymbol (getNodeShape network nodeNr) palette of
658 case Prelude.lookup portName ports of
659 Just portPosition -> Just (portName, portPosition)