initial work for svgDrawEdge

elm.json

@@ -21,7 +21,7 @@
             "elm-community/intdict": "3.0.0",
             "elm-community/list-extra": "8.2.4",
             "elm-community/random-extra": "3.1.0",
-            "elm-community/typed-svg": "6.0.0",
+            "elm-community/typed-svg": "7.0.0",
             "fapian/elm-html-aria": "1.4.0",
             "folkertdev/one-true-path-experiment": "5.0.2",
             "gampleman/elm-visualization": "2.1.2"

examples/Test.elm

@@ -6,6 +6,8 @@ import Html
 import Render as R
 import Render.StandardDrawers as DRD
 import Render.StandardDrawers.Attributes as RSDA
+import Render.StandardDrawers.Types as RSDT
+import TypedSvg.Types as TT
 
 
 
@@ -64,5 +66,13 @@ main =
                 -- , RSDA.label (\n -> String.fromInt (n.id + )
                 ]
             )
+        , R.edgeDrawer
+            (DRD.svgDrawEdge
+                [ RSDA.arrowHead RSDT.Triangle
+                , RSDA.strokeWidth (\_ -> TT.Px 5)
+                , RSDA.label (\e -> String.fromInt e.from ++ " to " ++ String.fromInt e.to)
+                ]
+            )
+        , R.style "height: 100vh;"
         ]
         tree

src/Render.elm

@@ -105,45 +105,13 @@ edgeDrawing edge_ drawEdge_ coordDict controlPointsDict =
     drawEdge_ (EdgeAttributes edge_ sourcePos targetPos ctrlPts)
 
 
-getCoordDict : List DA.Attribute -> Graph n e -> D.GraphLayout
-getCoordDict edits graph =
-    D.runLayout edits graph
-
-
-getCanvasSize : Dict.Dict G.NodeId ( Float, Float ) -> ( ( Float, Float ), ( Float, Float ) )
-getCanvasSize coordDict =
-    let
-        coords =
-            Dict.values coordDict
-
-        xCoords =
-            List.map (\( x, _ ) -> x) coords
-
-        yCoords =
-            List.map (\( _, y ) -> y) coords
-
-        minX =
-            Maybe.withDefault -100.0 (List.minimum xCoords) - 100
-
-        minY =
-            Maybe.withDefault -100.0 (List.minimum yCoords) - 100
-
-        maxX =
-            Maybe.withDefault 200.0 (List.maximum xCoords)
-
-        maxY =
-            Maybe.withDefault 400.0 (List.maximum yCoords)
-    in
-    ( ( minX, minY ), ( maxX - minX + 100, maxY - minY + 100 ) )
-
-
 
 {- defualt config for the draw function -}
 
 
 defDrawConfig : DrawConfig n e msg
 defDrawConfig =
-    { edgeDrawer = DRD.svgDrawEdge2 []
+    { edgeDrawer = DRD.svgDrawEdge []
     , nodeDrawer = DRD.svgDrawNode []
     , style = ""
     }
@@ -172,8 +140,6 @@ draw edits1 edits2 graph =
         { width, height, coordDict, controlPtsDict } =
             D.runLayout edits1 graph
 
-        -- ( ( minX, minY ), ( w, h ) ) =
-        --     getCanvasSize coordDict
         dagreConfig =
             List.foldl (\f a -> f a) D.defaultConfig edits1
 
@@ -187,15 +153,11 @@ draw edits1 edits2 graph =
             g [ class [ "nodes" ] ] <| List.map (\n -> nodeDrawing n drawConfig.nodeDrawer coordDict dagreConfig) <| G.nodes graph
     in
     TS.svg
-        [ --   TA.width (Px w)
-          -- , TA.height (Px h)
-          TA.viewBox 0 0 width height
-        , TA.style "height: 100vh;"
-
-        -- , TA.display DisplayInline
+        [ TA.viewBox 0 0 width height
+        , TA.style drawConfig.style
         ]
         [ TS.defs [] [ triangleHeadElement, veeHeadElement ]
-        , g [] [ edgesSvg, nodesSvg ]
+        , g [ TA.id "graph0" ] [ edgesSvg, nodesSvg ]
         ]
 
 
@@ -233,15 +195,17 @@ triangleHeadElement : Svg msg
 triangleHeadElement =
     TS.marker
         [ TA.id "triangle-head"
-        , TA.markerWidth <| Px 10
-        , TA.markerHeight <| Px 10
+        , TA.viewBox 0 0 9 6
+        , TA.markerWidth <| Px 4
+        , TA.markerHeight <| Px 4
         , TA.refX "16"
         , TA.refY "3"
         , TA.orient "auto"
         , TA.markerUnits MarkerCoordinateSystemStrokeWidth
         ]
         [ TS.path
             [ TA.d "M0,0 L0,6 L9,3 z"
+            , TA.stroke ContextStroke
             ]
             []
         ]
@@ -261,6 +225,7 @@ veeHeadElement =
         [ TS.path
             [ TA.d "M0,0 L4.5,3 L0,6 L9,3 z"
             , TA.fill ContextFill
+            , TA.stroke ContextStroke
             ]
             []
         ]

src/Render/StandardDrawers.elm

@@ -15,6 +15,7 @@ default drawers for the draw function.
 
 -}
 
+import Bootstrap.Accordion exposing (config)
 import Color
 import Curve
 import Graph exposing (Node)
@@ -23,11 +24,12 @@ import Render.StandardDrawers.ConfigTypes exposing (..)
 import Render.StandardDrawers.Types exposing (..)
 import Render.Types exposing (..)
 import SubPath as SP
-import TypedSvg as TS exposing (g, polyline)
-import TypedSvg.Attributes as TA exposing (class, points, stroke, textAnchor, transform)
+import TypedSvg as TS exposing (g)
+import TypedSvg.Attributes as TA
 import TypedSvg.Attributes.InPx exposing (cx, cy, r, x, y)
 import TypedSvg.Core as TC exposing (Svg)
-import TypedSvg.Types
+import TypedSvg.Events as TE
+import TypedSvg.Types as TT
     exposing
         ( AlignmentBaseline(..)
         , AnchorAlignment(..)
@@ -61,7 +63,6 @@ defEdgeDrawerConfig =
     , title = f
     , linkStyle = Spline
     , alpha = 0.5
-    , orientLabelAlongEdge = False
     }
 
 
@@ -88,82 +89,103 @@ defNodeDrawerConfig =
     }
 
 
