Initial code for intransitive DAG drawing

src/Diagrams/IntransitiveDAG.hs

@@ -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

stack.yaml

@@ -22,7 +22,13 @@ extra-deps:
   - hit-network-0.1
   - libravatar-0.4
   - monad-hash-0.1
+    # for 'tuple' package, remove once I use lenses instead
+  - OneTuple-0.2.1
   - 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
   # Required for M.alter used in hit-graph
   - unordered-containers-0.2.6.0

vervis.cabal

@@ -72,6 +72,7 @@ library
                        Database.Persist.Local.Sql.Orphan.Common
                        Database.Persist.Local.Sql.Orphan.PersistQueryForest
                        Development.DarcsRev
+                       Diagrams.IntransitiveDAG
                        Formatting.CaseInsensitive
                        Network.SSH.Local
                        Text.Blaze.Local
@@ -199,6 +200,8 @@ library
                      , data-default
                        -- for Data.Paginate.Local
                      , data-default-class
+                       -- for drawing DAGs: RBAC role inheritance, etc.
+                     , diagrams-lib
                      , directory
                        -- for Data.Git.Local
                      , directory-tree
@@ -246,11 +249,15 @@ library
                      , resourcet
                      , safe
                      , shakespeare
+                       -- for text drawing in 'diagrams'
+                     , SVGFonts
                      , ssh
                      , template-haskell
                      , text
                      , time
                      , transformers
+                       -- probably should be replaced with lenses once I learn
+                     , tuple
                      , unordered-containers
                      , wai
                      , wai-extra