sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-28 23:44:51 +09:00
Code Issues Activity

Draw the arrows in role diagram

Browse source
This commit is contained in:
fr33domlover 2016-07-02 11:57:20 +00:00
parent c292bd51a4
commit 7542b33c7d
1 changed files with 11 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
src/Diagrams/IntransitiveDAG.hs
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