diff --git a/src/Diagrams/IntransitiveDAG.hs b/src/Diagrams/IntransitiveDAG.hs index e037f5b..c69dcb7 100644 --- a/src/Diagrams/IntransitiveDAG.hs +++ b/src/Diagrams/IntransitiveDAG.hs @@ -31,12 +31,14 @@ import Data.IntMap.Lazy (IntMap) import Data.Tuple.Select (sel2) import Diagrams.Combinators (atop) import Diagrams.Core.Types (href) +import Diagrams.Names (named) +import Diagrams.TwoD.Arrow (connectOutside) import Diagrams.TwoD.Attributes (fc, lc) import Diagrams.TwoD.Combinators (hcat, vcat) import Diagrams.TwoD.Path (stroke) import Diagrams.TwoD.Shapes (roundedRect) import Diagrams.TwoD.Size (width) -import Diagrams.Util ((#), with) +import Diagrams.Util ((#), with, applyAll) import Graphics.SVGFonts.Fonts (lin2) import Graphics.SVGFonts.Text (textSVG', TextOpts (..)) --import Yesod.Core.Handler (toTextUrl) @@ -79,18 +81,18 @@ box w h = # fc black # lc plain -roleBox s u = +textBox n s u = let h = 1 t = href u $ stroke $ textSVG' with {textFont = lin2, textHeight = h} s t' = t # lc plain w = width t' b = box w h - in t' `atop` b + in named n $ t' `atop` b -- intransDag :: Graph g => g a b -> QDiagram -intransDag disp link = --TODO connect the layers - vcat . - I.elems . - fmap (hcat . map (uncurry roleBox . (disp &&& link) . sel2)) . - attachNumbers . - layers +intransDag disp link graph = + let ls = layers graph + conn (n, _, cs) = map (\ c -> connectOutside c n) cs + conns = concatMap (concatMap conn) ls + tbox (n, l, _) = textBox n (disp l) (link l) + in applyAll conns $ vcat $ map (hcat . map tbox) ls