INblobs-0.1.1: src/Network.hs

module Network
    (
    -- * Types
      Network, Node, Edge
    , NodeNr, EdgeNr, ViaNr
    , networkNodes  -- dangerous
    , networkEdges  -- dangerous

    -- * Creating and printing a network
    , Network.empty
    , Network.isEmpty
    , dumpNetwork
    -- ** Set\'s e get\'s
    , getNodeNrs
    , getNodeAssocs,    setNodeAssocs
    , getEdgeAssocs,    setEdgeAssocs
    , getCanvasSize,    setCanvasSize
    , getGlobalInfo,    setGlobalInfo
    -- ** Get usefull information from 'Network'
    , getNode
    , getEdge
    , getNodes
    , getEdges
    , getChildren
    , getParents
    , getParentMap, ParentMap
    -- ** Search\'s
    , nodeExists, edgeExists
    , findEdge, findNodeNrsByName
    , edgeConnectedOnPort
    , otherExtremeOfEdgeConnectedOnPort
    -- ** update network elements
    , updateNode
    , updateEdge
    , updateVia

    , mapNodeNetwork
    -- ** add and remove network elements
    , addNode,      addNodes,    removeNode, addNodeEx, addExistingNode
    , addEdge,      addEdges,    removeEdge
    , removeAllEdges
    , newViaEdge,   removeVia

    -- * Node
    , constructNode
    -- ** get and set node data in a network by 'NodeNr' 
    , getNodeInfo, getNodeName, getNodePosition, getNodeNameAbove, getNodeShape
    , setNodeInfo, setNodeName, setNodePosition, setNodeNameAbove, setNodeShape
    -- ** get\'s and set\'s of a node
    , getInfo, getName, getPosition, getNameAbove, getShape
    , setInfo, setName, setPosition, setNameAbove, setShape
    -- * Edge
    , constructEdge
    , getEdgeFrom, getPortFrom, getEdgeTo, getPortTo, getEdgeVia, getEdgeInfo, getFullPortFrom, getFullPortTo
    , setEdgeFrom, setPortFrom, setEdgeTo, setPortTo, setEdgeVia, setEdgeInfo
    -- * Interaction Nets functionality
    , getPorts
    , getPort
    , isPrincipalPort
    , showEdge
    ) where

import Common
import Math
import InfoKind
import Shape
import Ports
import Palette (Palette, shapes, ShapeName, getSymbol)

import Data.IntMap as IntMap hiding (map)
import qualified Data.List as List


data Network g n e = Network
    { networkNodes      :: !(IntMap (Node n)) -- ^ maps node numbers to nodes
    , networkEdges      :: !(IntMap (Edge e)) -- ^ maps edge numbers to edges
    , networkCanvasSize :: (Double, Double)
    , networkInfo       :: g
    } deriving Show

data Edge e = Edge
    { edgeFrom :: !NodeNr -- ^ the number of the node where the edge starts
    , portFrom :: PortName --
    , edgeTo   :: !NodeNr -- ^ the number of the node the edge points to
    , portTo   :: PortName --
    , edgeVia  :: [DoublePoint] -- ^ intermediate vertices when drawing
    , edgeInfo :: e
    } deriving (Show, Read, Eq)

showEdge :: Edge e -> String
showEdge edge =
    "Node " ++ show (edgeFrom edge) ++ showPort (portFrom edge)
    ++ " |-> " ++
    "Node " ++ show (edgeTo edge) ++ showPort (portTo edge)
    where
          showPort name =  '@' : name

data Node n = Node
    { nodePosition  :: DoublePoint  -- ^ the position of the node on screen
    , nodeName      :: !String
    , nodeNameAbove :: Bool         -- ^ should the name be displayed above (True) of below (False)
    , nodeShape     :: ShapeName       -- ^ symbol name from palette,
    , nodeInfo      :: n
    } deriving (Show, Read)

