From ec9fc486eedc9179e2426c8458913a564722cd3c Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Mon, 29 Feb 2016 01:59:33 +0000 Subject: [PATCH] Implement flexible Kahn topsort for use on git commit graphs --- src/Data/Graph/Inductive/Local.hs | 133 ++++++++++++++++++++++++++++++ vervis.cabal | 2 + 2 files changed, 135 insertions(+) create mode 100644 src/Data/Graph/Inductive/Local.hs diff --git a/src/Data/Graph/Inductive/Local.hs b/src/Data/Graph/Inductive/Local.hs new file mode 100644 index 0000000..aa5816f --- /dev/null +++ b/src/Data/Graph/Inductive/Local.hs @@ -0,0 +1,133 @@ +{- This file is part of Vervis. + - + - 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 + - . + -} + +-- | Graph tools for use with the @fgl@ package. +module Data.Graph.Inductive.Local + ( NodeSet (..) + , TraversalOrder (..) + , ResultList (..) + , topsortKahn + ) +where + +import Prelude + +import Data.Foldable (foldl') +import Data.Graph.Inductive.Graph +import Data.List (sortBy) + +-- | 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' diff --git a/vervis.cabal b/vervis.cabal index 0e54611..8fc209f 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -35,6 +35,7 @@ flag library-only library exposed-modules: Data.Char.Local + Data.Graph.Inductive.Local Data.List.Local Vervis.Application Vervis.Field.Person @@ -97,6 +98,7 @@ library , directory >= 1.1 && < 1.3 , esqueleto , fast-logger >= 2.2 && < 2.5 + , fgl , file-embed , filepath , hit