Initial code for intransitive DAG drawing
This commit is contained in:
parent
a4eeb61a44
commit
5b4607e64d
3 changed files with 105 additions and 0 deletions
92
src/Diagrams/IntransitiveDAG.hs
Normal file
92
src/Diagrams/IntransitiveDAG.hs
Normal file
|
@ -0,0 +1,92 @@
|
||||||
|
{- This file is part of Vervis.
|
||||||
|
-
|
||||||
|
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
|
||||||
|
-
|
||||||
|
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||||
|
-
|
||||||
|
- The author(s) have dedicated all copyright and related and neighboring
|
||||||
|
- rights to this software to the public domain worldwide. This software is
|
||||||
|
- distributed without any warranty.
|
||||||
|
-
|
||||||
|
- You should have received a copy of the CC0 Public Domain Dedication along
|
||||||
|
- with this software. If not, see
|
||||||
|
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||||
|
-}
|
||||||
|
|
||||||
|
-- | Layer an intransitive DAG and build a diagram of it. The layering
|
||||||
|
-- algorithm currently used here is trivial, and doesn't try to minimize
|
||||||
|
-- crossing edges. This will hopefully change in the future.
|
||||||
|
module Diagrams.IntransitiveDAG
|
||||||
|
( intransDag
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
|
import Prelude
|
||||||
|
|
||||||
|
import Data.Graph.Inductive.Graph
|
||||||
|
import Data.Graph.Inductive.Query.Layer (rlayerWith)
|
||||||
|
import Data.HashMap.Lazy (HashMap)
|
||||||
|
import Data.IntMap.Lazy (IntMap)
|
||||||
|
import Data.Tuple.Select (sel2)
|
||||||
|
import Diagrams.Combinators (atop)
|
||||||
|
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 Graphics.SVGFonts.Fonts (lin2)
|
||||||
|
import Graphics.SVGFonts.Text (textSVG', TextOpts (..))
|
||||||
|
|
||||||
|
import qualified Data.HashMap.Lazy as H
|
||||||
|
import qualified Data.IntMap.Lazy as I
|
||||||
|
|
||||||
|
import Vervis.Colour
|
||||||
|
|
||||||
|
-- TODO how do I connect the layers?
|
||||||
|
--
|
||||||
|
-- Here's a suggestion. I can use rlayerWith to specify the result, and then in
|
||||||
|
-- addition to the Node, also return its out-edges. Now what remains is to
|
||||||
|
-- efficiently determine in which layer that node lives. That can be done by
|
||||||
|
-- keeping the node-to-layer map I built. But that may make the *layer*
|
||||||
|
-- function type sigs uglier, so instead I could also avoid relying on the
|
||||||
|
-- existence of such a map, and build it externally from the list of layers.
|
||||||
|
-- Yeah, sounds good to me.
|
||||||
|
--
|
||||||
|
-- However in order to find the layer quickly, it may be a good idea to put the
|
||||||
|
-- layer lists into an IntMap or HashMap for fast queries.
|
||||||
|
|
||||||
|
attachNumbers :: [a] -> IntMap a
|
||||||
|
attachNumbers = I.fromList . zip [1..]
|
||||||
|
|
||||||
|
nodeToLayerMap :: (a -> Node) -> IntMap [a] -> HashMap Node Int
|
||||||
|
nodeToLayerMap f =
|
||||||
|
H.fromList . concatMap (\ (l, xs) -> zip (map f xs) (repeat l)) . I.toList
|
||||||
|
|
||||||
|
layers :: Graph g => g a b -> [[(Node, a, [Node])]]
|
||||||
|
layers = rlayerWith $ \ c -> (node' c, lab' c, pre' c)
|
||||||
|
|
||||||
|
box w h =
|
||||||
|
let golden = 0.618 * h
|
||||||
|
w' = golden + w + golden
|
||||||
|
h' = golden + h + golden
|
||||||
|
r = golden
|
||||||
|
in roundedRect w' h' r
|
||||||
|
# fc black
|
||||||
|
# lc plain
|
||||||
|
|
||||||
|
roleBox s =
|
||||||
|
let h = 1
|
||||||
|
t = stroke $ textSVG' with {textFont = lin2, textHeight = h} s
|
||||||
|
t' = t # lc plain
|
||||||
|
w = width t'
|
||||||
|
b = box w h
|
||||||
|
in t' `atop` b
|
||||||
|
|
||||||
|
-- intransDag :: Graph g => g a b -> QDiagram
|
||||||
|
intransDag disp = --TODO connect the layers
|
||||||
|
vcat .
|
||||||
|
I.elems .
|
||||||
|
fmap (hcat . map (roleBox . disp . sel2)) .
|
||||||
|
attachNumbers .
|
||||||
|
layers
|
|
@ -22,7 +22,13 @@ extra-deps:
|
||||||
- hit-network-0.1
|
- hit-network-0.1
|
||||||
- libravatar-0.4
|
- libravatar-0.4
|
||||||
- monad-hash-0.1
|
- monad-hash-0.1
|
||||||
|
# for 'tuple' package, remove once I use lenses instead
|
||||||
|
- OneTuple-0.2.1
|
||||||
- SimpleAES-0.4.2
|
- SimpleAES-0.4.2
|
||||||
|
# for text drawing with 'diagrams'
|
||||||
|
- SVGFonts-1.5.0.1
|
||||||
|
# remove once I use lenses instead
|
||||||
|
- tuple-0.3.0.2
|
||||||
# - ssh-0.3.2
|
# - ssh-0.3.2
|
||||||
# Required for M.alter used in hit-graph
|
# Required for M.alter used in hit-graph
|
||||||
- unordered-containers-0.2.6.0
|
- unordered-containers-0.2.6.0
|
||||||
|
|
|
@ -72,6 +72,7 @@ library
|
||||||
Database.Persist.Local.Sql.Orphan.Common
|
Database.Persist.Local.Sql.Orphan.Common
|
||||||
Database.Persist.Local.Sql.Orphan.PersistQueryForest
|
Database.Persist.Local.Sql.Orphan.PersistQueryForest
|
||||||
Development.DarcsRev
|
Development.DarcsRev
|
||||||
|
Diagrams.IntransitiveDAG
|
||||||
Formatting.CaseInsensitive
|
Formatting.CaseInsensitive
|
||||||
Network.SSH.Local
|
Network.SSH.Local
|
||||||
Text.Blaze.Local
|
Text.Blaze.Local
|
||||||
|
@ -199,6 +200,8 @@ library
|
||||||
, data-default
|
, data-default
|
||||||
-- for Data.Paginate.Local
|
-- for Data.Paginate.Local
|
||||||
, data-default-class
|
, data-default-class
|
||||||
|
-- for drawing DAGs: RBAC role inheritance, etc.
|
||||||
|
, diagrams-lib
|
||||||
, directory
|
, directory
|
||||||
-- for Data.Git.Local
|
-- for Data.Git.Local
|
||||||
, directory-tree
|
, directory-tree
|
||||||
|
@ -246,11 +249,15 @@ library
|
||||||
, resourcet
|
, resourcet
|
||||||
, safe
|
, safe
|
||||||
, shakespeare
|
, shakespeare
|
||||||
|
-- for text drawing in 'diagrams'
|
||||||
|
, SVGFonts
|
||||||
, ssh
|
, ssh
|
||||||
, template-haskell
|
, template-haskell
|
||||||
, text
|
, text
|
||||||
, time
|
, time
|
||||||
, transformers
|
, transformers
|
||||||
|
-- probably should be replaced with lenses once I learn
|
||||||
|
, tuple
|
||||||
, unordered-containers
|
, unordered-containers
|
||||||
, wai
|
, wai
|
||||||
, wai-extra
|
, wai-extra
|
||||||
|
|
Loading…
Reference in a new issue