type NodeNr = Int
type EdgeNr = Int
type ViaNr  = Int

-- | Create an empty network
empty :: (InfoKind n g, InfoKind e g) => g -> n -> e -> Network g n e
empty g _ _ = Network
    { networkNodes      = IntMap.empty
    , networkEdges      = IntMap.empty
    , networkCanvasSize = (15, 9)
    , networkInfo       = g
    }

-- | Map a function over the nodes, possibly changes the type
--   of the Network (i.e. the kind of values stored in the
--   probability tables)
mapNodeNetwork :: InfoKind m g =>
                  (Node n->Node m) -> Network g n e -> Network g m e
mapNodeNetwork nodeFun network =
    let numberedNodes = getNodeAssocs network
        newNodes = [ (nr, nodeFun node) | (nr, node) <- numberedNodes ]
    in Network
        { networkNodes = IntMap.fromList newNodes
        , networkEdges = networkEdges network
        , networkCanvasSize = networkCanvasSize network
        , networkInfo = networkInfo network
        }

constructEdge :: NodeNr -> PortName -> NodeNr -> PortName -> [DoublePoint] -> e -> Edge e
constructEdge fromNr fromPort toNr toPort via info =
    Edge
        { edgeFrom = fromNr
        , portFrom = fromPort
        , edgeTo   = toNr
        , portTo   = toPort
        , edgeVia  = via
        , edgeInfo = info
        }

getEdgeFrom :: Edge e -> NodeNr
getEdgeFrom = edgeFrom

getPortFrom :: Edge e -> PortName
getPortFrom = portFrom

getFullPortFrom :: Edge e -> (NodeNr, PortName)
getFullPortFrom e = (edgeFrom e, portFrom e)

getEdgeTo :: Edge e -> NodeNr
getEdgeTo = edgeTo

getPortTo :: Edge e -> PortName
getPortTo = portTo

getFullPortTo :: Edge e -> (NodeNr, PortName)
getFullPortTo e = (edgeTo e, portTo e)

getEdgeVia :: Edge e -> [DoublePoint]
getEdgeVia = edgeVia

getEdgeInfo :: Edge e -> e
getEdgeInfo = edgeInfo

setEdgeFrom :: NodeNr -> Edge e -> Edge e
setEdgeFrom fromNr edge = edge { edgeFrom = fromNr }

setPortFrom :: NodeNr -> PortName -> Edge e -> Edge e
setPortFrom fromNr fromPort edge = edge { edgeFrom = fromNr, portFrom = fromPort }

setEdgeTo :: NodeNr -> Edge e -> Edge e
setEdgeTo toNr edge = edge { edgeTo = toNr }

setPortTo :: NodeNr -> PortName -> Edge e -> Edge e
setPortTo toNr toPort edge = edge { edgeTo = toNr, portTo = toPort }

setEdgeVia :: [DoublePoint] -> Edge e -> Edge e
setEdgeVia via edge = edge { edgeVia = via }

setEdgeInfo :: e -> Edge oldInfo -> Edge e
setEdgeInfo info edge =
    constructEdge (getEdgeFrom edge) (portFrom edge)
                  (getEdgeTo edge)   (portTo edge)
                  (getEdgeVia edge) info

constructNode :: (InfoKind n g) => String -> DoublePoint -> Bool
                                   -> ShapeName -> n -> Node n
constructNode name position nameAbove shape info =
       Node
          { nodeName      = name
          , nodePosition  = position
          , nodeNameAbove = nameAbove
          , nodeShape     = shape
          , nodeInfo      = info
          }

getNodeName :: Network g n e -> NodeNr -> String
getNodeName network nodeNr = nodeName (networkNodes network ! nodeNr)

setNodeName :: NodeNr -> String -> Network g n e -> Network g n e
setNodeName nodeNr name network =
    network { networkNodes = insert nodeNr (node { nodeName = name }) (networkNodes network) }
  where node = networkNodes network ! nodeNr

