mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
Add support for arrow heads and tails.
This commit is contained in:
parent
d5e0b6bf63
commit
9cf6722241
19
app/Icons.hs
19
app/Icons.hs
@ -7,13 +7,13 @@ module Icons
|
|||||||
--drawIconAndPorts,
|
--drawIconAndPorts,
|
||||||
--drawIconsAndPortNumbers,
|
--drawIconsAndPortNumbers,
|
||||||
nameDiagram,
|
nameDiagram,
|
||||||
connectMaybePorts,
|
|
||||||
textBox,
|
textBox,
|
||||||
enclosure,
|
enclosure,
|
||||||
lambdaRegion,
|
lambdaRegion,
|
||||||
resultIcon,
|
resultIcon,
|
||||||
guardIcon,
|
guardIcon,
|
||||||
apply0NDia
|
apply0NDia,
|
||||||
|
defaultLineWidth
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Diagrams.Prelude
|
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.
|
-- | Names the diagram and puts all sub-names in the namespace of the top level name.
|
||||||
nameDiagram name dia = name .>> (dia # named 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 |||)
|
-- | 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.
|
--- since mempty has no size and will not be placed where you want it.
|
||||||
makePort :: Int -> Diagram B
|
makePort :: Int -> Diagram B
|
||||||
|
19
app/Main.hs
19
app/Main.hs
@ -15,17 +15,23 @@ import Data.Typeable(Typeable)
|
|||||||
|
|
||||||
import Lib
|
import Lib
|
||||||
import Icons(apply0Dia, apply0NDia)
|
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 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: 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: Rotate based on difference from ideal tangent angle, not line distance.
|
||||||
-- todo: layout and rotate considering external connections.
|
-- 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: figure out local vs. global icon positions
|
||||||
-- todo: replace hrule and vrule with strutX and strutY
|
|
||||||
|
|
||||||
applyDia = apply0Dia
|
applyDia = apply0Dia
|
||||||
-- --apply0A = "A" .>> applyDia
|
-- --apply0A = "A" .>> applyDia
|
||||||
@ -134,8 +140,6 @@ fact0Icons = toNames
|
|||||||
("*", TextBoxIcon "*"),
|
("*", TextBoxIcon "*"),
|
||||||
("recurAp", Apply0Icon),
|
("recurAp", Apply0Icon),
|
||||||
("*Ap", Apply0NIcon 2),
|
("*Ap", Apply0NIcon 2),
|
||||||
--("*Ap1", Apply0Icon),
|
|
||||||
--("*Ap2", Apply0Icon),
|
|
||||||
("arg", BranchIcon),
|
("arg", BranchIcon),
|
||||||
("res", ResultIcon)
|
("res", ResultIcon)
|
||||||
]
|
]
|
||||||
@ -154,6 +158,7 @@ fact0Edges = [
|
|||||||
iconToPort "arg" "*Ap" 2,
|
iconToPort "arg" "*Ap" 2,
|
||||||
portToPort "-1Ap" 2 "recurAp" 1,
|
portToPort "-1Ap" 2 "recurAp" 1,
|
||||||
iconToPort "res" "g0" 0
|
iconToPort "res" "g0" 0
|
||||||
|
--iconToIconEnds "-1" Ap1Result "eq0" Ap1Arg
|
||||||
]
|
]
|
||||||
|
|
||||||
fact0Drawing = Drawing fact0Icons fact0Edges []
|
fact0Drawing = Drawing fact0Icons fact0Edges []
|
||||||
|
@ -5,6 +5,7 @@ module Rendering (
|
|||||||
portToPort,
|
portToPort,
|
||||||
iconToPort,
|
iconToPort,
|
||||||
iconToIcon,
|
iconToIcon,
|
||||||
|
iconToIconEnds,
|
||||||
toNames,
|
toNames,
|
||||||
renderDrawing
|
renderDrawing
|
||||||
) where
|
) where
|
||||||
@ -13,7 +14,7 @@ import Diagrams.Prelude
|
|||||||
import Diagrams.TwoD.GraphViz
|
import Diagrams.TwoD.GraphViz
|
||||||
import Diagrams.Backend.SVG(B)
|
import Diagrams.Backend.SVG(B)
|
||||||
|
|
||||||
import Data.GraphViz
|
import qualified Data.GraphViz as GV
|
||||||
import qualified Data.GraphViz.Attributes.Complete as GVA
|
import qualified Data.GraphViz.Attributes.Complete as GVA
|
||||||
--import Data.GraphViz.Commands
|
--import Data.GraphViz.Commands
|
||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
@ -22,9 +23,10 @@ import qualified Debug.Trace
|
|||||||
import Data.List(minimumBy)
|
import Data.List(minimumBy)
|
||||||
import Data.Function(on)
|
import Data.Function(on)
|
||||||
import Data.Graph.Inductive.PatriciaTree (Gr)
|
import Data.Graph.Inductive.PatriciaTree (Gr)
|
||||||
|
import Data.Typeable(Typeable)
|
||||||
|
|
||||||
import Icons
|
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.
|
-- | 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 :: (IsName a, IsName b) => a -> b -> Edge
|
||||||
iconToIcon a c = Edge (toName a, Nothing, toName c, Nothing) noEnds
|
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 :: (Ord v) => [v] -> [(v, t, v , t1)] -> Gr v ()
|
||||||
edgesToGraph names edges = mkGraph names simpleEdges
|
edgesToGraph names edges = mkGraph names simpleEdges
|
||||||
where
|
where
|
||||||
simpleEdges = map (\(a, _, c, _) -> (a, c, ())) edges
|
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 :: [Edge] -> Diagram B -> Diagram B
|
||||||
makeConnections edges = applyAll connections
|
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 :: Gr Name e -> [(Name, Diagram B)] -> (Diagram B -> r) -> [Connection] -> IO r
|
||||||
doGraphLayout graph nameDiagramMap connectNodes edges = do
|
doGraphLayout graph nameDiagramMap connectNodes edges = do
|
||||||
layoutResult <- layoutGraph' layoutParams Neato graph
|
layoutResult <- layoutGraph' layoutParams GVA.Neato graph
|
||||||
return $ placeNodes layoutResult nameDiagramMap edges # connectNodes
|
return $ placeNodes layoutResult nameDiagramMap edges # connectNodes
|
||||||
where
|
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, _) =
|
nodeAttribute (nodeInt, _) =
|
||||||
-- todo: Potential bug. GVA.Width and GVA.Height have a minimum of 0.01
|
-- 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
|
-- 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,
|
-- | 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.
|
-- 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,
|
-- | A drawing is a map from names to Icons, a list of edges,
|
||||||
-- and a map of names to subDrawings
|
-- and a map of names to subDrawings
|
||||||
|
Loading…
Reference in New Issue
Block a user