diagrams-graphviz (empty) → 1.3.0.0
raw patch · 6 files changed
+311/−0 lines, 6 filesdep +basedep +containersdep +diagrams-libsetup-changed
Dependencies added: base, containers, diagrams-lib, fgl, graphviz, split
Files
- CHANGES.markdown +4/−0
- LICENSE +30/−0
- README.markdown +8/−0
- Setup.hs +2/−0
- diagrams-graphviz.cabal +28/−0
- src/Diagrams/TwoD/GraphViz.hs +239/−0
+ CHANGES.markdown view
@@ -0,0 +1,4 @@+1.3.0.0 (2015-09-18)+--------------------++Initial release.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Brent Yorgey++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Brent Yorgey nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.markdown view
@@ -0,0 +1,8 @@+Use GraphViz and diagrams together, with each doing what it does best:+GraphViz for laying out graphs, and diagrams for drawing them.++Makes use of the excellent+[graphviz package](http://hackage.haskell.org/package/graphviz) for+doing the actual communication with graphviz. So this package is+actually little more than some glue code that makes it a bit easier to+interface `diagrams` and the `graphviz` package.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ diagrams-graphviz.cabal view
@@ -0,0 +1,28 @@+name: diagrams-graphviz+version: 1.3.0.0+synopsis: Graph layout and drawing with GrahpViz and diagrams+description: Use GraphViz and diagrams together, with each doing what+ it does best: GraphViz for laying out graphs, and diagrams+ for drawing them.+homepage: http://projects.haskell.org/diagrams/+license: BSD3+license-file: LICENSE+author: Brent Yorgey+maintainer: byorgey@gmail.com+copyright: Brent Yorgey 2014,2015+category: Graphics+build-type: Simple+extra-source-files: README.markdown, CHANGES.markdown+cabal-version: >=1.10++library+ exposed-modules: Diagrams.TwoD.GraphViz+ other-extensions: FlexibleContexts, MultiParamTypeClasses, NoMonomorphismRestriction+ build-depends: base >=4.6 && <4.9,+ containers >= 0.4 && < 0.6,+ diagrams-lib >= 1.3 && < 1.4,+ graphviz >= 2999.17 && < 2999.19,+ fgl >= 5.5 && < 5.6,+ split >= 0.2 && < 0.3+ hs-source-dirs: src+ default-language: Haskell2010
+ src/Diagrams/TwoD/GraphViz.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+-- |+-- Module : Diagrams.TwoD.GraphViz+-- Copyright : (c) 2014, 2015 Brent Yorgey+-- License : BSD-style (see LICENSE)+-- Maintainer : byorgey@gmail.com+--+-- A simple module with some "glue code" necessary for using diagrams+-- and GraphViz (<http://www.graphviz.org/>) in conjunction. GraphViz+-- is great at laying out graphs but terrible at drawing them, so why+-- not let GraphViz do what it is good at, and use a dedicated drawing+-- library for the actual drawing?+--+-- Here is some example code to lay out and draw a simple directed+-- graph hierarchically:+--+-- > {-# LANGUAGE NoMonomorphismRestriction #-}+-- >+-- > import Diagrams.Backend.Rasterific.CmdLine+-- > import Diagrams.Prelude+-- > import Diagrams.TwoD.GraphViz+-- >+-- > import Data.GraphViz+-- > import Data.GraphViz.Commands+-- >+-- > hex = mkGraph [0..19]+-- > ( [ (v, (v+1)`mod`6, ()) | v <- [0..5] ]+-- > ++ [ (v, v+k, ()) | v <- [0..5], k <- [6,12] ]+-- > ++ [ (2,18,()), (2,19,()), (15,18,()), (15,19,()), (18,3,()), (19,3,()) ]+-- > )+-- >+-- > graphvizExample1 = do+-- > hex' <- layoutGraph Dot hex+-- > let hexDrawing :: Diagram B+-- > hexDrawing = drawGraph+-- > (const $ place (circle 19))+-- > (\_ p1 _ p2 _ p -> arrowBetween' (opts p) p1 p2)+-- > hex'+-- > opts p = with & gaps .~ 16 & arrowShaft .~ (unLoc . head $ pathTrails p)+-- > return (hexDrawing # frame 1)+--+-- There are a few quirks to note.+--+-- * GraphViz seems to assume the circular nodes have radius 19.+--+-- * Note how we draw an arrow for each edge, and use the path+-- computed by GraphViz (which might be curved) to specify the shaft+-- for the arrow.+--+-- Here is a slightly modified example, which tells GraphViz not to+-- use any arrowheads on the edges:+--+-- > {-# LANGUAGE NoMonomorphismRestriction #-}+-- >+-- > import Diagrams.Backend.Rasterific.CmdLine+-- > import Diagrams.Prelude+-- > import Diagrams.TwoD.GraphViz+-- >+-- > import Data.GraphViz+-- > import Data.GraphViz.Attributes.Complete+-- > import Data.GraphViz.Commands+-- >+-- > hex = mkGraph [0..19]+-- > ( [ (v, (v+1)`mod`6, ()) | v <- [0..5] ]+-- > ++ [ (v, v+k, ()) | v <- [0..5], k <- [6,12] ]+-- > ++ [ (2,18,()), (2,19,()), (15,18,()), (15,19,()), (18,3,()), (19,3,()) ]+-- > )+-- >+-- > main = do+-- > let params :: GraphvizParams Int v e () v+-- > params = defaultDiaParams+-- > { fmtEdge = const [arrowTo noArrow] }+-- > hex' <- layoutGraph' params Dot hex+-- > let hexDrawing :: Diagram B+-- > hexDrawing = drawGraph+-- > (const $ place (circle 19))+-- > (\_ _ _ _ _ p -> stroke p)+-- > hex'+-- > mainWith $ hexDrawing # frame 1+--+-- * The type signature on @params@ is unfortunately necessary;+-- otherwise some ambiguity errors arise.+--+-- * Note how in this simple case we can just draw the path+-- for each edge directly.+-----------------------------------------------------------------------------++module Diagrams.TwoD.GraphViz (+ mkGraph+ , layoutGraph+ , layoutGraph'+ , defaultDiaParams++ , drawGraph+ , getGraph+ ) where++import Diagrams.Prelude++import qualified Data.Graph.Inductive.Graph as G (Graph, Node, labEdges,+ labNodes, mkGraph)+import Data.Graph.Inductive.PatriciaTree (Gr)+import Data.GraphViz hiding (Path)+import Data.GraphViz.Attributes.Complete as G (Attribute (Pos, Overlap, Splines),+ EdgeType (SplineEdges), Overlap (ScaleOverlaps),+ Point (..), Pos (..),+ Spline (..))+import Data.GraphViz.Commands.IO (hGetDot)+import Data.GraphViz.Types.Generalised (FromGeneralisedDot (..))++import Data.List (group, sort)+import Data.List.Split (chunksOf)+import qualified Data.Map as M+import Data.Maybe (catMaybes, fromJust,+ maybeToList)+import Data.Tuple (swap)++-- | Construct a graph from a list of vertex labels (which must be unique) and+-- a list of (directed) edges. The result is suitable as input to 'layoutGraph'.+mkGraph :: Ord v => [v] -> [(v,v,e)] -> Gr v e+mkGraph vs es = G.mkGraph vpairs edges+ where+ vpairs = zip [0..] (map head . group . sort $ vs)+ vmap = M.fromList $ map swap vpairs+ edges = catMaybes $ map mkEdge es+ mkEdge (v1,v2,e) = (,,) <$> M.lookup v1 vmap <*> M.lookup v2 vmap <*> pure e++-- | Decompose an annotated, concretely laid-out graph into a map from vertex labels to+-- points and a collection of edges associating vertex and edge+-- labels to 'Path' values. This is used internally by 'drawGraph',+-- but exported since it may also be useful for more fine-grained+-- control over graph drawing.+getGraph+ :: Ord v+ => Gr (AttributeNode v) (AttributeNode e)+ -> (M.Map v (P2 Double), [(v, v, e, Path V2 Double)])+getGraph gr = (vmap, edges)+ where+ nodes = G.labNodes gr+ vmap = M.fromList [ (v, pointToP2 pt) | (_,(attrs,v)) <- nodes, Pos (PointPos pt) <- attrs ]+ ixmap = M.fromList [ (i,v) | (i,(_,v)) <- nodes ]+ edges = [ (fromJust $ M.lookup i ixmap, fromJust $ M.lookup j ixmap, e, getPath attrs)+ | (i, j, (attrs,e)) <- G.labEdges gr+ ]+ getPath attrs = case [ss | Pos (SplinePos ss) <- attrs] of+ [splines] -> mconcat . map getSpline $ splines+ _ -> mempty+ getSpline (Spline { startPoint = s, endPoint = e, splinePoints = pt1:pts}) = thePath+ where+ ptGroups = chunksOf 3 (map pointToP2 pts)+ fixedBeziers = zipWith mkBez (pointToP2 pt1 : map last ptGroups) ptGroups+ mkBez x1 [c1,c2,x2] = FCubic x1 c1 c2 x2+ thePath = fromLocSegments . fixup . map fromFixedSeg $ fixedBeziers+ fixup [] = [] `at` origin+ fixup (b1:rest) = (unLoc b1 : map unLoc rest) `at` loc b1++-- | Convert a GraphViz point to a diagrams point.+pointToP2 :: G.Point -> P2 Double+pointToP2 (G.Point {xCoord = x, yCoord = y}) = x ^& y++-- | Render an annotated graph as a diagram, given functions+-- controlling the drawing of vertices and of edges. The first+-- function is given the label and location of each vertex. The+-- second function, for each edge, is given the label and location+-- of the first vertex, the label and location of the second vertex,+-- and the label and path corresponding to the edge.+drawGraph+ :: (Ord v, Semigroup m)+ => (v -> P2 Double -> QDiagram b V2 Double m)+ -> (v -> P2 Double -> v -> P2 Double -> e -> Path V2 Double -> QDiagram b V2 Double m)+ -> Gr (AttributeNode v) (AttributeNode e)+ -> QDiagram b V2 Double m+drawGraph drawV drawE gr+ = mconcat (map drawE' edges)+ <> mconcat (map (uncurry drawV) (M.assocs vmap))+ where+ (vmap, edges) = getGraph gr+ drawE' (v1,v2,e,p)+ = drawE v1 (fromJust $ M.lookup v1 vmap) v2 (fromJust $ M.lookup v2 vmap) e p++-- | Round-trip a graph through an external graphviz layout algorithm, and+-- read back in a version annotated with explicit positioning+-- information. The result is suitable for input to 'drawGraph' or,+-- more directly, to 'getGraph'. The 'GraphvizCommand' should be+-- something like @Dot@ or @Neato@; to access them you should import+-- "Data.GraphViz.Command". For more control over the functioning+-- of graphviz, see 'layoutGraph''.+layoutGraph+ :: forall gr v e. G.Graph gr+ => GraphvizCommand+ -> gr v e+ -> IO (gr (AttributeNode v) (AttributeEdge e))+layoutGraph = layoutGraph' (defaultDiaParams :: GraphvizParams G.Node v e () v)++-- | Like 'layoutGraph', but with an extra 'GraphvizParams' parameter+-- controlling various aspects of the graphviz layout process. See+-- 'defaultDiaParams', and the "Data.GraphViz.Attributes" and+-- "Data.GraphViz.Attributes.Complete" modules.+layoutGraph'+ :: (Ord cl, G.Graph gr)+ => GraphvizParams G.Node v e cl l+ -> GraphvizCommand+ -> gr v e+ -> IO (gr (AttributeNode v) (AttributeEdge e))+layoutGraph' params com gr = dotAttributes' com (isDirected params) gr' dot+ where+ dot = graphToDot params' gr'+ params' = params { fmtEdge = setEdgeIDAttribute $ fmtEdge params }+ gr' = addEdgeIDs gr++-- | Some convenient parameters for GraphViz which work better for+-- diagrams than the default. In particular, use circular nodes+-- (instead of the default ovals), and allow cubic splines for+-- edges.+defaultDiaParams :: GraphvizParams G.Node v e cl v+defaultDiaParams+ = defaultParams+ { globalAttributes =+ [ NodeAttrs [shape Circle]+ , GraphAttrs [Overlap ScaleOverlaps, Splines SplineEdges]+ ]+ }++-- This should not be exported. It is more or less copied from the+-- graphviz package source; the problem is that graphviz does not+-- export any way to have this parameterized by the GraphvizCommand.+dotAttributes' :: (G.Graph gr, PPDotRepr dg G.Node, FromGeneralisedDot dg G.Node)+ => GraphvizCommand -> Bool -> gr v (EdgeID e)+ -> dg G.Node -> IO (gr (AttributeNode v) (AttributeEdge e))+dotAttributes' command isDir gr dot+ = augmentGraph gr . parseDG <$> graphvizWithHandle command dot DotOutput hGetDot+ where+ parseDG = (`asTypeOf` dot) . fromGeneralised