getNodePosition :: Network g n e -> NodeNr -> DoublePoint
getNodePosition network nodeNr = nodePosition (networkNodes network ! nodeNr)

setNodePosition :: NodeNr -> DoublePoint -> Network g n e -> Network g n e
setNodePosition nodeNr position network =
    network { networkNodes = insert nodeNr (node { nodePosition = position }) (networkNodes network) }
  where node = networkNodes network ! nodeNr

getNodeNameAbove :: Network g n e -> NodeNr -> Bool
getNodeNameAbove network nodeNr = nodeNameAbove (networkNodes network ! nodeNr)

setNodeNameAbove :: NodeNr -> Bool -> Network g n e -> Network g n e
setNodeNameAbove nodeNr nameAbove network =
    network { networkNodes = insert nodeNr (node { nodeNameAbove = nameAbove }) (networkNodes network) }
  where node = networkNodes network ! nodeNr

getNodeShape :: Network g n e -> NodeNr -> ShapeName
getNodeShape network nodeNr = nodeShape (networkNodes network ! nodeNr)

setNodeShape :: NodeNr -> ShapeName -> Network g n e -> Network g n e
setNodeShape nodeNr shape network =
    network { networkNodes = insert nodeNr (node { nodeShape = shape })
                                           (networkNodes network) }
  where node = networkNodes network ! nodeNr

getNodeInfo :: Network g n e -> NodeNr -> n
getNodeInfo network nodeNr = nodeInfo (networkNodes network ! nodeNr)

setNodeInfo :: NodeNr -> n -> Network g n e -> Network g n e
setNodeInfo nodeNr info network =
    network { networkNodes = insert nodeNr (node { nodeInfo = info }) (networkNodes network) }
  where node = networkNodes network ! nodeNr

getNameAbove :: Node a -> Bool
getNameAbove node = nodeNameAbove node

getName :: Node a -> String
getName node = nodeName node

getShape :: Node a -> ShapeName
getShape node = nodeShape node

getPosition :: Node a -> DoublePoint
getPosition node = nodePosition node

getInfo :: Node a -> a
getInfo node = nodeInfo node

-- | Set whether the name should appear above (True) or below (False) the node
setNameAbove :: Bool -> Node a -> Node a
setNameAbove above node = node { nodeNameAbove = above }

setName :: String -> Node a -> Node a
setName name node = node { nodeName = name }

setShape :: ShapeName -> Node a -> Node a
setShape s node = node { nodeShape = s }

setPosition :: DoublePoint -> Node a -> Node a
setPosition position node = node { nodePosition = position }

setInfo :: a -> Node a -> Node a
setInfo info node = node { nodeInfo = info }

-- | Get the next unused node number
getUnusedNodeNr :: Network g n e -> NodeNr
getUnusedNodeNr network | List.null used = 1
                        | otherwise = maximum used + 1
  where
    used = keys (networkNodes network)

-- | Get the next unused edge number
getUnusedEdgeNr :: Network g n e -> EdgeNr
getUnusedEdgeNr network | List.null used = 1
                        | otherwise = maximum used + 1
  where
    used = keys (networkEdges network)

-- | Get the node numbers of the parents of a given node
getParents :: Network g n e -> NodeNr -> [NodeNr]
getParents network child =
    [ parent
    | edge <- getEdges network
    , edgeTo edge == child
    , let parent = edgeFrom edge
    ]

type ParentMap = IntMap.IntMap [NodeNr]

-- | getParents is quite expensive (see above) and so
--   we store the parent relationship in an IntMap
getParentMap :: Network g n e -> ParentMap
getParentMap network =
    IntMap.fromList
        [ (nodeNr, getParents network nodeNr)
        | nodeNr <- getNodeNrs network
        ]

-- | Get the node numbers of the children of a given node
getChildren :: Network g n e -> NodeNr -> [NodeNr]
getChildren network parent =
    [ child
    | edge <- getEdges network
    , edgeFrom edge == parent
    , let child = edgeTo edge
    ]


