planar-graph (empty) → 1.0.0.0
raw patch · 8 files changed
+2213/−0 lines, 8 filesdep +attoparsecdep +basedep +blaze-buildersetup-changed
Dependencies added: attoparsec, base, blaze-builder, bytestring, containers, data-clist, deepseq
Files
- Data/Graph/Planar.hs +1772/−0
- Data/Graph/Planar/Serialisation.hs +73/−0
- Data/Graph/Planar/Serialisation/AsciiCode.hs +73/−0
- Data/Graph/Planar/Serialisation/Internal.hs +144/−0
- Data/Graph/Planar/Serialisation/PlanarCode.hs +74/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- planar-graph.cabal +45/−0
+ Data/Graph/Planar.hs view
@@ -0,0 +1,1772 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++{- |+ 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:+ <http://cs.anu.edu.au/~bdm/plantri/> (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.++ 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+ , mergeGraphs+ , mergeAllGraphs+ -- ** Graph Construction+ , empty+ , addNode+ , addUNode+ , EdgePos(..)+ , addEdge+ , addEdgeUndirected+ , addUEdge+ -- ** Graph Deconstruction+ , isEmpty+ , deleteNode+ , deleteEdge+ , contractEdge+ -- ** Other+ , unlabel+ , mapNodes+ , adjustNodeLabel+ , setNodeLabel+ , mapEdges+ , adjustEdgeLabel+ , setEdgeLabel+ -- * Graph traversal+ , traverse+ , connectedComponents+ , renumber+ -- ** Controlling traversal+ , Traversal+ , breadthFirst+ , depthFirst+ , antiClockwiseTraversal+ , spanningTraversal+ -- ** Results of traversing+ , GraphTraversal+ , TraversedValues+ , visited+ , traversed+ , anyMissing+ , mergeGraphTraversals+ -- * 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+ , onlyCanonicalExamples+ -- * Alternate representations+ -- ** Serialisation+ -- $serialisation+ , SerialisedGraph+ , serialise+ , deserialise+ , serialTraversal+ , serialiseBFS+ -- ** Pretty-Printing+ , prettify+ , prettyPrint+ ) where++import qualified Data.CircularList as CL+import Data.CircularList hiding (empty, isEmpty, size)+import qualified Data.Foldable as F+import Data.List(unfoldr,partition,mapAccumL,foldl1',delete)+import Data.Maybe(fromJust,fromMaybe)+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 Data.Word(Word)+import Control.Arrow((***), first, second)+import Control.DeepSeq(NFData(..))+import Control.Monad(liftM2,ap)++import Text.Read(Lexeme(Ident), lexP, parens, readPrec)+import Text.ParserCombinators.ReadPrec(ReadPrec, lift, prec)+import Text.ParserCombinators.ReadP(string, char, readS_to_P)++-- -----------------------------------------------------------------------------++{-++ 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 overall planar graph data structure.+data PlanarGraph n e = PG { _nodes :: !(NodeMap n)+ , _edges :: !(EdgeMap e)+ }+ deriving (Eq)++instance Functor (PlanarGraph n) where+ fmap = mapEdges++instance (Show n, Show e) => Show (PlanarGraph n e) where+ showsPrec d pg = showParen (d > 10) $+ showString "deserialise " . shows (serialise pg)++instance (Read n, Read e) => Read (PlanarGraph n e) where+ readPrec = parens . prec 10+ $ do Ident "deserialise" <- lexP+ lst <- readPrec+ return $ deserialise lst++instance (NFData n, NFData e) => NFData (PlanarGraph n e) where+ rnf (PG ns es) = rnf ns `seq` rnf es++withNodes :: (NodeMap n -> NodeMap n') -> PlanarGraph n e -> PlanarGraph n' e+withNodes f pg = PG { _nodes = f $ _nodes pg+ , _edges = _edges pg+ }++{-# INLINE withNodes #-}++withEdges :: (EdgeMap e -> EdgeMap e') -> PlanarGraph n e -> PlanarGraph n e'+withEdges f pg = PG { _nodes = _nodes pg+ , _edges = f $ _edges pg+ }++{-# INLINE withEdges #-}++-- | 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 = NInfo { outgoing = outgoing ni+ , nodeInfo = f $ nodeInfo ni+ }++mapNodeIDs :: (Node -> Node) -> PlanarGraph n e -> PlanarGraph n e+mapNodeIDs = mapNodeIDsWith M.mapKeys++mapNodeIDsMonotonic :: (Node -> Node) -> PlanarGraph n e -> PlanarGraph n e+mapNodeIDsMonotonic = mapNodeIDsWith M.mapKeysMonotonic++mapNodeIDsWith :: ((Node -> Node) -> NodeMap n -> NodeMap n)+ -> (Node -> Node) -> PlanarGraph n e -> PlanarGraph n e+mapNodeIDsWith mapMap f = withNodes (mapMap f)+ . withEdges (M.map fEI)+ where+ fEI ei = ei { _fromNode = f $ _fromNode ei+ , _toNode = f $ _toNode ei+ }++-- | Apply a mapping function over the edge labels.+mapEdges :: (e -> e') -> PlanarGraph n e -> PlanarGraph n e'+mapEdges f = withEdges (M.map mf)+ where+ mf ei = EInfo { _fromNode = _fromNode ei+ , _toNode = _toNode ei+ , _prevEdge = _prevEdge ei+ , _nextEdge = _nextEdge ei+ , inverse = inverse ei+ , edgeInfo = f $ edgeInfo ei+ }++mapEdgeIDs :: (Edge -> Edge) -> PlanarGraph n e -> PlanarGraph n e+mapEdgeIDs = mapEdgeIDsWith M.mapKeys++mapEdgeIDsMonotonic :: (Edge -> Edge) -> PlanarGraph n e -> PlanarGraph n e+mapEdgeIDsMonotonic = mapEdgeIDsWith M.mapKeysMonotonic++mapEdgeIDsWith :: ((Edge -> Edge) -> EdgeMap e -> EdgeMap e)+ -> (Edge -> Edge) -> PlanarGraph n e -> PlanarGraph n e+mapEdgeIDsWith mapMap f = withNodes (M.map fNI)+ . withEdges (mapMap 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++{-++ The following definitions are defined such that when adding a new+ node/edge then old deleted identifiers can be reused, rather than+ continually marching on upwards.++ This way we can try and delay any possibility of the number of+ identifiers going over maxBound :: Word, and also try and prevent+ users from getting used to what the identifiers mean.++-}++newNodeID :: PlanarGraph n e -> Node+newNodeID = newID _nodes initNode succNode node++{-# INLINE newNodeID #-}++newEdgeID :: PlanarGraph n e -> Edge+newEdgeID = newID _edges initEdge succEdge edge++{-# INLINE newEdgeID #-}++newID :: (Ord k) => (PlanarGraph n e -> Map k a) -> k -> (k -> k)+ -> (k -> Word) -> PlanarGraph n e -> k+newID used initID succID fromID pg+ | M.null ks = initID+ | compactMap = succID maxUsed -- Need a completely new ID.+ | minUsed > initID = initID -- Missing from front+ | otherwise = fst . head+ . filter (uncurry (<)) -- Remove non-gaps+ . map (first succID)+ . (zip`ap`tail)+ $ ksIDs+ where+ ks = used pg+ ksIDs = M.keys ks+ minUsed = head ksIDs+ maxUsed = fst $ M.findMax ks+ -- See if the set contains [0..max] already.+ -- Assumes we don't go too large...+ compactMap = fromIntegral (fromID maxUsed) == pred (M.size ks)++-- | @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 the edge and its inverse from the graph.+deleteEdge :: Edge -> PlanarGraph n e -> PlanarGraph n e+deleteEdge e pg = withEdges (delE eInv eiInv . delE e ei)+ . withNodes (delEN eInv eiInv . delEN e ei)+ $ pg+ where+ ei = getEdgeInfo pg e+ eInv = inverse ei+ eiInv = getEdgeInfo pg eInv+++-- 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)+++-- -----------------------------------------------------------------------------++type NodeMap n = Map Node (NodeInfo n)++-- | An abstract representation of a node.+newtype Node = Node { node :: Word }+ deriving (Eq, Ord, NFData)++succNode :: Node -> Node+succNode = Node . succ . node++enumNode :: Node -> [Node]+enumNode = map Node . enumFrom . node++-- | This instance of 'Show' does not produce valid Haskell code;+-- however, the 'Node' type is abstract and not designed to be+-- directly accessed.+instance Show Node where+ showsPrec = showsFrom node "Node"++-- | Note that this instance of 'Read' only works when directly+-- applied to a 'String'; it is supplied solely to assist with+-- debugging.+instance Read Node where+ readPrec = readsFrom Node "Node"++initNode :: Node+initNode = Node minBound++data NodeInfo n = NInfo { outgoing :: !(CList Edge)+ , nodeInfo :: !n+ }+ deriving (Eq, Show, Read)++instance (NFData n) => NFData (NodeInfo n) where+ rnf (NInfo out inf) = rnf out `seq` rnf inf++-- Assumes the node is part of the graph+withNode :: (NodeInfo n -> a) -> PlanarGraph n e -> Node -> a+withNode f pg n = maybe err f . M.lookup n $ _nodes pg+ where+ err = error $ "The node " ++ show n ++ " is not part of the specified graph."++{-# INLINE withNode #-}++getNodeInfo :: PlanarGraph n e -> Node -> NodeInfo n+getNodeInfo = withNode 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 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 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 (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++ -}++type EdgeMap e = Map Edge (EdgeInfo e)++-- | An abstract representation of an edge. Note that an explicit+-- identifier is used for each edge rather than just using the two+-- nodes that the edge connects. This is required in case more than+-- one edge connects two nodes as we need to be able to distinguish+-- them.+newtype Edge = Edge { edge :: Word }+ deriving (Eq, Ord, NFData)++succEdge :: Edge -> Edge+succEdge = Edge . succ . edge++enumEdge :: Edge -> [Edge]+enumEdge = map Edge . enumFrom . edge++-- | This instance of 'Show' does not produce valid Haskell code;+-- however, the 'Edge' type is abstract and not designed to be+-- directly accessed.+instance Show Edge where+ showsPrec = showsFrom edge "Edge"++-- | Note that this instance of 'Read' only works when directly+-- applied to a 'String'; it is supplied solely to assist with+-- debugging.+instance Read Edge where+ readPrec = readsFrom Edge "Edge"++initEdge :: Edge+initEdge = Edge minBound++data EdgeInfo e = EInfo { -- | The 'Node' which this 'Edge' is coming from.+ _fromNode :: !Node+ -- | The 'Node' this 'Edge' is going to.+ , _toNode :: !Node++ -- | The previous 'Edge' going clockwise around the '_fromNode'.+ , _prevEdge :: !Edge+ -- | The next 'Edge' going clockwise around the '_fromNode'.+ , _nextEdge :: !Edge++ -- | The 'Edge' that is an inverse to this one; i.e.:+ --+ -- > _fromNode ei == _toNode $ inverse ei+ -- > _toNode ei == _fromNode $ inverse ei+ , inverse :: !Edge++ -- | The stored information for this 'Edge'.+ , edgeInfo :: !e+ }+ deriving (Eq, Ord, Show, Read)++instance (NFData e) => NFData (EdgeInfo e) where+ rnf (EInfo f t p n i l) = rnf f `seq` rnf t+ `seq` rnf p `seq` rnf n+ `seq` rnf i `seq` rnf l++-- 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.+-}++-- | Information about the faces in a planar graph.+type FaceMap = Map Face FaceInfo++type EdgeFaceMap = Map Edge Face++-- | An abstract representation of a face.+newtype Face = Face { face :: Word }+ deriving (Eq, Ord, NFData)++enumFace :: Face -> [Face]+enumFace = map Face . enumFrom . face++-- | This instance of 'Show' does not produce valid Haskell code;+-- however, the 'Face' type is abstract and not designed to be+-- directly accessed.+instance Show Face where+ showsPrec = showsFrom face "Face"++-- | Note that this instance of 'Read' only works when directly+-- applied to a 'String'; it is supplied solely to assist with+-- debugging.+instance Read Face where+ readPrec = readsFrom Face "Face"++initFace :: Face+initFace = Face minBound++-- | Information about a particular 'Face'.+data FaceInfo = FInfo { -- | The 'Node's that make up the face.+ faceNodes :: !(CList Node)++ -- | The 'Edge's that make up the face, its+ -- inverse and the 'Face' on the other side+ -- of that 'Edge'.+ , edgeCrossings :: !(CList ((Edge,Edge), Face))+ }+ deriving (Eq, Show, Read)++instance NFData FaceInfo where+ rnf (FInfo ns ecs) = rnf ns `seq` rnf ecs++-- | 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'.+-}++-- | The definition of a more compact, serialised form of a planar+-- graph. The various fields correspond to:+--+-- > [( node index+-- > , node label+-- > , [( edge index+-- > , node index that this edge points to+-- > , edge label+-- > , inverse edge index+-- > )]+-- > )]+-- >+--+-- The list of edges should be in clockwise order around the node.+--+-- Note that there will be twice as many edges lists as the /size/;+-- that's because each edge is listed twice.+type SerialisedGraph n e = [(Word, n, [(Word, Word, e, Word)])]++-- | Create the serialised form of this graph.+serialise :: PlanarGraph n e -> SerialisedGraph n e+serialise pg = map serialiseN . M.assocs $ _nodes pg+ where+ serialiseN (n,ni) = (node n, nodeInfo ni, getEs ni)++ es = _edges pg+ getEs = map serialiseE . toList . outgoing+ serialiseE e = (edge e, node $ _toNode ei, edgeInfo ei, edge $ inverse ei)+ where+ ei = es ! e++-- | An alias for 'serialiseBFS' with no specified edge. Also added+-- are the 'order' and 'size' of the graph.+--+-- This function is mainly intended for use by the+-- "Data.Graph.Planar.Serialisation" module.+serialTraversal :: PlanarGraph n e -> ((Int,Int),SerialisedGraph n e)+serialTraversal pg = (ordSz, serialiseBFS pg Nothing)+ where+ ordSz = (order pg, size pg)++-- | 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.+--+-- Note that only one connected component is used: this is because+-- if there is more than one component then the serialisation is+-- /not/ unique (due to how to choose the ordering of the+-- components).+serialiseBFS :: PlanarGraph n e -> Maybe Edge -> SerialisedGraph n e+serialiseBFS pg me+ | M.null es = []+ | otherwise = unfoldr travNodes ts+ where+ es = _edges pg++ se = fromMaybe (fst $ M.findMin es) me++ ts = initTS (fromNode pg se) se++ travNodes = fmap (uncurry $ traverseNode pg) . nextNode++data TravState = TSt { visitedNodes :: Map Node Word+ , toVisit :: Seq (Node,Edge)+ , visitedEdges :: Map Edge (Word,Word) -- Include inverse+ , currentNode :: !Word+ , nextNodeRep :: !Word+ , nextEdgeRep :: !Word+ }+ deriving (Eq, Ord, Show, Read)++initTS :: Node -> Edge -> TravState+initTS n e = TSt { visitedNodes = M.singleton n 0+ , toVisit = Seq.singleton (n,e)+ , visitedEdges = M.empty+ , currentNode = 0+ , nextNodeRep = 1+ , nextEdgeRep = 0+ }++-- Edge, then its inverse.+traverseEdge :: TravState -> (Edge, EdgeInfo e) -> (TravState,(Word,Word,e,Word))+traverseEdge ts (e,ei) = (ts'', eTrav)+ where+ eInv = inverse ei+ n = _toNode ei++ ((eRep,eRepInv),ts') = getEdgeReplacement e eInv ts+ (nRep,ts'') = getNodeReplacement n eInv ts'++ eTrav = (eRep, nRep, edgeInfo ei, eRepInv)++-- Edge then its inverse+getEdgeReplacement :: Edge -> Edge -> TravState -> ((Word,Word), TravState)+getEdgeReplacement e ei ts = case e `M.lookup` es of+ Just eids -> (eids, ts) -- TODO: try deleting e here, since it will never need to be looked up again.+ Nothing -> ((eRep,eRepInv), ts')+ where+ es = visitedEdges ts++ eRep = nextEdgeRep ts+ eRepInv = succ eRep++ -- Note: we insert /ei/ into the Map, because that's what'll be looked up!+ ts' = ts { visitedEdges = M.insert ei (eRepInv,eRep) es+ , nextEdgeRep = succ eRepInv+ }++-- Node and outgoing edge from it+getNodeReplacement :: Node -> Edge -> TravState -> (Word, TravState)+getNodeReplacement n eOut ts = case n `M.lookup` ns of+ Just nid -> (nid, ts)+ Nothing -> (nRep, ts')+ where+ ns = visitedNodes ts++ nRep = nextNodeRep ts++ ts' = ts { visitedNodes = M.insert n nRep ns+ , toVisit = toVisit ts |> (n,eOut)+ , nextNodeRep = succ nRep+ }++nextNode :: TravState -> Maybe ((Node,Edge,Word),TravState)+nextNode ts = case viewl $ toVisit ts of+ EmptyL -> Nothing+ (n,e) :< vis' -> let nid = visitedNodes ts M.! n+ in Just ((n,e,nid), ts { toVisit = vis', currentNode = nid })++traverseNode :: PlanarGraph n e -> (Node,Edge,Word) -> TravState -> ((Word,n,[(Word,Word,e,Word)]),TravState)+traverseNode pg (n,e,nid) ts = ((nid,nodeInfo ni,eReps),ts')+ where+ ni = getNodeInfo pg n++ es = map (ap (,) (getEdgeInfo pg))+ . toList . fromJust . rotateTo e $ outgoing ni++ (ts',eReps) = mapAccumL traverseEdge ts es++-- | Creates the graph from its serialised form. Assumes that the+-- graph is valid.+deserialise :: SerialisedGraph n e -> PlanarGraph n e+deserialise = uncurry PG . (M.fromList *** M.unions)+ . unzip . map deserialiseNode++deserialiseNode :: (Word, n, [(Word, Word, e, Word)]) -> ((Node, NodeInfo n), EdgeMap e)+deserialiseNode (n,l,es) = (nd, M.fromList $ map mkE es)+ where+ nd = (n', NInfo { outgoing = os, nodeInfo = l })+ n' = Node n+ -- Outgoing edges+ os = fromList $ map (\(e,_,_,_) -> Edge e) es++ mkE (e,t,el,i) = (e', EInfo { _fromNode = n'+ , _toNode = Node t+ , _prevEdge = prevElem os'+ , _nextEdge = nextElem os'+ , inverse = Edge i+ , edgeInfo = el+ })+ where+ os' = fromJust $ rotateTo e' os+ e' = Edge e++-- | 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++-- -----------------------------------------------------------------------------++{- | 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 { -- First Seq is existing one, second is new values+ addValues :: Seq [Edge] -> [Edge] -> Seq [Edge]+ , mkEdgeList :: CList Edge -> [Edge]+ -- | Should an edge be included even if the node+ -- it points to has already been visited?+ , allEdges :: !Bool+ }++defTraversal :: Traversal+defTraversal = Trv { addValues = undefined+ , 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 { addValues = (|>) }++{- | 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 { addValues = flip (<|) }++-- | 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 }++-- | 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 }++-- | The values found whilst traversing. See 'GraphTraversal' for+-- more specific information.+data TraversedValues a = TV { -- | All values encountered.+ visited :: !(Set a)+ -- | The order in which values are+ -- encountered.+ , traversed :: !(Seq a)+ -- | Did we skip any edges?+ , anyMissing :: !Bool+ }++mergeTV :: (Ord a) => TraversedValues a -> TraversedValues a -> TraversedValues a+mergeTV (TV v1 t1 am1) (TV v2 t2 am2) = TV (v1 `S.union` v2)+ (t1 >< t2)+ (am1 || am2)++mergeGT :: GraphTraversal -> GraphTraversal -> GraphTraversal+mergeGT (n1,e1) (n2,e2) = (mergeTV n1 n2, mergeTV e1 e2)++-- | Merge the results from 'traverse' into one traversal (i.e. you+-- don't care about individual components).+mergeGraphTraversals :: [GraphTraversal] -> GraphTraversal+mergeGraphTraversals [] = (initTV, initTV)+mergeGraphTraversals gts = foldl1' mergeGT gts++-- | Specify part of a graph found by traversing it. For nodes,+-- @'visited' == 'S.fromList' . 'F.toList' . 'traversed'@; the same+-- is true for edges /except/ when 'spanningTraversal' is used. In+-- that case, 'traversed' may contain a sub-set of 'visited' (and if+-- they aren't equal, 'anyMissing' will be 'True'.).+type GraphTraversal = (TraversedValues Node, TraversedValues Edge)++initTV :: TraversedValues a+initTV = TV S.empty Seq.empty False++addValue :: (Ord a) => a -> TraversedValues a -> TraversedValues a+addValue a tv = tv { visited = S.insert a $ visited tv+ , traversed = traversed tv |> a+ }++visitNotTraverse :: (Ord a) => a -> TraversedValues a -> TraversedValues a+visitNotTraverse a tv = tv { visited = S.insert a $ visited tv+ , anyMissing = True+ }++hasValue :: (Ord a) => a -> TraversedValues a -> Bool+hasValue a = S.member a . visited++-- | Perform a re-numbering of the identifiers in this graph using the+-- specified traversal and optionally starting from a specified+-- edge.+--+-- If there is only one connected component in the graph and the+-- same edge is specified each time (relative to the location in the+-- graph), then the re-numbering is /canonical/: that is, it can be+-- used to compare whether two graphs constructed via separate paths+-- (and thus using different identifiers) are indeed the same.+renumber :: Traversal -> PlanarGraph n e -> Maybe Edge+ -> (PlanarGraph n e, (Node -> Node, Edge -> Edge))+renumber trv pg me = renumberComponent pg gt+ where+ gt = mergeGraphTraversals $ traverse trv pg me++-- | Use a 'breadthFirst' traversal to find all the connected+-- components. The node and edge identifiers for each component are+-- re-numbered.+connectedComponents :: PlanarGraph n e+ -> [(PlanarGraph n e, (Node -> Node, Edge -> Edge))]+connectedComponents pg = map (onlyComponent pg) tcs+ where+ tcs = traverseAll breadthFirst pg++-- Get the graph corresponding just to this component; also renumbers it.+onlyComponent :: PlanarGraph n e -> GraphTraversal+ -> (PlanarGraph n e, (Node -> Node, Edge -> Edge))+onlyComponent pg tc@(TV{visited=vn},tve) = renumberComponent pg' tc+ where+ pg' = pg { _nodes = _nodes pg `setIntersection` vn+ , _edges = _edges pg `setIntersection` ve+ }++ ve | anyMissing tve = S.fromList . F.toList $ traversed tve+ | otherwise = visited tve++setIntersection :: (Ord k) => Map k a -> Set k -> Map k a+setIntersection m s = m `M.intersection` m'+ where+ m' = M.fromAscList . map (flip (,) ()) $ S.toAscList s++-- This requires that all nodes and edges in the graph are listed in+-- the component; if not, delete the others first!+renumberComponent :: PlanarGraph n e -> GraphTraversal+ -> (PlanarGraph n e,(Node -> Node, Edge -> Edge))+renumberComponent pg (TV{traversed = ns}, TV{traversed = es}) = (pg', (fn,fe))+ where+ nMap = M.fromList . zip (F.toList ns) $ enumNode initNode+ eMap = M.fromList . zip (F.toList es) $ enumEdge initEdge++ fn n = nMap M.! n+ fe e = eMap M.! e++ pg' = mapEdgeIDs fe . mapNodeIDs fn $ pg++-- | Traverse through a graph, and return each connected component+-- found. If an edge is specified, start with that edge and then+-- for subsequent components (if there are any) arbitrarily pick+-- edges to start with; if no edge is provided than start at an+-- arbitrary edge.+traverse :: Traversal -> PlanarGraph n e -> Maybe Edge -> [GraphTraversal]+traverse trv pg = maybe (traverseAll trv pg) (traverseFrom trv pg)++-- No edge specified.+traverseAll :: Traversal -> PlanarGraph n e -> [GraphTraversal]+traverseAll trv pg+ | M.null es = traverseNodes . M.keysSet $ _nodes pg+ | otherwise = traverseFrom trv pg . fst $ M.findMin es+ where+ es = _edges pg++traverseFrom :: Traversal -> PlanarGraph n e -> Edge -> [GraphTraversal]+traverseFrom trv pg se = go se sns ses+ where+ sns = M.keysSet $ _nodes pg+ ses = M.keysSet $ _edges pg++ go e ns es = tnes : if S.null es'+ then traverseNodes ns'+ else go e' ns' es'+ where+ tnes@(tns,tes) = traverseNextFrom trv pg e+ ns' = ns `S.difference` visited tns+ es' = es `S.difference` visited tes++ e' = S.findMin es'++-- Only singleton nodes left+traverseNodes :: Set Node -> [GraphTraversal]+traverseNodes = map mkComp . S.elems+ where+ mkComp n = (addValue n initTV, initTV)++traverseNextFrom :: Traversal -> PlanarGraph n e -> Edge -> GraphTraversal+traverseNextFrom (Trv add mkList allEs) pg se = go ses snm sem+ where+ addEdges st n e = st `add`+ (mkList . fromJust . rotateTo e $ outgoingEdges pg n)++ sn = fromNode pg se+ ses = addEdges Seq.empty sn se+ snm = addValue sn initTV+ sem = initTV -- addValue (inverseEdge pg se) $ addValue se initEdgeTV++ go sq nm em+ | Seq.null sq = (nm,em)+ | null es = go sq' nm em+ | hasValue e em = go sq'' nm em+ | hasValue n nm = go sq'' nm $ if allEs then em' else vem+ | otherwise = go sq''' nm' em'+ where+ (es :< sq') = viewl sq+ (e:es') = es+ sq'' = es' <| sq'++ ei = getEdgeInfo pg e++ n = _toNode ei+ e' = inverse ei++ em' = addValue e' $ addValue e em+ nm' = addValue n nm++ sq''' = addEdges sq'' n e'++ vem = visitNotTraverse e' $ visitNotTraverse e em++-- -----------------------------------------------------------------------------++-- | 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++-- | 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)++-- -----------------------------------------------------------------------------+-- Utility functions++showsFrom :: (a -> Word) -> String -> Int -> a -> ShowS+showsFrom f nm _ a = showString nm . showChar '_' . shows (f a)++readsFrom :: (Word -> a) -> String -> ReadPrec a+readsFrom f nm = lift $ do _ <- string nm+ _ <- char '_'+ n <- readS_to_P reads+ return $ f n++-- Get the previous element in the CList; assumes non-empty+prevElem :: CList a -> a+prevElem = fromJust . focus . rotL++nextElem :: CList a -> a+nextElem = fromJust . focus . rotR
+ Data/Graph/Planar/Serialisation.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE TypeFamilies #-}++{- |+ Module : Data.Graph.Planar.Serialisation+ Description : Serialisation for planar graphs.+ Copyright : (c) Ivan Lazar Miljenovic+ License : 3-Clause BSD-style+ Maintainer : Ivan.Miljenovic@gmail.com++ -}+module Data.Graph.Planar.Serialisation+ ( PlanarEncoding(..)+ , encodePlanarFile+ , encodePlanarFileFrom+ , decodePlanarFile+ ) where++import Data.Graph.Planar hiding (isEmpty)+import Data.Graph.Planar.Serialisation.Internal++import Blaze.ByteString.Builder(toLazyByteString)+import Blaze.ByteString.Builder.Char8(fromChar)+import Data.Attoparsec.ByteString.Lazy(parse, eitherResult, many1, (<?>))+import Data.Attoparsec.ByteString.Char8(endOfLine)+import qualified Data.ByteString.Lazy as B+import Data.Monoid(mempty, mappend)+import Control.Applicative((<*))+import Control.Monad(foldM)++-- -----------------------------------------------------------------------------++-- | Encode a list of planar graphs to file using the specified+-- encoding.+encodePlanarFile :: (PlanarEncoding ser) => ser -> FilePath+ -> [PlanarGraph (NLabel ser) (ELabel ser)]+ -> IO Int+encodePlanarFile ser fp = encodePlanarFileFrom ser fp . map ((,) Nothing)++-- | Encode a list of planar graphs to file using the specified+-- encoding, with the serialisation traversing from the an+-- optionally specified edge.+encodePlanarFileFrom :: (PlanarEncoding ser) => ser -> FilePath+ -> [(Maybe Edge,PlanarGraph (NLabel ser) (ELabel ser))]+ -> IO Int+encodePlanarFileFrom ser fp pgs = do B.writeFile fp $ toLazyByteString header+ foldM printCount 0 pgs+ where+ header = putName ser++ maybeNewline | sepByNewline ser = fromChar '\n'+ | otherwise = mempty++ printCount c pg = c `seq` (B.appendFile fp (toB pg) >> return (c+1))+ toB pg = toLazyByteString $ putSG ser (toSer pg) `mappend` maybeNewline++ toSer (me,pg) = ((order pg, size pg), serialiseBFS pg me)++-- | Read in a file containing encoded graphs. The 'PlanarEncoding'+-- argument is only used for its /type/ to determine which parser to+-- use.+decodePlanarFile :: (PlanarEncoding ser) => ser -> FilePath+ -> IO [PlanarGraph (NLabel ser) (ELabel ser)]+decodePlanarFile ser fp = do bs <- B.readFile fp+ case eitherResult $ parse parser bs of+ Left err -> error $ "Could not parse file " ++ fp ++ " with the error: " ++ err+ Right sgs -> return $ map deserialise sgs++ where+ parser = do nm <- fmap (`asTypeOf` ser) getName <?> "Parsing encoding header"+ many1 $ getSG nm <* maybeNewLine++ maybeNewLine | sepByNewline ser = endOfLine+ | otherwise = return ()
+ Data/Graph/Planar/Serialisation/AsciiCode.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE TypeFamilies #-}++{- |+ Module : Data.Graph.Planar.Serialisation.AsciiCode+ Description : Implementation of ASCII CODE.+ Copyright : (c) Ivan Lazar Miljenovic+ License : 3-Clause BSD-style+ Maintainer : Ivan.Miljenovic@gmail.com++ -}+module Data.Graph.Planar.Serialisation.AsciiCode(AsciiCode(..)) where++import Data.Graph.Planar(SerialisedGraph)+import Data.Graph.Planar.Serialisation.Internal++import Blaze.ByteString.Builder+import Blaze.ByteString.Builder.Char8+import Data.Attoparsec.ByteString.Lazy hiding (satisfy)+import qualified Data.Attoparsec.ByteString.Char8 as C+import qualified Data.ByteString as SBS+import Data.Char(ord)+import Data.List(intersperse)+import Data.Foldable(foldMap)+import Control.Applicative((<*))+import Data.Monoid(Monoid(..))+import Data.Word(Word8,Word)++-- -----------------------------------------------------------------------------++{- |++ ASCII_CODE is a human-readable variant of+ "Data.Graph.Planar.Serialisation.PlanarCode". The same caveats+ regarding loops apply, but it is only able to represent graphs with+ @<=26@ nodes.++ -}+data AsciiCode = AsciiCode+ deriving (Eq, Ord, Show, Read)++instance PlanarEncoding AsciiCode where+ type NLabel AsciiCode = ()+ type ELabel AsciiCode = ()++ putSG = const putAsciiCode++ getSG = const getAsciiCode++ putName = mempty++ getName = return AsciiCode++ sepByNewline = const True++putAsciiCode :: ((Int,Int),SerialisedGraph n e) -> Builder+putAsciiCode ((p,_),sg) = fromShow p `mappend` fromChar ' '+ `mappend`+ mconcat (intersperse (fromChar ',')+ $ map (fromWrite . putNode . nodeEdgesSer) sg)+ where+ putNode es = foldMap (writeAsLetter . toNodeSer) es++writeAsLetter :: Word -> Write+writeAsLetter = writeWord8 . (aValue+) . fromIntegral++getAsciiCode :: Parser (SerialisedGraph () ())+getAsciiCode = do _ <- C.satisfy C.isDigit <* C.skipSpace -- We don't actually use this...+ ess <- sepBy1 (SBS.unpack `fmap` C.takeWhile1 C.isAlpha_ascii) (C.char ',')+ let ess' = map (map $ fromIntegral . subtract aValue) ess+ return $ processPC ess'++aValue :: Word8+aValue = fromIntegral $ ord 'a'
+ Data/Graph/Planar/Serialisation/Internal.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE TypeFamilies #-}++{- |+ Module : Data.Graph.Planar.Serialisation.Internal+ Description : Internal definitions of serialisation classes.+ Copyright : (c) Ivan Lazar Miljenovic+ License : 3-Clause BSD-style+ Maintainer : Ivan.Miljenovic@gmail.com+ -}+module Data.Graph.Planar.Serialisation.Internal where++import Data.Graph.Planar++import Blaze.ByteString.Builder+import Data.Attoparsec.ByteString.Lazy+import Data.Function(on)+import Data.List(groupBy, sortBy, mapAccumL)+import qualified Data.Map as M+import Data.Word(Word)+import Control.Arrow(first, second)+import Control.Monad(liftM2)++-- -----------------------------------------------------------------------------++-- | A class covering the different ways of encoding and decoding+-- planar graphs from binary data.+class PlanarEncoding ser where+ type NLabel ser+ type ELabel ser++ putSG :: ser -> ((Int,Int),SerialisedGraph (NLabel ser) (ELabel ser)) -> Builder++ getSG :: ser -> Parser (SerialisedGraph (NLabel ser) (ELabel ser))++ -- | Print the required header if appropriate; otherwise return an+ -- empty 'Builder'. Should end in a newline if appropriate.+ putName :: ser -> Builder++ -- | Attempt to parse a header; if none exists, this should return+ -- an appropriate default (if allowable). Should also parse+ -- trailing newlines if appropriate.+ getName :: Parser ser++ -- | Is each graph on a new line?+ sepByNewline :: ser -> Bool++-- -----------------------------------------------------------------------------++type SerialisedNode n e = (Word, n, [SerialisedEdge e])++nodeSer :: SerialisedNode n e -> Word+nodeSer (n, _, _) = n++nodeLabelSer :: SerialisedNode n e -> n+nodeLabelSer (_, l, _) = l++nodeEdgesSer :: SerialisedNode n e -> [SerialisedEdge e]+nodeEdgesSer (_, _, es) = es++withEdgesSer :: ([SerialisedEdge e] -> a)+ -> SerialisedNode n e -> (Word, n, a)+withEdgesSer f (n, l, es) = (n, l, f es)++type SerialisedEdge e = (Word, Word, e, Word)++edgeIDSer :: SerialisedEdge e -> Word+edgeIDSer (e, _, _, _) = e++toNodeSer :: SerialisedEdge e -> Word+toNodeSer (_, t, _, _) = t++edgeLabelSer :: SerialisedEdge e -> e+edgeLabelSer (_, _, l, _) = l++inverseEdgeSer :: SerialisedEdge e -> Word+inverseEdgeSer (_, _, _, ei) = ei++-- -----------------------------------------------------------------------------++-- Process a PlanarCode-like input. The [[Word]] is expected to be 0-based node IDs.+processPC :: [[Word]] -> SerialisedGraph () ()+processPC ess = snd . mapAccumL processNode initSt $ nes'+ where+ -- Give each node an ID.+ nes = zip [0..] ess++ -- Give all the edges temporary IDs to start with.++ -- eIDsTmp :: [((from node, to node), tmpID)]+ eIDsTmp = flip zip [0 :: Word ..] . concatMap (uncurry (map . (,))) $ nes+ -- nes' :: [(from node, [(to node, tmpID)])]+ nes' = groupSortCollectBy (fst . fst) (first snd) eIDsTmp++ -- eGrps :: [((from node, to node), [tmpID])]+ eGrps = map (\ (f,(t,es)) -> ((f,t),es))+ . concatMap (uncurry $ map . (,))+ . map (second $ groupSortCollectBy fst snd)+ $ nes'++ eMp = M.fromList eGrps++ -- tmpInvs :: Map tmpID tmpID+ tmpInvs = M.fromList+ . concatMap getInvs+ $ eGrps++ getInvs ((f,t),ftes) = zip ftes . neighbourList' $ eMp M.! (t,f)+ where+ neighbourList' | f == t = reverse+ | otherwise = neighbourList++ processEdge (assgnd, next) (t, eTmp) = case eTmp `M.lookup` assgnd of+ Just (e,ei) -> ((assgnd,next), (e, t, (), ei)) -- Can delete eTmp here+ Nothing -> ((assgnd',next'), (e', t, (), ei'))+ where+ e' = next+ ei' = succ e'+ next' = succ ei'+ assgnd' = M.insert (tmpInvs M.! eTmp) (ei', e') assgnd++ processNode st (f,esTmp) = second ((,,) f ()) $ mapAccumL processEdge st esTmp++ initSt = (M.empty, 0)++-- Swap the edge list of a neighbour.+neighbourList :: [a] -> [a]+neighbourList [] = []+neighbourList (e:es) = e : reverse es++applyUntil :: (Monad m) => (a -> Bool) -> m a -> m [a]+applyUntil p m = do a <- m+ if p a+ then return [a]+ else do as <- applyUntil p m+ return $ a:as++groupSortBy :: (Ord b) => (a -> b) -> [a] -> [[a]]+groupSortBy f = groupBy ((==) `on` f) . sortBy (compare `on` f)++groupSortCollectBy :: (Ord b) => (a -> b) -> (a -> c) -> [a] -> [(b,[c])]+groupSortCollectBy f g = map (liftM2 (,) (f . head) (map g)) . groupSortBy f++swap :: (a,b) -> (b,a)+swap (a,b) = (b,a)
+ Data/Graph/Planar/Serialisation/PlanarCode.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE TypeFamilies, OverloadedStrings #-}++{- |+ Module : Data.Graph.Planar.Serialisation.PlanarCode+ Description : Implementation of PLANAR CODE.+ Copyright : (c) Ivan Lazar Miljenovic+ License : 3-Clause BSD-style+ Maintainer : Ivan.Miljenovic@gmail.com++ -}+module Data.Graph.Planar.Serialisation.PlanarCode(PlanarCode(..)) where++import Data.Graph.Planar(SerialisedGraph)+import Data.Graph.Planar.Serialisation.Internal++import Blaze.ByteString.Builder+import Data.Attoparsec.ByteString.Lazy+import qualified Data.ByteString as SBS+import Data.Foldable(foldMap)+import Control.Applicative((<*))+import Data.Monoid(Monoid(..))+import Control.Monad(replicateM)++-- -----------------------------------------------------------------------------++{- |++ PLANAR_CODE is the most common encoding for planar graphs, and is+ supported by various generation and visualisation tools. It is a+ binary format and not intended to be human-readable.++ The default encoding only supports graphs with @<256@ nodes, and+ takes @2*|E|+|N|+1@ bytes per graph.++ Please note that PLANAR_CODE is /not/ suitable for graphs with+ multiple loops on vertices (multiple edges with distinct endpoints+ however are catered for). As such, no guarantees are made about what+ happens with multiple loops.++ -}+data PlanarCode = PlanarCode+ deriving (Eq, Ord, Show, Read)++instance PlanarEncoding PlanarCode where+ type NLabel PlanarCode = ()+ type ELabel PlanarCode = ()++ putSG = const putPlanarCode++ getSG = const getPlanarCode++ putName = const $ fromByteString ">>planar_code<<"++ getName = string ">>planar_code<<" >> return PlanarCode++ sepByNewline = const False++putPlanarCode :: ((Int,Int),SerialisedGraph n e) -> Builder+putPlanarCode ((ord,_),sg) = fromWord8 (fromIntegral ord)+ `mappend` foldMap (fromWrite . putNode . nodeEdgesSer)+ sg+ where+ putNode es = foldMap (writeWord8 . succ . fromIntegral . toNodeSer) es+ `mappend` writeWord8 0+ -- Need succ here, because the SerialisedGraph is 0-based, but PC is 1-based.++getPlanarCode :: Parser (SerialisedGraph () ())+getPlanarCode = do num <- fromIntegral `fmap` anyWord8+ ess <- replicateM num getNode+ -- Convert to 0-based Word values+ let ess' = map (map $ fromIntegral . pred) ess+ return $ processPC ess'+ where+ getNode = SBS.unpack `fmap` takeWhile1 (/= 0) <* anyWord8 -- will be 0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2010, Ivan Lazar Miljenovic++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Ivan Lazar Miljenovic nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ planar-graph.cabal view
@@ -0,0 +1,45 @@+Name: planar-graph+Version: 1.0.0.0+Synopsis: A representation of planar graphs+Description: {+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.)+}+License: BSD3+License-file: LICENSE+Author: Ivan Lazar Miljenovic+Maintainer: Ivan.Miljenovic@gmail.com+Category: Data, Maths, Graphs+Build-type: Simple+Cabal-version: >=1.6++Source-Repository head+ type: darcs+ location: http://code.haskell.org/~ivanm/planar-graph++Library+ Exposed-modules: Data.Graph.Planar+ Data.Graph.Planar.Serialisation+ Data.Graph.Planar.Serialisation.PlanarCode+ Data.Graph.Planar.Serialisation.AsciiCode++ Other-modules: Data.Graph.Planar.Serialisation.Internal++ Build-depends: base < 5,+ containers < 0.5,+ data-clist >= 0.0.7.2 && <0.1,+ deepseq >= 1.1 && < 1.4,+ bytestring < 0.10,+ blaze-builder == 0.3.*,+ attoparsec == 0.10.*++ GHC-Options: -funbox-strict-fields -Wall++ GHC-Prof-Options: -prof -auto-all