{- | Module : Data.Graph.Planar Description : Planar Graph data structure. Copyright : (c) Ivan Lazar Miljenovic License : 3-Clause BSD-style Maintainer : Ivan.Miljenovic@gmail.com Planar graphs are graphs that can be embedded onto a surface (i.e. they can be drawn on that surface without any edges crossing). As such, it is preferable to use a dedicated data structure for them that has information about how to achieve this embedding rather than a standard graph data structure. (Please note however that this implementation has only been tested in terms of the embedding being on the unit sphere or disc; whether it works or not as-is on any other type of surface is unknown.) The implementation here is loosely based upon that found in /plantri/ by Gunnar Brinkmann and Brendan McKay: (which is similar in concept to a doubly-connected edge list). The main differences are (if my understanding of the C code is correct): * plantri uses arrays (technically it uses one big array that it continually mutates); planar-graph uses Maps (thus making it easier to grow/shrink graphs). * plantri doesn't explicitly store nodes, just edges. * plantri utilises pointers, avoiding extra lookups. * Each edge stores in plantri has the face it is on, but only after they are explicitly calculated. In planar-graph, 'getFaces' instead returns a Map for the faces. * plantri doesn't allow labels. * plantri can only encode the graphs; "Data.Graph.Planar.Serialisation" also allows you to decode graphs. In particular, all edges - even undirected ones - are stored as two opposing directed half-edges. As such, care should be taken when dealing with edges. Also, the 'Node', 'Edge' and 'Face' identifiers are all abstract, and as such cannot be constructed directly. All returned 'CList's represent values in a clockwise fashion (relative to the 'Node' or 'Face' in question). Care should also be taken when dealing with more than one connected component, as there is no fixed embedding of multiple graphs on the same surface. -} module Data.Graph.Planar ( PlanarGraph -- * Graph Information -- ** Information about the nodes , Node , order , hasNode , nodes , labNodes , outgoingEdges , incomingEdges , neighbours , nodeLabel -- ** Information about the edges -- $edges , Edge , size , hasEdge , halfEdges , labHalfEdges , halfEdgesBetween , labHalfEdgesBetween , edges , labEdges , edgesBetween , labEdgesBetween , fromNode , toNode , prevEdge , nextEdge , inverseEdge , edgeLabel -- * Graph Manipulation , mirrorGraph , mergeGraphs , mergeAllGraphs -- ** Graph Construction , empty , addNode , addUNode , EdgePos(..) , addEdge , addEdgeUndirected , addUEdge -- ** Graph Deconstruction , isEmpty , deleteNode , deleteNodes , deleteEdge , deleteEdges , contractEdge -- ** Other , unlabel , mapNodes , adjustNodeLabel , setNodeLabel , mapEdges , adjustEdgeLabel , setEdgeLabel -- * Graph traversal , traverse , serialiseBFS , traverseGraph , traverseComponents -- ** Controlling traversal , Traversal , breadthFirst , depthFirst , antiClockwiseTraversal , spanningTraversal -- ** Results of traversing , TraversedValues , serialisedTraversal , traversedNodes , traversedEdges , renumberedTraversal , traversalComponent , traversalNodeFn , traversalRevNodeFn , traversalRevNodeFn' , traversalEdgeFn , traversalRevEdgeFn , traversalRevEdgeFn' -- * Graph duals and faces -- $duals -- ** Faces in the graph , Face , FaceMap , FaceInfo , faceNodes , edgeCrossings , faceEdges , adjoiningFaces , getFaces , getFace -- ** Constructing the dual , makeDual , toDual -- * Isomorphism testing , canonicalExampleBy , canonicalMirrorExampleBy , onlyCanonicalExamples , onlyCanonicalMirrorExamples , toCanonical -- * Alternate representations -- ** Serialisation -- $serialisation , SerialisedGraph , serialise , deserialise -- ** Pretty-Printing , prettify , prettyPrint , prettifyDetailed , detailedPrint , prettifyStructure , structurePrint ) where import Data.Graph.Planar.Internal import qualified Data.CircularList as CL import Data.CircularList hiding (empty, isEmpty, size) import qualified Data.DList as DL import Data.DList(DList) import qualified Data.Array.IArray as A import Data.List(unfoldr,partition,mapAccumL,foldl',delete) import Data.Maybe(fromJust,fromMaybe,catMaybes) import Data.Monoid(Monoid(mempty)) import qualified Data.Map as M import Data.Map(Map, (!)) import qualified Data.Set as S import Data.Set(Set) import qualified Data.Sequence as Seq import Data.Sequence(Seq, (|>), viewl, ViewL(..)) import qualified Data.Traversable as T import Data.Word(Word) import Control.Applicative(Applicative(..), (<*), (<|>), (<$>), liftA2) import Control.Arrow(first, second, (&&&)) import Control.Monad(liftM,liftM2,ap,(>=>)) -- ----------------------------------------------------------------------------- {- INVARIANT: | e - inverse e | == 1 That is, edge IDs are +/- 1 their inverse. The lower edge identifier is assumed to be the primary one (i.e. the actual edge). -} -- | The number of nodes in the graph (i.e. @length . nodes@). order :: PlanarGraph n e -> Int order = M.size . _nodes -- | The number of edges in the graph (i.e. @length . edges@). size :: PlanarGraph n e -> Int size = (`div`2) . M.size . _edges -- | Remove all labels from this graph. unlabel :: PlanarGraph n e -> PlanarGraph () () unlabel = withNodes rmNs . withEdges rmEs where rmNs = M.map (\ni -> ni {nodeInfo = ()}) rmEs = M.map (\ei -> ei {edgeInfo = ()}) -- | Apply a mapping function over the node labels. mapNodes :: (n -> n') -> PlanarGraph n e -> PlanarGraph n' e mapNodes f = withNodes (M.map mf) where mf ni = ni { nodeInfo = f $ nodeInfo ni } mapNodeIDsMonotonic :: (Node -> Node) -> PlanarGraph n e -> PlanarGraph n e mapNodeIDsMonotonic f = withNodes (M.mapKeysMonotonic f) . withEdges (M.map fEI) where fEI ei = ei { _fromNode = f $ _fromNode ei , _toNode = f $ _toNode ei } mapEdgeIDsMonotonic :: (Edge -> Edge) -> PlanarGraph n e -> PlanarGraph n e mapEdgeIDsMonotonic f = withNodes (M.map fNI) . withEdges (M.mapKeysMonotonic f . M.map fEI) where fNI ni = ni { outgoing = fmap f $ outgoing ni } fEI ei = ei { _prevEdge = f $ _prevEdge ei , _nextEdge = f $ _nextEdge ei , inverse = f $ inverse ei } -- | Is this node still in the graph? hasNode :: PlanarGraph n e -> Node -> Bool hasNode pg n = n `M.member` _nodes pg -- | All the nodes in the graph (in some arbitrary order). nodes :: PlanarGraph n e -> [Node] nodes = M.keys . _nodes -- | All the nodes and their labels in the graph (in some arbitrary -- order). labNodes :: PlanarGraph n e -> [(Node, n)] labNodes = map (second nodeInfo) . M.assocs . _nodes -- | Is this edge still in the graph? hasEdge :: PlanarGraph n e -> Edge -> Bool hasEdge pg e = e `M.member` _edges pg -- | All the half-edges (thus also including inverses) in the graph -- (in some arbitrary order). halfEdges :: PlanarGraph n e -> [Edge] halfEdges = M.keys . _edges -- | All the half-edges and their labels in the graph (in some -- arbitrary order). labHalfEdges :: PlanarGraph n e -> [(Edge, e)] labHalfEdges = map (second edgeInfo) . M.assocs . _edges -- | A variant of 'halfEdges' that returns the pair of nodes that form an -- edge rather than its unique identifier (again including inverse -- edges). halfEdgesBetween :: PlanarGraph n e -> [(Node,Node)] halfEdgesBetween = map (liftM2 (,) _fromNode _toNode) . M.elems . _edges -- | As with 'halfEdgesBetween', but including the labels. labHalfEdgesBetween :: PlanarGraph n e -> [((Node,Node),e)] labHalfEdgesBetween = map (liftM2 (,) (liftM2 (,) _fromNode _toNode) edgeInfo) . M.elems . _edges -- The following four functions cheat by abusing the fact that the -- first edge of every pair added is even. -- | All the primary edges in the graph returned in arbitrary order. edges :: PlanarGraph n e -> [Edge] edges = filter (even . edge) . halfEdges -- | All the primary edges and their labels in the graph (in some -- arbitrary order). labEdges :: PlanarGraph n e -> [(Edge, e)] labEdges = filter (even . edge . fst) . labHalfEdges -- | A variant of 'edges' that returns the pair of nodes that form the -- primary edges. edgesBetween :: PlanarGraph n e -> [(Node,Node)] edgesBetween = map (liftM2 (,) _fromNode _toNode . snd) . filter (even . edge . fst) . M.assocs . _edges -- | As with 'edgesBetween' but including the labels. labEdgesBetween :: PlanarGraph n e -> [((Node,Node),e)] labEdgesBetween = map (liftM2 (,) (liftM2 (,) _fromNode _toNode) edgeInfo . snd) . filter (even . edge . fst) . M.assocs . _edges newNodeID :: PlanarGraph n e -> Node newNodeID = newID _nodes initNode succNode {-# INLINE newNodeID #-} newEdgeID :: PlanarGraph n e -> Edge newEdgeID = newID _edges initEdge succEdge {-# INLINE newEdgeID #-} newID :: (Ord k) => (PlanarGraph n e -> Map k a) -> k -> (k -> k) -> PlanarGraph n e -> k newID used initID succID pg | M.null ks = initID | minUsed > initID = initID -- Missing from front | otherwise = succID maxUsed where ks = used pg ksIDs = M.keys ks minUsed = head ksIDs maxUsed = fst $ M.findMax ks -- | Returns the "mirrored" graph by swapping the order of rotations. mirrorGraph :: PlanarGraph n e -> PlanarGraph n e mirrorGraph = withNodes (M.map fNI) . withEdges (M.map fEI) where fNI ni = ni { outgoing = reverseDirection $ outgoing ni } fEI ei = ei { _prevEdge = _nextEdge ei , _nextEdge = _prevEdge ei } -- | @mergeGraphs pg1 pg2@ creates a disjoint union between @pg1@ and -- @pg2@ (i.e. puts them into the same graph but disconnected). -- This is used when they were created independently and thus -- probably have clashing @Node@ and @Edge@ values. For best -- performance, @pg1@ should be larger than @pg2@. -- -- Along with the merged graph, two functions are returned: they -- respectively convert Node and Edge values from @pg2@ to those -- found in the merged graph. -- -- Please note that these functions are /partial/ and should only be -- used for the Node and Edge identifiers from @pg2@. mergeGraphs :: PlanarGraph n e -> PlanarGraph n e -> (PlanarGraph n e, Node -> Node, Edge -> Edge) mergeGraphs pg1@(PG ns1 es1) pg2 = (PG ns es, transN, transE) where transN = transNodeID pg1 pg2 transE = transEdgeID pg1 pg2 PG { _nodes = ns2', _edges = es2' } = mapNodeIDsMonotonic transN . mapEdgeIDsMonotonic transE $ pg2 ns = ns1 `M.union` ns2' es = es1 `M.union` es2' {- These three functions used for merging purposes only. For efficiency reasons, use a direct "numeric" shift of IDs when merging two graphs as the translation function becomes O(1). -} transNodeID :: PlanarGraph n e -> PlanarGraph n e -> (Node -> Node) transNodeID = transID _nodes Node node {-# INLINE transNodeID #-} transEdgeID :: PlanarGraph n e -> PlanarGraph n e -> (Edge -> Edge) transEdgeID = transID _edges Edge edge {-# INLINE transEdgeID #-} transID :: (PlanarGraph n e -> Map k a) -> (Word -> k) -> (k -> Word) -> PlanarGraph n e -> PlanarGraph n e -> (k -> k) transID used toID fromID pg1 pg2 | M.null ks1 = id | M.null ks2 = id | min2 > max1 = id -- Already distinct pairings | otherwise = \ id2 -> toID $ fromID id2 - min2 + max1 + 1 where ks1 = used pg1 ks2 = used pg2 max1 = fromID . fst $ M.findMax ks1 min2 = fromID . fst $ M.findMin ks2 -- | Merge all the provided planar graphs together into one large -- graph, and provide translation functions for every graph in the -- list (the first pair in this list is just @('id','id')@). -- -- See 'mergeGraphs' for more information. For best performance, -- the graphs should be decreasing in size/order. mergeAllGraphs :: [PlanarGraph n e] -> (PlanarGraph n e, [(Node -> Node, Edge -> Edge)]) mergeAllGraphs [] = (empty, []) mergeAllGraphs (pg:pgs) = second ((id,id):) $ mapAccumL mrg pg pgs where mrg = (shift .) . mergeGraphs shift (a,b,c) = (a,(b,c)) -- ----------------------------------------------------------------------------- -- Construction -- | Constructs an empty planar graph. empty :: PlanarGraph n e empty = PG { _nodes = M.empty , _edges = M.empty } -- | Add a node with the provided label to the graph, returning the -- updated graph and the node identifier. addNode :: n -> PlanarGraph n e -> (Node, PlanarGraph n e) addNode n pg = (n', withNodes (M.insert n' ni) pg) where n' = newNodeID pg ni = NInfo { outgoing = CL.empty , nodeInfo = n } -- | As with 'addNode', but uses @'mempty'@ as the label. addUNode :: (Monoid n) => PlanarGraph n e -> (Node, PlanarGraph n e) addUNode = addNode mempty -- | Specification of where to place a new edge on a node in clockwise order. data EdgePos = Anywhere -- ^ The new edge can be placed anywhere. | BeforeEdge !Edge -- ^ The new edge should be placed before the specified edge. | AfterEdge !Edge -- ^ The new edge should be placed after the specified edge. deriving (Eq, Ord, Show, Read) {- | Add an edge between two nodes @f@ and @t@. In reality, since all edges are duplicated (see 'inverseEdge'), two half-edges are inserted, and the identifiers of both are returned. For functions such as 'edges', the first added half-edge is assumed to be the /primary/ one. If either node does not currently have any edges, then its corresponding 'EdgePos' value is ignored. An 'EdgePos' of 'Anywhere' will place the edge before (i.e. anti-clockwise) of the last edge added to that node. For example, let @g@ refer to the following graph (where @n1@, etc. are both the labels and the variable names): > ==== ==== > ( n1 ) ( n2 ) > ==== ==== > > > > > > ==== > ( n3 ) > ==== We can add an edge between @n1@ and @n2@ (using 'Anywhere' as the 'EdgePos' since there are currently no edges on either node): > ((e1,e2),g') = addEdge n1 Anywhere n2 Anywhere "e1" "e2" g This will result in the following graph: > e2 > ==== <--------------- ==== > ( n1 ) ( n2 ) > ==== ---------------> ==== > e1 > > > > > ==== > ( n3 ) > ==== If we want to add edges between @n2@ and @n3@, we have three options for the location on @n2@: * Use @'Anywhere'@: since there is only one other edge, it makes no difference in terms of the embedding where the second edge goes. * Put the new edge @'BeforeEdge' e2@ (going clockwise around @n2@). * Put the new edge @'AfterEdge' e2@ (going clockwise around @n2@). Since @n2@ currently only has one edge, all three 'EdgePos' values will result in the same graph, so we can arbitrarily pick one: > ((e3,e4),g'') = addEdge n2 (BeforeEdge e2) n3 Anywhere "e3" "e4" g' However, with more edges care must be taken on which 'EdgePos' value is used. The resulting graph is: > e2 > ==== <--------------- ==== > ( n1 ) ( n2 ) > ==== ---------------> ==== > e1 | ^ > | | > e3 | | e4 > | | > v | > ==== > ( n3 ) > ==== The same graph (up to the actual 'Edge' values; so it won't satisfy @==@) would have been obtained with: > ((e4,e3), g'') = addEdge n3 Anywhere n2 (BeforeEdge e2) "e4" "e3" g' (Note, however, that now 'edges' will return @e4@ rather than @e3@ as it is considered to be the primary edge.) -} addEdge :: Node -- ^ The node @f@ at which the main edge starts. -> EdgePos -- ^ Positioning information at @f@. -> Node -- ^ The node @t@ at which the main edge ends. -> EdgePos -- ^ Positioning information at @t@ for -- the inverse edge (i.e. refers to -- @'outgoingEdges' t@). -> e -- ^ The label for the main edge @f -> t@. -> e -- ^ The label for the inverse edge @t -> f@. -> PlanarGraph n e -- ^ The graph at which to add the edge. -> ((Edge, Edge), PlanarGraph n e) -- ^ The main and inverse edge -- identifiers, and the updated -- graph. addEdge f fpos t tpos e1 e2 pg = ((e1',e2'), pg') where pg' = withEdges updateEdges . withNodes (M.insert t tNi . M.insert f fNi) $ pg e1' = newEdgeID pg -- Relying upon the invariant here, so that any gaps will be of even size. e2' = succEdge e1' updateEdges = fixAround e1' fPrv fNxt . fixAround e2' tPrv tNxt . M.insert e2' ei2 . M.insert e1' ei1 fixAround e p n = M.adjust (\inf -> inf {_nextEdge = e}) p . M.adjust (\inf -> inf {_prevEdge = e}) n (fPrv,fNxt,fNi) = edgePos f fpos e1' pg (tPrv,tNxt,tNi) = edgePos t tpos e2' pg ei1 = EInfo { _fromNode = f , _toNode = t , _prevEdge = fPrv , _nextEdge = fNxt , inverse = e2' , edgeInfo = e1 } ei2 = EInfo { _fromNode = t , _toNode = f , _prevEdge = tPrv , _nextEdge = tNxt , inverse = e1' , edgeInfo = e2 } -- Work out where to put the new edge at the specified starting node. edgePos :: Node -> EdgePos -> Edge -> PlanarGraph n e -> (Edge, Edge, NodeInfo n) edgePos f pos e pg | CL.isEmpty es = (e, e, ni { outgoing = singleton e }) | otherwise = (prv, nxt, ni { outgoing = insertR e esR }) where ni = getNodeInfo pg f es = outgoing ni esR = case pos of Anywhere -> es (BeforeEdge e') -> rot e' es (AfterEdge e') -> rotR $ rot e' es prv = prevElem esR -- No need to use nextElem as we haven't added the new edge yet -- Safe to use fromJust here: esR won't be empty or else an error -- would have already been thrown. nxt = fromJust $ focus esR rot e' = fromMaybe (error $ "When adding an edge, " ++ show f ++ " does not have " ++ show e' ++ " as an outgoing edge") . rotateTo e' -- | As with 'addEdge', but the edges are meant to be undirected so -- use the same label for both. addEdgeUndirected :: Node -> EdgePos -> Node -> EdgePos -> e -> PlanarGraph n e -> (Edge, PlanarGraph n e) addEdgeUndirected f fP t tP e = first fst . addEdge f fP t tP e e -- | As with 'addEdge', but both labels are set to @'mempty'@. addUEdge :: (Monoid e) => Node -> EdgePos -> Node -> EdgePos -> PlanarGraph n e -> ((Edge, Edge), PlanarGraph n e) addUEdge f fP t tP = addEdge f fP t tP mempty mempty -- ----------------------------------------------------------------------------- -- Deconstruction -- | Determines if the graph is empty. isEmpty :: PlanarGraph n e -> Bool isEmpty = M.null . _nodes -- | Delete the node and all adjacent edges from the graph. deleteNode :: Node -> PlanarGraph n e -> PlanarGraph n e deleteNode n pg = withNodes (delens' . M.delete n) . withEdges (deles' . deles) $ pg where es = toList $ outgoingEdges pg n deles em = foldr M.delete em es es' = map (inverseEdge pg) es eis' = map (getEdgeInfo pg) es' deles' em = foldr ($) em $ zipWith delE es' eis' delens' nm = foldr ($) nm $ zipWith delEN es' eis' -- | Delete all of the specified nodes. deleteNodes :: [Node] -> PlanarGraph n e -> PlanarGraph n e deleteNodes = flip (foldl' $ flip deleteNode) -- | Delete the edge and its inverse from the graph. deleteEdge :: Edge -> PlanarGraph n e -> PlanarGraph n e deleteEdge e pg | hasEdge pg e = withEdges (delE eInv eiInv . delE e ei) . withNodes (delEN eInv eiInv . delEN e ei) $ pg | otherwise = pg where ei = getEdgeInfo pg e eInv = inverse ei eiInv = getEdgeInfo pg eInv -- | Delete all of the specified edges (and their inverses). deleteEdges :: [Edge] -> PlanarGraph n e -> PlanarGraph n e deleteEdges = flip (foldl' $ flip deleteEdge) -- Deletes the provided edge from the outgoing list of the node it -- comes from in the NodeMap. delEN :: Edge -> EdgeInfo e -> NodeMap n -> NodeMap n delEN e ei = M.adjust (\inf -> inf { outgoing = removeR . fromJust . rotateTo e $ outgoing inf }) (_fromNode ei) -- Deletes the provided edge from the EdgeMap, and fixes up references -- in adjacent edges. delE :: Edge -> EdgeInfo e -> EdgeMap e -> EdgeMap e delE e ei = M.adjust (\inf -> inf { _prevEdge = _prevEdge ei }) (_nextEdge ei) . M.adjust (\inf -> inf { _nextEdge = _nextEdge ei }) (_prevEdge ei) . M.delete e -- | Merges the two nodes adjoined by this edge, and delete all edges -- between them. The provided function is to decide what the label -- for the resulting node should be (if the edge goes from @f@ to -- @t@, then the function is @fLabel -> tLabel -> newLabel@). The -- 'Node' value for the merged node is @'fromNode' pg e@. -- -- Note that this may result in multiple edges between the new node -- and another node if it is adjacent to both nodes being merged. contractEdge :: Edge -> (n -> n -> n) -> PlanarGraph n e -> PlanarGraph n e contractEdge e newL pg = withNodes adjNs . withEdges adjEs $ pg where ei = getEdgeInfo pg e f = _fromNode ei t = _toNode ei eInv = inverse ei -- eInvI = getEdgeInfo pg eInv fi = getNodeInfo pg f (fout,fDel) = validEs t e $ outgoing fi ti = getNodeInfo pg t (tout,tDel) = validEs f eInv $ outgoing ti es = fromList es' es' = fout ++ tout esL = toList $ rotL es esR = toList $ rotR es -- fromJust should be safe here, as it's using values obtained -- internally. validEs n' e' = partition ((/=n') . _toNode . getEdgeInfo pg) . toList . fromJust . rotateTo e' fi' = NInfo { outgoing = es , nodeInfo = newL (nodeInfo fi) (nodeInfo ti) } adjNs = M.insert f fi' . M.delete t adjEs = fixRefs . flip (foldr M.delete) (fDel ++ tDel) fixRefs pg' = foldr fixRef pg' $ zip3 esL es' esR fixRef (prv,thisE,nxt) = M.adjust (\ei' -> ei' { _fromNode = f , _prevEdge = prv , _nextEdge = nxt } ) thisE . M.adjust (\ei' -> ei' { _toNode = f }) (inverseEdge pg thisE) -- ----------------------------------------------------------------------------- succNode :: Node -> Node succNode = Node . succ . node initNode :: Node initNode = Node minBound -- Assumes the node is part of the graph withNode :: Either String a -> (NodeInfo n -> a) -> PlanarGraph n e -> Node -> a withNode enm f pg n = maybe df f . M.lookup n $ _nodes pg where df = either mkErr id enm mkErr nm = error $ nm ++ ": the node " ++ show n ++ " is not part of the specified graph." {-# INLINE withNode #-} getNodeInfo :: PlanarGraph n e -> Node -> NodeInfo n getNodeInfo = withNode (Left "getNodeInfo") id {-# INLINE getNodeInfo #-} -- | Returns all outgoing edges for the specified node, travelling -- clockwise around the node. It assumes the node is indeed in the -- graph. outgoingEdges :: PlanarGraph n e -> Node -> CList Edge outgoingEdges = withNode (Right CL.empty) outgoing -- | Returns all incoming edges for the specified node, travelling -- clockwise around the node. It assumes the node is indeed in the -- graph. incomingEdges :: PlanarGraph n e -> Node -> CList Edge incomingEdges pg = fmap (inverseEdge pg) . outgoingEdges pg -- | Returns the label for the specified node. nodeLabel :: PlanarGraph n e -> Node -> n nodeLabel = withNode (Left "nodeLabel") nodeInfo -- | Apply a function to the label of the specified node. adjustNodeLabel :: (n -> n) -> Node -> PlanarGraph n e -> PlanarGraph n e adjustNodeLabel f = withNodes . M.adjust (\ni -> ni { nodeInfo = f $ nodeInfo ni }) -- | Set the label of the specified node. setNodeLabel :: n -> Node -> PlanarGraph n e -> PlanarGraph n e setNodeLabel = adjustNodeLabel . const -- | The 'Node's that are connected to this 'Node' with an edge (in -- clockwise order). neighbours :: PlanarGraph n e -> Node -> CList Node neighbours pg = withNode (Right CL.empty) (fmap (toNode pg) . outgoing) pg -- ----------------------------------------------------------------------------- {- $edges To be able to embed the required order of edges around a particular 'Node', we can't rely on just having each node specify which other nodes are adjacent to it as with non-planar graph types; instead, we need a unique identifier (to be able to distinguish between multiple edges between two nodes). Furthermore, each edge has an /inverse edge/ in the opposite direction. To be more precise, these can be referred to as /half-edges/. Due to every edge having an inverse, a 'PlanarGraph' implicitly /undirected/ even though each edge is directed. As such, if you require a directed planar graph, use appropriate edge labels to denote whether an edge is the one you want or just its inverse. Note the distinction between functions such as 'edges' and 'halfEdges': the latter returns every single half-edge (i.e the inverse \"edge\" is also included) whereas the former only considers the /primary/ edge. The distinction is made when adding edges to the graph: the first edge added in 'addEdge' is considered the primary one. To be more specific: > length . edges == size > length . halfEdges == 2 * size -} succEdge :: Edge -> Edge succEdge = Edge . succ . edge initEdge :: Edge initEdge = Edge minBound -- Assumes the edge is part of the graph withEdge :: String -> (EdgeInfo e -> a) -> PlanarGraph n e -> Edge -> a withEdge nm f pg e = maybe err f . M.lookup e $ _edges pg where err = error $ nm ++ ": the edge " ++ show e ++ " is not part of the specified graph." {-# INLINE withEdge #-} getEdgeInfo :: PlanarGraph n e -> Edge -> EdgeInfo e getEdgeInfo = withEdge "getEdgeInfo" id {-# INLINE getEdgeInfo #-} -- | The 'Node' which this 'Edge' is coming from. fromNode :: PlanarGraph n e -> Edge -> Node fromNode = withEdge "fromNode" _fromNode -- | The 'Node' which this 'Edge' is going to. toNode :: PlanarGraph n e -> Edge -> Node toNode = withEdge "toNode" _toNode -- | The previous 'Edge' going clockwise around the 'fromNode'. prevEdge :: PlanarGraph n e -> Edge -> Edge prevEdge = withEdge "prevEdge" _prevEdge -- | The next 'Edge' going clockwise around the 'fromNode'. nextEdge :: PlanarGraph n e -> Edge -> Edge nextEdge = withEdge "nextEdge" _nextEdge -- | The 'Edge' that is an inverse to this one; i.e.: -- -- > fromNode pg e == toNode pg $ inverseEdge pg e -- > toNode pg e == fromNode pg $ inverseEdge pg e inverseEdge :: PlanarGraph n e -> Edge -> Edge inverseEdge = withEdge "inverseEdge" inverse -- | Return the label for the specified edge. edgeLabel :: PlanarGraph n e -> Edge -> e edgeLabel = withEdge "edgeLabel" edgeInfo -- | Apply a function to the label of the specified edge. adjustEdgeLabel :: (e -> e) -> Edge -> PlanarGraph n e -> PlanarGraph n e adjustEdgeLabel f = withEdges . M.adjust (\ei -> ei { edgeInfo = f $ edgeInfo ei }) -- | Set the label of the specified edge. setEdgeLabel :: e -> Edge -> PlanarGraph n e -> PlanarGraph n e setEdgeLabel = adjustEdgeLabel . const -- ----------------------------------------------------------------------------- {- $duals The /dual/ of a planar graph /G/ is another planar graph /H/ such that /H/ has an node for every face in /G/, and an edge between two nodes if the corresponding faces in /G/ are adjacent. For example, the graph (drawn as an undirected graph for simplicity): > o---------o---------o > | | | > | f1 | f2 | > | | | > o---------o---------o > \ / > \ / > \ f3 / > \ / > outer \ / > face \ / > \ / > \ / > \ / > o has a dual graph of: > ...... > ..... ..... > ... .. > .. ...... .. > . . . . > . . ===== ===== ..... > . . ..( f1 )...( f2 ) .... > . . .. ===== ===== .. > . . . . . . > . . . . . . > . ===== ===== . > . / \.........( f3 )... . > / \ ===== .... . > | outer | . . > \ face / . . > \ / . . . > ===== . . . > . . . . > . . . . > . ............. . > . . > .. . > . . > . .... > ................ A dual graph is a planar /multigraph/: it will still be a planar graph, but may have loops and multiple edges. However, the dual of a dual graph will be the original graph (though no guarantees are made that @g == makeDual (makeDual g)@ due to differing 'Node' and 'Edge' values). Note that the functions here assume that the graph is /connected/; in effect multiple connected components will be treated individually with no notion of relative embeddings. -} enumFace :: Face -> [Face] enumFace = map Face . enumFrom . face initFace :: Face initFace = Face minBound -- | The 'Edge's that make up the face. faceEdges :: FaceInfo -> CList Edge faceEdges = fmap (fst . fst) . edgeCrossings -- | The adjoining 'Face's. Will have repeats if the 'Face's are -- adjacent over more than one 'Edge'. adjoiningFaces :: FaceInfo -> CList Face adjoiningFaces = fmap snd . edgeCrossings -- | Create the dual of a planar graph. If actual node and edge -- labels are required, use 'toDual'. makeDual :: PlanarGraph n e -> PlanarGraph () () makeDual = snd . toDual (const ()) (const . const . const ()) . getFaces -- | Create the planar graph corresponding to the dual of the face -- relationships. The usage of 'FaceMap' rather than 'PlanarGraph' -- is to allow you to use the 'FaceMap' for constructing the -- label-creation functions if you so wish. -- -- The function @eLabel@ for edge labels takes the 'Face' that the -- edge comes from, the 'Edge' belonging to that 'Face' that it is -- crossing and then the 'Face' that it is going to. For example: -- -- > .... ....> -- > ...> =====.... -- > (#####) -- > ===== -- > | ^ e2 -- > | | -- > | | -- > face1 | | face2 -- > | | -- > | | -- > | | -- > e1 v | -- > ===== -- > (#####) -- > ...===== <.. -- > <... .... -- > ... -- -- Here, the edge in the dual graph going from /face1/ to /face2/ -- will have a label of \"@eLabel face1 e1 face2@\", and the edge -- going from /face2/ to /face1/ will have a label of \"@eLabel -- face2 e2 face1@\". -- -- The returned functions are a mapping from the faces in the -- 'FaceMap' to the nodes in the dual graph, and the edges in the -- original graph to the edge in the dual that crosses it (e.g. in -- the above diagram, /e1/ will have a mapping to the edge from -- /face1/ to /face2/). toDual :: (Face -> n) -> (Face -> Edge -> Face -> e) -> FaceMap -> ((Face -> Node,Edge -> Edge), PlanarGraph n e) toDual nLab eLab fm = ((f2n, e2e), dl) where -- Need a more rigorous definition of this; currently relies on -- behaviour of deserialise :s f2n = Node . face e2e = id dl = deserialise . map serialiseFace . M.assocs $ fm serialiseFace (f,fi) = (face f, nLab f, es) where es = map (mkFace f) . toList $ edgeCrossings fi mkFace f ((e,ei),f') = (edge e, face f', eLab f e f', edge ei) -- | Finds all faces in the planar graph. A face is defined by -- traversing along the right-hand-side of edges, e.g.: -- -- > -- > o----------------------------->o -- > ^..............................| -- > |..............................| -- > |..............FACE............| -- > |..............................| -- > |..............................v -- > o<-----------------------------o -- > -- -- (with the inverse edges all being on the outside of the edges -- shown). getFaces :: PlanarGraph n e -> FaceMap getFaces pg = M.fromList fis where efm = M.fromList . concatMap (\(fid, finfs) -> map (flip (,) fid) finfs) $ map (second (toList . faceEdges)) fis fis = zip (enumFace initFace) . unfoldr (getNextFace pg efm) . M.keysSet $ _edges pg -- | Finds a new face in the provided graph, where the Set contains -- all edges which have not yet been matched up to a face. getNextFace :: PlanarGraph n e -> EdgeFaceMap -> Set Edge -> Maybe (FaceInfo, Set Edge) getNextFace pg efm unmatchedEs | S.null unmatchedEs = Nothing | otherwise = Just (f, unmatchedEs') where e = S.findMin unmatchedEs (ns, es) = getFace pg e toCrossing e' = let ei' = inverseEdge pg e' in ((e',ei'), efm ! ei') unmatchedEs' = unmatchedEs `S.difference` S.fromList es f = FInfo { faceNodes = fromList ns , edgeCrossings = fromList $ map toCrossing es } -- | Returns all nodes and edges in the same face as the provided edge -- (including that edge); assumes the edge is part of the graph. getFace :: PlanarGraph n e -> Edge -> ([Node], [Edge]) getFace pg e = unzip $ (fromNode pg e, e) : unfoldr go e where go e' | e == e'' = Nothing | otherwise = Just (nxt, e'') where nxt = nextInFace pg e' e'' = snd nxt -- | Returns the next node and edge in the same face as the provided -- edge. Assumes the provided edge is indeed in this graph. nextInFace :: PlanarGraph n e -> Edge -> (Node, Edge) nextInFace pg e = (n', e') where eI = _edges pg ! e eInv = inverse eI n' = _toNode eI e' = _prevEdge $ _edges pg ! eInv -- ----------------------------------------------------------------------------- -- Serialisation and pretty-printing {- $serialisation Serialisation support can be found here to aid in converting a 'PlanarGraph' to alternate formats. Care should be taken when constructing the 'SerialisedGraph', and these functions should not be abused just to edit an existing 'PlanarGraph'. -} -- | Perform a breadth-first traversal serialisation of the provided -- graph. If an edge is provided, then it is the first edge and its -- 'fromNode' is the first node; if no edge is provided then an -- arbitrary edge is chosen. -- -- Up to the choice of starting edge, the returned 'SerialisedGraph' -- should be unique no matter how the graph was constructed /if/ the -- graph consists of only one component. serialiseBFS :: PlanarGraph n e -> Maybe Edge -> SerialisedGraph n e serialiseBFS = traverse breadthFirst -- | Use the specified traversal to provide a serialisation of the -- provided graph. If an edge is provided, then it is the first -- edge and its 'fromNode' is the first node; if no edge is provided -- then an arbitrary edge is chosen. -- -- Up to the choice of starting edge, the returned 'SerialisedGraph' -- should be unique no matter how the graph was constructed /if/ the -- graph consists of only one component. traverse :: Traversal -> PlanarGraph n e -> Maybe Edge -> SerialisedGraph n e traverse trv pg = serialisedTraversal . traverseGraph trv pg -- | Traverse the graph using the specified traversal. If an edge is -- provided, then it is the first edge and its 'fromNode' is the -- first node; if no edge is provided then an arbitrary edge is -- chosen. -- -- Up to the choice of starting edge, the 'serialisedTraversal' of -- the returned 'TraversedValues' should be unique no matter how the -- graph was constructed /if/ the graph consists of only one -- component. traverseGraph :: Traversal -> PlanarGraph n e -> Maybe Edge -> TraversedValues n e traverseGraph trv pg = toTV . mergeAllTR . evalState traverseAllComps . initTS False trv pg -- | Traverse the graph using the specified traversal, and return a -- 'TraversedValues' for each connected component. If an edge is -- provided, then it is the first edge and its 'fromNode' is the -- first node of the /first/ connected component; if no edge is -- provided then an arbitrary edge is chosen. -- -- The 'Bool' parameter signifies whether each component should be -- re-numbered when traversed (use 'False' if you want to refer to -- the original graph). -- -- The ordering of components after the first (if an initial edge is -- specified) are picked arbitrarily. traverseComponents :: Bool -> Traversal -> PlanarGraph n e -> Maybe Edge -> [TraversedValues n e] traverseComponents sc trv pg = map toTV . evalState traverseAllComps . initTS sc trv pg {- | Different ways of traversing through a graph. To assist in visualising how the traversals differ, sample traversals will be provided for the following graph: > ===== > ( 1 ) > ===== > | > a | > | > ===== > ( 2 ) > ===== > / | \ > b / | \ c > /------------- | -------------\ > / | \ > ===== d | ===== > ( 3 ) | ( 5 ) > ===== ===== ===== > | ( 4 ) / \ > | ===== / \ > | | / \ > e | f | g / \ h > | | / \ > | | | | > | / | | > | / | | > ===== / ===== ===== > ( 6 )-----------/ ( 7 ) ( 8 ) > ===== ===== ===== > Each traversal shall start at the edge labelled /a/: note that whenever an edge is traversed, it immediately also traverses its inverse. In particular, note where the node labelled /4/ and its two adjacent edges are found. -} data Traversal = Trv { travType :: TravType , mkEdgeList :: CList Edge -> [Edge] , allEdges :: Bool } data TravType = BFS | DFS deriving (Eq, Ord, Show, Read) defTraversal :: Traversal defTraversal = Trv { travType = error "Unspecified traversal type" , mkEdgeList = rightElements , allEdges = True } {- | A breadth-first traversal on the sample graph would visit the nodes and edges in the following order: [/nodes/:] 1 2 5 4 3 8 7 6 [/edges/:] a c d b h g f e If 'spanningTraversal' was used, then the edge /e/ wouldn't be traversed; if 'antiClockwiseTraversal' was also used, then instead /f/ wouldn't be traversed. -} breadthFirst :: Traversal breadthFirst = defTraversal { travType = BFS } {- | A depth-first traversal on the sample graph would visit the nodes and edges in the following order: [/nodes/:] 1 2 5 8 7 4 6 3 [/edges/:] a c h g d f e b If 'spanningTraversal' was used, then the edge /b/ wouldn't be traversed; if 'antiClockwiseTraversal' was also used then instead /d/ wouldn't be traversed. -} depthFirst :: Traversal depthFirst = defTraversal { travType = DFS } -- | Perform a traversal suitable for a spanning tree. In this case, -- edges that reach a node that has already been visited won't be -- traversed. -- -- This /does/ make getting each connected component more expensive. spanningTraversal :: Traversal -> Traversal spanningTraversal trv = trv { allEdges = False } -- | By default, the traversals do so in a clockwise fashion, just as -- the outgoing edges are defined for each node. This lets you -- specify that an anti-clockwise traversal should be done instead. -- -- This is not computationally any more expensive than clockwise -- traversals. antiClockwiseTraversal :: Traversal -> Traversal antiClockwiseTraversal trv = trv { mkEdgeList = leftElements } -- | Results from traversing a graph. data TraversedValues n e = TV { -- | A re-numbered serialisation of the traversal. serialisedTraversal :: SerialisedGraph n e -- | Order of traversing nodes. , traversedNodes :: [Node] -- | The range of \"node\" values in 'serialisedTraversal'. , nodeBounds :: Maybe (Word, Word) -- | Order of traversing edges. , traversedEdges :: [Edge] -- | The range of \"edge\" values in 'serialisedTraversal'. , edgeBounds :: Maybe (Word, Word) } deriving (Eq, Ord, Show, Read) -- | The graph re-numbered by the traversal. renumberedTraversal :: TraversedValues n e -> PlanarGraph n e renumberedTraversal = deserialise . serialisedTraversal -- | Get back the original sub-graph denoted by this traversal. If -- 'traverseGraph' was used /without/ 'spanningTraversal', then this -- will be equal to the original graph. traversalComponent :: TraversedValues n e -> PlanarGraph n e traversalComponent tv = deserialise . map mapSN $ serialisedTraversal tv where fn = node . traversalNodeFn tv fe = edge . traversalEdgeFn tv mapSN (nid, nl, ses) = (fn nid, nl, map mapSE ses) mapSE (eid, toN, el, eInv) = (fe eid, fn toN, el, fe eInv) -- | The mapping between the node identifiers in 'serialisedTraversal' -- and the original graph. traversalNodeFn :: TraversedValues n e -> (Word -> Node) traversalNodeFn tv = mkArrayFn "Node" (nodeBounds tv) (traversedNodes tv) -- | The mapping between the edge identifiers in 'serialisedTraversal' -- and the original graph. traversalEdgeFn :: TraversedValues n e -> (Word -> Edge) traversalEdgeFn tv = mkArrayFn "Edge" (edgeBounds tv) (traversedEdges tv) mkArrayFn :: String -> Maybe (Word,Word) -> [a] -> (Word -> a) mkArrayFn tp = maybe (\ _ _ -> error $ "No " ++ tp ++ "s in this component") go where go bnds vs = \ w -> if A.inRange bnds w then arr A.! w else error $ "No " ++ tp ++ " corresponds to " ++ show w where arr = mkArray bnds vs mkArray :: (Word, Word) -> [v] -> A.Array Word v mkArray = A.listArray -- | The mapping between the node identifiers in the original graph -- and those in 'serialisedTraversal'. traversalRevNodeFn :: TraversedValues n e -> (Node -> Word) traversalRevNodeFn tv = mkMapFn "Node" (nodeBounds tv) (traversedNodes tv) -- | The mapping between the node identifiers in the original graph -- and those in 'renumberedTraversal'. traversalRevNodeFn' :: TraversedValues n e -> (Node -> Node) traversalRevNodeFn' tv = Node . traversalRevNodeFn tv -- | The mapping between the edge identifiers in the original graph -- and those in 'serialisedTraversal'. traversalRevEdgeFn :: TraversedValues n e -> (Edge -> Word) traversalRevEdgeFn tv = mkMapFn "Edge" (edgeBounds tv) (traversedEdges tv) -- | The mapping between the edge identifiers in the original graph -- and those in 'renumberedTraversal'. traversalRevEdgeFn' :: TraversedValues n e -> (Edge -> Edge) traversalRevEdgeFn' tv = Edge . traversalRevEdgeFn tv mkMapFn :: (Ord a, Show a) => String -> Maybe (Word,Word) -> [a] -> (a -> Word) mkMapFn tp = maybe (\ _ _ -> error $ "No " ++ tp ++ "s in this component") go where go bnds vs = \ v -> fromMaybe (error $ "The " ++ tp ++ " \"" ++ show v ++ "\" is not in this traversal") $ M.lookup v mp where mp = M.fromList . zip vs $ A.range bnds toTV :: TravRes n e -> TraversedValues n e toTV (TRs ser ns nbds es ebds ) = TV (DL.toList ser) (DL.toList ns) nbds (DL.toList es) ebds -- Slightly faster than using State from transformers. newtype TState n e a = TState { runState :: TravState n e -> (a,TravState n e) } evalState :: TState n e a -> TravState n e -> a evalState m s = fst (runState m s) {-# INLINE evalState #-} instance Functor (TState n e) where fmap f m = TState $ first f . runState m {-# INLINE fmap #-} instance Applicative (TState n e) where pure = return {-# INLINE pure #-} af <*> ax = do f <- af f <$> ax {-# INLINE (<*>) #-} aa <* ab = TState $ second (snd . runState ab) . runState aa {-# INLINE (<*) #-} (*>) = (>>) {-# INLINE (*>) #-} instance Monad (TState n e) where return a = TState $ (,) a {-# INLINE return #-} m >>= k = TState $ uncurry (runState . k) . runState m {-# INLINE (>>=) #-} ma >> mb = TState $ runState mb . snd . runState ma {-# INLINE (>>) #-} modify :: (TravState n e -> TravState n e) -> TState n e () modify f = TState $ (,) () . f {-# INLINE modify #-} gets :: (TravState n e -> a) -> TState n e a gets f = TState $ \s -> (f s, s) {-# INLINE gets #-} data TravRes n e = TRs (DList (SerialisedNode n e)) (DList Node) (Maybe (Word,Word)) -- Node bounds (DList Edge) (Maybe (Word,Word)) -- Edge bounds mergeAllTR :: [TravRes n e] -> TravRes n e mergeAllTR = foldr mergeTR empt where empt = TRs DL.empty DL.empty Nothing DL.empty Nothing mergeTR :: TravRes n e -> TravRes n e -> TravRes n e mergeTR (TRs s1 n1 nb1 e1 eb1) ~(TRs s2 n2 nb2 e2 eb2) = TRs (s1 `DL.append` s2) (n1 `DL.append` n2) (bndMrge nb1 nb2) (e1 `DL.append` e2) (bndMrge eb1 eb2) where bndMrge Nothing b2 = b2 bndMrge b1 Nothing = b1 bndMrge (Just (min1,max1)) (Just (min2,max2)) = Just (min min1 min2, max max1 max2) traverseAllComps :: TState n e [TravRes n e] traverseAllComps = liftA2 DL.unDL nonSingletons traverseSingletons where travComp = gets nextStrtEdge >>= T.mapM (travFrom >=> toRes) toRes sr = gets $ \ ts -> TRs sr (nodeTrav ts) (Just (firstNodeRep ts, pred $ nextNodeRep ts)) (edgeTrav ts) (Just (firstEdgeRep ts, pred $ nextEdgeRep ts)) nonSingletons = unfoldrM travComp travFrom :: Edge -> TState n e (DList (SerialisedNode n e)) travFrom se = modify (newComponent se) *> (mrg <$> unfoldrM travNodes) <* modify afterComponent where travNodes = nextNode >>= T.mapM traverseNode mrg = DL.concat . DL.toList data TravState n e = TSt { graphState :: !(PlanarGraph n e) , travControl :: !Traversal -- The next two parameters together -- determine whether each component is -- renumbered. , sepComps :: !Bool , restartCount :: !Bool , visitedNodes :: !(Map Node Word) , toVisit :: !(Seq (Node,Edge)) , visitedEdges :: !(Map Edge (Word,Word)) -- Include inverse , travEdges :: !(Map Edge ()) -- Using as a set for M.difference , nodeTrav :: !(DList Node) , edgeTrav :: !(DList Edge) , firstNodeRep :: !Word , nextNodeRep :: !Word , firstEdgeRep :: !Word , nextEdgeRep :: !Word , nextStrtEdge :: !(Maybe Edge) } defTS :: TravState n e defTS = TSt { graphState = empty , travControl = defTraversal , sepComps = False -- Start as 'True' so that on the first component it -- starts at 0, etc. , restartCount = True , visitedNodes = M.empty , toVisit = Seq.empty , visitedEdges = M.empty , travEdges = M.empty , nodeTrav = DL.empty , edgeTrav = DL.empty , firstNodeRep = n0 , nextNodeRep = succ n0 , firstEdgeRep = e0 , nextEdgeRep = e0 , nextStrtEdge = Nothing } where n0 = node initNode e0 = edge initEdge -- Provide a starting edge if one has been specified. If one isn't -- specified, one is picked from the graph (if any edges exist). initTS :: Bool -> Traversal -> PlanarGraph n e -> Maybe Edge -> TravState n e initTS sc trv pg me = defTS { sepComps = sc , graphState = pg , travControl = trv , nextStrtEdge = me' } where me' = me <|> (fmap (fst . fst) . M.minViewWithKey $ _edges pg) newComponent :: Edge -> TravState n e -> TravState n e newComponent e ts = ts { restartCount = sepComps ts , visitedNodes = M.singleton n sn , toVisit = Seq.singleton (n,e) , visitedEdges = M.empty , travEdges = M.empty , nodeTrav = DL.singleton n , edgeTrav = DL.empty , firstNodeRep = sn , nextNodeRep = succ sn -- This edge /will/ be used. , firstEdgeRep = se , nextEdgeRep = se } where pg = graphState ts n = fromNode pg e (sn,se) | restartCount ts = (node initNode,edge initEdge) | otherwise = (nextNodeRep ts, nextEdgeRep ts) afterComponent :: TravState n e -> TravState n e afterComponent ts = ts { graphState = PG ns' es' , nextStrtEdge = me } where (PG ns es) = graphState ts vns = visitedNodes ts ves = travEdges ts -- The edges that were "visited". -- Since we're not going to magically obtain nodes and edges from -- thin air, we can optimise the common case of a single connected -- component. ns' | M.size ns == M.size vns = M.empty | otherwise = ns `M.difference` vns es' | M.size es == M.size ves = M.empty | otherwise = es `M.difference` ves me = (fst . fst) <$> M.minViewWithKey es' -- Edge, then its inverse. traverseEdge :: (Edge, EdgeInfo e) -> TState n e (Maybe (SerialisedEdge e, DList (SerialisedNode n e))) traverseEdge (e,ei) = do mrep <- getEdgeReplacement e eInv n maybe (return Nothing) (fmap Just . unTraversed) mrep where eInv = inverse ei n = _toNode ei unTraversed (eRep, eRepInv) = do trvTp <- gets $ travType . travControl (nRep,trv) <- getNodeReplacement (trvFnFor trvTp) n return ((eRep, nRep, edgeInfo ei, eRepInv), trv) trvFnFor BFS = modify (\ ts -> ts { toVisit = toVisit ts |> (n,eInv) }) *> return DL.empty trvFnFor DFS = getNodeID n eInv >>= traverseNode -- Edge then its inverse, and the to node for the edge getEdgeReplacement :: Edge -> Edge -> Node -> TState n e (Maybe (Word,Word)) getEdgeReplacement e ei n = do (meids,mtrv) <- gets $ checkIDs &&& checkTraversed -- Might be more cumbersome than -- checking mtrv first, but going for -- the common case of very few edges -- /not/ being assigned a new ID and -- this avoids looking it up twice. maybe (checkNew mtrv) (return . Just) meids where checkIDs = M.lookup e . visitedEdges checkTraversed = M.lookup e . travEdges checkNew = maybe newEdge (const $ return Nothing) newEdge = do (eRep,isSpan,vis) <- gets $ \ ts -> ( nextEdgeRep ts , not . allEdges $ travControl ts , M.member n $ visitedNodes ts) if isSpan && vis then modify (\ ts -> ts { travEdges = addTrav ts }) *> return Nothing else let eRepInv = succ eRep in modify ( \ ts -> ts { visitedEdges = M.insert ei (eRepInv,eRep) $ visitedEdges ts , travEdges = addTrav ts , edgeTrav = edgeTrav ts `DL.snoc` e `DL.snoc` ei , nextEdgeRep = succ eRepInv }) *> return (Just (eRep, eRepInv)) addTrav = M.insert e () . M.insert ei () . travEdges -- Node and outgoing edge from it getNodeReplacement :: TState n e (DList (SerialisedNode n e)) -> Node -> TState n e (Word, DList (SerialisedNode n e)) getNodeReplacement fn n = do mnid <- gets $ M.lookup n . visitedNodes maybe newNode (return . flip (,) DL.empty) mnid where newNode = do nRep <- gets nextNodeRep modify $ \ ts -> ts { visitedNodes = M.insert n nRep $ visitedNodes ts , nodeTrav = nodeTrav ts `DL.snoc` n , nextNodeRep = succ nRep } (,) nRep <$> fn nextNode :: TState n e (Maybe (Node,Edge,Word)) nextNode = do mv <- gets toVisit case viewl mv of EmptyL -> return Nothing (n,e) :< vis' -> do modify $ \ ts -> ts { toVisit = vis' } Just <$> getNodeID n e getNodeID :: Node -> Edge -> TState n e (Node,Edge,Word) getNodeID n e = do nid <- gets $ (M.! n) . visitedNodes return (n,e,nid) traverseNode :: (Node,Edge,Word) -> TState n e (DList (SerialisedNode n e)) traverseNode (n,e,nid) = do (toL,pg) <- gets $ (mkEdgeList . travControl) &&& graphState let ni = getNodeInfo pg n es = map (ap (,) (getEdgeInfo pg)) . toL . fromJ . rotateTo e $ outgoing ni (eReps,trvs) <- (unzip . catMaybes) <$> mapM traverseEdge es return $ (nid,nodeInfo ni, eReps) `DL.cons` DL.concat trvs where fromJ = fromMaybe (error $ "traverseNode: the node " ++ show n ++ " does not have outgoing edge " ++ show e ++ ".") traverseSingletons :: TState n e [TravRes n e] traverseSingletons = do (ns, startFrom, isSep) <- gets neededVals let nIDs | isSep = repeat minBound | otherwise = enumFrom startFrom return $ zipWith mkSingletonComp nIDs ns where nodeLabels = map (second nodeInfo) . M.assocs . _nodes . graphState mkSingletonComp nid (n,nl) = TRs (DL.singleton (nid,nl,[])) (DL.singleton n) (Just (nid,nid)) DL.empty Nothing neededVals ts = ( nodeLabels ts , nextNodeRep ts , sepComps ts ) -- ----------------------------------------------------------------------------- -- | Pretty-print the graph. Note that this loses a lot of -- information, such as edge inverses, etc. prettify :: (Show n, Show e) => PlanarGraph n e -> String prettify = unlines . map (printN . third (map eParts)) . serialise where printN (n,l,as) = show n ++ ":" ++ show l ++ "->" ++ show as eParts (_,t,l,_) = (l,t) third f (a,b,c) = (a, b, f c) -- | Pretty-print the graph to stdout. prettyPrint :: (Show n, Show e) => PlanarGraph n e -> IO () prettyPrint = putStr . prettify -- | Pretty-print the graph, but showing more information than in -- 'prettify'. prettifyDetailed :: (Show n, Show e) => PlanarGraph n e -> String prettifyDetailed = concat . map printN . serialise where printN (n, l, es) = show n ++ ": label = " ++ show l ++ "\n" ++ unlines (map (indent . printE) es) printE (e, to, l, ei) = unwords [ show e ++ ":" , "toNode = " ++ show to ++ "," , "label = " ++ show l ++ "," , "inverse = " ++ show ei ] -- | Pretty-print details of the graph to stdout. detailedPrint :: (Show n, Show e) => PlanarGraph n e -> IO () detailedPrint = putStr . prettifyDetailed -- | As with 'prettifyDetailed', but discards the labels in the graph. prettifyStructure :: PlanarGraph n e -> String prettifyStructure = concat . map printN . serialise where printN (n, _, es) = show n ++ ":\n" ++ unlines (map (indent . printE) es) printE (e, to, _, ei) = unwords [ show e ++ ":" , "toNode = " ++ show to ++ "," , "inverse = " ++ show ei ] -- | Pretty-print the structure of the graph to stdout. structurePrint :: (Show n, Show e) => PlanarGraph n e -> IO () structurePrint = putStr . prettifyStructure -- Prepend two spaces indent :: String -> String indent = (" "++) -- ----------------------------------------------------------------------------- -- | Determine if this graph is the canonical representative of the -- isomorphic class (defined as such by having a breadth-first -- serialisation via 'serialiseBFS' that is @<=@ any other such -- serialisation). -- -- The function specifies all possible starting edges for the -- traversal (it is safe to leave the specified edge being returned -- by this function). If there are no known unique aspects of this -- graph that could be used to minimise \"uniqueness\", then use the -- 'halfEdges' function (note: you probably do /not/ want to use -- 'edges' if the graph is undirected). -- -- Note that this really only makes sense for graphs of type -- @PlanarGraph () ()@, unless you are sure that the labels won't -- affect the comparisons. canonicalExampleBy :: (Ord n, Ord e) => (PlanarGraph n e -> [Edge]) -> Edge -> PlanarGraph n e -> Bool canonicalExampleBy fe e pg = all ((serE <=) . toSer) es where es = delete e $ fe pg toSer = serialiseBFS pg . Just serE = toSer e -- | As with 'canonicalExampleBy', but also considers the -- 'mirrorGraph' when determining isomorphisms. canonicalMirrorExampleBy :: (Ord n, Ord e) => (PlanarGraph n e -> [Edge]) -> Edge -> PlanarGraph n e -> Bool canonicalMirrorExampleBy fe e pg = all (serE <=) sgs where es = delete e $ fe pg pgM = mirrorGraph pg eMs = fe pgM serE = serialiseBFS pg (Just e) sgs = map (serialiseBFS pg . Just) es ++ map (serialiseBFS pgM . Just) eMs -- | Filter out all those graphs for which 'canonicalExampleBy' isn't True. -- -- For this function to be correct, no two @(Edge, PlanarGraph n e)@ -- pairs should have the same result from 'serialiseBFS'. For -- example, consider the following graph /g/: -- -- > -- > e1 -- > ===== <--------- ===== -- > ( )--------->( ) -- > ===== / ===== -- > | ^ / /| | ^ -- > | | / / | | -- > | | / / | | -- > | | / / | | -- > | | / / | | -- > | | / / | | -- > | | / / | | -- > | | / / | | -- > | | / / | | -- > v | |/ / v | -- > ===== / ===== -- > ( )<---------( ) -- > ===== ---------> ===== -- > e2 -- > -- -- Then @onlyCanonicalExamples 'halfEdges' [(e1,g), (e2,g)]@ will -- return both graphs, even though they represent the same graph. -- -- Note that this really only makes sense for graphs of type -- @PlanarGraph () ()@, unless you are sure that the labels won't -- affect the comparisons. onlyCanonicalExamples :: (Ord n, Ord e) => (PlanarGraph n e -> [Edge]) -> [(Edge, PlanarGraph n e)] -> [(Edge, PlanarGraph n e)] onlyCanonicalExamples fe = filter (uncurry $ canonicalExampleBy fe) onlyCanonicalMirrorExamples :: (Ord n, Ord e) => (PlanarGraph n e -> [Edge]) -> [(Edge, PlanarGraph n e)] -> [(Edge, PlanarGraph n e)] onlyCanonicalMirrorExamples fe = filter (uncurry $ canonicalMirrorExampleBy fe) -- | Convert this graph into the canonical representation; that is, it -- will return 'True' for 'canonicalExampleBy'. -- -- Note that this really only makes sense for graphs of type -- @PlanarGraph () ()@, unless you are sure that the labels won't -- affect the comparisons. toCanonical :: (Ord n, Ord e) => PlanarGraph n e -> PlanarGraph n e toCanonical pg | isEmpty pg = pg | otherwise = deserialise . minimum . map (serialiseBFS pg . Just) $ halfEdges pg -- ----------------------------------------------------------------------------- -- Utility functions unfoldrM :: (Monad m) => m (Maybe a) -> m (DList a) unfoldrM mf = go =<< mf where go Nothing = return DL.empty go (Just a) = liftM (DL.cons a) . go =<< mf