mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-16 18:30:36 +03:00
Add support for arrow heads and tails.
This commit is contained in:
Robbie Gleichman
parent
d5e0b6bf63
commit
9cf6722241
19
app/Icons.hs
19
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
|
||||
|
||||
19
app/Main.hs
19
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 []
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user