diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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"), diff --git a/src/StackedDag.hs b/src/StackedDag.hs --- a/src/StackedDag.hs +++ b/src/StackedDag.hs @@ -1,7 +1,6 @@ module StackedDag ( Labels , Edges -, NodeId , mkLabels , mkEdges , edgesToText diff --git a/src/StackedDag/Base.hs b/src/StackedDag/Base.hs --- a/src/StackedDag/Base.hs +++ b/src/StackedDag/Base.hs @@ -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)..] diff --git a/src/StackedDag/Graphviz.hs b/src/StackedDag/Graphviz.hs --- a/src/StackedDag/Graphviz.hs +++ b/src/StackedDag/Graphviz.hs @@ -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 diff --git a/stacked-dag.cabal b/stacked-dag.cabal --- a/stacked-dag.cabal +++ b/stacked-dag.cabal @@ -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 category: Graphs, Graphics