diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for stacked-dag + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2018 + +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 Author name here 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,90 @@ +# stacked-dag + +[![Hackage version](https://img.shields.io/hackage/v/stacked-dag.svg?style=flat)](https://hackage.haskell.org/package/stacked-dag) [![Build Status](https://travis-ci.org/junjihashimoto/stacked-dag.png?branch=master)](https://travis-ci.org/junjihashimoto/stacked-dag) + +Ascii DAG for visualization of dataflow + +stacked-dag can show Ascii-DAG(Directed acyclic graph) from a Dot file of graphviz. +Dataflow's direction is from top to bottom. +'o' means a node. A label of the node is shown to the left side. +Other characters are edges of DAG. + +A sample of DAG is below. + +``` +o o l0,l4 +|/ +o l1 +| +o l2 +| +o l3 +``` + +# Usages + +Write a Dot file of graphviz. + +``` +$ cat > sample.dot +digraph graphname { + 0 [label="l0"]; + 1 [label="l1"]; + 2 [label="l2"]; + 3 [label="l3"]; + 4 [label="l4"]; + 0->1; + 1->2; + 2->3; + 4->1; +} +``` + +Show ascii DAG by following command. + +``` +$ stacked-dag dot sample.dot +o o l0,l4 +|/ +o l1 +| +o l2 +| +o l3 +``` + +# Samples + +``` +$ stacked-dag samples +o o l0,l1 +|/ +o o o l2,l4,l6 +|/_/ +o l3 +| +o l5 +--- +o o l0,l1 + x +o o l2,l3 +--- +o l0 +|\ +o o l1,l2 +--- +o +|\ +o | +|/ +o +--- +o +|\ +o | +| | +o | +|/ +o +``` + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,100 @@ +module Main where + +import StackedDag +import Options.Applicative +import qualified Data.Text.Lazy.IO as T + +data Command = + Dot FilePath + | Samples + +fromdot :: Parser Command +fromdot = Dot + <$> (argument str (metavar "DotFile")) + +samples :: Parser Command +samples = pure Samples + +parse :: Parser Command +parse = subparser $ + command "dot" (info fromdot (progDesc "convert graphviz-dot-file to ascii-dag")) <> + command "samples" (info samples (progDesc "show samples")) + +runCmd :: Command -> IO () +runCmd (Dot ifile) = do + v <- T.readFile ifile + T.putStr $ genAsciiFromDot v + + +runCmd (Samples) = do + putStr $ edgesToText samplelabels sampledat + putStrLn "---" + putStr $ edgesToText ( mkLabels [ + (0,"l0"), + (1,"l1"), + (2,"l2"), + (3,"l3") + ]) ( mkEdges [ + (0,[3]), + (1,[2]) + ]) + putStrLn "---" + putStr $ edgesToText ( mkLabels [ + (0,"l0"), + (1,"l1"), + (2,"l2"), + (3,"l3") + ]) ( mkEdges [ + (0,[1,2,3]) + ]) + putStrLn "---" + putStr $ edgesToText ( mkLabels [ + (0,"l0"), + (1,"l1"), + (2,"l2"), + (3,"l3"), + (4,"l4") + ]) ( mkEdges [ + (0,[4]), + (1,[4]), + (2,[4]), + (3,[4]) + ]) + putStrLn "---" + putStr $ edgesToText ( mkLabels []) ( mkEdges [ + (0,[1,2]), + (1,[2]) + ]) + putStrLn "---" + putStr $ edgesToText ( mkLabels []) ( mkEdges [ + (0,[1,3]), + (1,[2]), + (2,[3]) + ]) + +sampledat :: Edges +sampledat = mkEdges [ + (0,[2]), + (1,[2]), + (2,[3]), + (4,[3]), + (6,[3]), + (3,[5]) + ] + +samplelabels :: Labels +samplelabels = mkLabels [ + (0,"l0"), + (1,"l1"), + (2,"l2"), + (3,"l3"), + (5,"l5"), + (4,"l4"), + (6,"l6") + ] + +opts :: ParserInfo Command +opts = info (parse <**> helper) idm + +main :: IO () +main = execParser opts >>= runCmd diff --git a/src/StackedDag.hs b/src/StackedDag.hs new file mode 100644 --- /dev/null +++ b/src/StackedDag.hs @@ -0,0 +1,8 @@ +module StackedDag ( + module StackedDag.Base +, module StackedDag.Graphviz +) where + +import StackedDag.Base +import StackedDag.Graphviz + diff --git a/src/StackedDag/Base.hs b/src/StackedDag/Base.hs new file mode 100644 --- /dev/null +++ b/src/StackedDag/Base.hs @@ -0,0 +1,534 @@ +module StackedDag.Base ( + Labels +, Edges +, NodeId +, mkLabels +, mkEdges +, edgesToText +) where + +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.List as L +import Data.Maybe(maybe) + +type NodeId = Int + +type Edges = M.Map NodeId (S.Set NodeId) + +type Labels = M.Map NodeId String + +data Symbol = + SNode String -- o with label + | SLeft -- / + | SRight -- \ + | SHold -- | + | SLMove -- _ + | SRMove -- _ + | SCross -- x + | SSpace -- ' ' + deriving (Show, Read, Eq) + +instance Semigroup Symbol where + (<>) n@(SNode _) _ = n + (<>) _ n@(SNode _) = n + (<>) a SSpace = a + (<>) SSpace a = a + (<>) SLeft SRight = SCross + (<>) SRight SLeft = SCross + (<>) SCross SRight = SCross + (<>) SCross SLeft = SCross + (<>) SRight SCross = SCross + (<>) SLeft SCross = SCross + (<>) a _ = a + + +instance Monoid Symbol where + mempty = SSpace + +type Nodes = S.Set NodeId + +type Depth = Int +type Dest = Int +type Cur = Int +type Pos = Int + +type DepthNode = M.Map NodeId Depth + +type DepthGroup = M.Map Depth [NodeId] + +type DepthGroup' = M.Map Depth ([NodeId],[NodeId]) + +type DepthGroup'' = M.Map Depth ([(NodeId,Cur,Dest)],[(NodeId,Cur,Dest)]) + +mkEdges :: [(NodeId,[NodeId])] -> Edges +mkEdges edges = M.fromList $ map (\(nid,nids) -> (nid, S.fromList nids)) g + where + g = map (\xs@((k,_):_)-> (k,concat $ map snd xs) ) $ L.groupBy (\(a,_) (b,_) -> a == b) $ L.sortBy (\(a,_) (b,_) -> compare a b) $ edges + +mkLabels ::[(NodeId,String)] -> Labels +mkLabels labels = M.fromList labels + +sampledat :: Edges +sampledat = mkEdges [ + (0,[2]), + (1,[2]), + (2,[3]), + (4,[3]), + (6,[3]), + (3,[5]) + ] + +samplelabels :: Labels +samplelabels = mkLabels [ + (0,"l0"), + (1,"l1"), + (2,"l2"), + (3,"l3"), + (5,"l5"), + (4,"l4"), + (6,"l6") + ] + +-- | Grouping the nodes by the depth +-- +-- >>> getDepthGroup sampledat +-- fromList [(0,[5]),(1,[3]),(2,[2,4,6]),(3,[0,1])] +getDepthGroup :: Edges -> DepthGroup +getDepthGroup edges = M.fromList d2n + where + depth0 = getDepth edges + depth1 = getDepth $ reverseEdges edges + score nodeid = + maybe 0 id (M.lookup nodeid depth0) + + maybe 0 id (M.lookup nodeid depth1) + + sort' :: S.Set NodeId -> [NodeId] + sort' nodes = L.sortBy (\a b -> compare (score b) (score a)) $ S.toList nodes + + d2n = loop + $ L.groupBy (\(a,_) (b,_) -> a == b) + $ L.sortBy (\(a,_) (b,_) -> compare a b) + $ map (\(a,b) -> (b,a)) + $ M.toList depth0 + loop :: [[(NodeId,Depth)]] -> [(Depth,[NodeId])] + loop ls = + case ls of + [] -> [] + a:ax -> case a of + (n,d):_ -> (n,sort' $ S.fromList $ map snd a): loop ax + [] -> loop ax + +pairs edges = do + (p, c) <- M.toList edges + child <- S.toList c + return (child,p) + +-- | Reverse the directions of edges +-- +-- >>> sampledat +-- fromList [(0,fromList [2]),(1,fromList [2]),(2,fromList [3]),(3,fromList [5]),(4,fromList [3]),(6,fromList [3])] +-- >>> reverseEdges sampledat +-- fromList [(2,fromList [0,1]),(3,fromList [2,4,6]),(5,fromList [3])] +reverseEdges :: Edges -> Edges +reverseEdges edges = M.fromList d2n + where + d2n = loop + $ L.groupBy (\(a,_) (b,_) -> a == b) + $ L.sortBy (\(a,_) (b,_) -> compare a b) + $ pairs edges + loop :: [[(NodeId,NodeId)]] -> [(NodeId,S.Set NodeId)] + loop ls = + case ls of + [] -> [] + a:ax -> case a of + (n,d):_ -> (n,S.fromList $ map snd a): loop ax + [] -> loop ax + +-- | Get nodes by edges +-- +-- >>> getNodes sampledat +-- fromList [0,1,2,3,4,5,6] +getNodes :: Edges -> Nodes +getNodes edges = S.fromList $ parents ++ children + where + parents = do + (parent, c) <- M.toList edges + return parent + children = do + (_, c) <- M.toList edges + child <- S.toList c + return child + +getDepth :: Edges -> DepthNode +getDepth edges = M.fromList $ map (\v -> (v,getDepth' v edges)) $ S.toList $ getNodes edges + +getDepth' :: Int -> Edges -> Int +getDepth' i edges = + case M.lookup i edges of + Just v -> 1 + (maximum $ map (\v' -> getDepth' v' edges ) $ S.toList v) + Nothing -> 0 + + +-- | Move nodes to next step +-- +-- >>> moveOne [(0,0,4)] +-- [((0,2,4),[(SRight,1)])] +-- >>> moveOne [(0,0,4),(0,4,0)] +-- [((0,2,4),[(SRight,1)]),((0,2,0),[(SLeft,3)])] +moveOne :: [(NodeId,Cur,Dest)] -> [((NodeId,Cur,Dest),[(Symbol,Pos)])] +moveOne nodes = do + (n,c,g) <- nodes + if c < g + then + return ((n,c+2,g),[(SRight,c+1)]) + else + if c > g + then + return ((n,c-2,g),[(SLeft,c-1)]) + else + return ((n,c,g),[(SHold,c)]) + +takeNode :: Cur -> [((NodeId,Cur,Dest),[(Symbol,Pos)])] -> Maybe ((NodeId,Cur,Dest),[(Symbol,Pos)]) +takeNode c nodes = L.find (\(_,syms) -> any (== c) (map snd syms)) nodes + +-- | Move more nodes +-- +-- >>> moveLeft' [((0,0,0),[(SHold,0)]),((1,0,0),[(SLeft,1)]),((2,2,0),[(SLeft,3)])] +-- [((0,0,0),[(SHold,0)]),((1,0,0),[(SLeft,1)]),((2,0,0),[(SLMove,2),(SLeft,3)])] +-- >>> moveLeft' [((0,0,0),[(SHold,0)]),((1,0,0),[(SLeft,1)]),((2,0,0),[(SLMove,2),(SLeft,3)]),((3,2,0),[(SLMove,4),(SLeft,5)])] +-- [((0,0,0),[(SHold,0)]),((1,0,0),[(SLeft,1)]),((2,0,0),[(SLMove,2),(SLeft,3)]),((3,0,0),[(SLMove,4),(SLeft,5)])] +-- >>> moveLeft' [((0,2,0),[(SLeft,3)])] +-- [((0,0,0),[(SLMove,1),(SLMove,2),(SLeft,3)])] +moveLeft' :: [((NodeId,Cur,Dest),[(Symbol,Pos)])] -> [((NodeId,Cur,Dest),[(Symbol,Pos)])] +moveLeft' nodes = do + nn@((n,c,g),syms) <- nodes + if c > g + then + case (takeNode c nodes,takeNode (c-1) nodes) of + (Nothing,Nothing) -> return ((n,c-2,g),((SLMove,c-1):(SLMove,c):syms)) + (Nothing,Just ((n',c',g'),_)) -> if g' == g then return ((n,c-2,g),((SLMove,c):syms)) else return nn + (Just ((_,_,g'),_),_) -> if g' == g then return ((n,c-2,g),syms) else return nn + else + return nn + +-- | Move more nodes +-- +-- >>> moveLeft [((0,0,0),[(SHold,0)]),((1,0,0),[(SLeft,1)]),((2,2,0),[(SLeft,3)]),((3,4,0),[(SLeft,5)])] +-- [((0,0,0),[(SHold,0)]),((1,0,0),[(SLeft,1)]),((2,0,0),[(SLMove,2),(SLeft,3)]),((3,0,0),[(SLMove,4),(SLeft,5)])] +moveLeft :: [((NodeId,Cur,Dest),[(Symbol,Pos)])] -> [((NodeId,Cur,Dest),[(Symbol,Pos)])] +moveLeft nodes = if nodes == m then nodes else moveLeft m + where + m = moveLeft' nodes + +-- | Move nodes to the next depth +-- +-- >>> moveAll' [(0,0,4)] [] +-- [[(SRight,1)],[(SRight,3)]] +-- >>> moveAll' [(0,4,0)] [] +-- [[(SLMove,1),(SLMove,2),(SLeft,3)]] +-- >>> moveAll' [(0,2,0)] [] +-- [[(SLeft,1)]] +-- >>> moveAll' [(0,0,4),(0,4,0)] [] +-- [[(SRight,1),(SLeft,3)],[(SRight,3),(SLeft,1)]] +-- >>> moveAll' [(0,0,4),(0,2,0)] [] +-- [[(SRight,1),(SLeft,1)],[(SRight,3),(SHold,0)]] +moveAll' :: [(NodeId,Cur,Dest)] -> [[(Symbol,Pos)]] -> [[(Symbol,Pos)]] +moveAll' nodes buf | all (\(_,c,g) -> c==g) nodes && buf /= [] = buf + | otherwise = moveAll' (map fst next) (buf ++ [concat $ map snd next]) + where + next = moveLeft $ moveOne nodes + +mergeSymbol :: [(Symbol,Pos)] -> [(Symbol,Pos)] +mergeSymbol symbols = + map (\v -> (foldr mappend mempty (map fst v),(snd (head v)))) + $ L.groupBy (\(s0,p0) (s1,p1) -> p0 == p1) + $ L.sortBy (\(s0,p0) (s1,p1) -> p0 `compare` p1) symbols + +-- | Fill spaces +-- +-- >>> withSpace [(SRight,1),(SLeft,3)] +-- [(SSpace,0),(SRight,1),(SSpace,2),(SLeft,3)] +-- >>> withSpace [(SRight,3),(SLeft,1)] +-- [(SSpace,0),(SLeft,1),(SSpace,2),(SRight,3)] +withSpace :: [(Symbol,Pos)] -> [(Symbol,Pos)] +withSpace syms = merge sorted [0..max] + where + merge [] _ = [] + merge _ [] = [] + merge s@((s0,p0):sx) (p:px) | p0 == p = (s0,p0):merge sx px + | p0 < p = merge sx (p:px) + | otherwise = (SSpace,p):merge s px + sorted = L.sortBy (\a b -> snd a `compare` snd b) syms + max = maximum $ map snd sorted + +-- | Move nodes and fill spaces +-- +-- >>> moveAllWithSpace [(0,0,4)] +-- [[(SSpace,0),(SRight,1)],[(SSpace,0),(SSpace,1),(SSpace,2),(SRight,3)]] +-- >>> moveAllWithSpace [(0,4,0)] +-- [[(SSpace,0),(SLMove,1),(SLMove,2),(SLeft,3)]] +-- >>> moveAllWithSpace [(0,0,4),(0,4,0)] +-- [[(SSpace,0),(SRight,1),(SSpace,2),(SLeft,3)],[(SSpace,0),(SLeft,1),(SSpace,2),(SRight,3)]] +-- >>> moveAllWithSpace [(0,4,0),(1,0,4)] +-- [[(SSpace,0),(SRight,1),(SSpace,2),(SLeft,3)],[(SSpace,0),(SLeft,1),(SSpace,2),(SRight,3)]] +moveAllWithSpace :: [(NodeId,Cur,Dest)] -> [[(Symbol,Pos)]] +moveAllWithSpace nodes = map withSpace $ map mergeSymbol $ moveAll' nodes [] + +lstr :: Labels -> NodeId -> String +lstr labels nodeid = maybe "" id (M.lookup nodeid labels) + +nodeWithSpace :: Labels -> ([(NodeId,Cur,Dest)],[(NodeId,Cur,Dest)]) -> [(Symbol,Pos)] +nodeWithSpace labels (nodes,skipnodes) = + withSpace $ + (map (\(nid,c,_) -> (SNode (lstr labels nid),c)) nodes) ++ + (map (\(_,c,_) -> (SHold,c)) skipnodes) + +-- | Add bypass nodes +-- +-- >>> edges = mkEdges [(0,[1,2]),(1,[2])] +-- >>> addBypassNode'' 2 edges (M.fromList [(0,([2],[])),(1,([1],[])),(2,([0],[]))]) +-- fromList [(0,([2],[])),(1,([1],[0])),(2,([0],[]))] +-- >>> edges = mkEdges [(0,[1,3]),(1,[2]),(2,[3])] +-- >>> addBypassNode'' 3 edges (M.fromList [(0,([3],[])),(1,([2],[])),(2,([1],[])),(3,([0],[]))]) +-- fromList [(0,([3],[])),(1,([2],[])),(2,([1],[0])),(3,([0],[]))] +-- >>> addBypassNode'' 2 edges (M.fromList [(0,([3],[])),(1,([2],[])),(2,([1],[0])),(3,([0],[]))]) +-- fromList [(0,([3],[])),(1,([2],[0])),(2,([1],[0])),(3,([0],[]))] +addBypassNode'' :: Depth -> Edges -> DepthGroup' -> DepthGroup' +addBypassNode'' d edges dg | d < 2 = error $ "depth " ++ show d ++ " must be greater than 2" + | otherwise = + case (M.lookup d dg,M.lookup (d-1) dg) of + (Just (nids0,skipnids0),Just (nids1,_)) -> foldl (\dg' nid -> update d nids1 dg' nid) dg (nids0++skipnids0) + (Just (nids0,skipnids0),Nothing) -> dg + (Nothing,_) -> dg + where + elem :: NodeId -> [NodeId] -> Bool + elem nid nids = + case M.lookup nid edges of + Just m -> all id (map (\n -> L.elem n nids) (S.toList m)) + Nothing -> True + update :: Depth -> [NodeId] -> DepthGroup' -> NodeId -> DepthGroup' + update d' nids1 dg' nid0 = + if not (elem nid0 nids1) + then M.update (\(v,skip) -> Just (v,skip++[nid0])) (d'-1) dg' + else dg' + + +-- | Get a maximum of depth +-- +-- >>> maxDepth (M.fromList [(0,([2],[])),(1,([1],[])),(2,([0],[]))]) +-- 2 +maxDepth :: DepthGroup' -> Int +maxDepth dg = maximum $ map fst $ M.toList dg + +-- | Add bypass nodes +-- +-- >>> edges = mkEdges [(0,[1,2]),(1,[2])] +-- >>> addBypassNode' edges (M.fromList [(0,([2],[])),(1,([1],[])),(2,([0],[]))]) +-- fromList [(0,([2],[])),(1,([1],[0])),(2,([0],[]))] +-- >>> edges = mkEdges [(0,[1,3]),(1,[2]),(2,[3])] +-- >>> addBypassNode' edges (M.fromList [(0,([3],[])),(1,([2],[])),(2,([1],[])),(3,([0],[]))]) +-- fromList [(0,([3],[])),(1,([2],[0])),(2,([1],[0])),(3,([0],[]))] +addBypassNode' :: Edges -> DepthGroup' -> DepthGroup' +addBypassNode' edges dg = foldr (\d dg' -> addBypassNode'' d edges dg') dg $ [2..(maxDepth dg)] + +-- | Add bypass nodes +-- +-- >>> edges = mkEdges [(0,[1,2]),(1,[2])] +-- >>> dg = getDepthGroup edges +-- >>> addBypassNode edges dg +-- fromList [(0,([2],[])),(1,([1],[0])),(2,([0],[]))] +-- >>> edges = mkEdges [(0,[1,3]),(1,[2]),(2,[3])] +-- >>> dg = getDepthGroup edges +-- >>> addBypassNode edges dg +-- fromList [(0,([3],[])),(1,([2],[0])),(2,([1],[0])),(3,([0],[]))] +addBypassNode :: Edges -> DepthGroup -> DepthGroup' +addBypassNode edges dg = addBypassNode' edges $ M.fromList $ map (\(k,v)-> (k,(v,[]))) $ M.toList dg + +-- | Add destinations of nodes +-- +-- >>> edges = mkEdges [(0,[1,2]),(1,[2])] +-- >>> dg = getDepthGroup edges +-- >>> addPosNode edges $ M.fromList [(0,([2],[])),(1,([1],[0])),(2,([0],[]))] +-- fromList [(0,([(2,0,0)],[])),(1,([(1,0,0)],[(0,2,0)])),(2,([(0,0,0),(0,0,2)],[]))] +addPosNode :: Edges -> DepthGroup' -> DepthGroup'' +addPosNode edges dg = M.fromList $ mapAddPos $ reverse $ M.toList dg + where + mapAddPos :: [(Int,([NodeId],[NodeId]))] -> [(Int,([(NodeId,Cur,Dest)],[(NodeId,Cur,Dest)]))] + mapAddPos [] = [] + mapAddPos ((k,(a0,a1)):[]) = [(k,(zip3 a0 initpos0 initpos0,zip3 a1 initpos1 initpos1))] + where + initpos0 = map (*2) [0..] + initpos1 = map (*2) [(length a0)..] + mapAddPos ((ka,a):(kb,b):bx) = (ka,addPos edges a b): mapAddPos ((kb,b):bx) + +-- | Grouping the nodes by the depth +-- +-- >>> edges = mkEdges [(0,[1,2])] +-- >>> dg = getDepthGroup edges +-- >>> dg +-- fromList [(0,[1,2]),(1,[0])] +-- >>> addNode edges dg +-- fromList [(0,([(1,0,0),(2,2,2)],[])),(1,([(0,0,0),(0,0,2)],[]))] +addNode :: Edges -> DepthGroup -> DepthGroup'' +addNode edges dg = addPosNode edges $ addBypassNode edges dg + +toSymbol :: Labels -> DepthGroup'' -> [[(Symbol,Pos)]] +toSymbol labels dg = concat $ map (\(k,(n,s)) -> (nodeWithSpace labels (n,s)):moveAllWithSpace (n++s) ) $ reverse $ M.toList dg + +edgesToText :: Labels -> Edges -> String +edgesToText labels edges = renderToText ( reverse $ drop 1 $ reverse $ toSymbol labels $ addNode edges $ getDepthGroup edges) [] + +symbolToChar :: Symbol -> Char +symbolToChar (SNode _) = 'o' +symbolToChar SLeft = '/' +symbolToChar SRight = '\\' +symbolToChar SHold = '|' +symbolToChar SCross = 'x' +symbolToChar SLMove = '_' +symbolToChar SRMove = '_' +symbolToChar SSpace = ' ' + +-- | Rendering symbols to text +-- +-- >>> renderToText [[(SNode "",0)],[(SHold,0)],[(SNode "",0)]] [] +-- "o\n|\no\n" +-- >>> renderToText [[(SNode "",0),(SSpace,1),(SNode "",2)],[(SHold,0),(SLeft,1)],[(SNode "",0)]] [] +-- "o o\n|/\no\n" +renderToText :: [[(Symbol,Pos)]] -> [String] -> String +renderToText [] _ = [] +renderToText ([]:sxx) labelbuf = (if 0 == foldr (\i s -> s + length i) 0 labelbuf then "" else str )++ "\n" ++ renderToText sxx [] + where + str = " " ++ (L.intercalate "," labelbuf) +renderToText ((s@(SNode label,_):sx):sxx) labelbuf = (symbolToChar (fst s)):(renderToText (sx:sxx) (labelbuf ++ [label])) +renderToText ((s:sx):sxx) labelbuf = (symbolToChar (fst s)):(renderToText (sx:sxx) labelbuf) + +-- | Allocate destinations of nodes. +-- +-- >>> addPos sampledat ([0,1],[]) ([2],[]) +-- ([(0,0,0),(1,2,0)],[]) +-- >>> addPos (mkEdges [(0,[1,2]),(1,[2])]) ([0],[]) ([1],[0]) +-- ([(0,0,0),(0,0,2)],[]) +-- >>> addPos (mkEdges [(0,[1,2]),(1,[2])]) ([1],[0]) ([2],[]) +-- ([(1,0,0)],[(0,2,0)]) +-- >>> addPos (mkEdges [(0,[1,3]),(1,[2]),(2,[3])]) ([1],[0]) ([2],[0]) +-- ([(1,0,0)],[(0,2,2)]) +addPos :: Edges -> ([NodeId],[NodeId]) -> ([NodeId],[NodeId]) -> ([(NodeId,Cur,Dest)],[(NodeId,Cur,Dest)]) +addPos edges (curn,curs) (nxtn,nxts) = (n2n++n2s,s2n++s2s) + where + curn' = zip curn $ map (*2) [0..] + curs' = zip curs $ map (*2) [(length curn)..] + nxtn' = zip nxtn $ map (*2) [0..] + nxts' = zip nxts $ map (*2) [(length nxtn)..] + n2s = concat $ flip map curn' $ \(c,i) -> + case L.find (\(nid,_) -> nid == c) nxts' of + Just (_,ii) -> [(c,i,ii)] + Nothing -> [] + s2s = concat $ flip map curs' $ \(c,i) -> + case L.find (\(nid,_) -> nid == c) nxts' of + Just (_,ii) -> [(c,i,ii)] + Nothing -> [] + n2n = concat $ flip map curn' $ \(c,i) -> + case M.lookup c edges of + Just c' -> concat $ flip map (S.toList c') $ \c'' -> + case L.find (\(nid,_) -> nid == c'') nxtn' of + Just (_,ii) -> [(c,i,ii)] + Nothing -> [] + Nothing -> [] + s2n = concat $ flip map curs' $ \(c,i) -> + case M.lookup c edges of + Just c' -> concat $ flip map (S.toList c') $ \c'' -> + case L.find (\(nid,_) -> nid == c'') nxtn' of + Just (_,ii) -> [(c,i,ii)] + Nothing -> [] + Nothing -> [] + + + +{- + +o o 0,1 +|/ +o o o 2,4,6 +|/_/ +o +| +o + +o o o 0,1,8 +|/ \ +o o o o 2,4,6,7 +|/_/_/ +o 3 +| +o 5 + +o o o o +|____/ + +o o o +| '''\ + +o o o o +|/_/_/ +o add +|\ +| |\ +| | |\ +o o o o + +o o + x +a b + +o o o +| |/ +|/| +o o + +-} +main = do + putStr $ edgesToText samplelabels sampledat + putStrLn "---" + putStr $ edgesToText ( mkLabels [ + (0,"l0"), + (1,"l1"), + (2,"l2"), + (3,"l3") + ]) ( mkEdges [ + (0,[3]), + (1,[2]) + ]) + putStrLn "---" + putStr $ edgesToText ( mkLabels [ + (0,"l0"), + (1,"l1"), + (2,"l2"), + (3,"l3") + ]) ( mkEdges [ + (0,[1,2,3]) + ]) + putStrLn "---" + putStr $ edgesToText ( mkLabels [ + (0,"l0"), + (1,"l1"), + (2,"l2"), + (3,"l3"), + (4,"l4") + ]) ( mkEdges [ + (0,[4]), + (1,[4]), + (2,[4]), + (3,[4]) + ]) + putStrLn "---" + putStr $ edgesToText ( mkLabels []) ( mkEdges [ + (0,[1,2]), + (1,[2]) + ]) + putStrLn "---" + putStr $ edgesToText ( mkLabels []) ( mkEdges [ + (0,[1,3]), + (1,[2]), + (2,[3]) + ]) diff --git a/src/StackedDag/Graphviz.hs b/src/StackedDag/Graphviz.hs new file mode 100644 --- /dev/null +++ b/src/StackedDag/Graphviz.hs @@ -0,0 +1,25 @@ +module StackedDag.Graphviz where + +import qualified Data.List as L +import qualified Data.Text.Lazy as T +import qualified Data.String as S +import qualified Data.GraphViz as G +import qualified Data.GraphViz.Attributes.Complete as GT +import StackedDag.Base + +genAsciiFromDot :: T.Text -> T.Text +genAsciiFromDot dot = S.fromString $ edgesToText labels edges + where + dg :: G.DotGraph String + dg = G.parseDotGraph dot + edges = mkEdges $ map (\v -> (read (G.fromNode v),([read (G.toNode v)]))) $ G.graphEdges dg + getl' :: G.Attribute -> Maybe String + getl' attr = case attr of + (GT.Label (GT.StrLabel name)) -> Just (T.unpack name) + (GT.Label name) -> Just (show name) + _ -> Nothing + getl :: G.Attributes -> String + getl attrs = maybe "" id $ foldl (\s i-> s <> getl' i) Nothing attrs + labels = mkLabels $ map (\v -> (read (G.nodeID v),getl (G.nodeAttributes v))) $ G.graphNodes dg + + diff --git a/stacked-dag.cabal b/stacked-dag.cabal new file mode 100644 --- /dev/null +++ b/stacked-dag.cabal @@ -0,0 +1,76 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 57c444b244471ba568f185b245e319dac1300ef668335859a1516b8b2a0bbe7d + +name: stacked-dag +version: 0.1.0.0 +synopsis: Ascii DAG(Directed acyclic graph) for visualization of dataflow +description: Please see the README on GitHub at +category: Graphs, Graphics +homepage: https://github.com/junjihashimoto/stacked-dag#readme +bug-reports: https://github.com/junjihashimoto/stacked-dag/issues +author: Junji Hashimoto +maintainer: junji.hashimoto@gmail.com +copyright: 2018 Junji Hashimoto +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + ChangeLog.md + README.md + +source-repository head + type: git + location: https://github.com/junjihashimoto/stacked-dag + +library + exposed-modules: + StackedDag + StackedDag.Base + StackedDag.Graphviz + other-modules: + Paths_stacked_dag + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , containers + , graphviz + , text + default-language: Haskell2010 + +executable stacked-dag + main-is: Main.hs + other-modules: + Paths_stacked_dag + hs-source-dirs: + app + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , containers + , graphviz + , optparse-applicative + , stacked-dag + , text + default-language: Haskell2010 + +test-suite doctest + type: exitcode-stdio-1.0 + main-is: doctests.hs + other-modules: + Paths_stacked_dag + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , containers + , doctest + , graphviz + , stacked-dag + , text + default-language: Haskell2010 diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,5 @@ +import Test.DocTest +main = doctest [ + "-isrc" + , "src/StackedDag/Base.hs" + ]