Draw the arrows in role diagram

This commit is contained in:
fr33domlover 2016-07-02 11:57:20 +00:00
parent c292bd51a4
commit 7542b33c7d

View file

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