{- This file is part of hit-graph. - - Written in 2016 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - - The author(s) have dedicated all copyright and related and neighboring - rights to this software to the public domain worldwide. This software is - distributed without any warranty. - - You should have received a copy of the CC0 Public Domain Dedication along - with this software. If not, see - . -} module Data.Graph.Inductive.Query.Topsort ( nodeLabel , NodeSet (..) , TraversalOrder (..) , ResultList (..) , topsortKahn , NodeStack (..) , topsortUnmix , topsortUnmixOrder ) where import Prelude import Data.Foldable (foldl') import Data.Graph.Inductive.Graph import Data.List (sortBy) -- | Find the label for a 'Node', assuming you know the node exists in the -- graph. If the node isn't found, an exception is thrown. nodeLabel :: Graph g => g a b -> Node -> a nodeLabel g n = case lab g n of Nothing -> error "node not found in graph" Just l -> l -- | A graph node container to be used with Kanh's topsort algorithm. class NodeSet s where -- | Take a graph node and a container, insert the node into it and return -- the resulting container. --insert :: LNode a -> s a -> s a insertNode :: Node -> s -> s -- | Remove a node from the container. Return the removed node and the -- resulting container after removal. If the container is empty (i.e. there -- is no node to remove), return 'Nothing'. --extract :: s a -> Maybe (LNode a, s a) extractNode :: s -> Maybe (Node, s) -- | Specification of the order in which a node's outgoing edges should be -- traversed. data TraversalOrder b -- | The order in which they're listed by FGL functions. The FGL -- documentation doesn't seem to specify the order, which means it may -- depend entirely on the 'Graph' instance you are using. = InOrder -- | Reverse of 'InOrder'. | ReverseOrder -- | Sort the outgoing edge list before traversal, using the given ordering -- function. It takes two pairs, each pair having a labeled node and the -- label of the edge, and determines the order they should be visited. 'LT' -- means the first edge is visited first. 'GT' means the second edge is -- visited first. 'EQ' means it doesn't matter and the implementation can -- choose arbitrarily. | SortedOrder ((Node, b) -> (Node, b) -> Ordering) -- | Lets you reorder the edge list in an arbitrary way before it gets -- traversed. Note that it's up to you to make sure the list you return -- really contains all the items of the input list. | CustomOrder ([(Node, b)] -> [(Node, b)]) sortNodes :: TraversalOrder b -> [(Node, b)] -> [(Node, b)] sortNodes InOrder = id sortNodes ReverseOrder = reverse sortNodes (SortedOrder f) = sortBy f sortNodes (CustomOrder f) = f -- | A container for storing the result of the sorting. Kahn's algorithm begins -- with an empty structure and then appends nodes to produce the result. -- Therefore almost any sequence container could work. -- -- You can also use a regular Haskell list. Implement 'append' using list -- prepend and remember to 'reverse' the list returned by the algorithm. class ResultList l where emptyList :: l a appendItem :: a -> l a -> l a -- | Flexible topological sort using Kahn's algorithm. -- -- It seems that Haskell graph libraries (and perhaps graph libraries in -- general) tend to implement topological sort using depth-first search (DFS). -- While it's probably easier (since these libraries also implement DFS), the -- result is that you pass a graph to a function and get back the sorted list. -- There is no room left for specifying variable parts of the algorithm, which -- means you can't control which topsort order (out of potentially many orders -- possible) you get. Sometimes you don't care, but sometimes you do. -- -- Kahn's algorithm has room for variations in two places: -- -- (1) When traversing a node's outgoing edges, the order in which this -- traversal happens isn't specified. -- (2) The internals of structure S, the set of nodes with no inbound edges, -- aren't specified. Therefore, so is the order in which nodes are removed -- from it. -- -- https://en.wikipedia.org/wiki/Topological_sort#Kahn.27s_algorithm topsortKahn :: (DynGraph g, NodeSet s, ResultList l) => g a b -- ^ Graph whose nodes to sort -> s -- ^ The set of graph nodes which don't have inbound edges -> TraversalOrder b -- ^ In which order to go over the outgoing edges of a node -> Maybe (l Node) -- ^ Topologically sorted list. For each edge from node @u@ to node @v@, -- @u@ appears before @v@ in this list. If the graph is empty or the -- initial node set is empty, an empty list is returned. If the graph -- contains a cycle, 'Nothing' is returned. topsortKahn graph set order = f graph set emptyList where nEdges = length . labEdges sort = sortNodes order visit n (g, s) m = let g' = delEdge (n, m) g s' = if indeg g' m > 0 then s else insertNode m s in (g', s') f g s l = case extractNode s of Nothing -> if nEdges g > 0 then Nothing else Just l Just (n, s') -> let l' = appendItem n l children = map fst $ sort $ lsuc g n (g', s'') = foldl' (visit n) (g, s') children in f g' s'' l' newtype NodeStack = NodeStack [Node] instance NodeSet NodeStack where insertNode n (NodeStack l) = NodeStack $ n : l extractNode (NodeStack l) = case l of [] -> Nothing (n:ns) -> Just (n, NodeStack ns) -- | Topologically sort commits so that parallel lines of work, e.g. a master -- branch and a short topic branch merged into it, don't get their commits -- mixed in the sorted order. topsortUnmix :: (DynGraph g, ResultList l) => g a b -> NodeStack -> TraversalOrder b -> Maybe (l Node) topsortUnmix = topsortKahn -- | Adds an additioal constraint to 'topsortUnmix': When traversing a node's -- outgoing edges, do so using the 'Ord' instance of the labels of the edges. topsortUnmixOrder :: (Ord b, DynGraph g, ResultList l) => g a b -> NodeStack -> Maybe (l Node) topsortUnmixOrder graph stack = let order (_, i) (_, j) = compare i j in topsortUnmix graph stack (SortedOrder order)