stacked-dag (empty) → 0.1.0.0
raw patch · 10 files changed
+873/−0 lines, 10 filesdep +basedep +containersdep +doctestsetup-changed
Dependencies added: base, containers, doctest, graphviz, optparse-applicative, stacked-dag, text
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +90/−0
- Setup.hs +2/−0
- app/Main.hs +100/−0
- src/StackedDag.hs +8/−0
- src/StackedDag/Base.hs +534/−0
- src/StackedDag/Graphviz.hs +25/−0
- stacked-dag.cabal +76/−0
- test/doctests.hs +5/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for stacked-dag++## Unreleased changes
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,90 @@+# stacked-dag++[](https://hackage.haskell.org/package/stacked-dag) [](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+```+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -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
+ src/StackedDag.hs view
@@ -0,0 +1,8 @@+module StackedDag (+ module StackedDag.Base+, module StackedDag.Graphviz+) where++import StackedDag.Base+import StackedDag.Graphviz+
+ src/StackedDag/Base.hs view
@@ -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])+ ])
+ src/StackedDag/Graphviz.hs view
@@ -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++
+ stacked-dag.cabal view
@@ -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 <https://github.com/junji.hashimoto/stacked-dag#readme>+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
+ test/doctests.hs view
@@ -0,0 +1,5 @@+import Test.DocTest+main = doctest [+ "-isrc"+ , "src/StackedDag/Base.hs"+ ]