stacked-dag 0.1.0.4 → 0.1.1.0

raw patch · 5 files changed

+239/−193 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• app/Main.hs +13/−9
• src/StackedDag.hs +0/−1
• src/StackedDag/Base.hs +215/−175
• src/StackedDag/Graphviz.hs +9/−6
• stacked-dag.cabal +2/−2

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Main where  import StackedDag@@ -17,19 +18,22 @@  parse :: Parser Command parse = subparser $-        command "dot" (info fromdot (progDesc "convert graphviz-dot-file to ascii-dag")) <>+        command "dot" (info fromdot (progDesc "convert graphviz-dot-file to ascii-dag")) `mappend`         command "samples" (info samples (progDesc "show samples")) ++mkLabels' :: [(Int,String)] -> Labels Int String+mkLabels' = mkLabels+ 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 [+  putStr $ edgesToText ( mkLabels' [                            (0,"l0"),                            (1,"l1"),                            (2,"l2"),@@ -39,7 +43,7 @@                            (1,[2])                            ])   putStrLn "---"-  putStr $ edgesToText ( mkLabels [+  putStr $ edgesToText ( mkLabels' [                            (0,"l0"),                            (1,"l1"),                            (2,"l2"),@@ -48,7 +52,7 @@                            (0,[1,2,3])                            ])   putStrLn "---"-  putStr $ edgesToText ( mkLabels [+  putStr $ edgesToText ( mkLabels' [                            (0,"l0"),                            (1,"l1"),                            (2,"l2"),@@ -61,18 +65,18 @@                            (3,[4])                            ])   putStrLn "---"-  putStr $ edgesToText ( mkLabels []) ( mkEdges [+  putStr $ edgesToText ( mkLabels' []) ( mkEdges [                                           (0,[1,2]),                                           (1,[2])                                           ])   putStrLn "---"-  putStr $ edgesToText ( mkLabels []) ( mkEdges [+  putStr $ edgesToText ( mkLabels' []) ( mkEdges [                                           (0,[1,3]),                                           (1,[2]),                                           (2,[3])                                           ]) -sampledat :: Edges+sampledat :: Edges Int sampledat = mkEdges [   (0,[2]),   (1,[2]),@@ -82,7 +86,7 @@   (3,[5])   ] -samplelabels :: Labels+samplelabels :: Labels Int String samplelabels = mkLabels [   (0,"l0"),   (1,"l1"),

@@ -1,7 +1,6 @@ module StackedDag (   Labels , Edges-, NodeId , mkLabels , mkEdges , edgesToText

@@ -1,3 +1,8 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE OverloadedStrings #-}+ module StackedDag.Base where  import qualified Data.Map as M@@ -8,66 +13,69 @@ import Data.STRef import Data.Maybe(maybe) -type NodeId = Int--type Edges = M.Map NodeId (S.Set NodeId)+type Edges a = M.Map a (S.Set a) -type Labels = M.Map NodeId String+type Labels a b = M.Map a b -data Symbol =-    SNode String -- o with label-  | SLeft -- /-  | SRight -- \-  | SHold -- |-  | SLMove -- _-  | SRMove -- _-  | SCross -- x+data Symbol b =+    SNode b -- 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-+appendSymbol :: Symbol b -> Symbol b -> Symbol b+appendSymbol n@(SNode _) _  = n+appendSymbol _ n@(SNode _) = n+appendSymbol a SSpace = a+appendSymbol SSpace a = a+appendSymbol SLeft SRight = SCross+appendSymbol SRight SLeft = SCross+appendSymbol SCross SRight = SCross+appendSymbol SCross SLeft = SCross+appendSymbol SRight SCross = SCross+appendSymbol SLeft SCross = SCross+appendSymbol a _ = a -instance Monoid Symbol where+instance Monoid (Symbol b) where   mempty = SSpace+#if MIN_VERSION_base(4,11,0)+instance Semigroup (Symbol b) where+  (<>) = appendSymbol+#else+  mappend = appendSymbol+#endif -type Nodes = S.Set NodeId+type Nodes a = S.Set a  type Depth = Int type Dest = Int type Cur = Int type Pos = Int -type DepthNode = M.Map NodeId Depth+type DepthNode a = M.Map a Depth -type DepthGroup = M.Map Depth [NodeId]+type DepthGroup a = M.Map Depth [a] -type NodeDepth = M.Map NodeId Depth+type NodeDepth a = M.Map a Depth -type DepthGroup' = M.Map Depth ([NodeId],[NodeId])+type DepthGroup' a = M.Map Depth ([a],[a]) -type DepthGroup'' = M.Map Depth ([(NodeId,Cur,Dest)],[(NodeId,Cur,Dest)])+type DepthGroup'' a = M.Map Depth ([(a,Cur,Dest)],[(a,Cur,Dest)]) -mkEdges :: [(NodeId,[NodeId])] -> Edges+mkEdges :: Ord a => [(a,[a])] -> Edges a 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 :: Ord a => [(a,b)] -> Labels a b mkLabels labels = M.fromList labels -sampledat :: Edges+sampledat :: Edges Int sampledat = mkEdges [   (0,[2]),   (1,[2]),@@ -77,7 +85,7 @@   (3,[5])   ] -samplelabels :: Labels+samplelabels :: Labels Int String samplelabels = mkLabels [   (0,"l0"),   (1,"l1"),@@ -92,35 +100,71 @@ -- -- >>> getDepthGroup sampledat -- fromList [(0,[5]),(1,[3]),(2,[2,4,6]),(3,[0,1])]-getDepthGroup :: Edges -> DepthGroup+getDepthGroup :: forall a. Ord a => Edges a -> DepthGroup a getDepthGroup edges = M.fromList d2n   where     depth0 = getDepth2 edges     depth1 = getDepth2 $ reverseEdges edges+    score :: a -> Depth     score nodeid =       maybe 0 id (M.lookup nodeid depth0) +       maybe 0 id (M.lookup nodeid depth1) -    sort' :: S.Set NodeId -> [NodeId]+    sort' :: S.Set a -> [a]     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 :: [[(Depth,a)]] -> [(Depth,[a])]+    loop ls =+      case ls of+        [] -> []+        a:ax -> case a of+          (n,_):_ -> (n,sort' $ S.fromList $ map snd a): loop ax+          [] -> loop ax +-- | Grouping the nodes by the depth+--+-- >>> getDepthGroup2 samplelabels sampledat+-- fromList [(0,[5]),(1,[3]),(2,[2,4,6]),(3,[0,1])]+getDepthGroup2 :: forall a b. (Ord a,Ord b) => Labels a b -> Edges a -> DepthGroup a+getDepthGroup2 labels edges = M.fromList d2n+  where+    depth0 = getDepth2 edges+    depth1 = getDepth2 $ reverseEdges edges+    score :: a -> Depth+    score nodeid =+      maybe 0 id (M.lookup nodeid depth0) ++      maybe 0 id (M.lookup nodeid depth1)++    comp a b =+      case compare (score b) (score a) of+        EQ -> compare (M.lookup a labels) (M.lookup b labels)+        c -> c++    sort' :: S.Set a -> [a]+    sort' nodes = L.sortBy (\a b -> comp a b) $ 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 :: [[(Depth,a)]] -> [(Depth,[a])]     loop ls =       case ls of         [] -> []         a:ax -> case a of-          (n,d):_ -> (n,sort' $ S.fromList $ map snd a): loop ax+          (n,_):_ -> (n,sort' $ S.fromList $ map snd a): loop ax           [] -> loop ax -getNodeDepth :: DepthGroup -> NodeDepth++getNodeDepth :: Ord a => DepthGroup a -> NodeDepth a getNodeDepth dg = M.fromList $ concat $ map (\(d,nodes) -> map (\node -> (node,d)) nodes) $ M.toList dg  +pairs :: M.Map b (S.Set a) -> [(a, b)] pairs edges = do   (p, c) <- M.toList edges   child <- S.toList c@@ -132,30 +176,30 @@ -- 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 :: Ord a => Edges a -> Edges a 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 :: Ord a => [[(a,a)]] -> [(a,S.Set a)]     loop ls =       case ls of         [] -> []         a:ax -> case a of-          (n,d):_ -> (n,S.fromList $ map snd a): loop ax+          (n,_):_ -> (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 :: Ord a => Edges a -> Nodes a getNodes edges = S.fromList $ parents ++ children   where     parents = do-      (parent, c) <- M.toList edges+      (parent, _) <- M.toList edges       return parent     children = do       (_, c) <- M.toList edges@@ -163,43 +207,44 @@       return child  -getDepth2 :: Edges -> DepthNode+-- | Find all depth of nodes. This is faster than getDepth.+--+getDepth2 :: forall a. Ord a => Edges a -> DepthNode a getDepth2 edges = runST $ do   ref <- newSTRef M.empty   mm <- forM (S.toList $ getNodes edges) $ \v -> do-     d <- getDepth2' ref v edges+     d <- getDepth2' ref v      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+  where+    getDepth2' :: STRef s (DepthNode a) -> a -> ST s Int+    getDepth2' ref i = do+      d <- readSTRef ref+      case M.lookup i d of+        Just v -> return v         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+          case M.lookup i edges of+            Just v -> do+              dl <- forM (S.toList v) $ \v' -> do+                      getDepth2' ref v'+              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' :: 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--}+-- | Find all depth of nodes+--+getDepth :: forall a. Ord a => Edges a -> DepthNode a+getDepth edges = M.fromList $ map (\v -> (v,getDepth' v)) $ S.toList $ getNodes edges+  where+    getDepth' :: a -> Depth+    getDepth' i =+      case M.lookup i edges of+        Just v -> 1 + (maximum $ map (\v' -> getDepth' v') $ S.toList v)+        Nothing -> 0  -- | Move nodes to next step --@@ -207,7 +252,7 @@ -- [((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 :: Ord a => [(a,Cur,Dest)] -> [((a,Cur,Dest),[(Symbol b,Pos)])] moveOne nodes = do   (n,c,g) <- nodes   if c < g@@ -220,7 +265,7 @@       else         return ((n,c,g),[(SHold,c)]) -takeNode :: Cur -> [((NodeId,Cur,Dest),[(Symbol,Pos)])] -> Maybe ((NodeId,Cur,Dest),[(Symbol,Pos)])+takeNode :: Ord a => Cur -> [((a,Cur,Dest),[(Symbol b,Pos)])] -> Maybe ((a,Cur,Dest),[(Symbol b,Pos)]) takeNode c nodes = L.find (\(_,syms) -> any (== c) (map snd syms)) nodes  -- | Move more nodes@@ -231,14 +276,14 @@ -- [((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' :: Ord a => [((a,Cur,Dest),[(Symbol b,Pos)])] -> [((a,Cur,Dest),[(Symbol b,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+      (Nothing,Just ((_,_,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@@ -247,7 +292,7 @@ -- -- >>> 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 :: (Ord a, Eq b) => [((a,Cur,Dest),[(Symbol b,Pos)])] -> [((a,Cur,Dest),[(Symbol b,Pos)])] moveLeft nodes = if nodes == m then nodes else moveLeft m   where     m = moveLeft' nodes@@ -264,52 +309,52 @@ -- [[(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' :: (Ord a,Eq b) => [(a,Cur,Dest)] -> [[(Symbol b,Pos)]] -> [[(Symbol b,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 :: [(Symbol b,Pos)] -> [(Symbol b,Pos)] mergeSymbol symbols =   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+  $ L.groupBy (\(_,p0) (_,p1) -> p0 == p1)+  $ L.sortBy (\(_,p0) (_,p1) -> p0 `compare` p1) symbols  -- | Fill spaces -- -- >>> withSpace [(SRight,1),(SLeft,3)]--- [(SSpace,0),(SRight,1),(SSpace,2),(SLeft,3)]+-- [SSpace,SRight,SSpace,SLeft] -- >>> withSpace [(SRight,3),(SLeft,1)]--- [(SSpace,0),(SLeft,1),(SSpace,2),(SRight,3)]-withSpace :: [(Symbol,Pos)] -> [(Symbol,Pos)]-withSpace syms = merge sorted [0..max]+-- [SSpace,SLeft,SSpace,SRight]+withSpace :: [(Symbol b,Pos)] -> [Symbol b]+withSpace syms = merge sorted [0..max']   where     merge [] _ = []     merge _ [] = []-    merge s@((s0,p0):sx) (p:px) | p0 == p = (s0,p0):merge sx px+    merge s@((s0,p0):sx) (p:px) | p0 == p = s0:merge sx px                                 | p0 <  p = merge sx (p:px)-                                | otherwise = (SSpace,p):merge s px+                                | otherwise = SSpace:merge s px     sorted = L.sortBy (\a b -> snd a `compare` snd b) syms-    max = maximum $ map snd sorted+    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)]]+-- [[SSpace,SRight],[SSpace,SSpace,SSpace,SRight]] -- >>> moveAllWithSpace [(0,4,0)]--- [[(SSpace,0),(SLMove,1),(SLMove,2),(SLeft,3)]]+-- [[SSpace,SLMove,SLMove,SLeft]] -- >>> moveAllWithSpace [(0,0,4),(0,4,0)]--- [[(SSpace,0),(SRight,1),(SSpace,2),(SLeft,3)],[(SSpace,0),(SLeft,1),(SSpace,2),(SRight,3)]]+-- [[SSpace,SRight,SSpace,SLeft],[SSpace,SLeft,SSpace,SRight]] -- >>> 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)]]+-- [[SSpace,SRight,SSpace,SLeft],[SSpace,SLeft,SSpace,SRight]]+moveAllWithSpace :: (Ord a, Eq b) => [(a,Cur,Dest)] -> [[Symbol b]] moveAllWithSpace nodes = map withSpace $ map mergeSymbol $ moveAll' nodes [] -lstr :: Labels -> NodeId -> String-lstr labels nodeid = maybe "" id (M.lookup nodeid labels)+lstr :: (Ord a, Monoid b) => Labels a b -> a -> b+lstr labels nodeid = maybe mempty id (M.lookup nodeid labels) -nodeWithSpace :: Labels -> ([(NodeId,Cur,Dest)],[(NodeId,Cur,Dest)]) -> [(Symbol,Pos)]+nodeWithSpace :: (Ord a, Monoid b) => Labels a b -> ([(a,Cur,Dest)],[(a,Cur,Dest)]) -> [Symbol b] nodeWithSpace labels (nodes,skipnodes) =   withSpace $     (map (\(nid,c,_) -> (SNode (lstr labels nid),c)) nodes) ++@@ -317,41 +362,38 @@  -- | Add bypass nodes ----- >>> edges = mkEdges [(0,[1,2]),(1,[2])]--- >>> nd = getNodeDepth $ getDepthGroup edges+-- >>> let edges = mkEdges [(0,[1,2]),(1,[2])]+-- >>> let nd = getNodeDepth $ getDepthGroup edges -- >>> addBypassNode'' 2 edges nd (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])]--- >>> nd = getNodeDepth $ getDepthGroup edges+-- >>> let edges = mkEdges [(0,[1,3]),(1,[2]),(2,[3])]+-- >>> let nd = getNodeDepth $ getDepthGroup edges -- >>> addBypassNode'' 3 edges nd (M.fromList [(0,([3],[])),(1,([2],[])),(2,([1],[])),(3,([0],[]))]) -- fromList [(0,([3],[])),(1,([2],[])),(2,([1],[0])),(3,([0],[]))] -- >>> addBypassNode'' 2 edges nd (M.fromList [(0,([3],[])),(1,([2],[])),(2,([1],[0])),(3,([0],[]))]) -- fromList [(0,([3],[])),(1,([2],[0])),(2,([1],[0])),(3,([0],[]))] ----- >>> edges = mkEdges [(0,[1,2]),(1,[4]),(2,[3]),(3,[4])]--- >>> nd = getNodeDepth $ getDepthGroup edges+-- >>> let edges = mkEdges [(0,[1,2]),(1,[4]),(2,[3]),(3,[4])]+-- >>> let nd = getNodeDepth $ getDepthGroup edges -- >>> addBypassNode'' 2 edges nd (M.fromList [(0,([4],[])),(1,([3,1],[])),(2,([2],[0])),(3,([0],[]))]) -- fromList [(0,([4],[])),(1,([3,1],[])),(2,([2],[0])),(3,([0],[]))]-addBypassNode'' :: Depth -> Edges -> NodeDepth -> DepthGroup' -> DepthGroup'+addBypassNode'' :: forall a. Ord a => Depth -> Edges a -> NodeDepth a -> DepthGroup' a -> DepthGroup' a addBypassNode'' d edges nd 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 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-    getDepth :: NodeId -> Depth-    getDepth nid = maybe 0 id $ M.lookup nid nd-    edges' :: Edges-    edges' = M.fromList $ map (\(n,nids) ->  (n, S.fromList (filter (\nid -> getDepth nid < d) (S.toList nids)))) $ M.toList edges-    elem :: NodeId -> [NodeId] -> Bool-    elem nid nids =+    (Just (nids0,skipnids0),Just n1@(nids1,_)) -> M.update (\_ -> Just (foldl (\n1' nid -> update nids1 n1' nid) n1 (nids0++skipnids0))) (d-1) dg+    _ -> dg+   where+    nodeDepth nid = maybe 0 id $ M.lookup nid nd+    edges' = M.fromList $ map (\(n,nids) ->  (n, S.fromList (filter (\nid -> nodeDepth nid < d) (S.toList nids)))) $ M.toList edges+    elem' :: Ord a => a -> [a] -> 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 :: [NodeId] -> ([NodeId],[NodeId]) -> NodeId -> ([NodeId],[NodeId])+    update :: Ord a => [a] -> ([a],[a]) -> a -> ([a],[a])     update nids1 (v,skip) nid0 =-      if not (elem nid0 nids1)+      if not (elem' nid0 nids1)       then (v,skip++[nid0])       else (v,skip) @@ -360,81 +402,81 @@ -- -- >>> maxDepth (M.fromList [(0,([2],[])),(1,([1],[])),(2,([0],[]))]) -- 2-maxDepth :: DepthGroup' -> Int+maxDepth :: Ord a => DepthGroup' a -> Int maxDepth dg = maximum $ map fst $ M.toList dg  -- | Add bypass nodes ----- >>> edges = mkEdges [(0,[1,2]),(1,[2])]--- >>> nd = getNodeDepth $ getDepthGroup edges+-- >>> let edges = mkEdges [(0,[1,2]),(1,[2])]+-- >>> let nd = getNodeDepth $ getDepthGroup edges -- >>> addBypassNode' edges nd (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])]--- >>> nd = getNodeDepth $ getDepthGroup edges+-- >>> let edges = mkEdges [(0,[1,3]),(1,[2]),(2,[3])]+-- >>> let nd = getNodeDepth $ getDepthGroup edges -- >>> addBypassNode' edges nd (M.fromList [(0,([3],[])),(1,([2],[])),(2,([1],[])),(3,([0],[]))]) -- fromList [(0,([3],[])),(1,([2],[0])),(2,([1],[0])),(3,([0],[]))]-addBypassNode' :: Edges -> NodeDepth -> DepthGroup' -> DepthGroup'+addBypassNode' :: Ord a => Edges a -> NodeDepth a -> DepthGroup' a -> DepthGroup' a addBypassNode' edges nd dg = foldr (\d dg' -> addBypassNode'' d edges nd dg') dg $ [2..(maxDepth dg)]  -- | Add bypass nodes ----- >>> edges = mkEdges [(0,[1,2]),(1,[2])]--- >>> dg = getDepthGroup edges--- >>> nd = getNodeDepth dg+-- >>> let edges = mkEdges [(0,[1,2]),(1,[2])]+-- >>> let dg = getDepthGroup edges+-- >>> let nd = getNodeDepth dg -- >>> addBypassNode edges nd dg -- fromList [(0,([2],[])),(1,([1],[0])),(2,([0],[]))]--- >>> edges = mkEdges [(0,[1,3]),(1,[2]),(2,[3])]--- >>> dg = getDepthGroup edges--- >>> nd = getNodeDepth dg+-- >>> let edges = mkEdges [(0,[1,3]),(1,[2]),(2,[3])]+-- >>> let dg = getDepthGroup edges+-- >>> let nd = getNodeDepth dg -- >>> addBypassNode edges nd dg -- fromList [(0,([3],[])),(1,([2],[0])),(2,([1],[0])),(3,([0],[]))]--- >>> edges = mkEdges [(0,[1,2]),(1,[4]),(2,[3]),(3,[4])]--- >>> dg = getDepthGroup edges--- >>> nd = getNodeDepth dg+-- >>> let edges = mkEdges [(0,[1,2]),(1,[4]),(2,[3]),(3,[4])]+-- >>> let dg = getDepthGroup edges+-- >>> let nd = getNodeDepth dg -- >>> addBypassNode edges nd dg -- fromList [(0,([4],[])),(1,([3,1],[])),(2,([2],[0])),(3,([0],[]))]-addBypassNode :: Edges -> NodeDepth -> DepthGroup -> DepthGroup'+addBypassNode :: Ord a => Edges a -> NodeDepth a -> DepthGroup a -> DepthGroup' a addBypassNode edges nd dg = addBypassNode' edges nd $ 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],[]))]+-- >>> let edges = mkEdges [(0,[1,2]),(1,[2])]+-- >>> let dg = getDepthGroup edges+-- >>> addDestWithBypass 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+addDestWithBypass :: forall a. Ord a => Edges a -> DepthGroup' a -> DepthGroup'' a+addDestWithBypass edges dg = M.fromList $ mapAddPos $ reverse $ M.toList dg   where-    mapAddPos :: [(Int,([NodeId],[NodeId]))] -> [(Int,([(NodeId,Cur,Dest)],[(NodeId,Cur,Dest)]))]+    mapAddPos :: Ord a => [(Int,([a],[a]))] -> [(Int,([(a,Cur,Dest)],[(a,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)+    mapAddPos ((ka,a):(kb,b):bx) = (ka,addDest edges a b): mapAddPos ((kb,b):bx)  -- | Grouping the nodes by the depth ----- >>> edges = mkEdges [(0,[1,2])]--- >>> dg = getDepthGroup edges--- >>> nd = getNodeDepth dg+-- >>> let edges = mkEdges [(0,[1,2])]+-- >>> let dg = getDepthGroup edges+-- >>> let nd = getNodeDepth dg -- >>> dg -- fromList [(0,[1,2]),(1,[0])] -- >>> addNode edges nd dg -- fromList [(0,([(1,0,0),(2,2,2)],[])),(1,([(0,0,0),(0,0,2)],[]))]-addNode :: Edges -> NodeDepth -> DepthGroup -> DepthGroup''-addNode edges nd dg = addPosNode edges $ addBypassNode edges nd dg+addNode :: Ord a => Edges a -> NodeDepth a -> DepthGroup a -> DepthGroup'' a+addNode edges nd dg = addDestWithBypass edges $ addBypassNode edges nd 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+toSymbol :: (Ord a, Eq b, Monoid b) => Labels a b -> DepthGroup'' a -> [[Symbol b]]+toSymbol labels dg = concat $ map (\(_,(n,s)) -> (nodeWithSpace labels (n,s)):moveAllWithSpace (n `mappend` s) ) $ reverse $ M.toList dg -edgesToText :: Labels -> Edges -> String+edgesToText :: (Ord a) => Labels a String -> Edges a -> String edgesToText labels edges = renderToText ( reverse $ drop 1 $ reverse $ toSymbol labels $ addNode edges nd dg) []   where-    dg = getDepthGroup edges+    dg = getDepthGroup2 labels edges     nd = getNodeDepth dg -symbolToChar :: Symbol -> Char+symbolToChar :: Symbol b -> Char symbolToChar (SNode _) = 'o' symbolToChar SLeft = '/' symbolToChar SRight = '\\'@@ -447,52 +489,50 @@  -- | Rendering symbols to text ----- >>> renderToText [[(SNode "",0)],[(SHold,0)],[(SNode "",0)]] []+-- >>> renderToText [[SNode ""],[SHold],[SNode ""]] [] -- "o\n|\no\n"--- >>> renderToText [[(SNode "",0),(SSpace,1),(SNode "",2)],[(SHold,0),(SLeft,1)],[(SNode "",0)]] []+-- >>> renderToText [[SNode "",SSpace,SNode ""],[SHold,SLeft],[SNode ""]] [] -- "o o\n|/\no\n"-renderToText :: [[(Symbol,Pos)]] -> [String] -> String+renderToText :: [[Symbol String]] -> [String] -> String renderToText [] _ = [] renderToText ([]:sxx) labelbuf = (if 0 == foldr (\i s -> s + length i) 0 labelbuf                                   then ""                                   else if len >= 4 && llen >= 2                                        then str0                                        else str-                                 )++ "\n" ++ renderToText sxx []+                                 ) `mappend` "\n" `mappend` renderToText sxx []   where-    str = "    " ++ (L.intercalate "," labelbuf)-    str0 = "    " ++ prefix ++ "{" ++ (L.intercalate "," (map (drop len) labelbuf)) ++ "}"+    str = "    " `mappend` (L.intercalate "," labelbuf)+    str0 = "    " `mappend` prefix `mappend` "{" `mappend` (L.intercalate "," (map (drop len) labelbuf)) `mappend` "}"     prefix = getLongestCommonPrefix labelbuf     len = length prefix     llen = length 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)--getLongestCommonPrefix' :: String -> String -> String -> String-getLongestCommonPrefix' (x:xs) (y:ys) buf | x == y = getLongestCommonPrefix' xs ys (buf ++ (x:[]))-                                          | otherwise = buf-getLongestCommonPrefix' [] _ buf = buf-getLongestCommonPrefix' _ [] buf = buf-+renderToText ((s@(SNode label):sx):sxx) labelbuf = (symbolToChar s):(renderToText (sx:sxx) (labelbuf `mappend` [label]))+renderToText ((s:sx):sxx) labelbuf = (symbolToChar s):(renderToText (sx:sxx) labelbuf)  getLongestCommonPrefix :: [String] -> String-getLongestCommonPrefix (str:strs) = foldl (\a b -> getLongestCommonPrefix' a b []) str strs getLongestCommonPrefix [] = []-+getLongestCommonPrefix (str:strs) = foldl (\a b -> getLongestCommonPrefix' a b []) str strs+  where+    getLongestCommonPrefix' :: String -> String -> String -> String+    getLongestCommonPrefix' (x:xs) (y:ys) buf | x == y = getLongestCommonPrefix' xs ys (buf ++ (x:[]))+                                              | otherwise = buf+    getLongestCommonPrefix' [] _ buf = buf+    getLongestCommonPrefix' _ [] buf = buf  -- | Allocate destinations of nodes. ----- >>> addPos sampledat ([0,1],[]) ([2],[])+-- >>> addDest sampledat ([0,1],[]) ([2],[]) -- ([(0,0,0),(1,2,0)],[])--- >>> addPos (mkEdges [(0,[1,2]),(1,[2])]) ([0],[]) ([1],[0])+-- >>> addDest (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],[])+-- >>> addDest (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])+-- >>> addDest (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)+addDest :: Ord a => Edges a -> ([a],[a]) -> ([a],[a]) -> ([(a,Cur,Dest)],[(a,Cur,Dest)])+addDest edges (curn,curs) (nxtn,nxts) = (n2n++n2s,s2n++s2s)   where     curn' = zip curn $ map (*2) [0..]     curs' = zip curs $ map (*2) [(length curn)..]

@@ -1,26 +1,29 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE OverloadedStrings #-}+ 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 -genEdgesFromDot :: T.Text -> (Labels,Edges)+genEdgesFromDot :: T.Text -> (Labels T.Text String,Edges T.Text) genEdgesFromDot dot = (labels,edges)   where-   dg :: G.DotGraph String+   dg :: G.DotGraph T.Text    dg = G.parseDotGraph dot-   edges = mkEdges $ map (\v -> (read (G.fromNode v),([read (G.toNode v)]))) $ G.graphEdges dg+   edges = mkEdges $ map (\v -> ( (G.fromNode v),([ (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+   getl attrs = maybe "" id $ foldl (\s i-> s `mappend` getl' i) Nothing attrs+   labels = mkLabels $ map (\v -> ((G.nodeID v),getl (G.nodeAttributes v))) $ G.graphNodes dg   genAsciiFromDot :: T.Text -> T.Text

@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: d1deae2678881c1a7678ef1c83698157d8a51551cc1989a25a4ba2c3879c63e8+-- hash: 58ebdc4bb3cfa456feefd67e8f7abc962027f2c8e2d9450c6c0e791be5eef3bc  name:           stacked-dag-version:        0.1.0.4+version:        0.1.1.0 synopsis:       Ascii DAG(Directed acyclic graph) for visualization of dataflow description:    Please see the README on GitHub at <https://github.com/junjihashimoto/stacked-dag#readme> category:       Graphs, Graphics