mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-16 18:30:36 +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(..))
|
||||
|
||||
-- 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 Later --
|
||||
@ -177,6 +176,24 @@ fact1Drawing = Drawing fact1Icons fact1Edges []
|
||||
|
||||
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 = do
|
||||
placedNodes <- renderDrawing factLam1Drawing
|
||||
|
@ -13,7 +13,7 @@ module Rendering (
|
||||
) where
|
||||
|
||||
import Diagrams.Prelude
|
||||
import Diagrams.TwoD.GraphViz
|
||||
import Diagrams.TwoD.GraphViz(mkGraph, getGraph, layoutGraph')
|
||||
import Diagrams.Backend.SVG(B)
|
||||
|
||||
import qualified Data.GraphViz as GV
|
||||
@ -29,23 +29,25 @@ import Data.Typeable(Typeable)
|
||||
|
||||
import Icons(colorScheme, Icon(..), iconToDiagram, nameDiagram, defaultLineWidth, ColorStyle(..))
|
||||
import Types(Edge(..), Connection, Drawing(..), EdgeEnd(..))
|
||||
import Control.Arrow(first)
|
||||
|
||||
|
||||
-- | 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 subDiagramMap =
|
||||
map (\(name, icon) -> (name, iconToDiagram icon subDiagramMap # nameDiagram name))
|
||||
|
||||
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 = mapFst toName
|
||||
|
||||
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 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)
|
||||
|
||||
-- | 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 names edges = mkGraph names simpleEdges
|
||||
where
|
||||
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.
|
||||
arg1ResHT :: (RealFloat n) => ArrowHT n
|
||||
arg1ResHT len _ = (circle (len / 2) # alignR, mempty)
|
||||
arg1ResT :: (RealFloat n) => ArrowHT n
|
||||
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 (t, h) = arrowOptions
|
||||
where
|
||||
lookupEnd :: (RealFloat n, Typeable n) => EdgeEnd -> ArrowOpts n -> ArrowOpts n
|
||||
lookupEnd EndNone = id
|
||||
lookupEnd EndAp1Arg = (arrowHead .~ arrowheadDart (0.4 @@ turn))
|
||||
. (headTexture .~ solid (backgroundC colorScheme)) . (headStyle %~ (lw thick . lc (apply1C colorScheme) ))
|
||||
lookupEnd EndAp1Result = (arrowTail .~ arg1ResHT) . (tailTexture .~ solid (apply1C colorScheme))
|
||||
ap1ArgTexture = solid (backgroundC colorScheme)
|
||||
ap1ArgStyle = lw thick . lc (apply1C colorScheme)
|
||||
ap1ResultTexture = 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 =
|
||||
with & arrowHead .~ noHead
|
||||
& arrowTail .~ noTail
|
||||
& lengths .~ normalized 0.04
|
||||
& lengths .~ global 0.75
|
||||
& shaftStyle %~ lwG defaultLineWidth . lc (lineC colorScheme)
|
||||
& lookupEnd t & lookupEnd h
|
||||
& lookupTail t & lookupHead h
|
||||
|
||||
plainLine = getArrowOpts (EndNone, EndNone)
|
||||
|
||||
@ -146,6 +163,7 @@ angleWithMinDist myLocation edges =
|
||||
|
||||
-- constant
|
||||
scaleFactor = 0.02
|
||||
--scaleFactor = 0.04
|
||||
|
||||
getFromMapAndScale :: (Fractional a, Functor f, Ord k) => Map.Map k (f a) -> k -> f a
|
||||
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 graph nameDiagramMap connectNodes edges = do
|
||||
layoutResult <- layoutGraph' layoutParams GVA.Neato graph
|
||||
-- layoutResult <- layoutGraph' layoutParams GVA.Fdp graph
|
||||
return $ placeNodes layoutResult nameDiagramMap edges # connectNodes
|
||||
where
|
||||
layoutParams :: GV.GraphvizParams Int v e () v
|
||||
|
Loading…
Reference in New Issue
Block a user