mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
Fix arrow heads and tails.
This commit is contained in:
parent
f90b39ea6a
commit
3c105a7a89
19
app/Main.hs
19
app/Main.hs
@ -14,7 +14,6 @@ import Rendering(toNames, portToPort, iconToPort, iconToIcon,
|
|||||||
import Types(Icon(..), Drawing(..), EdgeEnd(..))
|
import Types(Icon(..), Drawing(..), EdgeEnd(..))
|
||||||
|
|
||||||
-- TODO Now --
|
-- TODO Now --
|
||||||
-- 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: consider moving portToPort etc. to a new file
|
||||||
|
|
||||||
-- TODO Later --
|
-- TODO Later --
|
||||||
@ -177,6 +176,24 @@ fact1Drawing = Drawing fact1Icons fact1Edges []
|
|||||||
|
|
||||||
factLam1Drawing = Drawing factLam0Icons factLam0Edges [(fact0Name, fact1Drawing)]
|
factLam1Drawing = Drawing factLam0Icons factLam0Edges [(fact0Name, fact1Drawing)]
|
||||||
|
|
||||||
|
(arr1, arr2, arr3, arr4) = ("arr1", "arr2", "arr3", "arr4")
|
||||||
|
|
||||||
|
arrowTestIcons = toNames [
|
||||||
|
(arr1, TextBoxIcon "1"),
|
||||||
|
(arr2, TextBoxIcon "2"),
|
||||||
|
(arr3, TextBoxIcon "3"),
|
||||||
|
(arr4, TextBoxIcon "4")
|
||||||
|
]
|
||||||
|
|
||||||
|
arrowTestEdges = [
|
||||||
|
iconToIconEnds arr1 EndAp1Arg arr2 EndAp1Result,
|
||||||
|
iconToIconEnds arr1 EndAp1Result arr3 EndAp1Arg,
|
||||||
|
iconToIconEnds arr2 EndAp1Result arr3 EndAp1Result,
|
||||||
|
iconToIconEnds arr1 EndAp1Arg arr4 EndAp1Arg
|
||||||
|
]
|
||||||
|
|
||||||
|
arrowTestDrawing = Drawing arrowTestIcons arrowTestEdges []
|
||||||
|
|
||||||
main1 :: IO ()
|
main1 :: IO ()
|
||||||
main1 = do
|
main1 = do
|
||||||
placedNodes <- renderDrawing factLam1Drawing
|
placedNodes <- renderDrawing factLam1Drawing
|
||||||
|
@ -13,7 +13,7 @@ module Rendering (
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Diagrams.Prelude
|
import Diagrams.Prelude
|
||||||
import Diagrams.TwoD.GraphViz
|
import Diagrams.TwoD.GraphViz(mkGraph, getGraph, layoutGraph')
|
||||||
import Diagrams.Backend.SVG(B)
|
import Diagrams.Backend.SVG(B)
|
||||||
|
|
||||||
import qualified Data.GraphViz as GV
|
import qualified Data.GraphViz as GV
|
||||||
@ -29,23 +29,25 @@ import Data.Typeable(Typeable)
|
|||||||
|
|
||||||
import Icons(colorScheme, Icon(..), iconToDiagram, nameDiagram, defaultLineWidth, ColorStyle(..))
|
import Icons(colorScheme, Icon(..), iconToDiagram, nameDiagram, defaultLineWidth, ColorStyle(..))
|
||||||
import Types(Edge(..), Connection, Drawing(..), EdgeEnd(..))
|
import Types(Edge(..), Connection, Drawing(..), EdgeEnd(..))
|
||||||
|
import Control.Arrow(first)
|
||||||
|
|
||||||
|
|
||||||
-- | 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.
|
||||||
-- The subDiagramMap
|
-- The first argument is the subdiagram map used for the inside of lambdaIcons
|
||||||
|
-- The second argument is the map of icons that should be converted to diagrams.
|
||||||
makeNamedMap :: IsName name => [(Name, Diagram B)] -> [(name, Icon)] -> [(name, Diagram B)]
|
makeNamedMap :: IsName name => [(Name, Diagram B)] -> [(name, Icon)] -> [(name, Diagram B)]
|
||||||
makeNamedMap subDiagramMap =
|
makeNamedMap subDiagramMap =
|
||||||
map (\(name, icon) -> (name, iconToDiagram icon subDiagramMap # nameDiagram name))
|
map (\(name, icon) -> (name, iconToDiagram icon subDiagramMap # nameDiagram name))
|
||||||
|
|
||||||
mapFst :: (a -> b) -> [(a, c)] -> [(b, c)]
|
mapFst :: (a -> b) -> [(a, c)] -> [(b, c)]
|
||||||
mapFst f = map (\(x, y) -> (f x, y))
|
mapFst f = map (first f)
|
||||||
|
|
||||||
toNames :: (IsName a) => [(a, b)] -> [(Name, b)]
|
toNames :: (IsName a) => [(a, b)] -> [(Name, b)]
|
||||||
toNames = mapFst toName
|
toNames = mapFst toName
|
||||||
|
|
||||||
noEnds = (EndNone, EndNone)
|
noEnds = (EndNone, EndNone)
|
||||||
|
|
||||||
--portToPort :: (IsName a, IsName c) => a -> b -> c -> d -> Edge
|
-- Edge constructors --
|
||||||
portToPort :: (IsName a, IsName b) => a -> Int -> b -> Int -> Edge
|
portToPort :: (IsName a, IsName b) => a -> Int -> b -> Int -> Edge
|
||||||
portToPort a b c d = Edge (toName a, Just b, toName c, Just d) noEnds
|
portToPort a b c d = Edge (toName a, Just b, toName c, Just d) noEnds
|
||||||
|
|
||||||
@ -65,30 +67,45 @@ iconHeadToPort a endHead c d = Edge (toName a, Nothing, toName c, Just d) (EndNo
|
|||||||
|
|
||||||
iconTailToPort a endTail c d = Edge (toName a, Nothing, toName c, Just d) (endTail, EndNone)
|
iconTailToPort a endTail c d = Edge (toName a, Nothing, toName c, Just d) (endTail, EndNone)
|
||||||
|
|
||||||
|
-- | Make an inductive Graph from a list of node names, and a list of Connections.
|
||||||
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
|
||||||
|
|
||||||
-- Custom arrow tail for the arg1 result circle.
|
|
||||||
|
-- | Custom arrow tail for the arg1 result circle.
|
||||||
-- The ArrowHT type does not seem to be documented.
|
-- The ArrowHT type does not seem to be documented.
|
||||||
arg1ResHT :: (RealFloat n) => ArrowHT n
|
arg1ResT :: (RealFloat n) => ArrowHT n
|
||||||
arg1ResHT len _ = (circle (len / 2) # alignR, mempty)
|
arg1ResT len _ = (circle (len / 2) # alignR, mempty)
|
||||||
|
|
||||||
|
-- | Arrow head version of arg1ResT
|
||||||
|
arg1ResH :: (RealFloat n) => ArrowHT n
|
||||||
|
arg1ResH len _ = (circle (len / 2) # alignL, mempty)
|
||||||
|
|
||||||
getArrowOpts :: (RealFloat n, Typeable n) => (EdgeEnd, EdgeEnd) -> ArrowOpts n
|
getArrowOpts :: (RealFloat n, Typeable n) => (EdgeEnd, EdgeEnd) -> ArrowOpts n
|
||||||
getArrowOpts (t, h) = arrowOptions
|
getArrowOpts (t, h) = arrowOptions
|
||||||
where
|
where
|
||||||
lookupEnd :: (RealFloat n, Typeable n) => EdgeEnd -> ArrowOpts n -> ArrowOpts n
|
ap1ArgTexture = solid (backgroundC colorScheme)
|
||||||
lookupEnd EndNone = id
|
ap1ArgStyle = lw thick . lc (apply1C colorScheme)
|
||||||
lookupEnd EndAp1Arg = (arrowHead .~ arrowheadDart (0.4 @@ turn))
|
ap1ResultTexture = solid (apply1C colorScheme)
|
||||||
. (headTexture .~ solid (backgroundC colorScheme)) . (headStyle %~ (lw thick . lc (apply1C colorScheme) ))
|
|
||||||
lookupEnd EndAp1Result = (arrowTail .~ arg1ResHT) . (tailTexture .~ solid (apply1C colorScheme))
|
lookupTail EndNone = id
|
||||||
|
lookupTail EndAp1Arg = (arrowTail .~ dart')
|
||||||
|
. (tailTexture .~ ap1ArgTexture) . (tailStyle %~ ap1ArgStyle)
|
||||||
|
lookupTail EndAp1Result = (arrowTail .~ arg1ResT) . (tailTexture .~ ap1ResultTexture)
|
||||||
|
|
||||||
|
lookupHead EndNone = id
|
||||||
|
lookupHead EndAp1Arg = (arrowHead .~ arrowheadDart (0.4 @@ turn))
|
||||||
|
. (headTexture .~ ap1ArgTexture) . (headStyle %~ ap1ArgStyle)
|
||||||
|
lookupHead EndAp1Result = (arrowHead .~ arg1ResH) . (headTexture .~ ap1ResultTexture)
|
||||||
|
|
||||||
arrowOptions =
|
arrowOptions =
|
||||||
with & arrowHead .~ noHead
|
with & arrowHead .~ noHead
|
||||||
& arrowTail .~ noTail
|
& arrowTail .~ noTail
|
||||||
& lengths .~ normalized 0.04
|
& lengths .~ global 0.75
|
||||||
& shaftStyle %~ lwG defaultLineWidth . lc (lineC colorScheme)
|
& shaftStyle %~ lwG defaultLineWidth . lc (lineC colorScheme)
|
||||||
& lookupEnd t & lookupEnd h
|
& lookupTail t & lookupHead h
|
||||||
|
|
||||||
plainLine = getArrowOpts (EndNone, EndNone)
|
plainLine = getArrowOpts (EndNone, EndNone)
|
||||||
|
|
||||||
@ -146,6 +163,7 @@ angleWithMinDist myLocation edges =
|
|||||||
|
|
||||||
-- constant
|
-- constant
|
||||||
scaleFactor = 0.02
|
scaleFactor = 0.02
|
||||||
|
--scaleFactor = 0.04
|
||||||
|
|
||||||
getFromMapAndScale :: (Fractional a, Functor f, Ord k) => Map.Map k (f a) -> k -> f a
|
getFromMapAndScale :: (Fractional a, Functor f, Ord k) => Map.Map k (f a) -> k -> f a
|
||||||
getFromMapAndScale posMap name = scaleFactor *^ (posMap Map.! name)
|
getFromMapAndScale posMap name = scaleFactor *^ (posMap Map.! name)
|
||||||
@ -191,6 +209,7 @@ 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 GVA.Neato graph
|
layoutResult <- layoutGraph' layoutParams GVA.Neato graph
|
||||||
|
-- layoutResult <- layoutGraph' layoutParams GVA.Fdp graph
|
||||||
return $ placeNodes layoutResult nameDiagramMap edges # connectNodes
|
return $ placeNodes layoutResult nameDiagramMap edges # connectNodes
|
||||||
where
|
where
|
||||||
layoutParams :: GV.GraphvizParams Int v e () v
|
layoutParams :: GV.GraphvizParams Int v e () v
|
||||||
|
Loading…
Reference in New Issue
Block a user