-- | Get node with given index, raises exception if node number does not exist
getNode :: NodeNr -> Network g n e -> Node n
getNode nodeNr network
    | member nodeNr nodesMap = nodesMap ! nodeNr
    | otherwise = internalError "Network" "getNode" "illegal node number"
  where
    nodesMap = networkNodes network

-- | Get edge with given index, raises exception if edge number does not exist
getEdge :: EdgeNr -> Network g n e -> Edge e
getEdge edgeNr network = networkEdges network ! edgeNr

-- | Get all of the nodes in the network
getNodes :: Network g n e -> [Node n]
getNodes network = elems (networkNodes network)

-- | Get all of the edges in the network
getEdges :: Network g n e -> [Edge e]
getEdges network = elems (networkEdges network)

-- | Get all of the node numbers in the network
getNodeNrs :: Network g n e -> [NodeNr]
getNodeNrs network = keys (networkNodes network)

getCanvasSize :: Network g n e -> (Double, Double)
getCanvasSize network = networkCanvasSize network

getGlobalInfo :: Network g n e -> g
getGlobalInfo network = networkInfo network

-- | Find the number of an edge given start and end node number
findEdge :: NodeNr -> PortName -> NodeNr -> PortName -> Network g n e -> Maybe EdgeNr
findEdge fromNodeNr fromPort toNodeNr toPort network =
    let hits = IntMap.filter
                    (\edge ->
		     sameFromAndTo (Edge { edgeFrom = fromNodeNr
                                         , portFrom = fromPort
                                         , edgeTo   = toNodeNr
                                         , portTo   = toPort
                                         , edgeVia  = undefined
                                         , edgeInfo = undefined }) edge
		     || sameFromAndTo (Edge { edgeFrom = toNodeNr
                                         , portFrom = toPort
                                         , edgeTo   = fromNodeNr
                                         , portTo   = fromPort
                                         , edgeVia  = undefined
                                         , edgeInfo = undefined }) edge)
                    (networkEdges network)
    in case IntMap.keys hits of
        [key] -> Just key
        _ -> Nothing

-- | Find node numbers given a node name
findNodeNrsByName :: String -> Network g n e -> [NodeNr]
findNodeNrsByName theNodeName network =
    [ nodeNr
    | nodeNr <- getNodeNrs network
    , getNodeName network nodeNr == theNodeName
    ]

-- | Get a list of pairs where each pair contains a node number and the corresponding node
getNodeAssocs :: Network g n e -> [(NodeNr, Node n)]
getNodeAssocs network = assocs (networkNodes network)

setNodeAssocs :: [(NodeNr, Node n)] -> Network g n e -> Network g n e
setNodeAssocs nodeAssocs network =
    network { networkNodes = IntMap.fromList nodeAssocs }

-- | Get a list of pairs where each pair contains a edge number and the corresponding edge
getEdgeAssocs :: Network g n e -> [(EdgeNr, Edge e)]
getEdgeAssocs network = assocs (networkEdges network)

setEdgeAssocs :: [(EdgeNr, Edge e)] -> Network g n e -> Network g n e
setEdgeAssocs edgeAssocs network =
    network { networkEdges = IntMap.fromList edgeAssocs }

-- | Check if a network is empty. A network is empty is it has no nodes.
isEmpty :: Network g n e -> Bool
isEmpty = IntMap.null . networkNodes

-- | Create a string that describes the network
dumpNetwork :: InfoKind e g => Network g String e -> String
dumpNetwork network = show (getNodeAssocs network) ++ "\n" ++ show (getEdgeAssocs network)

-- | Test for existence of a node number
nodeExists :: NodeNr ->  Network g n e -> Bool
nodeExists nodeNr network =
    member nodeNr (networkNodes network)

-- | Test for existence of an edge number
edgeExists :: EdgeNr ->  Network g n e -> Bool
edgeExists edgeNr network =
    member edgeNr (networkEdges network)

