From 9cf672224157361201b05cb0d36fe31e5be4bedd Mon Sep 17 00:00:00 2001 From: Robbie Gleichman Date: Wed, 20 Jan 2016 18:24:42 -0800 Subject: [PATCH] Add support for arrow heads and tails. --- app/Icons.hs | 19 ++------------- app/Main.hs | 19 +++++++++------ app/Rendering.hs | 63 +++++++++++++++++++++++++++++++++++++++--------- app/Types.hs | 4 +-- 4 files changed, 67 insertions(+), 38 deletions(-) diff --git a/app/Icons.hs b/app/Icons.hs index d148ac4..80675ac 100644 --- a/app/Icons.hs +++ b/app/Icons.hs @@ -7,13 +7,13 @@ module Icons --drawIconAndPorts, --drawIconsAndPortNumbers, nameDiagram, - connectMaybePorts, textBox, enclosure, lambdaRegion, resultIcon, guardIcon, - apply0NDia + apply0NDia, + defaultLineWidth ) where import Diagrams.Prelude @@ -38,21 +38,6 @@ iconToDiagram (LambdaRegionIcon n diagramName) nameToSubdiagramMap = -- | Names the diagram and puts all sub-names in the namespace of the top level name. nameDiagram name dia = name .>> (dia # named name) -arrowOptions = with & arrowHead .~ noHead & shaftStyle %~ lwG defaultLineWidth . lc white - -connectMaybePorts :: Edge -> Diagram B -> Diagram B -connectMaybePorts (Edge (icon0, Just port0, icon1, Just port1) _) = - connect' - arrowOptions - (icon0 .> port0) - (icon1 .> port1) -connectMaybePorts (Edge (icon0, Nothing, icon1, Just port1) _) = - connectOutside' arrowOptions icon0 (icon1 .> port1) -connectMaybePorts (Edge (icon0, Just port0, icon1, Nothing) _) = - connectOutside' arrowOptions (icon0 .> port0) icon1 -connectMaybePorts (Edge (icon0, Nothing, icon1, Nothing) _) = - connectOutside' arrowOptions icon0 icon1 - -- | Make an port with an integer name. Always use <> to add a ports (not === or |||) --- since mempty has no size and will not be placed where you want it. makePort :: Int -> Diagram B diff --git a/app/Main.hs b/app/Main.hs index 861d833..c69b9b2 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -15,17 +15,23 @@ import Data.Typeable(Typeable) import Lib import Icons(apply0Dia, apply0NDia) -import Rendering(toNames, portToPort, iconToPort, iconToIcon, renderDrawing) -import Types(Icon(..), Drawing(..)) +import Rendering(toNames, portToPort, iconToPort, iconToIcon, iconToIconEnds, renderDrawing) +import Types(Icon(..), Drawing(..), EdgeEnd(..)) +-- TODO Now -- +-- todo: replace hrule and vrule with strutX and strutY +-- todo: add port to bottom of guard. +-- todo: use constants for icon name strings in Main +-- todo: figure out how to deal with the difference between arrow heads and arrow tails +-- todo: consider moving portToPort etc. to a new file + +-- TODO Later -- -- todo: Find out how to hide unqualified names such that recursive drawings are connected correctly -- todo: Find out and fix why connectinos to sub-icons need to be qualified twice (eg. "lam0" .> "arg" .> "arg") -- todo: Rotate based on difference from ideal tangent angle, not line distance. -- todo: layout and rotate considering external connections. --- todo: add port to bottom of guard. --- todo: use constants for icon name strings in Main -- todo: figure out local vs. global icon positions --- todo: replace hrule and vrule with strutX and strutY + applyDia = apply0Dia -- --apply0A = "A" .>> applyDia @@ -134,8 +140,6 @@ fact0Icons = toNames ("*", TextBoxIcon "*"), ("recurAp", Apply0Icon), ("*Ap", Apply0NIcon 2), - --("*Ap1", Apply0Icon), - --("*Ap2", Apply0Icon), ("arg", BranchIcon), ("res", ResultIcon) ] @@ -154,6 +158,7 @@ fact0Edges = [ iconToPort "arg" "*Ap" 2, portToPort "-1Ap" 2 "recurAp" 1, iconToPort "res" "g0" 0 + --iconToIconEnds "-1" Ap1Result "eq0" Ap1Arg ] fact0Drawing = Drawing fact0Icons fact0Edges [] diff --git a/app/Rendering.hs b/app/Rendering.hs index abb5766..c881d3f 100644 --- a/app/Rendering.hs +++ b/app/Rendering.hs @@ -5,6 +5,7 @@ module Rendering ( portToPort, iconToPort, iconToIcon, + iconToIconEnds, toNames, renderDrawing ) where @@ -13,7 +14,7 @@ import Diagrams.Prelude import Diagrams.TwoD.GraphViz import Diagrams.Backend.SVG(B) -import Data.GraphViz +import qualified Data.GraphViz as GV import qualified Data.GraphViz.Attributes.Complete as GVA --import Data.GraphViz.Commands import qualified Data.Map as Map @@ -22,9 +23,10 @@ import qualified Debug.Trace import Data.List(minimumBy) import Data.Function(on) import Data.Graph.Inductive.PatriciaTree (Gr) +import Data.Typeable(Typeable) import Icons -import Types(Edge(..), Connection, Drawing(..), EdgeEndType(..)) +import Types(Edge(..), Connection, Drawing(..), EdgeEnd(..)) -- | Convert a map of names and icons, to a list of names and diagrams. @@ -51,12 +53,49 @@ iconToPort a c d = Edge (toName a, Nothing, toName c, Just d) noEnds iconToIcon :: (IsName a, IsName b) => a -> b -> Edge iconToIcon a c = Edge (toName a, Nothing, toName c, Nothing) noEnds + +-- If there are gaps between the arrow and the icon, try switching the first two arguments +-- with the last two arguments +iconToIconEnds :: (IsName a, IsName b) => a -> EdgeEnd -> b -> EdgeEnd -> Edge +iconToIconEnds a b c d = Edge (toName a, Nothing, toName c, Nothing) (b, d) + edgesToGraph :: (Ord v) => [v] -> [(v, t, v , t1)] -> Gr v () edgesToGraph names edges = mkGraph names simpleEdges where simpleEdges = map (\(a, _, c, _) -> (a, c, ())) edges -uncurry4 f (a, b, c, d) = f a b c d +-- Custom arrow tail for the arg1 result circle. +-- The ArrowHT type does not seem to be documented. +arg1ResHT :: (RealFloat n) => ArrowHT n +arg1ResHT len _ = (circle (len / 2) # alignR, mempty) + +getArrowOpts :: (RealFloat n, Typeable n) => (EdgeEnd, EdgeEnd) -> ArrowOpts n +getArrowOpts (t, h) = arrowOptions + where + lookupEnd :: (RealFloat n, Typeable n) => EdgeEnd -> ArrowOpts n -> ArrowOpts n + lookupEnd NoEnd = id + lookupEnd Ap1Arg = (arrowHead .~ thorn) . (headTexture .~ solid cyan) + lookupEnd Ap1Result = (arrowTail .~ arg1ResHT) . (tailTexture .~ solid cyan) + arrowOptions = + with & arrowHead .~ noHead + & arrowTail .~ noTail + & shaftStyle %~ lwG defaultLineWidth . lc white + & (lookupEnd t) & (lookupEnd h) + +plainLine = getArrowOpts (NoEnd, NoEnd) + +connectMaybePorts :: Edge -> Diagram B -> Diagram B +connectMaybePorts (Edge (icon0, Just port0, icon1, Just port1) _) = + connect' + plainLine + (icon0 .> port0) + (icon1 .> port1) +connectMaybePorts (Edge (icon0, Nothing, icon1, Just port1) _) = + connectOutside' plainLine icon0 (icon1 .> port1) +connectMaybePorts (Edge (icon0, Just port0, icon1, Nothing) _) = + connectOutside' plainLine (icon0 .> port0) icon1 +connectMaybePorts (Edge (icon0, Nothing, icon1, Nothing) ends) = + connectOutside' (getArrowOpts ends) icon0 icon1 makeConnections :: [Edge] -> Diagram B -> Diagram B makeConnections edges = applyAll connections @@ -143,19 +182,19 @@ placeNodes layoutResult nameDiagramMap edges = mconcat placedNodes doGraphLayout :: Gr Name e -> [(Name, Diagram B)] -> (Diagram B -> r) -> [Connection] -> IO r doGraphLayout graph nameDiagramMap connectNodes edges = do - layoutResult <- layoutGraph' layoutParams Neato graph + layoutResult <- layoutGraph' layoutParams GVA.Neato graph return $ placeNodes layoutResult nameDiagramMap edges # connectNodes where - layoutParams :: GraphvizParams Int v e () v - layoutParams = defaultParams{ - globalAttributes = - [ NodeAttrs [shape Circle] - , GraphAttrs [GVA.Overlap GVA.ScaleXYOverlaps, GVA.Splines GVA.LineEdges] + layoutParams :: GV.GraphvizParams Int v e () v + layoutParams = GV.defaultParams{ + GV.globalAttributes = + [ GV.NodeAttrs [GVA.Shape GVA.Circle] + , GV.GraphAttrs [GVA.Overlap GVA.ScaleXYOverlaps, GVA.Splines GVA.LineEdges] ], - fmtEdge = const [arrowTo noArrow], - fmtNode = nodeAttribute + GV.fmtEdge = const [GV.arrowTo GV.noArrow], + GV.fmtNode = nodeAttribute } - nodeAttribute :: (Int, l) -> [Data.GraphViz.Attribute] + nodeAttribute :: (Int, l) -> [GV.Attribute] nodeAttribute (nodeInt, _) = -- todo: Potential bug. GVA.Width and GVA.Height have a minimum of 0.01 -- throw an error if the width or height are less than 0.01 diff --git a/app/Types.hs b/app/Types.hs index 42a3fb5..ca3d4da 100644 --- a/app/Types.hs +++ b/app/Types.hs @@ -17,9 +17,9 @@ type Connection = (Name, Maybe Int, Name, Maybe Int) -- | An Edge has an name of the source icon, and its optional port number, -- and the name of the destination icon, and its optional port number. -data Edge = Edge {edgeConnection :: Connection, edgeEnds :: (EdgeEndType, EdgeEndType)} +data Edge = Edge {edgeConnection :: Connection, edgeEnds :: (EdgeEnd, EdgeEnd)} -data EdgeEndType = Ap1Result | Ap1Arg | NoEnd +data EdgeEnd = Ap1Result | Ap1Arg | NoEnd -- | A drawing is a map from names to Icons, a list of edges, -- and a map of names to subDrawings