Add support for arrow heads and tails.

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

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 Rendering(toNames, portToPort, iconToPort, iconToIcon, iconToIconEnds, renderDrawing)
-import Types(Icon(..), Drawing(..))
+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 []

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 :: GV.GraphvizParams Int v e () v
-    layoutParams = defaultParams{
+    layoutParams = GV.defaultParams{
-      globalAttributes =
+      GV.globalAttributes =
-        [ NodeAttrs [shape Circle]
+        [ GV.NodeAttrs [GVA.Shape GVA.Circle]
-        , GraphAttrs [GVA.Overlap GVA.ScaleXYOverlaps, GVA.Splines GVA.LineEdges]
+        , GV.GraphAttrs [GVA.Overlap GVA.ScaleXYOverlaps, GVA.Splines GVA.LineEdges]
         ],
-      fmtEdge = const [arrowTo noArrow],
+      GV.fmtEdge = const [GV.arrowTo GV.noArrow],
-      fmtNode = nodeAttribute
+      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

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