diff --git a/src/StackedDag.hs b/src/StackedDag.hs --- a/src/StackedDag.hs +++ b/src/StackedDag.hs @@ -1,6 +1,12 @@ module StackedDag ( - module StackedDag.Base -, module StackedDag.Graphviz + Labels +, Edges +, NodeId +, mkLabels +, mkEdges +, edgesToText +, genEdgesFromDot +, genAsciiFromDot ) where import StackedDag.Base diff --git a/src/StackedDag/Base.hs b/src/StackedDag/Base.hs --- a/src/StackedDag/Base.hs +++ b/src/StackedDag/Base.hs @@ -1,15 +1,11 @@ -module StackedDag.Base ( - Labels -, Edges -, NodeId -, mkLabels -, mkEdges -, edgesToText -) where +module StackedDag.Base where import qualified Data.Map as M import qualified Data.Set as S import qualified Data.List as L +import Control.Monad +import Control.Monad.ST +import Data.STRef import Data.Maybe(maybe) type NodeId = Int @@ -99,8 +95,8 @@ getDepthGroup :: Edges -> DepthGroup getDepthGroup edges = M.fromList d2n where - depth0 = getDepth edges - depth1 = getDepth $ reverseEdges edges + depth0 = getDepth2 edges + depth1 = getDepth2 $ reverseEdges edges score nodeid = maybe 0 id (M.lookup nodeid depth0) + maybe 0 id (M.lookup nodeid depth1) @@ -166,6 +162,35 @@ child <- S.toList c return child + +getDepth2 :: Edges -> DepthNode +getDepth2 edges = runST $ do + ref <- newSTRef M.empty + mm <- forM (S.toList $ getNodes edges) $ \v -> do + d <- getDepth2' ref v edges + return (v,d) + return $ M.fromList mm + +getDepth2' :: STRef s DepthNode -> Int -> Edges -> ST s Int +getDepth2' ref i edges = do + d <- readSTRef ref + case M.lookup i d of + Just v -> return v + Nothing -> do + case M.lookup i edges of + Just v -> do + dl <- forM (S.toList v) $ \v' -> do + getDepth2' ref v' edges + let m = 1 + (maximum dl) + d' <- readSTRef ref + writeSTRef ref $ M.insert i m d' + return m + Nothing -> do + writeSTRef ref $ M.insert i 0 d + return 0 + + +{- getDepth :: Edges -> DepthNode getDepth edges = M.fromList $ map (\v -> (v,getDepth' v edges)) $ S.toList $ getNodes edges @@ -174,7 +199,7 @@ 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 -- @@ -247,7 +272,7 @@ mergeSymbol :: [(Symbol,Pos)] -> [(Symbol,Pos)] mergeSymbol symbols = - map (\v -> (foldr mappend mempty (map fst v),(snd (head v)))) + map (\v -> (foldl 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 @@ -308,7 +333,7 @@ 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),Just n1@(nids1,v)) -> M.update (\_ -> Just (foldl (\n1' nid -> update nids1 n1' nid) n1 (nids0++skipnids0))) (d-1) dg (Just (nids0,skipnids0),Nothing) -> dg (Nothing,_) -> dg where @@ -322,11 +347,11 @@ 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 = + update :: [NodeId] -> ([NodeId],[NodeId]) -> NodeId -> ([NodeId],[NodeId]) + update nids1 (v,skip) nid0 = if not (elem nid0 nids1) - then M.update (\(v,skip) -> Just (v,skip++[nid0])) (d'-1) dg' - else dg' + then (v,skip++[nid0]) + else (v,skip) -- | Get a maximum of depth @@ -461,93 +486,3 @@ 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 --- a/src/StackedDag/Graphviz.hs +++ b/src/StackedDag/Graphviz.hs @@ -7,8 +7,8 @@ import qualified Data.GraphViz.Attributes.Complete as GT import StackedDag.Base -genAsciiFromDot :: T.Text -> T.Text -genAsciiFromDot dot = S.fromString $ edgesToText labels edges +genEdgesFromDot :: T.Text -> (Labels,Edges) +genEdgesFromDot dot = (labels,edges) where dg :: G.DotGraph String dg = G.parseDotGraph dot @@ -23,3 +23,5 @@ labels = mkLabels $ map (\v -> (read (G.nodeID v),getl (G.nodeAttributes v))) $ G.graphNodes dg +genAsciiFromDot :: T.Text -> T.Text +genAsciiFromDot dot = S.fromString $ uncurry edgesToText $ genEdgesFromDot dot diff --git a/stacked-dag.cabal b/stacked-dag.cabal --- a/stacked-dag.cabal +++ b/stacked-dag.cabal @@ -2,12 +2,12 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 2188812bea0c0424ece99cd546a16fcd01cedc61c8eacdac83b90c3447583c5d +-- hash: 69c513999c24a509f1f35aa177e15003ba58f3377108f1da8396fb38afb3188c name: stacked-dag -version: 0.1.0.1 +version: 0.1.0.2 synopsis: Ascii DAG(Directed acyclic graph) for visualization of dataflow -description: Please see the README on GitHub at +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