rgleichman/glance
1
1
Fork 0
mirror of https://github.com/rgleichman/glance.git synced 2024-11-30 14:22:20 +03:00
Code Issues Projects Releases Wiki Activity

Extract the Graphviz parameters in Rendering.hs so they can be reused by renderFglGraph.

Browse Source
This commit is contained in:
Robbie Gleichman 2016-11-03 14:52:22 -07:00
parent 7ceb5977e4
commit cab045da4b
2 changed files with 26 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
app/Rendering.hs
View File

@ -1,7 +1,8 @@
{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, TypeFamilies, PartialTypeSignatures #-}
module Rendering (
renderDrawing
renderDrawing,
customLayoutParams
) where
import Diagrams.Prelude hiding ((#), (&))
@ -232,19 +233,8 @@ placeNodes layoutResult nameDiagramMap edges = mconcat placedNodes
-- todo: Not sure if the diagrams should already be centered at this point.
placeNode (name, diagram) = place (centerXY diagram) (scaleFactor *^ (positionMap Map.! name))
doGraphLayout :: SpecialBackend b =>
Gr Name e
-> [(Name, Bool -> Double -> SpecialQDiagram b)]
-> [Connection]
-> IO (SpecialQDiagram b)
doGraphLayout graph nameDiagramMap edges = do
layoutResult <- layoutGraph' layoutParams GVA.Neato graph
-- layoutResult <- layoutGraph' layoutParams GVA.Fdp graph
return $ placeNodes layoutResult nameDiagramMap edges
where
layoutParams :: GV.GraphvizParams Int v e () v
--layoutParams :: GV.GraphvizParams Int l el Int l
layoutParams = GV.defaultParams{
customLayoutParams :: GV.GraphvizParams n v e () v
customLayoutParams = GV.defaultParams{
GV.globalAttributes = [
GV.NodeAttrs [GVA.Shape GVA.BoxShape]
--GV.NodeAttrs [GVA.Shape GVA.Circle]
@ -259,7 +249,22 @@ doGraphLayout graph nameDiagramMap edges = do
GVA.OverlapShrink True
]
],
GV.fmtEdge = const [GV.arrowTo GV.noArrow],
GV.fmtEdge = const [GV.arrowTo GV.noArrow]
}
doGraphLayout :: SpecialBackend b =>
Gr Name e
-> [(Name, Bool -> Double -> SpecialQDiagram b)]
-> [Connection]
-> IO (SpecialQDiagram b)
doGraphLayout graph nameDiagramMap edges = do
layoutResult <- layoutGraph' layoutParams GVA.Neato graph
-- layoutResult <- layoutGraph' layoutParams GVA.Fdp graph
return $ placeNodes layoutResult nameDiagramMap edges
where
layoutParams :: GV.GraphvizParams Int v e () v
--layoutParams :: GV.GraphvizParams Int l el Int l
layoutParams = customLayoutParams{
GV.fmtNode = nodeAttribute
}
nodeAttribute :: (Int, l) -> [GV.Attribute]

21
test/AllTests.hs
View File

@ -10,7 +10,7 @@ import qualified Data.Graph.Inductive.Graph as ING
import qualified Data.Graph.Inductive.PatriciaTree as FGR
import Icons(textBox, colorScheme, ColorStyle(..), coloredTextBox)
import Rendering(renderDrawing)
import Rendering(renderDrawing, customLayoutParams)
import Util(toNames, portToPort, iconToPort, iconToIcon,
iconToIconEnds, iconTailToPort)
import Types(Icon(..), Drawing(..), EdgeEnd(..), SgNamedNode, Edge)
@ -417,7 +417,7 @@ graphTests = do
nodeFunc (name, syntaxNode) =
place (coloredTextBox white (opaque white) (show syntaxNode) :: Diagram B)
-- TODO Refactor with doGraphLayout in Rendering.hs
renderFglGraph :: FGR.Gr SgNamedNode Edge -> IO (Diagram B)
renderFglGraph fglGraph = do
layedOutGraph <- DiaGV.layoutGraph' layoutParams GVA.Neato fglGraph
@ -429,22 +429,7 @@ renderFglGraph fglGraph = do
nodeFunc (name, syntaxNode) =
place (coloredTextBox white (opaque white) (show syntaxNode) :: Diagram B)
layoutParams :: GV.GraphvizParams Int v e () v
layoutParams = GV.defaultParams{
GV.globalAttributes = [
GV.NodeAttrs [GVA.Shape GVA.BoxShape]
--GV.NodeAttrs [GVA.Shape GVA.Circle]
, GV.GraphAttrs
[
--GVA.Overlap GVA.KeepOverlaps,
--GVA.Overlap GVA.ScaleOverlaps,
GVA.Overlap $ GVA.PrismOverlap (Just 5000),
GVA.Splines GVA.LineEdges,
GVA.OverlapScaling 8,
--GVA.OverlapScaling 4,
GVA.OverlapShrink True
]
],
GV.fmtEdge = const [GV.arrowTo GV.noArrow],
layoutParams = customLayoutParams{
GV.fmtNode = nodeAttribute
}
nodeAttribute :: (Int, l) -> [GV.Attribute]