{-----------------------------------
  Functions that change the network
 -----------------------------------}

-- | Add a node to the network
addNode :: InfoKind n g
        => ShapeName               -- ^ the current shape's name
        -> Palette n               -- ^ the palette
        -> Network g n e           -- ^ the network to add the node to
        -> (NodeNr, Network g n e) -- ^ the number of the new node and
                                   --   the extended network
addNode shape palette network =
    addNodeEx   ("Node " ++ show nodeNr)
                (DoublePoint 0.0 0.0)
                True
                shape
                blank
                network
  where
    nodeNr = getUnusedNodeNr network
    palette' = shapes palette


addNodes :: InfoKind n g => ShapeName -> Palette n -> Int -> Network g n e -> ([NodeNr], Network g n e)
addNodes _ _ 0 network = ([], network)
addNodes shapeName palette n network1 =
    let (nodeNr, network2) = addNode shapeName palette network1
        (nodeNrs, network3) = addNodes shapeName palette (n-1) network2
    in (nodeNr:nodeNrs, network3)

addNodeEx :: InfoKind n g =>
             String -> DoublePoint -> Bool -> ShapeName -> n
             -> Network g n e -> (NodeNr, Network g n e)
addNodeEx name position labelAbove shape info network =
    ( nodeNr
    , network { networkNodes = insert nodeNr node (networkNodes network) }
    )
  where
    nodeNr = getUnusedNodeNr network
    node = constructNode name position labelAbove shape info