-svgDrawEdge : EdgeDrawer () msg
-svgDrawEdge edgeAtrib =
-    let
-        edge =
-            edgeAtrib.edge
-
-        ( sourceX, sourceY ) =
-            edgeAtrib.source
+arrowHeadId : ArrowHeadShape -> String
+arrowHeadId ah =
+    case ah of
+        None ->
+            ""
 
-        ( targetX, targetY ) =
-            edgeAtrib.target
+        Triangle ->
+            "url(#triangle-head)"
 
-        controlPts =
-            edgeAtrib.controlPts
-    in
-    polyline
-        [ TA.points <| List.concat [ [ ( sourceX, sourceY ) ], controlPts, [ ( targetX, targetY ) ] ]
-        , TA.stroke <| Paint Color.black
-        , TA.strokeWidth <| Px 2
-        , TA.fill PaintNone
-        , TA.markerEnd "url(#triangle-head)"
-        ]
-        []
+        Vee ->
+            "url(#vee-head)"
 
 
-svgDrawEdge2 : List (Attribute (EdgeDrawerConfig e msg)) -> EdgeDrawer e msg
-svgDrawEdge2 edits edgeAtrib =
+svgDrawEdge : List (Attribute (EdgeDrawerConfig e msg)) -> EdgeDrawer e msg
+svgDrawEdge edits edgeAtrib =
     let
         edge =
             edgeAtrib.edge
 
-        ( sourceX, sourceY ) =
-            edgeAtrib.source
-
-        ( targetX, targetY ) =
-            edgeAtrib.target
-
-        controlPts =
-            edgeAtrib.controlPts
-
         config =
             List.foldl (\f a -> f a) defEdgeDrawerConfig edits
 
         curve =
-            Curve.catmullRom config.alpha (List.concat [ [ edgeAtrib.source ], edgeAtrib.controlPts, [ edgeAtrib.target ] ])
+            let
+                pts =
+                    List.concat [ [ edgeAtrib.source ], edgeAtrib.controlPts, [ edgeAtrib.target ] ]
+            in
+            case config.linkStyle of
+                Spline ->
+                    Curve.catmullRom config.alpha pts
 
-        tolerance =
-            1.0e-4
+                Polyline ->
+                    Curve.linear pts
 
-        parameterized =
-            SP.arcLengthParameterized tolerance curve
+        parameterizedCurve =
+            SP.arcLengthParameterized 1.0e-4 curve
 
         ( midX, midY ) =
