From 7886d9a515aa4de2ac2c453aafb12149d7113e7e Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Mon, 20 Jun 2016 22:50:16 +0000 Subject: [PATCH] Layering of intransitive DAGs --- src/Data/Graph/Inductive/Query/Layer.hs | 207 ++++++++++++++++++++++++ src/Data/HashMap/Lazy/Local.hs | 32 ++++ vervis.cabal | 2 + 3 files changed, 241 insertions(+) create mode 100644 src/Data/Graph/Inductive/Query/Layer.hs create mode 100644 src/Data/HashMap/Lazy/Local.hs diff --git a/src/Data/Graph/Inductive/Query/Layer.hs b/src/Data/Graph/Inductive/Query/Layer.hs new file mode 100644 index 0000000..11fd4bc --- /dev/null +++ b/src/Data/Graph/Inductive/Query/Layer.hs @@ -0,0 +1,207 @@ +{- 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 + - . + -} + +-- | Layering of directed acyclic graphs +module Data.Graph.Inductive.Query.Layer + ( -- * Intro + -- $into + + -- * Forward Layer + -- $forward + layer + , layern + , layerWith + , layernWith + + -- * Backward Layer + -- $backward + , rlayer + , rlayern + , rlayerWith + , rlayernWith + + -- * Custom Layer + -- $custom + , xlayern + , xlayernWith + ) +where + +import Prelude + +import Data.Graph.Inductive.Basic (gsel) +import Data.Graph.Inductive.Graph +import Data.Graph.Inductive.Internal.Queue +import Data.List (sortOn) + +import qualified Data.HashMap.Lazy as M + +import qualified Data.HashMap.Lazy.Local as ML + +noIn :: Graph g => g a b -> [Node] +noIn = map node' . gsel (null . pre') + +noOut :: Graph g => g a b -> [Node] +noOut = map node' . gsel (null . suc') + +-- $intro +-- Layering a directed acyclic graph basically means to partition its nodes +-- such that all the edges point in the same direction. Layering is often used +-- for graph visualization, an therefore requires that the result has certain +-- human-friendly properties. +-- +-- This module currently offers a very simple algorithm meant for DAGs that are +-- transitively reduced, i.e. if edges AB and BC exist, an edge AC shouldn't +-- exist in the graph. In other words, assuming the edges represent partial +-- ordering of the nodes, no edge should be possible to deduce from other +-- edges. + +-- $forward +-- Forward layering starts from a set of nodes, usually the nodes which don't +-- have in-edges, and builds the layers by traversing the out-edges +-- recursively. The initial nodes are the first layer, their children are the +-- second layer, the children's children are the third layer, and so on. + +-- | The initial nodes are the nodes which don't have in-edges. +layer :: Graph g => g a b -> [[Node]] +layer = layerWith node' + +-- | Specify the initial nodes. +layern :: Graph g => [Node] -> g a b -> [[Node]] +layern = layernWith node' + +-- | Specify function to apply to nodes whose result will be in the result +-- list. The initial nodes are the nodes which don't have in-edges. +layerWith :: Graph g => (Context a b -> c) -> g a b -> [[c]] +layerWith result graph = layernWith result (noIn graph) graph + +-- | Specify function to apply to nodes whose result will be in the result +-- list, and specify initial nodes. +layernWith :: Graph g => (Context a b -> c) -> [Node] -> g a b -> [[c]] +layernWith = xlayernWith suc' (not . null . pre') + +-- $backward +-- Backward layering starts from a set of nodes, usually the nodes which don't +-- have out-edges, and builds the layers by traversing the in-edges +-- recursively. The initial nodes are the first layer, their parents are the +-- second layer, the parents' parents are the third layer, and so on. + +-- | The initial nodes are the nodes which don't have out-edges. +rlayer :: Graph g => g a b -> [[Node]] +rlayer = rlayerWith node' + +-- | Specify the initial nodes. +rlayern :: Graph g => [Node] -> g a b -> [[Node]] +rlayern = rlayernWith node' + +-- | Specify function to apply to nodes whose result will be in the result +-- list. The initial nodes are the nodes which don't have out-edges. +rlayerWith :: Graph g => (Context a b -> c) -> g a b -> [[c]] +rlayerWith result graph = rlayernWith result (noOut graph) graph + +-- | Specify function to apply to nodes whose result will be in the result +-- list, and specify initial nodes. +rlayernWith :: Graph g => (Context a b -> c) -> [Node] -> g a b -> [[c]] +rlayernWith = xlayernWith pre' (not . null . suc') + +-- $custom +-- Custom layering starts from a set of nodes, and builds the layers by +-- traversing edges recursively. A user-specified function determines which +-- edges are traversed, and another functions is used for checking whether +-- there are edges through which a given node can be reached. For example, if +-- you follow just out-edges that point from red-colored nodes, the second +-- function would check whether the given nodes has red-colored nodes pointing +-- to it. The initial nodes are the first layer, the nodes reached from them +-- are the second layer and so on. + +-- | Specify which paths to follow, and the initial nodes. +xlayern + :: Graph g + => (Context a b -> [Node]) + -> (Context a b -> Bool) + -> [Node] + -> g a b + -> [[Node]] +xlayern follow back = xlayernWith follow back node' + +-- (1) All nodes have unspecified layer +-- (2) Mark all child-less nodes with layer 1 and place in a queue +-- (3) Dequeue a node N and remove N from the graph +-- (4) For each parent of N, P: +-- (5) layer(P) = max (layer(P), layer(N)+1) +-- (6) If N was P's only child, enqueue P +-- (7) Jump back to 3 +depths + :: Graph g + => (Context a b -> [Node]) + -> (Context a b -> Bool) + -> g a b + -> Queue Node + -> M.HashMap Node Int + -> M.HashMap Node Int +depths follow back = go + where + depth n m = + case M.lookup n m of + Nothing -> error "Layer of node not found, should never happen" + Just d -> d + visit g l p (m, q) = + ( case M.lookup p m of + Nothing -> M.insert p l m + Just d -> + if l > d + then M.insert p l m + else m + , if back $ context g p + then q + else queuePut p q + ) + go g q m = + if queueEmpty q + then m + else + let (n, q') = queueGet q + in case match n g of + (Nothing, g') -> go g' q' m + (Just c, g') -> + let ps = follow c + l = depth n m + 1 + (m', q'') = foldr (visit g' l) (m, q') ps + in go g' q'' m' + +-- | Specify which paths to follow, a function to apply to nodes whose result +-- will be in the result list, and the initial nodes. +xlayernWith + :: Graph g + => (Context a b -> [Node]) + -> (Context a b -> Bool) + -> (Context a b -> c) + -> [Node] + -> g a b + -> [[c]] +xlayernWith follow back result initials graph = + -- Sort by layer number and drop the layer numbers, leaving just nodes + map snd $ sortOn fst $ M.toList $ + -- Map nodes to results according to user specified function + M.map (map $ result . context graph) $ + -- Turn node-to-layer map into layer-to-nodes map + ML.flip $ + -- Determine the layer number for each node + depths + follow + back + graph + (queuePutList initials mkQueue) + (M.fromList $ zip initials (repeat 1)) diff --git a/src/Data/HashMap/Lazy/Local.hs b/src/Data/HashMap/Lazy/Local.hs new file mode 100644 index 0000000..65577c8 --- /dev/null +++ b/src/Data/HashMap/Lazy/Local.hs @@ -0,0 +1,32 @@ +{- 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 + - . + -} + +module Data.HashMap.Lazy.Local + ( flip + ) +where + +import Prelude hiding (flip) + +import Data.Hashable (Hashable) + +import qualified Data.HashMap.Lazy as M + +-- | Build a 'M.HashMap' which maps each value in the original HashMap to the +-- keys under which it appears there. +flip :: (Eq b, Hashable b) => M.HashMap a b -> M.HashMap b [a] +flip = M.foldrWithKey collect M.empty + where + collect k v = M.insertWith (\ _new old -> k : old) v [k] diff --git a/vervis.cabal b/vervis.cabal index 4f433d8..d8d4f3e 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -53,6 +53,8 @@ library Data.EventTime.Local Data.Functor.Local Data.Git.Local + Data.Graph.Inductive.Query.Layer + Data.HashMap.Lazy.Local Data.Hourglass.Local Data.List.Local Data.Paginate.Local