addExistingNode :: InfoKind n g => Node n -> Network g n e -> (NodeNr, Network g n e)
addExistingNode node network = 
    ( nodeNr
    , network { networkNodes = insert nodeNr node' (networkNodes network) }
    )
  where
    nodeNr = getUnusedNodeNr network
    node' = setName ("Node " ++ show nodeNr) node

-- | Add an edge to the network. The probability table of the target node is updated:
--   a dimension is added and all values are zeroed.
addEdge :: InfoKind e g => Palette n -> NodeNr -> PortName -> NodeNr -> PortName -> Network g n e -> Network g n e
addEdge palette fromNodeNr fromPort toNodeNr toPort network
    | any (sameFromAndTo edge) edgesList || -- prohibit double edges 
      any (sameFromAndTo (reverseEdge edge)) edgesList || -- prohibit edges in opposite direction
      anyPortAlreadyUsed edge edgesList -- only one connection per port is allowed
      || (fromNodeNr, fromPort) == (toNodeNr, toPort) -- prohibit edges from a port to itself
        = network
    | otherwise =
        let edgeNr = getUnusedEdgeNr network
            networkPlusEdge = network { networkEdges = insert edgeNr edge (networkEdges network) }
        in networkPlusEdge
  where
    edge = Edge { edgeFrom = fromNodeNr, portFrom = fromPort
                , edgeTo = toNodeNr, portTo = toPort
                , edgeVia = if fromNodeNr /= toNodeNr then [] else [point2EdgeInNode palette fromNodeNr fromPort toPort network]
                , edgeInfo = blank }
    edgesList = elems (networkEdges network)

addEdges :: InfoKind e g => Palette n -> [( (NodeNr, PortName), (NodeNr, PortName) )]
                 -> Network g n e -> Network g n e
addEdges palette edgeTuples network =
  foldr (\((fromNr, fromMPort), (toNr, toMPort)) net -> addEdge palette fromNr fromMPort toNr toMPort net) 
        network edgeTuples

-- | Insert a new 'via' control point in the middle of an edge.
newViaEdge :: EdgeNr -> ViaNr -> DoublePoint
              -> Network g n e -> Network g n e
newViaEdge edgeNr viaNr point network =
    network { networkEdges = adjust (\e->e{ edgeVia= take viaNr (edgeVia e)
                                                     ++[point]
                                                     ++drop viaNr (edgeVia e) })
                                    edgeNr
                                    (networkEdges network) }

-- | Remove node with given index, raises exception if node number does not exist.
--   This function also removes all edges that start or end in this node.
removeNode :: NodeNr ->  Network g n e -> Network g n e
removeNode nodeNr network =
    let involvedEdges = [ i
                        | (i, edge) <- getEdgeAssocs network
                        , edgeFrom edge == nodeNr || edgeTo edge == nodeNr
                        ]
        networkWithoutEdges = foldr removeEdge network involvedEdges
        networkWithoutNode = networkWithoutEdges { networkNodes = delete nodeNr (networkNodes networkWithoutEdges) }
    in networkWithoutNode

-- | Remove an edge from the network. The probability table of the target node is updated:
--   the corresponding dimension is removed and all values are zeroed.
--   An exception is raised if edge number does not exist.
removeEdge :: EdgeNr -> Network g n e -> Network g n e
removeEdge edgeNr network =
    network { networkEdges = delete edgeNr (networkEdges network) }

-- | Remove all edges from the network. The probability tables of all node are zeroed.
removeAllEdges :: Network g n e -> Network g n e
removeAllEdges network =
    let networkWithoutEdges       = network { networkEdges = IntMap.empty }
    in  networkWithoutEdges

-- | Remove a control point from an edge.
removeVia :: EdgeNr -> ViaNr -> Network g n e -> Network g n e
removeVia edgeNr viaNr network =
    let remove n e = e { edgeVia = take n (edgeVia e)
                                   ++ drop (n+1) (edgeVia e) } in
    network { networkEdges = adjust (remove viaNr)
                                    edgeNr (networkEdges network) }

setCanvasSize :: (Double, Double) -> Network g n e -> Network g n e
setCanvasSize canvasSize network = network { networkCanvasSize = canvasSize }

setGlobalInfo :: g -> Network g n e -> Network g n e
setGlobalInfo info network = network { networkInfo = info }

{-----------------------------------
  Local functions
 -----------------------------------}

{- | Checks if two edges are equal. Equality in edges is: 
 *  if the edges have information of ports then the edges are equal when the pairs
 (node,port) from and to of the two edges are the same
 * otherwise the edges are equal if the from and to Nodes are the same
-}
sameFromAndTo :: Edge e -> Edge e -> Bool
sameFromAndTo edge1 edge2 =
    getFullPortFrom edge1 == getFullPortFrom edge2 && getFullPortTo edge1 == getFullPortTo edge2  -- equality on nodes and ports

reverseEdge :: Edge e -> Edge e
reverseEdge edge =
    edge { edgeFrom = edgeTo edge 
         , portFrom = portTo edge
         , edgeTo   = edgeFrom edge
         , portTo   = portFrom edge}

-- | Avoid the introduction of connections on ports that already are used.
-- So only one connection per port is allowed.
anyPortAlreadyUsed :: Edge e -> [Edge e] -> Bool
anyPortAlreadyUsed edge edgesList = 
     (edgeFrom edge, portFrom edge) `elem` portsList
     || (edgeTo edge, portTo edge)  `elem` portsList
     where portsList = concatMap f edgesList
           f e = [(edgeFrom e, portFrom e), (edgeTo e, portTo e)]

-- | Update node with given number by applying the function to it
--   Dangerous (wrt network consistency, do not export)
updateNode :: NodeNr -> (Node n -> Node n) -> Network g n e -> Network g n e
updateNode nodeNr nodeFunction network =
    let node = getNode nodeNr network in
    network { networkNodes = insert nodeNr (nodeFunction node)
                                           (networkNodes network) }

updateEdge :: EdgeNr -> (Edge e -> Edge e) -> Network g n e -> Network g n e
updateEdge edgeNr edgeFunction network =
    network { networkEdges = adjust edgeFunction edgeNr
                                    (networkEdges network) }

updateVia :: EdgeNr -> ViaNr -> DoublePoint -> Network g n e -> Network g n e
updateVia edgeNr viaNr v network =
    network { networkEdges =
                  adjust (\e-> e { edgeVia = take viaNr (edgeVia e)
                                             ++[v]++drop (viaNr+1) (edgeVia e) })
                         edgeNr (networkEdges network) }

edgeConnectedOnPort :: Network g n e -> NodeNr -> PortName -> Maybe EdgeNr
edgeConnectedOnPort network nodeNr port = 
   case IntMap.keys (IntMap.filter f (networkEdges network) ) of
      [edgeNr] -> Just edgeNr
      _        -> Nothing
   where f :: Edge e -> Bool
         f edge = 
             getFullPortFrom edge == (nodeNr, port)
             || getFullPortTo edge == (nodeNr, port)

otherExtremeOfEdgeConnectedOnPort :: Network g n e -> NodeNr -> PortName
                                     -> Maybe (NodeNr, PortName)
otherExtremeOfEdgeConnectedOnPort network nodeNr port =
    case edgeConnectedOnPort network nodeNr port of
     Just edgeNr | getFullPortFrom (getEdge edgeNr network) == (nodeNr, port) -> Just $ getFullPortTo   (getEdge edgeNr network)
     Just edgeNr | getFullPortTo   (getEdge edgeNr network) == (nodeNr, port) -> Just $ getFullPortFrom (getEdge edgeNr network)
     _ -> Nothing

point2EdgeInNode :: Palette n -> NodeNr -> PortName -> PortName -> Network g n e -> DoublePoint
point2EdgeInNode palette nodeNr fromPort toPort network =
	case getPorts palette network nodeNr of
	  Just ports ->
	     case (Prelude.lookup fromPort ports, Prelude.lookup toPort ports) of
		(Just fromPortPos, Just toPortPos) ->
		    g (portZone (fromPort,fromPortPos)) (portZone (toPort,toPortPos))
		_ -> error "unexpected situation"
	  Nothing -> f 1 1
        where  g Ztop    Ztop    = top 
               g Zbottom Zbottom = bottom 
               g Zleft   Zleft   = left
               g Zright  Zright  = right
               g Ztop    Zbottom = right
               g Zbottom Ztop    = right
               g Zleft   Zright  = top
               g Zright  Zleft   = top
               g Ztop    Zleft   = q2
               g Ztop    Zright  = q1
               g Zbottom Zleft   = q3
               g Zbottom Zright  = q4
               g Zleft   Ztop    = q2
               g Zleft   Zbottom = q3
               g Zright  Ztop    = q1
               g Zright  Zbottom = q4

               param = 2.0
               f x y = translate (getNodePosition network nodeNr) $ DoublePoint (x * param) (y * param)

               top    = f 0 (-1)  
               bottom = f 0 1
               left   = f (-1) 0
               right  = f 1 0
               q1     = f 1 (-1)
               q2     = f (-1) (-1)
               q3     = f (-1) 1
               q4     = f 1 1

isPrincipalPort :: Palette n -> Network g n e -> NodeNr -> PortName -> Bool
isPrincipalPort palette network nodeNr port =
  maybe False f $ getPorts palette network nodeNr
  where
        f ((port2,_):_) = port2 == port
        f _ = False

getPorts :: Palette n -> Network g n e -> NodeNr -> Maybe Ports
getPorts palette network nodeNr =
     case getSymbol (getNodeShape network nodeNr) palette of
        Just (_,ports,_) -> Just ports
        _ -> Nothing

getPort :: Palette n -> Network g n e -> (NodeNr,PortName) -> Maybe Port
getPort palette network (nodeNr,portName) =
     case getSymbol (getNodeShape network nodeNr) palette of
        Just (_,ports,_) ->
	     case Prelude.lookup portName ports of
		Just portPosition -> Just (portName, portPosition)
		_ -> Nothing
        _ -> Nothing