-            case SP.pointAlong parameterized (SP.arcLength parameterized / 2) of
+            (case SP.pointAlong parameterizedCurve (SP.arcLength parameterizedCurve / 2) of
                 Just m ->
                     m
 
                 Nothing ->
                     ( -10, -10 )
+            )
+                |> Tuple.mapBoth
+                    (\a ->
+                        if isNaN a then
+                            -10
+
+                        else
+                            a
+                    )
+                    (\a ->
+                        if isNaN a then
+                            -10
+
+                        else
+                            a
+                    )
+
+        edge_id =
+            "edge-" ++ String.fromInt edge.from ++ "-" ++ String.fromInt edge.to
+
+        gAtrib =
+            case config.onClick of
+                Nothing ->
+                    [ TA.id edge_id
+                    , TA.class [ "edge" ]
+                    , TA.style <| config.style edge
+                    , TA.markerEnd (arrowHeadId config.arrowHead)
+                    ]
+
+                Just f ->
+                    [ TA.id edge_id
+                    , TA.class [ "edge" ]
+                    , TA.style <| config.style edge
+                    , TA.markerEnd (arrowHeadId config.arrowHead)
+                    , TE.onClick (f edge)
+                    ]
     in
     g
-        []
+        gAtrib
         [ TS.title [] [ TC.text <| config.title edge ]
         , TS.path
-            [ TA.d <| SP.toString curve
-
-            -- [ DRI.spline 0.2 ( sourceX, sourceY ) ( targetX, targetY ) controlPts
+            [ TA.id (edge_id ++ "-path")
+            , TA.d <| SP.toString curve
             , TA.stroke <| config.strokeColor edge
             , TA.strokeWidth <| config.strokeWidth edge
+            , TA.strokeDasharray <| config.strokeDashArray edge
             , TA.fill (config.fill edge)
-            , TA.markerEnd "url(#vee-head)"
             ]
             []
         , TS.text_
-            [ textAnchor AnchorMiddle
-            , transform [ Translate midX (midY + 5) ]
+            [ TA.textAnchor AnchorMiddle
+            , TA.alignmentBaseline AlignmentCentral
+            , TA.transform [ Translate midX midY ]
             ]
             [ TC.text (config.label edge) ]
         ]
@@ -204,8 +226,9 @@ svgDrawNode edits nodeAtrib =
             ]
             []
         , TS.text_
-            [ textAnchor AnchorMiddle
-            , transform [ Translate posX (posY + 5) ]
+            [ TA.textAnchor AnchorMiddle
+            , TA.alignmentBaseline AlignmentCentral
+            , TA.transform [ Translate posX posY ]
             ]
             [ TC.text lbl ]
         , xLabelDrawer (config.xLabel node) config.xLabelPos nodeAtrib
@@ -225,8 +248,9 @@ xLabelDrawer lbl xLabelPos nodeAtrib =
             ( posX + xPosX, posY + xPosY )
     in
     TS.text_
-        [ textAnchor AnchorMiddle
-        , transform [ Translate xlPosX xlPosY ]
+        [ TA.textAnchor AnchorMiddle
+        , TA.alignmentBaseline AlignmentCentral
+        , TA.transform [ Translate xlPosX xlPosY ]
         ]
         [ TC.text lbl
         ]

src/Render/StandardDrawers/Attributes.elm

@@ -27,7 +27,7 @@ The following attributes can be used both on Node and Edge Drawers.
 
 import Graph exposing (Node)
 import Render.StandardDrawers.ConfigTypes exposing (..)
-import Render.StandardDrawers.Types as RSDT exposing (..)
+import Render.StandardDrawers.Types exposing (ArrowHeadShape, LinkStyle, Shape)
 import TypedSvg.Types exposing (Length(..), Paint(..))
 
 
@@ -156,9 +156,11 @@ alpha a =
         { edc | alpha = a }
 
 
-{-| To set the label orientation along the curvature of edge
--}
-orientLabelAlongEdge : Bool -> Attribute (EdgeDrawerConfig e msg)
-orientLabelAlongEdge b =
-    \edc ->
-        { edc | orientLabelAlongEdge = b }
+
+-- Need to look into this, lay edge labels along the curvature
+-- {-| To set the label orientation along the curvature of edge
+-- -}
+-- orientLabelAlongEdge : Bool -> Attribute (EdgeDrawerConfig e msg)
+-- orientLabelAlongEdge b =
+--     \edc ->
+--         { edc | orientLabelAlongEdge = b }

src/Render/StandardDrawers/ConfigTypes.elm

@@ -29,7 +29,6 @@ type alias EdgeDrawerConfig e msg =
     , title : Edge e -> String
     , linkStyle : LinkStyle
     , alpha : Float
-    , orientLabelAlongEdge : Bool
     }
 
 

src/Render/StandardDrawers/Types.elm

@@ -31,6 +31,7 @@ type LinkStyle
 
 
 {-| This type represents the shape of node.
+_Note_ : RoundedBox takes radius of curvature in px as parameter
 -}
 type Shape
     = Circle