diff --git a/README.md b/README.md index b41dca7..6516beb 100644 --- a/README.md +++ b/README.md @@ -31,12 +31,7 @@ elm-doc-preview ## TODO -- Capture L2W transformation when events are declared, not when they are - attached to objects. -- Text. -- "Bake" node. -- Refactor to separate out styles and events stuff from the huge main file. -- Use a non-recursive traversal of the graph. -- Need a way to draw items in world coordinates. -- Arrow heads. -- More examples. \ No newline at end of file +- Events. +- Baked nodes (with ID for ``). +- Simple text. +- Elmtris. \ No newline at end of file diff --git a/elm.json b/elm.json index 314b179..b4591b9 100644 --- a/elm.json +++ b/elm.json @@ -5,26 +5,40 @@ "license": "BSD-3-Clause", "version": "1.0.0", "exposed-modules": [ - "Techdraw", - "Techdraw.Math", - "Techdraw.Path", - "Techdraw.PathBuilder", - "Techdraw.Shapes.Simple", - "Techdraw.Shapes.Spring", - "Techdraw.Svg.SvgStringPath", - "Techdraw.Widgets.DragPt" + "Depict", + "Depict.Event", + "Depict.Math", + "Depict.Path", + "Depict.PathBuilder", + "Depict.Style", + "Depict.Types", + "Depict.Shapes.Simple", + "Depict.Shapes.Spring", + "Depict.Internal.CSysDict", + "Depict.Internal.Dwg", + "Depict.Internal.Hash", + "Depict.Internal.StyleAtom", + "Depict.Internal.Svg.Defs", + "Depict.Internal.Svg.Env", + "Depict.Internal.Svg.Event", + "Depict.Internal.Svg.Extras", + "Depict.Internal.Svg.Machine", + "Depict.Internal.Svg.Path", + "Depict.Internal.Svg.Style" ], "source-directories": ["src"], "elm-version": "0.19.1 <= v < 0.20.0", "dependencies": { "avh4/elm-color": "1.0.0 <= v < 2.0.0", + "elm/bytes": "1.0.0 <= v < 2.0.0", "elm/core": "1.0.0 <= v < 2.0.0", "elm/html": "1.0.0 <= v < 2.0.0", "elm/json": "1.1.3 <= v < 2.0.0", "elm/virtual-dom": "1.0.3 <= v < 2.0.0", "elm-community/easing-functions": "2.0.0 <= v <= 3.0.0", "elm-community/typed-svg": "7.0.0 <= v < 8.0.0", - "mgold/elm-nonempty-list": "4.2.0 <= v < 5.0.0" + "mgold/elm-nonempty-list": "4.2.0 <= v < 5.0.0", + "TSFoster/elm-sha1": "2.0.0 <= v <= 3.0.0" }, "test-dependencies": { "elm-explorations/test": "2.2.0 <= v < 3.0.0" diff --git a/examples/hello-spring/src/Main.elm b/examples/hello-spring/src/Main.elm deleted file mode 100644 index 0bb6795..0000000 --- a/examples/hello-spring/src/Main.elm +++ /dev/null @@ -1,96 +0,0 @@ -module Main exposing (..) - -{-| Draw an interactive spring! - --} - -import Browser -import Color -import Html exposing (Html) -import Techdraw as TD exposing (Drawing) -import Techdraw.Math as Math -import Techdraw.Shapes.Spring exposing (spring) -import Techdraw.Widgets.DragPt as DragPt -import TypedSvg.Types - exposing - ( Paint(..) - , StrokeLinecap(..) - , StrokeLinejoin(..) - ) - - -type Model - = Model - { pt1 : DragPt.Model - , pt2 : DragPt.Model - } - - -type Msg - = MsgPt1 DragPt.Msg - | MsgPt2 DragPt.Msg - - -init : Model -init = - Model - { pt1 = DragPt.init DragPt.defaultStyle (Math.p2 50 300) - , pt2 = DragPt.init DragPt.defaultStyle (Math.p2 550 300) - } - - -drawing : Model -> Drawing Msg -drawing (Model model) = - TD.group - [ TD.path - (spring - { start = model.pt1.location - , end = model.pt2.location - , restLength = 500 - , restCoilHeight = 20 - , restCoilWidth = 300 - , coilCount = 10 - , minEndLength = 10 - , minCoilAngleDeg = 10 - , maxCoilAngleDeg = 88 - } - ) - |> TD.fill PaintNone - |> TD.stroke (Paint Color.black) - |> TD.strokeWidth 2 - |> TD.strokeLinecap StrokeLinecapButt - |> TD.strokeLinejoin StrokeLinejoinRound - , DragPt.view model.pt1 |> TD.map MsgPt1 - , DragPt.view model.pt2 |> TD.map MsgPt2 - ] - - -view : Model -> Html Msg -view model = - let - viewBox = - { minX = 0 - , minY = 0 - , width = 600 - , height = 600 - } - in - Html.div [] [ drawing model |> TD.render viewBox ] - - -update : Msg -> Model -> Model -update msg (Model model) = - case msg of - MsgPt1 p1msg -> - Model { model | pt1 = DragPt.updateModel p1msg model.pt1 } - - MsgPt2 p2msg -> - Model { model | pt2 = DragPt.updateModel p2msg model.pt2 } - - -main = - Browser.sandbox - { init = init - , view = view - , update = update - } diff --git a/examples/hello-spring/elm.json b/examples/hello-world/elm.json similarity index 77% rename from examples/hello-spring/elm.json rename to examples/hello-world/elm.json index 8424a4d..edc6a9c 100644 --- a/examples/hello-spring/elm.json +++ b/examples/hello-world/elm.json @@ -7,19 +7,23 @@ "elm-version": "0.19.1", "dependencies": { "direct": { + "TSFoster/elm-sha1": "2.1.1", "avh4/elm-color": "1.0.0", "elm/browser": "1.0.2", + "elm/bytes": "1.0.8", "elm/core": "1.0.5", "elm/html": "1.0.0", "elm/json": "1.1.3", - "elm/virtual-dom": "1.0.3", "elm-community/typed-svg": "7.0.0", "mgold/elm-nonempty-list": "4.2.0" }, "indirect": { + "danfishgold/base64-bytes": "1.1.0", "elm/random": "1.0.0", "elm/time": "1.0.0", - "elm/url": "1.0.0" + "elm/url": "1.0.0", + "elm/virtual-dom": "1.0.3", + "rtfeldman/elm-hex": "1.0.0" } }, "test-dependencies": { diff --git a/examples/hello-world/src/Main.elm b/examples/hello-world/src/Main.elm new file mode 100644 index 0000000..cf7950b --- /dev/null +++ b/examples/hello-world/src/Main.elm @@ -0,0 +1,291 @@ +module Main exposing (main) + +import Browser +import Color +import Depict as TD exposing (Drawing) +import Depict.Event exposing (MouseInfo(..)) +import Depict.Math as Math exposing (P2, p2) +import Depict.Shapes.Simple exposing (circle, rectRounded) +import Depict.Style as Style exposing (LinearGradient, Stop(..)) +import Depict.Types as TT +import Html exposing (Html) +import Html.Attributes as HA +import Html.Events as HE + + +type Model + = Model + { translateX : Float + , translateY : Float + , rotate : Float + , scaleX : Float + , scaleY : Float + , skewX : Float + , coords : Maybe P2 + } + + +type Msg + = MsgReset + | MsgTranslateXChanged Float + | MsgTranslateYChanged Float + | MsgRotateChanged Float + | MsgScaleXChanged Float + | MsgScaleYChanged Float + | MsgSkewXChanged Float + | MsgMouseMove P2 + + +init : Model +init = + Model + { translateX = 0 + , translateY = 0 + , rotate = 0 + , scaleX = 1 + , scaleY = 1 + , skewX = 0 + , coords = Nothing + } + + +drawingWidth = + 600 + + +drawingHeight = + 400 + + +halfWidth = + drawingWidth / 2 + + +halfHeight = + drawingHeight / 2 + + +circleRadius = + 0.2 * min drawingWidth drawingHeight + + + +-- Bottom-left: Red +-- Top-right: Green + + +lg : LinearGradient +lg = + Style.linearGradient + { start = p2 (halfWidth - circleRadius) (halfHeight - circleRadius) + , end = p2 (halfWidth + circleRadius) (halfHeight + circleRadius) + , transform = Math.affIdentity + , gradient = + Style.gradient + [ Stop 0 Color.red + , Stop 1 Color.green + ] + } + + +rectStyle : Drawing msg -> Drawing msg +rectStyle = + TD.fill (Style.PaintLinearGradient lg) + >> TD.stroke (Style.Paint Color.black) + >> TD.strokeWidth 8 + + +rectTransform : Model -> Drawing msg -> Drawing msg +rectTransform (Model model) = + (TD.translate (Math.v2 -halfWidth -halfHeight) + >> TD.scale model.scaleX model.scaleY + >> TD.skewXDegrees model.skewX + >> TD.translate (Math.v2 halfWidth halfHeight) + ) + >> TD.translate (Math.v2 model.translateX model.translateY) + >> TD.rotateDegreesAbout model.rotate (Math.p2 halfWidth halfHeight) + + +drawing : Model -> Drawing Msg +drawing (Model model) = + TD.stack TT.BottomToTop + [ TD.path + (rectRounded + { x = halfWidth - circleRadius + , y = halfHeight - circleRadius + , width = 2 * circleRadius + , height = 2 * circleRadius + , rx = 0.2 * circleRadius + , ry = 0.2 * circleRadius + } + ) + |> rectStyle + |> TD.freeze TT.Hidden (Just (TT.FrozenName "frozen_rect")) + , TD.path + (rectRounded + { x = halfWidth - (1 - 0.2) * circleRadius + , y = halfHeight - (1 - 0.2) * circleRadius + , width = (2 * (1 - 0.2)) * circleRadius + , height = (2 * (1 - 0.2)) * circleRadius + , rx = 0.2 * circleRadius + , ry = 0.2 * circleRadius + } + ) + |> rectStyle + , TD.stack + TT.TopToBottom + [ TD.use (TT.FrozenName "frozen_rect") + |> TD.translate (Math.v2 (2 * circleRadius + 10) 0) + , TD.use (TT.FrozenName "frozen_rect") + |> TD.translate (Math.v2 -(2 * circleRadius + 10) 0) + ] + |> TD.freeze TT.Visible (Just (TT.FrozenName "rect_pair")) + , TD.stack TT.TopToBottom + [ TD.use (TT.FrozenName "rect_pair") + , TD.use (TT.FrozenName "frozen_rect") + ] + |> TD.freeze TT.Visible (Just (TT.FrozenName "triple")) + |> TD.translate (Math.v2 0 (2 * circleRadius + 10)) + , TD.use (TT.FrozenName "triple") + |> TD.translate (Math.v2 0 -(2 * circleRadius + 10)) + , case model.coords of + Nothing -> + TD.empty + + Just p -> + TD.path + (circle + { cx = Math.p2x p + , cy = Math.p2y p + , r = 0.1 * circleRadius + } + ) + |> TD.fill (Style.Paint Color.red) + ] + |> TD.tagCSys (TT.CSysName "original") + |> rectTransform (Model model) + |> TD.freeze TT.Visible Nothing + |> TD.onHostMouseMove + (\(MouseInfo mouseInfo) -> + mouseInfo.pointIn (TT.CSysName "original") |> MsgMouseMove + ) + + +view : Model -> Html Msg +view (Model model) = + Html.div [] + [ Html.div [] + [ drawing (Model model) + |> TD.toSvg (TT.sizingWH drawingWidth drawingHeight) + ] + , drawSlider "TranslateX" + model.translateX + ( -100, 100 ) + MsgTranslateXChanged + , drawSlider "TranslateY" + model.translateY + ( -100, 100 ) + MsgTranslateYChanged + , drawSlider "Rotation" + model.rotate + ( -360, 360 ) + MsgRotateChanged + , drawSlider "ScaleX" + model.scaleX + ( 0.1, 2 ) + MsgScaleXChanged + , drawSlider "ScaleY" + model.scaleY + ( 0.1, 2 ) + MsgScaleYChanged + , drawSlider "SkewX" + model.skewX + ( -80, 80 ) + MsgSkewXChanged + , Html.div + [ HA.style "display" "inline-block" + , HA.style "width" "8em" + , HA.style "text-align" "right" + , HA.style "margin-top" "10px" + ] + [ Html.button + [ HE.onClick MsgReset + ] + [ Html.text "Reset" + ] + ] + ] + + +drawSlider : String -> Float -> ( Float, Float ) -> (Float -> Msg) -> Html Msg +drawSlider title value ( minValue, maxValue ) createMessage = + Html.div + [ HA.style "display" "flex" + , HA.style "align-items" "center" + ] + [ Html.p + [ HA.style "display" "inline-block" + , HA.style "min-width" "8em" + , HA.style "max-width" "8em" + , HA.style "width" "8em" + , HA.style "text-align" "right" + , HA.style "padding-right" "10px" + , HA.style "font-family" "sans-serif" + , HA.style "margin" "0.3ex" + ] + [ Html.text title + ] + , Html.input + [ HA.type_ "range" + , HA.min (String.fromFloat minValue) + , HA.max (String.fromFloat maxValue) + , HA.step (String.fromFloat (0.001 * (maxValue - minValue))) + , HA.style "display" "inline-block" + , HA.style "min-width" "400px" + , HA.style "max-width" "400px" + , HA.style "width" "400px" + , HA.value (String.fromFloat value) + , HE.onInput + (String.toFloat + >> Maybe.withDefault 0 + >> createMessage + ) + ] + [] + ] + + +update : Msg -> Model -> Model +update message (Model model) = + case message of + MsgReset -> + init + + MsgTranslateXChanged tx -> + Model { model | translateX = tx } + + MsgTranslateYChanged ty -> + Model { model | translateY = ty } + + MsgRotateChanged angleDeg -> + Model { model | rotate = angleDeg } + + MsgScaleXChanged scaleX -> + Model { model | scaleX = scaleX } + + MsgScaleYChanged scaleY -> + Model { model | scaleY = scaleY } + + MsgSkewXChanged angleDeg -> + Model { model | skewX = angleDeg } + + MsgMouseMove p -> + Model { model | coords = Just p } + + +main = + Browser.sandbox + { init = init + , view = view + , update = update + } diff --git a/examples/spring-carts/elm.json b/examples/spring-carts/elm.json deleted file mode 100644 index 8424a4d..0000000 --- a/examples/spring-carts/elm.json +++ /dev/null @@ -1,29 +0,0 @@ -{ - "type": "application", - "source-directories": [ - "src", - "../../src" - ], - "elm-version": "0.19.1", - "dependencies": { - "direct": { - "avh4/elm-color": "1.0.0", - "elm/browser": "1.0.2", - "elm/core": "1.0.5", - "elm/html": "1.0.0", - "elm/json": "1.1.3", - "elm/virtual-dom": "1.0.3", - "elm-community/typed-svg": "7.0.0", - "mgold/elm-nonempty-list": "4.2.0" - }, - "indirect": { - "elm/random": "1.0.0", - "elm/time": "1.0.0", - "elm/url": "1.0.0" - } - }, - "test-dependencies": { - "direct": {}, - "indirect": {} - } -} diff --git a/examples/spring-carts/src/Main.elm b/examples/spring-carts/src/Main.elm deleted file mode 100644 index dfecbdf..0000000 --- a/examples/spring-carts/src/Main.elm +++ /dev/null @@ -1,629 +0,0 @@ -module Main exposing (..) - -{-| Draw a spring-cart system. - --} - -import Array exposing (Array) -import Browser -import Browser.Events exposing (onAnimationFrameDelta) -import Color exposing (Color) -import Html exposing (Html) -import Techdraw as TD exposing (Drawing) -import Techdraw.Math as M exposing (P2) -import Techdraw.PathBuilder as PB -import Techdraw.Shapes.Simple exposing (circle, rect) -import Techdraw.Shapes.Spring exposing (spring) -import TypedSvg.Types exposing (Paint(..), StrokeLinejoin(..)) - - -type Model - = Model - { dragging : Maybe ( Int, P2 ) - , cartOver : Maybe Int - , cartState : CartState - } - - -type Msg - = MsgCartEnter Int - | MsgCartLeave - | MsgStartDrag Int P2 - | MsgMidDrag P2 - | MsgEndDrag - | MsgAnimFrame Float - - -init : Model -init = - Model - { dragging = Nothing - , cartOver = Nothing - , cartState = - initCartState - { cart1X = 0 - , cart2X = 0 - , cart3X = 0 - , cart1V = 0 - , cart2V = 0 - , cart3V = 0 - } - } - - -cartColor : Int -> Model -> Color -cartColor i (Model model) = - let - nonDraggingColor : () -> Color - nonDraggingColor _ = - case model.cartOver of - Just j -> - if i == j then - Color.lightGreen - - else - Color.lightGray - - Nothing -> - Color.lightGray - in - case model.dragging of - Just ( j, _ ) -> - if i == j then - Color.lightOrange - - else - Color.lightGray - - Nothing -> - nonDraggingColor () - - -cart1Start = - 200 - - -cart2Start = - 400 - - -cart3Start = - 600 - - -drawing : Model -> Drawing Msg -drawing (Model model) = - let - groundY = - 60 - - cart1Fill = - cartColor 1 (Model model) - - cart2Fill = - cartColor 2 (Model model) - - cart3Fill = - cartColor 3 (Model model) - - cart1x = - csGetCart1X model.cartState + cart1Start - - cart2x = - csGetCart2X model.cartState + cart2Start - - cart3x = - csGetCart3X model.cartState + cart3Start - in - TD.group - [ TD.tagCSys (TD.CSysName "drawing") - - -- Ground plane - , TD.path (rect { x = 50, y = groundY - 15, width = 720, height = 15 }) - |> TD.fill (Paint Color.gray) - , TD.path - (PB.empty - |> PB.moveTo ( 50, groundY ) - |> PB.lineTo ( 770, groundY ) - |> PB.createPath - ) - |> TD.stroke (Paint Color.black) - |> TD.strokeWidth 3 - - -- Left wall - , TD.path (rect { x = 80 - 15, y = 180, width = 15, height = 270 - 180 }) - |> TD.fill (Paint Color.gray) - , TD.path - (PB.empty - |> PB.moveTo ( 80, 180 ) - |> PB.lineTo ( 80, 270 ) - |> PB.createPath - ) - |> TD.stroke (Paint Color.black) - |> TD.strokeWidth 3 - , TD.dropAnchor "wall.right" ( 80, (270 + 180) / 2 ) - - -- Carts - , cart { height = 250, fillColor = cart1Fill } - |> TD.translate ( cart1x, groundY ) - |> TD.prependAnchorNamespace "cart1" - |> TD.onMouseEnter (\_ -> MsgCartEnter 1) - |> TD.onMouseLeave (\_ -> MsgCartLeave) - |> TD.onMouseDown (\minfo -> MsgStartDrag 1 (minfo.pointIn <| TD.CSysName "drawing")) - , cart { height = 150, fillColor = cart2Fill } - |> TD.translate ( cart2x, groundY ) - |> TD.prependAnchorNamespace "cart2" - |> TD.onMouseEnter (\_ -> MsgCartEnter 2) - |> TD.onMouseLeave (\_ -> MsgCartLeave) - |> TD.onMouseDown (\minfo -> MsgStartDrag 2 (minfo.pointIn <| TD.CSysName "drawing")) - , cart { height = 250, fillColor = cart3Fill } - |> TD.translate ( cart3x, groundY ) - |> TD.prependAnchorNamespace "cart3" - |> TD.onMouseEnter (\_ -> MsgCartEnter 3) - |> TD.onMouseLeave (\_ -> MsgCartLeave) - |> TD.onMouseDown (\minfo -> MsgStartDrag 3 (minfo.pointIn <| TD.CSysName "drawing")) - - -- Springs - , TD.weighAnchors - (\getAnchor -> - let - ( cart1LeftX, _ ) = - getAnchor "cart1.left" - - ( cart1RightX, _ ) = - getAnchor "cart1.right" - - ( cart2LeftX, _ ) = - getAnchor "cart2.left" - - ( cart2RightX, _ ) = - getAnchor "cart2.right" - - ( cart3LeftX, _ ) = - getAnchor "cart3.left" - - ( wallRightX, wallRightY ) = - getAnchor "wall.right" - in - TD.group - [ TD.path - (spring - { start = M.p2 cart1RightX 290 - , end = M.p2 cart3LeftX 290 - , restLength = 400 - , restCoilHeight = 15 - , restCoilWidth = 200 - , coilCount = 8 - , minEndLength = 5 - , minCoilAngleDeg = 5 - , maxCoilAngleDeg = 88 - } - ) - |> TD.fill PaintNone - |> TD.stroke (Paint Color.black) - |> TD.strokeWidth 2 - |> TD.strokeLinejoin StrokeLinejoinRound - , TD.path - (spring - { start = M.p2 cart1RightX 160 - , end = M.p2 cart2LeftX 160 - , restLength = 200 - , restCoilHeight = 15 - , restCoilWidth = 100 - , coilCount = 4 - , minEndLength = 5 - , minCoilAngleDeg = 5 - , maxCoilAngleDeg = 88 - } - ) - |> TD.fill PaintNone - |> TD.stroke (Paint Color.black) - |> TD.strokeWidth 2 - |> TD.strokeLinejoin StrokeLinejoinRound - , TD.path - (spring - { start = M.p2 cart2RightX 160 - , end = M.p2 cart3LeftX 160 - , restLength = 200 - , restCoilHeight = 15 - , restCoilWidth = 100 - , coilCount = 4 - , minEndLength = 5 - , minCoilAngleDeg = 5 - , maxCoilAngleDeg = 88 - } - ) - |> TD.fill PaintNone - |> TD.stroke (Paint Color.black) - |> TD.strokeWidth 2 - |> TD.strokeLinejoin StrokeLinejoinRound - , TD.path - (spring - { start = M.p2 wallRightX wallRightY - , end = M.p2 cart1LeftX wallRightY - , restLength = 150 - , restCoilHeight = 15 - , restCoilWidth = 100 - , coilCount = 3 - , minEndLength = 5 - , minCoilAngleDeg = 5 - , maxCoilAngleDeg = 88 - } - ) - |> TD.fill PaintNone - |> TD.stroke (Paint Color.black) - |> TD.strokeWidth 2 - |> TD.strokeLinejoin StrokeLinejoinRound - ] - ) - ] - |> (\dwg -> - case model.dragging of - Nothing -> - dwg - - Just _ -> - dwg - |> TD.onHostMouseUp (\_ -> MsgEndDrag) - |> TD.onHostMouseLeave (\_ -> MsgEndDrag) - |> TD.onHostMouseMove - (\minfo -> - if minfo.buttons.button1 == TD.MouseButtonPressed then - MsgMidDrag <| minfo.pointIn <| TD.CSysName "drawing" - - else - MsgEndDrag - ) - ) - - -view : Model -> Html Msg -view model = - let - (Model m) = - model - - viewBox = - { minX = 0 - , minY = 0 - , width = 800 - , height = 400 - } - in - Html.div [] - [ drawing model |> TD.render viewBox ] - - -update : Msg -> Model -> Model -update msg (Model model) = - case msg of - MsgCartEnter i -> - Model { model | cartOver = Just i } - - MsgCartLeave -> - Model { model | cartOver = Nothing } - - MsgStartDrag i p -> - Model - { model - | dragging = Just ( i, p ) - } - - MsgMidDrag p -> - let - ( i, _ ) = - Maybe.withDefault ( 1, M.p2 0 0 ) model.dragging - in - Model - { model - | dragging = Just ( i, p ) - } - - MsgEndDrag -> - Model - { model - | dragging = Nothing - } - - MsgAnimFrame dt -> - let - -- Stop large jumps when the window loses focus. - clampedDt = - clamp 0 100 dt - in - Model - { model - | cartState = - updateCartState - model.dragging - clampedDt - model.cartState - } - - -main = - Browser.element - { init = \() -> ( init, Cmd.none ) - , view = view - , update = \msg model -> ( update msg model, Cmd.none ) - , subscriptions = - \_ -> - Sub.batch - [ onAnimationFrameDelta MsgAnimFrame - ] - } - - - ----- Drawing a Cart ----------------------------------------------------------- - - -cart : - { height : Float - , fillColor : Color - } - -> Drawing msg -cart r = - let - wheelRadius = - 8 - - baseWidth = - 50 - - memberWidth = - 15 - - wheel = - TD.path - (circle - { cx = 0 - , cy = 0 - , r = wheelRadius - } - ) - |> TD.fill PaintNone - |> TD.stroke (Paint Color.black) - |> TD.strokeWidth 2 - in - TD.group - [ TD.group - [ wheel |> TD.translate ( -baseWidth / 2 + wheelRadius, 0 ) - , wheel |> TD.translate ( baseWidth / 2 - wheelRadius, 0 ) - ] - |> TD.translate ( 0, wheelRadius ) - , TD.path - (PB.empty - |> PB.moveTo ( -baseWidth / 2, 0 ) - |> PB.lineTo ( baseWidth / 2, 0 ) - |> PB.lineTo ( baseWidth / 2, memberWidth ) - |> PB.lineTo ( memberWidth / 2, memberWidth ) - |> PB.lineTo ( memberWidth / 2, r.height ) - |> PB.lineTo ( -memberWidth / 2, r.height ) - |> PB.lineTo ( -memberWidth / 2, memberWidth ) - |> PB.lineTo ( -baseWidth / 2, memberWidth ) - |> PB.close - |> PB.createPath - ) - |> TD.fill (Paint r.fillColor) - |> TD.stroke (Paint Color.black) - |> TD.strokeWidth 2 - |> TD.translate ( 0, 2 * wheelRadius ) - , TD.dropAnchor "left" ( -memberWidth / 2, 0 ) - , TD.dropAnchor "right" ( memberWidth / 2, 0 ) - ] - - - ----- CartState ---------------------------------------------------------------- - - -type CartState - = CartState (Array Float) - - -initCartState : - { cart1X : Float - , cart2X : Float - , cart3X : Float - , cart1V : Float - , cart2V : Float - , cart3V : Float - } - -> CartState -initCartState r = - CartState <| - Array.fromList - [ r.cart1X - , r.cart2X - , r.cart3X - , r.cart1V - , r.cart2V - , r.cart3V - ] - - -csGetCart1X : CartState -> Float -csGetCart1X cs = - csGet 0 cs - - -csGetCart2X : CartState -> Float -csGetCart2X cs = - csGet 1 cs - - -csGetCart3X : CartState -> Float -csGetCart3X cs = - csGet 2 cs - - -csGetCart1V : CartState -> Float -csGetCart1V cs = - csGet 3 cs - - -csGetCart2V : CartState -> Float -csGetCart2V cs = - csGet 4 cs - - -csGetCart3V : CartState -> Float -csGetCart3V cs = - csGet 5 cs - - -csGet : Int -> CartState -> Float -csGet i (CartState s) = - Array.get i s |> Maybe.withDefault 0 - - -csSet : Int -> Float -> CartState -> CartState -csSet i x (CartState s) = - CartState <| Array.set i x s - - -updateCartState : Maybe ( Int, P2 ) -> Float -> CartState -> CartState -updateCartState maybeDragInfo dt cs = - let - k = - 2.0e-5 - - c = - 4.5e-4 - - k1 = - k * 3 - - k2 = - k - - k3 = - k * 0.3 - - k4 = - k * 0.3 - - c1 = - c * 2 - - c2 = - c - - c3 = - c - - c4 = - c * 0.6 - - m = - 0.2 - - ( u1, u2, u3 ) = - ( csGetCart1X cs, csGetCart2X cs, csGetCart3X cs ) - - ( v1, v2, v3 ) = - ( csGetCart1V cs, csGetCart2V cs, csGetCart3V cs ) - - f1Internal = - (-k1 - k2 - k3) * u1 + k3 * u2 + k2 * u3 + (-c1 - c2 - c3) * v1 + c3 * v2 + c2 * v3 - - f2Internal = - k3 * u1 + (-k3 - k4) * u2 + k4 * u3 + c3 * v1 + (-c3 - c4) * v2 + c4 * v3 - - f3Internal = - k2 * u1 + k4 * u2 + (-k2 - k4) * u3 + c2 * v1 + c4 * v2 + (-c2 - c4) * v3 - - ( f1, f2, f3 ) = - case maybeDragInfo of - Nothing -> - ( 0, 0, 0 ) - - Just ( i, p ) -> - let - cartX = - csGet (i - 1) cs - + (case i of - 1 -> - cart1Start - - 2 -> - cart2Start - - 3 -> - cart3Start - - _ -> - 0 - ) - - dx = - M.p2x p - cartX - - kDrag = - 0.000015 - - f = - kDrag * dx - in - case i of - 1 -> - ( f, 0, 0 ) - - 2 -> - ( 0, f, 0 ) - - 3 -> - ( 0, 0, f ) - - _ -> - ( 0, 0, 0 ) - - accel = - initCartState - { cart1X = csGetCart1V cs - , cart2X = csGetCart2V cs - , cart3X = csGetCart3V cs - , cart1V = (f1 + f1Internal) / m - , cart2V = (f2 + f2Internal) / m - , cart3V = (f3 + f3Internal) / m - } - in - step cartStateNIType dt accel cs - - -cartStateNIType : NIType CartState -cartStateNIType = - NIType - { scale = - \s (CartState cs) -> - cs - |> Array.toList - |> List.map (\x -> s * x) - |> Array.fromList - |> CartState - , add = - \(CartState l) (CartState r) -> - List.map2 - (\lx rx -> lx + rx) - (Array.toList l) - (Array.toList r) - |> Array.fromList - |> CartState - } - - - ----- Numerical Integration ---------------------------------------------------- - - -type NIType a - = NIType - { scale : Float -> a -> a - , add : a -> a -> a - } - - -step : NIType a -> Float -> a -> a -> a -step (NIType ops) dt accel x = - ops.add x (ops.scale dt accel) diff --git a/src/Depict.elm b/src/Depict.elm new file mode 100644 index 0000000..8dd1abe --- /dev/null +++ b/src/Depict.elm @@ -0,0 +1,520 @@ +module Depict exposing + ( Drawing + , empty, path, atop, beneath, stack + , fill, fillRule, stroke, strokeWidth, lineCap, lineJoin + , dashArray, dashOffset + , transform, translate, rotateDegrees, rotateDegreesAbout + , skewXDegrees, scale + , freeze, use + , onEvent + , onMouseClick, onMouseContextMenu, onMouseDblClick, onMouseDown + , onMouseEnter, onMouseLeave, onMouseMove, onMouseOut, onMouseOver + , onMouseUp + , onHostMouseClick, onHostMouseContextMenu, onHostMouseDblClick + , onHostMouseDown, onHostMouseEnter, onHostMouseLeave, onHostMouseMove + , onHostMouseOut, onHostMouseOver, onHostMouseUp + , tagCSys + , toSvg, toSvgWithWarnings + ) + +{-| Techdraw: Interactive Technical Drawing in Elm + + +# Creating Drawings + +@docs Drawing +@docs empty, path, atop, beneath, stack + + +# Styling Drawings + +@docs fill, fillRule, stroke, strokeWidth, lineCap, lineJoin +@docs dashArray, dashOffset + + +# Transforming Drawings + +@docs transform, translate, rotateDegrees, rotateDegreesAbout +@docs skewXDegrees, scale + + +# Freezing Drawings + +@docs freeze, use + + +# Adding Handlers for Events + +@docs onEvent +@docs onMouseClick, onMouseContextMenu, onMouseDblClick, onMouseDown +@docs onMouseEnter, onMouseLeave, onMouseMove, onMouseOut, onMouseOver +@docs onMouseUp +@docs onHostMouseClick, onHostMouseContextMenu, onHostMouseDblClick +@docs onHostMouseDown, onHostMouseEnter, onHostMouseLeave, onHostMouseMove +@docs onHostMouseOut, onHostMouseOver, onHostMouseUp + + +# Tagging Coordinate Systems + +@docs tagCSys + + +# Converting Drawings to SVG + +@docs toSvg, toSvgWithWarnings + +-} + +import Depict.Event as Event exposing (EventHandler, MouseInfo) +import Depict.Internal.Dwg exposing (Dwg(..)) +import Depict.Internal.StyleAtom as StyleAtom exposing (StyleAtom) +import Depict.Internal.Svg.Machine as DwgMachine +import Depict.Math as Math exposing (AffineTransform, P2, V2) +import Depict.Path exposing (Path) +import Depict.Style as Style +import Depict.Types + exposing + ( CSysName + , FrozenName + , Order(..) + , Sizing + , Visibility + ) +import Html exposing (Html) + + + +---- Creating Drawings -------------------------------------------------------- + + +{-| A drawing. +-} +type Drawing msg + = Drawing (Dwg msg) + + +{-| Un-apply the `Drawing` newtype. +-} +unDrawing : Drawing msg -> Dwg msg +unDrawing (Drawing dwg) = + dwg + + +{-| Create an empty `Drawing`. +-} +empty : Drawing msg +empty = + Drawing DwgEmpty + + +{-| Create a `Drawing` of a `Path`. +-} +path : Path -> Drawing msg +path = + DwgPath >> Drawing + + +{-| Draw the first drawing on top of the second drawing. + +The first/top drawing is processed first. + +-} +atop : Drawing msg -> Drawing msg -> Drawing msg +atop top bottom = + Drawing (DwgAtop (unDrawing top) (unDrawing bottom)) + + +{-| Draw the first drawing below the second drawing. + +The first/bottom drawing is processed first. + +-} +beneath : Drawing msg -> Drawing msg -> Drawing msg +beneath bottom top = + Drawing (DwgBeneath (unDrawing bottom) (unDrawing top)) + + +{-| Stack drawings in either a bottom-to-top or top-to-bottom order. +-} +stack : Order -> List (Drawing msg) -> Drawing msg +stack order = + case order of + TopToBottom -> + List.foldl beneath empty + + BottomToTop -> + List.foldl atop empty + + + +---- Styling Drawings --------------------------------------------------------- + + +{-| Helper function to apply a `StyleAtom` to a `Drawing`. +-} +applyStyleAtom : (a -> StyleAtom) -> a -> Drawing msg -> Drawing msg +applyStyleAtom createFn value childDrawing = + Drawing (DwgStyled (createFn value) (unDrawing childDrawing)) + + +{-| Set the fill paint. +-} +fill : Style.Paint -> Drawing msg -> Drawing msg +fill = + applyStyleAtom StyleAtom.Fill + + +{-| Set the fill rule. +-} +fillRule : Style.FillRule -> Drawing msg -> Drawing msg +fillRule = + applyStyleAtom StyleAtom.FillRule + + +{-| Set the stroke paint. +-} +stroke : Style.Paint -> Drawing msg -> Drawing msg +stroke = + applyStyleAtom StyleAtom.Stroke + + +{-| Set the stroke width. +-} +strokeWidth : Float -> Drawing msg -> Drawing msg +strokeWidth = + applyStyleAtom StyleAtom.StrokeWidth + + +{-| Set the line cap. +-} +lineCap : Style.LineCap -> Drawing msg -> Drawing msg +lineCap = + applyStyleAtom StyleAtom.LineCap + + +{-| Set the line join. +-} +lineJoin : Style.LineJoin -> Drawing msg -> Drawing msg +lineJoin = + applyStyleAtom StyleAtom.LineJoin + + +{-| Set the dash array. +-} +dashArray : Style.DashArray -> Drawing msg -> Drawing msg +dashArray = + applyStyleAtom StyleAtom.DashArray + + +{-| Set the dash offset. +-} +dashOffset : Float -> Drawing msg -> Drawing msg +dashOffset = + applyStyleAtom StyleAtom.DashOffset + + + +---- Transforming Drawings ---------------------------------------------------- + + +{-| Transform a drawing using an affine transformation. +-} +transform : AffineTransform -> Drawing msg -> Drawing msg +transform affineTransform = + unDrawing >> DwgTransformed affineTransform >> Drawing + + +{-| Translate a drewing by the supplied offset vector. +-} +translate : V2 -> Drawing msg -> Drawing msg +translate = + Math.Translation >> Math.affTranslation >> transform + + +{-| Rotate a drawing by the specified number of degrees about the origin. +-} +rotateDegrees : Float -> Drawing msg -> Drawing msg +rotateDegrees = + Math.toRadians + >> Math.angle2Pi + >> Math.Rotation + >> Math.affRotation + >> transform + + +{-| Rotate a drawing by the specified number of degrees about a given point. +-} +rotateDegreesAbout : Float -> P2 -> Drawing msg -> Drawing msg +rotateDegreesAbout angle pt = + transform <| + Math.affFromComponents + [ Math.AffineTranslation <| + Math.Translation <| + Math.v2Neg <| + Math.p2v pt + , Math.AffineRotation <| + Math.Rotation <| + Math.angle2Pi <| + Math.toRadians angle + , Math.AffineTranslation <| + Math.Translation <| + Math.p2v pt + ] + + +{-| Skew along the x-axis by a value in degrees. +-} +skewXDegrees : Float -> Drawing msg -> Drawing msg +skewXDegrees = + Math.toRadians >> tan >> Math.ShearingX >> Math.affShearingX >> transform + + +{-| Scale by the provided factors along the x and y axes. +-} +scale : Float -> Float -> Drawing msg -> Drawing msg +scale scaleX scaleY = + Math.Scaling scaleX scaleY |> Math.affScaling |> transform + + + +---- Freezing Drawings -------------------------------------------------------- + + +{-| Freeze a drawing, adding an optional name to it. + +Freezing a drawing freezes all the styles and transformations of a drawing +in place. If the drawing is later transformed, the transformation will apply +to the entire drawing, including all its stroked paths, etc. This means that +non-uniform stroke widths, etc., can be produced by freezing and then +transforming a drawing. + +A frozen drawing may be re-used later in the drawing tree with the +[`use`](#use) function. Re-using a drawing is very efficient, because in the +underlying SVG, the re-used drawing will be referenced by name. + +-} +freeze : Visibility -> Maybe FrozenName -> Drawing msg -> Drawing msg +freeze visibility optName = + unDrawing >> DwgFrozen visibility optName >> Drawing + + +{-| Re-use a frozen drawing, summoning it by name. +-} +use : FrozenName -> Drawing msg +use = + DwgUse >> Drawing + + + +---- Adding Handlers for Events ----------------------------------------------- + + +{-| Add an event handler to an existing drawing. +-} +onEvent : EventHandler msg -> Drawing msg -> Drawing msg +onEvent eventHandler = + unDrawing >> DwgEventHandler eventHandler >> Drawing + + +{-| Helper function ao add a mouse event. +-} +onMouseEvent : + (Event.MouseHandler msg -> EventHandler msg) + -> (MouseInfo -> msg) + -> Drawing msg + -> Drawing msg +onMouseEvent createEventHandler createMsg = + onEvent (Event.MouseHandler createMsg |> createEventHandler) + + +{-| Add a mouse click handler to an existing drawing. +-} +onMouseClick : (MouseInfo -> msg) -> Drawing msg -> Drawing msg +onMouseClick = + onMouseEvent Event.MouseClick + + +{-| Add a mouse context menu handler to an existing drawing. +-} +onMouseContextMenu : (MouseInfo -> msg) -> Drawing msg -> Drawing msg +onMouseContextMenu = + onMouseEvent Event.MouseContextMenu + + +{-| Add a mouse double click handler to an existing drawing. +-} +onMouseDblClick : (MouseInfo -> msg) -> Drawing msg -> Drawing msg +onMouseDblClick = + onMouseEvent Event.MouseDblClick + + +{-| Add a mouse button down handler to an existing drawing. +-} +onMouseDown : (MouseInfo -> msg) -> Drawing msg -> Drawing msg +onMouseDown = + onMouseEvent Event.MouseDown + + +{-| Add a mouse enter handler to an existing drawing. +-} +onMouseEnter : (MouseInfo -> msg) -> Drawing msg -> Drawing msg +onMouseEnter = + onMouseEvent Event.MouseEnter + + +{-| Add a mouse leave handler to an existing drawing. +-} +onMouseLeave : (MouseInfo -> msg) -> Drawing msg -> Drawing msg +onMouseLeave = + onMouseEvent Event.MouseLeave + + +{-| Add a mouse move event handler to an existing drawing. +-} +onMouseMove : (MouseInfo -> msg) -> Drawing msg -> Drawing msg +onMouseMove = + onMouseEvent Event.MouseMove + + +{-| Add a mouse out event handler to an existing drawing. +-} +onMouseOut : (MouseInfo -> msg) -> Drawing msg -> Drawing msg +onMouseOut = + onMouseEvent Event.MouseOut + + +{-| Add a mouse over event handler to an existing drawing. +-} +onMouseOver : (MouseInfo -> msg) -> Drawing msg -> Drawing msg +onMouseOver = + onMouseEvent Event.MouseOver + + +{-| Add a mouse up event handler to an existing drawing. +-} +onMouseUp : (MouseInfo -> msg) -> Drawing msg -> Drawing msg +onMouseUp = + onMouseEvent Event.MouseUp + + +{-| Add a host event handler to an existing drawing. +-} +onHostEvent : EventHandler msg -> Drawing msg -> Drawing msg +onHostEvent eventHandler = + unDrawing >> DwgHostEventHandler eventHandler >> Drawing + + +{-| Helper function ao add a mouse event to the host. +-} +onHostMouseEvent : + (Event.MouseHandler msg -> EventHandler msg) + -> (MouseInfo -> msg) + -> Drawing msg + -> Drawing msg +onHostMouseEvent createEventHandler createMsg = + onHostEvent (Event.MouseHandler createMsg |> createEventHandler) + + +{-| Add a mouse click handler to the host of an existing drawing. +-} +onHostMouseClick : (MouseInfo -> msg) -> Drawing msg -> Drawing msg +onHostMouseClick = + onHostMouseEvent Event.MouseClick + + +{-| Add a mouse context menu handler to the host of an existing drawing. +-} +onHostMouseContextMenu : (MouseInfo -> msg) -> Drawing msg -> Drawing msg +onHostMouseContextMenu = + onHostMouseEvent Event.MouseContextMenu + + +{-| Add a mouse double click handler to the host of an existing drawing. +-} +onHostMouseDblClick : (MouseInfo -> msg) -> Drawing msg -> Drawing msg +onHostMouseDblClick = + onHostMouseEvent Event.MouseDblClick + + +{-| Add a mouse button down handler to the host of an existing drawing. +-} +onHostMouseDown : (MouseInfo -> msg) -> Drawing msg -> Drawing msg +onHostMouseDown = + onHostMouseEvent Event.MouseDown + + +{-| Add a mouse enter handler to the host of an existing drawing. +-} +onHostMouseEnter : (MouseInfo -> msg) -> Drawing msg -> Drawing msg +onHostMouseEnter = + onHostMouseEvent Event.MouseEnter + + +{-| Add a mouse leave handler to the host of an existing drawing. +-} +onHostMouseLeave : (MouseInfo -> msg) -> Drawing msg -> Drawing msg +onHostMouseLeave = + onHostMouseEvent Event.MouseLeave + + +{-| Add a mouse move event handler to the host of an existing drawing. +-} +onHostMouseMove : (MouseInfo -> msg) -> Drawing msg -> Drawing msg +onHostMouseMove = + onHostMouseEvent Event.MouseMove + + +{-| Add a mouse out event handler to the host of an existing drawing. +-} +onHostMouseOut : (MouseInfo -> msg) -> Drawing msg -> Drawing msg +onHostMouseOut = + onHostMouseEvent Event.MouseOut + + +{-| Add a mouse over event handler to the host of an existing drawing. +-} +onHostMouseOver : (MouseInfo -> msg) -> Drawing msg -> Drawing msg +onHostMouseOver = + onHostMouseEvent Event.MouseOver + + +{-| Add a mouse up event handler to the host of an existing drawing. +-} +onHostMouseUp : (MouseInfo -> msg) -> Drawing msg -> Drawing msg +onHostMouseUp = + onHostMouseEvent Event.MouseUp + + + +---- Tagging Coordinate Systems ----------------------------------------------- + + +{-| Tag the current local-to-world transformation with the supplied +coordinate system name. + +This coordinate system name can be used with later mouse events to retrieve +coordinates in the named coordinate system. + +-} +tagCSys : CSysName -> Drawing msg -> Drawing msg +tagCSys cSysName = + unDrawing >> DwgTagCSys cSysName >> Drawing + + + +---- Converting Drawings To SVG ----------------------------------------------- + + +{-| Convert a `Drawing` to `Html`. +-} +toSvg : Sizing -> Drawing msg -> Html msg +toSvg sizing = + unDrawing >> DwgMachine.toSvg sizing >> DwgMachine.svgResultGetHtml + + +{-| Convert a `Drawing` to `Html`, additionally returning a list of +strings containing any warnings generated while producing the drawing. +-} +toSvgWithWarnings : Sizing -> Drawing msg -> ( Html msg, List String ) +toSvgWithWarnings sizing = + unDrawing >> DwgMachine.toSvg sizing >> DwgMachine.svgResultTuple diff --git a/src/Depict/Event.elm b/src/Depict/Event.elm new file mode 100644 index 0000000..1a4993d --- /dev/null +++ b/src/Depict/Event.elm @@ -0,0 +1,129 @@ +module Depict.Event exposing + ( EventHandler(..) + , MouseHandler(..), MouseInfo(..) + , Buttons, BState(..), Modifiers, KState(..) + , map + ) + +{-| Events. + +@docs EventHandler +@docs MouseHandler, MouseInfo +@docs Buttons, BState, Modifiers, KState +@docs map + +-} + +import Depict.Math exposing (P2) +import Depict.Types exposing (CSysName) + + +{-| All event handler types. +-} +type EventHandler msg + = MouseClick (MouseHandler msg) + | MouseContextMenu (MouseHandler msg) + | MouseDblClick (MouseHandler msg) + | MouseDown (MouseHandler msg) + | MouseEnter (MouseHandler msg) + | MouseLeave (MouseHandler msg) + | MouseMove (MouseHandler msg) + | MouseOut (MouseHandler msg) + | MouseOver (MouseHandler msg) + | MouseUp (MouseHandler msg) + + +{-| Mouse event handler. +-} +type MouseHandler msg + = MouseHandler (MouseInfo -> msg) + + +{-| Mouse information; passed to a mouse event handler. +-} +type MouseInfo + = MouseInfo + { offset : P2 + , local : P2 + , buttons : Buttons + , modifiers : Modifiers + , pointIn : CSysName -> P2 + } + + +{-| State of mouse buttons. +-} +type alias Buttons = + { b1 : BState + , b2 : BState + , b3 : BState + , b4 : BState + , b5 : BState + } + + +{-| Individual mouse button state (down / up). +-} +type BState + = BDown + | BUp + + +{-| Modifier keys state. +-} +type alias Modifiers = + { ctrl : KState + , shift : KState + , alt : KState + , meta : KState + } + + +{-| Individual key state (down / up). +-} +type KState + = KDown + | KUp + + +{-| Map a function over an `EventHandler` event type. +-} +map : (a -> b) -> EventHandler a -> EventHandler b +map f handler = + case handler of + MouseClick h -> + mouseHandlerMap f h |> MouseClick + + MouseContextMenu h -> + mouseHandlerMap f h |> MouseContextMenu + + MouseDblClick h -> + mouseHandlerMap f h |> MouseDblClick + + MouseDown h -> + mouseHandlerMap f h |> MouseDown + + MouseEnter h -> + mouseHandlerMap f h |> MouseEnter + + MouseLeave h -> + mouseHandlerMap f h |> MouseLeave + + MouseMove h -> + mouseHandlerMap f h |> MouseMove + + MouseOut h -> + mouseHandlerMap f h |> MouseOut + + MouseOver h -> + mouseHandlerMap f h |> MouseOver + + MouseUp h -> + mouseHandlerMap f h |> MouseUp + + +{-| Map a function over a `MouseHandler` event type. +-} +mouseHandlerMap : (a -> b) -> MouseHandler a -> MouseHandler b +mouseHandlerMap f (MouseHandler g) = + MouseHandler (g >> f) diff --git a/src/Depict/Internal/CSysDict.elm b/src/Depict/Internal/CSysDict.elm new file mode 100644 index 0000000..384e569 --- /dev/null +++ b/src/Depict/Internal/CSysDict.elm @@ -0,0 +1,66 @@ +module Depict.Internal.CSysDict exposing + ( CSysDict + , empty, insertLocalToWorld, getLocalToWorld, getWorldToLocal + , inCSys + ) + +{-| Dictionary (map) containing coordinate systems. + +@docs CSysDict +@docs empty, insertLocalToWorld, getLocalToWorld, getWorldToLocal +@docs inCSys + +-} + +import Depict.Math as Math exposing (AffineTransform, P2) +import Depict.Types exposing (CSysName(..)) +import Dict exposing (Dict) + + +{-| Map from the names of coordinate systems to their local-to-world +transformation. +-} +type CSysDict + = CSysDict (Dict String AffineTransform) + + +{-| Empty coordinate system dictionary. +-} +empty : CSysDict +empty = + CSysDict Dict.empty + + +{-| Insert a named coordinate system local-to-world transformation into the +dictionary. +-} +insertLocalToWorld : CSysName -> AffineTransform -> CSysDict -> CSysDict +insertLocalToWorld (CSysName name) localToWorld (CSysDict oldDict) = + CSysDict <| Dict.insert name localToWorld oldDict + + +{-| Get a named coordinate system local-to-world transformation from the +dictionary. +-} +getLocalToWorld : CSysName -> CSysDict -> Maybe AffineTransform +getLocalToWorld (CSysName name) (CSysDict dict) = + Dict.get name dict + + +{-| Get a named coordinate system world-to-local transformation from the +dictionary. +-} +getWorldToLocal : CSysName -> CSysDict -> Maybe AffineTransform +getWorldToLocal name = + getLocalToWorld name >> Maybe.map Math.affInvert + + +{-| Convert a world-coordinate-system point to a point in the named +coordinate system. If the named coordinate system does not exist, a point +at (0,0) is returned. +-} +inCSys : CSysDict -> CSysName -> P2 -> P2 +inCSys dict name worldPt = + getWorldToLocal name dict + |> Maybe.map (\w2l -> Math.p2ApplyAffineTransform w2l worldPt) + |> Maybe.withDefault (Math.p2 0 0) diff --git a/src/Depict/Internal/Dwg.elm b/src/Depict/Internal/Dwg.elm new file mode 100644 index 0000000..faa5283 --- /dev/null +++ b/src/Depict/Internal/Dwg.elm @@ -0,0 +1,29 @@ +module Depict.Internal.Dwg exposing (Dwg(..)) + +{-| Internal sum type representing drawings. + +@docs Dwg + +-} + +import Depict.Event exposing (EventHandler) +import Depict.Internal.StyleAtom exposing (StyleAtom) +import Depict.Math exposing (AffineTransform) +import Depict.Path exposing (Path) +import Depict.Types exposing (CSysName, FrozenName, Visibility) + + +{-| Internal drawing type. +-} +type Dwg msg + = DwgEmpty + | DwgPath Path + | DwgStyled StyleAtom (Dwg msg) + | DwgTransformed AffineTransform (Dwg msg) + | DwgAtop (Dwg msg) (Dwg msg) + | DwgBeneath (Dwg msg) (Dwg msg) + | DwgEventHandler (EventHandler msg) (Dwg msg) + | DwgHostEventHandler (EventHandler msg) (Dwg msg) + | DwgTagCSys CSysName (Dwg msg) + | DwgFrozen Visibility (Maybe FrozenName) (Dwg msg) + | DwgUse FrozenName diff --git a/src/Depict/Internal/Hash.elm b/src/Depict/Internal/Hash.elm new file mode 100644 index 0000000..3159983 --- /dev/null +++ b/src/Depict/Internal/Hash.elm @@ -0,0 +1,305 @@ +module Depict.Internal.Hash exposing + ( Hash, Hasher, Manifest, Encoder + , toHex + , fromEncoder + , f32, u32 + , encHash + , sequence, list + , enc2, enc4, enc6 + , attachTag + , color + , p2, v2, m22, affineTransform + ) + +{-| Hashing values. + +To hash a value, there are typically two steps: + +1. Create an [`Encoder`](#Encoder) for the type. +2. Use the [`fromEncoder`](#fromEncoder) function to create a hasher. + +For example, suppose we have our own two-element record called `G`. We +might create a [`Hasher`](#Hasher) for it like this: + + type alias G + = { x : Float, y : Float } + + encG : Encoder G + encG = + enc2 f32 f32 .x .y |> attachTag "MyModule.G" + + hashG : Hasher G + hashG = + fromEncoder encG + + hashG {x = 1, y = 2} |> toHex + --> "997277d2368dc71980e42a29255275a33544f449" + + hashG {x = 2, y = 1} |> toHex + --> "6b0444634a826e716b090fdae9c183bc5f41af36" + +The hashing works by first encoding the value to a binary blob, and then +running a SHA1 algorithm over the blob to produce a hash. + + +# Hashing Types and Functions + +@docs Hash, Hasher, Manifest, Encoder +@docs toHex +@docs fromEncoder +@docs f32, u32 +@docs encHash +@docs sequence, list +@docs enc2, enc4, enc6 +@docs attachTag + + +# Encoders for Types + +@docs color +@docs p2, v2, m22, affineTransform + +-} + +import Bytes as B +import Bytes.Encode as BE +import Color exposing (Color) +import Depict.Math as Math exposing (AffineTransform, M22, P2, V2) +import SHA1 + + + +---- Hashing Machinery -------------------------------------------------------- + + +{-| A hash digest. + +Use [`toHex`](#toHex) to convert a `Hash` to a `String`. + +-} +type Hash + = Hash SHA1.Digest + + +{-| A `Hasher` is a function which produces a hash from a type. +-} +type alias Hasher a = + a -> Hash + + +{-| A `Manifest` records information from a type for hashing. +-} +type Manifest + = Manifest BE.Encoder + + +{-| An `Encoder` takes a type and produces a `Manifest`. +-} +type alias Encoder a = + a -> Manifest + + +{-| Convert a `Hash` value to a hex string. +-} +toHex : Hash -> String +toHex = + unHash >> SHA1.toHex + + +{-| Unwrap the `Hash` newtype. +-} +unHash : Hash -> SHA1.Digest +unHash (Hash digest) = + digest + + +{-| Unwrap the `Manifest` newtype. +-} +unManifest : Manifest -> BE.Encoder +unManifest (Manifest enc) = + enc + + +{-| Produce a `Hasher` from an `Encoder`. +-} +fromEncoder : Encoder a -> Hasher a +fromEncoder encFn = + encFn >> unManifest >> BE.encode >> SHA1.fromBytes >> Hash + + +{-| Default endianness. +-} +endianness : B.Endianness +endianness = + B.LE + + +{-| Encoder for `f32` values. +-} +f32 : Encoder Float +f32 = + BE.float32 endianness >> Manifest + + +{-| Encoder for `u32` values. +-} +u32 : Encoder Int +u32 = + BE.unsignedInt32 endianness >> Manifest + + +{-| Re-encode a hash into another hash. +-} +encHash : Encoder Hash +encHash = + \hash -> + let + { a, b, c, d, e } = + unHash hash |> SHA1.toInt32s + in + List.map u32 [ a, b, c, d, e ] |> sequence + + +{-| Sequence a list of manifests into a single manifest. +-} +sequence : List Manifest -> Manifest +sequence = + List.map unManifest >> BE.sequence >> Manifest + + +{-| Encode a list of items using an encoder for a single item. +-} +list : Encoder a -> Encoder (List a) +list itemEncoder items = + (List.length items |> u32) :: List.map itemEncoder items |> sequence + + +{-| Attach a type tag to the front of an existing encoder. +-} +attachTag : String -> Encoder a -> Encoder a +attachTag tag encFn = + \value -> + sequence + [ Manifest (BE.string tag) + , encFn value + ] + + +{-| Apply 2 encoders in sequence. +-} +enc2 : + Encoder a + -> Encoder b + -> (z -> a) + -> (z -> b) + -> Encoder z +enc2 ea eb fa fb = + applyAll [ fa >> ea, fb >> eb ] >> sequence + + +{-| Apply 4 encoders in sequence. +-} +enc4 : + Encoder a + -> Encoder b + -> Encoder c + -> Encoder d + -> (z -> a) + -> (z -> b) + -> (z -> c) + -> (z -> d) + -> Encoder z +enc4 ea eb ec ed fa fb fc fd = + applyAll [ fa >> ea, fb >> eb, fc >> ec, fd >> ed ] >> sequence + + +{-| Apply 6 encoders in sequence. +-} +enc6 : + Encoder a + -> Encoder b + -> Encoder c + -> Encoder d + -> Encoder e + -> Encoder f + -> (z -> a) + -> (z -> b) + -> (z -> c) + -> (z -> d) + -> (z -> e) + -> (z -> f) + -> Encoder z +enc6 ea eb ec ed ee ef fa fb fc fd fe ff = + applyAll + [ fa >> ea + , fb >> eb + , fc >> ec + , fd >> ed + , fe >> ee + , ff >> ef + ] + >> sequence + + +{-| Apply a list of functions to a value. +-} +applyAll : List (a -> b) -> a -> List b +applyAll = + applyAllAccum [] + + +{-| Apply a list of functions to a value using an explicit accumulator. +-} +applyAllAccum : List b -> List (a -> b) -> a -> List b +applyAllAccum accum fns value = + case fns of + [] -> + List.reverse accum + + f :: fs -> + applyAllAccum (f value :: accum) fs value + + + +---- Hashers for Types -------------------------------------------------------- + + +{-| Encoder for `Color`. +-} +color : Encoder Color +color = + Color.toRgba + >> enc4 f32 f32 f32 f32 .red .green .blue .alpha + |> attachTag "Color.Color" + + +{-| Encoder for `P2`. +-} +p2 : Encoder P2 +p2 = + enc2 f32 f32 Math.p2x Math.p2y + |> attachTag "Math.P2" + + +{-| Encoder for `V2`. +-} +v2 : Encoder V2 +v2 = + enc2 f32 f32 Math.v2e1 Math.v2e2 + |> attachTag "Math.V2" + + +{-| Encoder for `M22`. +-} +m22 : Encoder M22 +m22 = + enc4 f32 f32 f32 f32 Math.m22e11 Math.m22e12 Math.m22e21 Math.m22e22 + |> attachTag "Math.M22" + + +{-| Encoder for `AffineTransform`. +-} +affineTransform : Encoder AffineTransform +affineTransform = + enc2 m22 v2 Math.affGetLinear Math.affGetTranslation + |> attachTag "Math.AffineTransform" diff --git a/src/Depict/Internal/StyleAtom.elm b/src/Depict/Internal/StyleAtom.elm new file mode 100644 index 0000000..38770d7 --- /dev/null +++ b/src/Depict/Internal/StyleAtom.elm @@ -0,0 +1,56 @@ +module Depict.Internal.StyleAtom exposing (StyleAtom(..), apply) + +{-| Individual component of a Style. + +A [`StyleAtom`](#StyleAtom) is a single style setting, encapsulated as its +own type. These are used so that style settings in a drawing tree take up as +little memory as possible. + +@docs StyleAtom, apply + +-} + +import Depict.Style as Style exposing (Style) + + +{-| Individual component of a `Style`. +-} +type StyleAtom + = Fill Style.Paint + | FillRule Style.FillRule + | Stroke Style.Paint + | StrokeWidth Float + | LineCap Style.LineCap + | LineJoin Style.LineJoin + | DashArray Style.DashArray + | DashOffset Float + + +{-| Apply a `StyleAtom` to a style, producing a new style. +-} +apply : StyleAtom -> Style -> Style +apply styleAtom = + case styleAtom of + Fill paint -> + Style.fill paint + + FillRule fillRule -> + Style.fillRule fillRule + + Stroke paint -> + Style.stroke paint + + StrokeWidth strokeWidth -> + Style.strokeWidth strokeWidth + + LineCap lineCap -> + Style.lineCap lineCap + + LineJoin lineJoin -> + Style.lineJoin lineJoin + + DashArray dashArray -> + Style.dashArray dashArray + + DashOffset dashOffset -> + Style.dashOffset dashOffset diff --git a/src/Depict/Internal/Svg/Defs.elm b/src/Depict/Internal/Svg/Defs.elm new file mode 100644 index 0000000..6b8f497 --- /dev/null +++ b/src/Depict/Internal/Svg/Defs.elm @@ -0,0 +1,190 @@ +module Depict.Internal.Svg.Defs exposing + ( Defs + , empty + , ensureLinearGradient, ensureRadialGradient + , toSvg + ) + +{-| Manage items that can appear in an SVG `` element for the produced +document. + +@docs Defs +@docs empty +@docs ensureLinearGradient, ensureRadialGradient +@docs toSvg + +-} + +import Color +import Depict.Internal.Hash as Hash exposing (Hasher) +import Depict.Internal.Svg.Extras as Extras +import Depict.Internal.Svg.Path as SvgPath +import Depict.Math as Math +import Depict.Style as Style + exposing + ( LinearGradient + , RadialGradient + , radialGradient + ) +import Dict exposing (Dict) +import TypedSvg +import TypedSvg.Attributes as SvgAttr +import TypedSvg.Core exposing (Attribute, Svg, attribute) +import TypedSvg.Types exposing (CoordinateSystem(..), px) + + +{-| Item that can appear in a ``. +-} +type DefItem + = DefLinearGradient LinearGradient + | DefRadialGradient RadialGradient + + +{-| Defs element. +-} +type Defs + = Defs (Dict String DefItem) + + +{-| Empty defs. +-} +empty : Defs +empty = + Defs Dict.empty + + +{-| Ensure a hashable item appears in the `Defs`. +-} +ensure : Hasher a -> (a -> DefItem) -> a -> Defs -> Defs +ensure hashFn itemFn item (Defs defs) = + Defs <| Dict.insert (hashFn item |> Hash.toHex) (itemFn item) defs + + +{-| Ensure a `LinearGradient` appears in the `Defs`. +-} +ensureLinearGradient : LinearGradient -> Defs -> Defs +ensureLinearGradient = + ensure Style.hashLinearGradient DefLinearGradient + + +{-| Ensure a `RadialGradient` appears in the `Defs`. +-} +ensureRadialGradient : RadialGradient -> Defs -> Defs +ensureRadialGradient = + ensure Style.hashRadialGradient DefRadialGradient + + + +---- Conversion to SVG -------------------------------------------------------- + + +{-| Convert a `Defs` value to an `` element. +-} +toSvg : Defs -> Svg msg +toSvg (Defs defs) = + TypedSvg.defs [] (defs |> Dict.values |> List.map defItemToSvg) + + +{-| Convert a DefItem to its corresponding SVG. +-} +defItemToSvg : DefItem -> Svg msg +defItemToSvg item = + case item of + DefLinearGradient lg -> + linearGradientToSvg lg + + DefRadialGradient rg -> + radialGradientToSvg rg + + +{-| Convert a `LinearGradient` to SVG. +-} +linearGradientToSvg : Style.LinearGradient -> Svg msg +linearGradientToSvg linearGradient = + let + hash = + Style.hashLinearGradient linearGradient + + params = + Style.linearGradientParams linearGradient + in + TypedSvg.linearGradient + [ hash |> Hash.toHex |> SvgAttr.id + , SvgAttr.gradientUnits CoordinateSystemUserSpaceOnUse + , params.start |> Math.p2x |> px |> SvgAttr.x1 + , params.start |> Math.p2y |> px |> SvgAttr.y1 + , params.end |> Math.p2x |> px |> SvgAttr.x2 + , params.end |> Math.p2y |> px |> SvgAttr.y2 + , params.transform + |> Extras.convertAffineTransformToSvg + |> (\matrix -> SvgAttr.gradientTransform [ matrix ]) + ] + (params |> .gradient |> gradientToSvg) + + +{-| Convert a `RadialGradient` to SVG. +-} +radialGradientToSvg : Style.RadialGradient -> Svg msg +radialGradientToSvg radialGradient = + let + hash = + Style.hashRadialGradient radialGradient + + params = + Style.radialGradientParams radialGradient + in + TypedSvg.radialGradient + [ hash |> Hash.toHex |> SvgAttr.id + , SvgAttr.gradientUnits CoordinateSystemUserSpaceOnUse + , params.innerCenter |> Math.p2x |> px |> SvgAttr.fx + , params.innerCenter |> Math.p2y |> px |> SvgAttr.fy + , params.innerRadius |> attrFr + , params.outerCenter |> Math.p2x |> px |> SvgAttr.cx + , params.outerCenter |> Math.p2y |> px |> SvgAttr.cy + , params.outerRadius |> px |> SvgAttr.r + + -- TODO: AffineTransform + ] + (params |> .gradient |> gradientToSvg) + + +{-| Convert a `Gradient` to a list of SVG stop elements. +-} +gradientToSvg : Style.Gradient -> List (Svg msg) +gradientToSvg = + Style.gradientParams >> List.map stopToSvg + + +{-| Convert a gradient `Stop` to SVG. +-} +stopToSvg : Style.Stop -> Svg msg +stopToSvg stop = + TypedSvg.stop + [ stop |> Style.stopLocation |> strPercent |> SvgAttr.offset + , stop |> Style.stopColor |> Color.toCssString |> SvgAttr.stopColor + ] + [] + + +{-| The "fr" attribute. + + + +-} +attrFr : Float -> Attribute msg +attrFr value = + attribute + "fr" + (SvgPath.toFixed (SvgPath.NFixDigits 2) value ++ "px") + + +{-| Create a string with a percent sign and one significant figure after +the decimal point. + +The value passed in should typically be in the range [0, 1] to map to a +percentage value of [0%, 100%]. + +-} +strPercent : Float -> String +strPercent x = + SvgPath.toFixed (SvgPath.NFixDigits 1) (x * 100) ++ "%" diff --git a/src/Depict/Internal/Svg/Env.elm b/src/Depict/Internal/Svg/Env.elm new file mode 100644 index 0000000..5a13a77 --- /dev/null +++ b/src/Depict/Internal/Svg/Env.elm @@ -0,0 +1,350 @@ +module Depict.Internal.Svg.Env exposing + ( Env + , Warning + , EventHandlerCapturedEnv(..) + , unWarning + , getLocalToWorld, getWarnings, getNFixDigits, getStyle + , modStyle, applyStyleAtom + , getDefs, modDefs + , getInitLocalToWorld, getInitWorldToLocal + , setLocalToWorldTransform, setLocalToWorldTransformAsInit, concatTransform + , getEventHandlers, hasPendingEventHandlers, addEventHandler + , removeEventHandlers + , addHostEventHandler, getHostEventHandlers + , tagCSys, getCSysDict + , init + , thread + ) + +{-| Environment for SVG drawing machine. + +@docs Env +@docs Warning +@docs EventHandlerCapturedEnv +@docs unWarning +@docs getLocalToWorld, getWarnings, getNFixDigits, getStyle +@docs modStyle, applyStyleAtom +@docs getDefs, modDefs +@docs getInitLocalToWorld, getInitWorldToLocal +@docs setLocalToWorldTransform, setLocalToWorldTransformAsInit, concatTransform +@docs getEventHandlers, hasPendingEventHandlers, addEventHandler +@docs removeEventHandlers +@docs addHostEventHandler, getHostEventHandlers +@docs tagCSys, getCSysDict +@docs init +@docs thread + +-} + +import Depict.Event exposing (EventHandler) +import Depict.Internal.CSysDict as CSysDict exposing (CSysDict) +import Depict.Internal.StyleAtom as StyleAtom exposing (StyleAtom) +import Depict.Internal.Svg.Defs as Defs exposing (Defs) +import Depict.Internal.Svg.Path exposing (NFixDigits(..)) +import Depict.Math as Math exposing (AffineTransform) +import Depict.Style as Style exposing (Style) +import Depict.Types as T exposing (CSysName, Sizing(..)) + + +{-| Environment. +-} +type Env msg + = Env + { sizing : Sizing + , initTransform : AffineTransform + , localToWorld : AffineTransform + , warnings : List Warning + , nFixDigits : NFixDigits + , style : Style + , defs : Defs + , eventHandlers : List (EventHandlerCapturedEnv msg) + , hostEventHandlers : List (EventHandlerCapturedEnv msg) + , cSysDict : CSysDict + } + + +{-| Return the local-to-world affine transformation from the environment. +-} +getLocalToWorld : Env msg -> AffineTransform +getLocalToWorld (Env env) = + env.localToWorld + + +{-| Return the warnings from the environment. +-} +getWarnings : Env msg -> List Warning +getWarnings (Env env) = + env.warnings + + +{-| Get the number of fixed digits for Float formatting from the environment. +-} +getNFixDigits : Env msg -> NFixDigits +getNFixDigits (Env env) = + env.nFixDigits + + +{-| Return the style from the environment. +-} +getStyle : Env msg -> Style +getStyle (Env env) = + env.style + + +{-| Modify the style in the environment. +-} +modStyle : (Style -> Style) -> Env msg -> Env msg +modStyle styleFn (Env oldEnv) = + Env { oldEnv | style = styleFn oldEnv.style } + + +{-| Apply a `StyleAtom` to update the style in the environment. +-} +applyStyleAtom : StyleAtom -> Env msg -> Env msg +applyStyleAtom styleAtom = + modStyle (StyleAtom.apply styleAtom) + + +{-| Return the SVG definitions from the environment. +-} +getDefs : Env msg -> Defs +getDefs (Env env) = + env.defs + + +{-| Modify the `Defs` inside the environment. +-} +modDefs : (Defs -> Defs) -> Env msg -> Env msg +modDefs modFn (Env oldEnv) = + Env { oldEnv | defs = modFn oldEnv.defs } + + +{-| Return the initial local-to-world transformation. +-} +getInitLocalToWorld : Env msg -> AffineTransform +getInitLocalToWorld (Env env) = + env.initTransform + + +{-| Return the initial world-to-local transformation. +-} +getInitWorldToLocal : Env msg -> AffineTransform +getInitWorldToLocal = + getInitLocalToWorld >> Math.affInvert + + +{-| Set the local-to-world transformation. + +This completedly overrides the transformation. To concatenate a transformation, +use the [`concatTransform`](#concatTransform) function. + +-} +setLocalToWorldTransform : AffineTransform -> Env msg -> Env msg +setLocalToWorldTransform affineTransform (Env oldEnv) = + Env + { oldEnv + | localToWorld = affineTransform + } + + +{-| Override the transform in the environment with the original transform. +-} +setLocalToWorldTransformAsInit : Env msg -> Env msg +setLocalToWorldTransformAsInit (Env env) = + setLocalToWorldTransform env.initTransform (Env env) + + +{-| Concatenate a transformation with the current local-to-world +transformation. This post-multiplies the supplied transformation with the +local-to-world transform. +-} +concatTransform : AffineTransform -> Env msg -> Env msg +concatTransform childToParent (Env oldEnv) = + Env + { oldEnv + | localToWorld = + Math.affMatMul oldEnv.localToWorld childToParent + } + + +{-| Check if the environment has pending event handlers. +-} +hasPendingEventHandlers : Env msg -> Bool +hasPendingEventHandlers (Env env) = + List.isEmpty env.eventHandlers |> not + + +{-| Return the list of event handlers from the environment. +-} +getEventHandlers : Env msg -> List (EventHandlerCapturedEnv msg) +getEventHandlers (Env env) = + env.eventHandlers + + +{-| Prepend an event handler to the environment +-} +addEventHandler : EventHandler msg -> Env msg -> Env msg +addEventHandler eventHandler (Env oldEnv) = + let + handlerWithCapturedEnv = + EventHandlerCapturedEnv + { eventHandler = eventHandler + , localToWorld = oldEnv.localToWorld + } + in + Env + { oldEnv + | eventHandlers = handlerWithCapturedEnv :: oldEnv.eventHandlers + } + + +{-| Remove all event handlers. +-} +removeEventHandlers : Env msg -> Env msg +removeEventHandlers (Env oldEnv) = + Env + { oldEnv + | eventHandlers = [] + } + + +{-| Prepend a host event handler to the environment. +-} +addHostEventHandler : EventHandler msg -> Env msg -> Env msg +addHostEventHandler eventHandler (Env oldEnv) = + let + handlerWithCapturedEnv = + EventHandlerCapturedEnv + { eventHandler = eventHandler + , localToWorld = oldEnv.localToWorld + } + in + Env + { oldEnv + | hostEventHandlers = + handlerWithCapturedEnv :: oldEnv.hostEventHandlers + } + + +{-| Return the host event handlers from the environment. +-} +getHostEventHandlers : Env msg -> List (EventHandlerCapturedEnv msg) +getHostEventHandlers (Env env) = + env.hostEventHandlers + + +{-| Tag the current local-to-world coordinate system in the dictionary of +coordinate system names. +-} +tagCSys : CSysName -> Env msg -> Env msg +tagCSys name (Env oldEnv) = + Env + { oldEnv + | cSysDict = + CSysDict.insertLocalToWorld + name + oldEnv.localToWorld + oldEnv.cSysDict + } + + +{-| Return the coordinate system dictionary from the environment. +-} +getCSysDict : Env msg -> CSysDict +getCSysDict (Env env) = + env.cSysDict + + +{-| Warning string. +-} +type Warning + = Warning String + + +{-| Un-apply the `Warning` newtype. +-} +unWarning : Warning -> String +unWarning (Warning str) = + str + + +{-| Create an initial drawing environment using the sizing information. +-} +init : Sizing -> Env msg +init sizing = + let + initTransform = + initLocalToWorld sizing + in + Env + { sizing = sizing + , initTransform = initTransform + , localToWorld = initTransform + , warnings = [] + , nFixDigits = NFixDigits 2 + , style = Style.inheritAll + , defs = Defs.empty + , eventHandlers = [] + , hostEventHandlers = [] + , cSysDict = CSysDict.empty + } + + +{-| Create an initial local-to-world transformation using the sizing +information. +-} +initLocalToWorld : Sizing -> AffineTransform +initLocalToWorld sz = + Math.affFromComponents + [ -- Flip the y-axis. + Math.AffineScaling <| + Math.Scaling 1 -1 + , Math.AffineTranslation <| + Math.Translation <| + Math.v2 0 (sz |> T.sizingGetViewBox |> T.viewBoxGetHeight) + + -- Set the correct origin. + , Math.AffineTranslation <| + Math.Translation <| + Math.v2 + (sz |> T.sizingGetViewBox |> T.viewBoxGetXMin) + (sz |> T.sizingGetViewBox |> T.viewBoxGetYMin) + ] + + +{-| Thread an environment from ancestor to next in the depthwise traversal +order. + +This determines which parts of the environment inherit parent-to-child vs +which are threaded through the depthwise traversal of the tree. + + - Any part of the environment which comes from `ancestor` is inherited + parent-to-child, + - Any part of the environment which comes from `next` is threaded through + the depthwise traversal. + +-} +thread : Env msg -> Env msg -> Env msg +thread (Env ancestor) (Env next) = + Env + { sizing = ancestor.sizing + , initTransform = ancestor.initTransform + , localToWorld = ancestor.localToWorld + , warnings = next.warnings + , nFixDigits = ancestor.nFixDigits + , style = ancestor.style + , defs = next.defs + , eventHandlers = ancestor.eventHandlers + , hostEventHandlers = next.hostEventHandlers + , cSysDict = next.cSysDict + } + + +{-| Event handler that has captured relevant parts of its current +environment. +-} +type EventHandlerCapturedEnv msg + = EventHandlerCapturedEnv + { eventHandler : EventHandler msg + , localToWorld : AffineTransform + } diff --git a/src/Depict/Internal/Svg/Event.elm b/src/Depict/Internal/Svg/Event.elm new file mode 100644 index 0000000..02287bf --- /dev/null +++ b/src/Depict/Internal/Svg/Event.elm @@ -0,0 +1,220 @@ +module Depict.Internal.Svg.Event exposing (eventHandlersToSvgAttrs) + +{-| Conversion of events to SVG. + +@docs eventHandlersToSvgAttrs + +-} + +import Bitwise exposing (and, shiftLeftBy) +import Depict.Event + exposing + ( BState(..) + , Buttons + , EventHandler(..) + , KState(..) + , Modifiers + , MouseHandler(..) + , MouseInfo(..) + ) +import Depict.Internal.CSysDict as CSysDict exposing (CSysDict) +import Depict.Internal.Svg.Env exposing (EventHandlerCapturedEnv(..)) +import Depict.Math as Math exposing (AffineTransform, P2) +import Html.Events as HtmlEvents +import Json.Decode as D exposing (Decoder) +import TypedSvg.Core exposing (Attribute) + + +{-| Convert a list of event handlers to a list of SVG attributes. +-} +eventHandlersToSvgAttrs : + CSysDict + -> List (EventHandlerCapturedEnv msg) + -> List (Attribute msg) +eventHandlersToSvgAttrs cSysDict = + List.map (eventHandlerToSvgAttr cSysDict) + + +{-| Convert an `EventHandler msg` to an `Attribute msg` using appropriate +environmental information. +-} +eventHandlerToSvgAttr : + CSysDict + -> EventHandlerCapturedEnv msg + -> Attribute msg +eventHandlerToSvgAttr cSysDict eventHandlerWithCapturedEnv = + let + (EventHandlerCapturedEnv ecap) = + eventHandlerWithCapturedEnv + + processMouseHandler : String -> MouseHandler msg -> Attribute msg + processMouseHandler name = + mouseHandlerToSvgAttr name ecap.localToWorld cSysDict + in + case ecap.eventHandler of + MouseClick mouseHandler -> + processMouseHandler "click" mouseHandler + + MouseContextMenu mouseHandler -> + processMouseHandler "contextmenu" mouseHandler + + MouseDblClick mouseHandler -> + processMouseHandler "dblclick" mouseHandler + + MouseDown mouseHandler -> + processMouseHandler "mousedown" mouseHandler + + MouseEnter mouseHandler -> + processMouseHandler "mouseenter" mouseHandler + + MouseLeave mouseHandler -> + processMouseHandler "mouseleave" mouseHandler + + MouseMove mouseHandler -> + processMouseHandler "mousemove" mouseHandler + + MouseOut mouseHandler -> + processMouseHandler "mouseout" mouseHandler + + MouseOver mouseHandler -> + processMouseHandler "mouseover" mouseHandler + + MouseUp mouseHandler -> + processMouseHandler "mouseup" mouseHandler + + +{-| Convert a `MouseHandler msg` to an `Attribute msg` using appropriate +environmental information. +-} +mouseHandlerToSvgAttr : + String + -> AffineTransform + -> CSysDict + -> MouseHandler msg + -> Attribute msg +mouseHandlerToSvgAttr eventName localToWorld cSysDict mouseHandler = + HtmlEvents.on + eventName + (mouseHandlerToMessageDecoder localToWorld cSysDict mouseHandler) + + + +---- JSON Decoders ------------------------------------------------------------ + + +{-| Create a `Decoder msg` from a `MouseHandler msg` and appropriate +environmental information. + +TODO: This function will require information about the coordinate systems to +create the pointIn function. + +-} +mouseHandlerToMessageDecoder : + AffineTransform + -> CSysDict + -> MouseHandler msg + -> Decoder msg +mouseHandlerToMessageDecoder localToWorld cSysDict (MouseHandler toMsg) = + decodeMouseInfo localToWorld cSysDict |> D.map toMsg + + +{-| Decode mouse information for an event handler. +-} +decodeMouseInfo : AffineTransform -> CSysDict -> Decoder MouseInfo +decodeMouseInfo localToWorld cSysDict = + D.map3 + (\offsetP2 buttons modifiers -> + MouseInfo + { offset = offsetP2 + , local = + Math.p2ApplyAffineTransform + (Math.affInvert localToWorld) + offsetP2 + , buttons = buttons + , modifiers = modifiers + , pointIn = \name -> CSysDict.inCSys cSysDict name offsetP2 + } + ) + decodeOffsetP2 + decodeButtons + decodeModifiers + + +decodeOffsetP2 : Decoder P2 +decodeOffsetP2 = + D.map2 Math.p2 decodeOffsetX decodeOffsetY + + +decodeOffsetX : Decoder Float +decodeOffsetX = + D.field "offsetX" D.float + + +decodeOffsetY : Decoder Float +decodeOffsetY = + D.field "offsetY" D.float + + +decodeButtons : Decoder Buttons +decodeButtons = + D.field "buttons" D.int |> D.map intToButtons + + +intToButtons : Int -> Buttons +intToButtons i = + { b1 = getBitForBState 0 i + , b2 = getBitForBState 1 i + , b3 = getBitForBState 2 i + , b4 = getBitForBState 3 i + , b5 = getBitForBState 4 i + } + + +getBitForBState : Int -> Int -> BState +getBitForBState input bitNumber = + if and input (shiftLeftBy bitNumber 0x01) == 0 then + BUp + + else + BDown + + +decodeModifiers : Decoder Modifiers +decodeModifiers = + D.map4 + (\ctrl shift alt meta -> + { ctrl = ctrl, shift = shift, alt = alt, meta = meta } + ) + decodeCtrlKey + decodeShiftKey + decodeAltKey + decodeMetaKey + + +decodeCtrlKey : Decoder KState +decodeCtrlKey = + D.field "ctrlKey" D.bool |> D.map boolToKState + + +decodeShiftKey : Decoder KState +decodeShiftKey = + D.field "shiftKey" D.bool |> D.map boolToKState + + +decodeAltKey : Decoder KState +decodeAltKey = + D.field "altKey" D.bool |> D.map boolToKState + + +decodeMetaKey : Decoder KState +decodeMetaKey = + D.field "metaKey" D.bool |> D.map boolToKState + + +boolToKState : Bool -> KState +boolToKState b = + if b then + KDown + + else + KUp diff --git a/src/Depict/Internal/Svg/Extras.elm b/src/Depict/Internal/Svg/Extras.elm new file mode 100644 index 0000000..f88734c --- /dev/null +++ b/src/Depict/Internal/Svg/Extras.elm @@ -0,0 +1,41 @@ +module Depict.Internal.Svg.Extras exposing (convertAffineTransformToSvg) + +{-| Extra SVG conversions that don't belong somewhere more specific. + +@docs convertAffineTransformToSvg + +-} + +import Depict.Math + exposing + ( AffineTransform + , affGetLinear + , affGetTranslation + , m22e11 + , m22e12 + , m22e21 + , m22e22 + , v2e1 + , v2e2 + ) +import TypedSvg.Types as SvgTypes + + +{-| Convert an `AffineTransform` to a `TypedSvg` `Transform.Matrix`. +-} +convertAffineTransformToSvg : AffineTransform -> SvgTypes.Transform +convertAffineTransformToSvg affineTransform = + let + m = + affGetLinear affineTransform + + t = + affGetTranslation affineTransform + in + SvgTypes.Matrix + (m22e11 m) + (m22e21 m) + (m22e12 m) + (m22e22 m) + (v2e1 t) + (v2e2 t) diff --git a/src/Depict/Internal/Svg/Machine.elm b/src/Depict/Internal/Svg/Machine.elm new file mode 100644 index 0000000..b8a5576 --- /dev/null +++ b/src/Depict/Internal/Svg/Machine.elm @@ -0,0 +1,560 @@ +module Depict.Internal.Svg.Machine exposing + ( ToSvgResult + , svgResultGetHtml, svgResultGetWarnings, svgResultTuple + , toSvg + ) + +{-| Drawing state machine for producing SVG. + +This module implements a largely non-recursive state machine to evaluate a +`Dwg msg` into an `Svg msg`. Recursion is avoided for stack safety. + + +# Result Type and Warnings + +@docs ToSvgResult +@docs svgResultGetHtml, svgResultGetWarnings, svgResultTuple + + +# Conversion + +@docs toSvg + +-} + +import Depict.Internal.Dwg exposing (Dwg(..)) +import Depict.Internal.Svg.Defs as Defs +import Depict.Internal.Svg.Env as Env exposing (Env, Warning) +import Depict.Internal.Svg.Event exposing (eventHandlersToSvgAttrs) +import Depict.Internal.Svg.Extras as Extras +import Depict.Internal.Svg.Path as SvgPath +import Depict.Internal.Svg.Style as SvgStyle +import Depict.Math as Math +import Depict.Path as Path exposing (Path) +import Depict.Types as T + exposing + ( ContainerSize + , FrozenName(..) + , Sizing + , ViewBox + , Visibility(..) + ) +import Html exposing (Attribute, Html) +import Html.Attributes as HtmlA +import TypedSvg +import TypedSvg.Attributes as SvgA +import TypedSvg.Core exposing (Svg) +import TypedSvg.Types as SvgTypes + + + +---- Result Type and Warnings ------------------------------------------------- + + +{-| Result of the `toSvg` function. + +This collects together the `Html` produced (containing an `` element), +and a list of any warnings produced along the way. + +-} +type ToSvgResult msg + = ToSvgResult (Html msg) (List Warning) + + +{-| Return the HTML from a `ToSvgResult`. +-} +svgResultGetHtml : ToSvgResult msg -> Html msg +svgResultGetHtml (ToSvgResult html _) = + html + + +{-| Return the list of warnings from a `ToSvgResult`. +-} +svgResultGetWarnings : ToSvgResult msg -> List Warning +svgResultGetWarnings (ToSvgResult _ warnings) = + warnings + + +{-| Return a tuple version of `ToSvgResult`. +-} +svgResultTuple : ToSvgResult msg -> ( Html msg, List String ) +svgResultTuple result = + ( svgResultGetHtml result + , svgResultGetWarnings result |> List.map Env.unWarning + ) + + + +---- Conversion --------------------------------------------------------------- + + +{-| Convert a drawing to SVG. +-} +toSvg : Sizing -> Dwg msg -> ToSvgResult msg +toSvg sizing = + inject sizing >> loopTailRecursive >> produceHtml sizing + + +{-| Produce final HTML after running the state machine to completion. +-} +produceHtml : Sizing -> StateMachineResult msg -> ToSvgResult msg +produceHtml sizing (StateMachineResult result) = + ToSvgResult + (TypedSvg.svg + (sizingToSvg sizing ++ htmlEventHandlers result.envr) + result.childSvgs + ) + (Env.getWarnings result.envr) + + +{-| Produce HTML event handlers from the host event handlers list. +-} +htmlEventHandlers : Env msg -> List (Attribute msg) +htmlEventHandlers env = + eventHandlersToSvgAttrs + (Env.getCSysDict env) + (Env.getHostEventHandlers env) + + +{-| Convert all `Sizing` parameters to attributes on an SVG element. +-} +sizingToSvg : Sizing -> List (Attribute msg) +sizingToSvg sizing = + (T.sizingGetContainerSize sizing |> containerSizeToSvg) + ++ (T.sizingGetViewBox sizing |> viewBoxToSvg) + + +{-| Convert a `ContainerSize` to HTML height and width attributes. +-} +containerSizeToSvg : ContainerSize -> List (Attribute msg) +containerSizeToSvg cs = + [ HtmlA.width (T.containerSizeGetWidth cs) + , HtmlA.height (T.containerSizeGetHeight cs) + ] + + +{-| Convert a `ViewBox` to an SVG viewbox. +-} +viewBoxToSvg : ViewBox -> List (Attribute msg) +viewBoxToSvg vb = + [ SvgA.viewBox + (T.viewBoxGetXMin vb) + (T.viewBoxGetYMin vb) + (T.viewBoxGetWidth vb) + (T.viewBoxGetHeight vb) + ] + + +{-| Tail-recursive loop which steps the state machine evaluator until it +has completed and produces a result. +-} +loopTailRecursive : State msg -> StateMachineResult msg +loopTailRecursive state = + case extractIfDone state of + Just result -> + result + + Nothing -> + let + newState = + step state + in + loopTailRecursive newState + + + +---- State Machine ------------------------------------------------------------ + + +{-| Final result of running the state machine. +-} +type StateMachineResult msg + = StateMachineResult + { childSvgs : List (Svg msg) + , envr : Env msg + } + + +{-| Expression in the state machine. + +An expression is either: + + - An initial drawing value, or + - A final SVG value. + +-} +type Expr msg + = Init (Dwg msg) + | Fine (List (Svg msg)) + + +{-| Continuation for the state machine. +-} +type Kont msg + = KontAtop1 (Dwg msg) (Env msg) + | KontAtop2 (List (Svg msg)) (Env msg) + | KontBeneath1 (Dwg msg) (Env msg) + | KontBeneath2 (List (Svg msg)) (Env msg) + | KontFrozen Visibility (Maybe FrozenName) (Env msg) + + +{-| State in the state machine. +-} +type alias State msg = + { expr : Expr msg + , envr : Env msg + , kont : List (Kont msg) + } + + +{-| Inject an initial size and drawing into the machine state. +-} +inject : Sizing -> Dwg msg -> State msg +inject sizing dwg = + { expr = Init dwg + , envr = Env.init sizing + , kont = [] + } + + +{-| If the state machine has finished, return its result. +-} +extractIfDone : State msg -> Maybe (StateMachineResult msg) +extractIfDone state = + case ( state.expr, state.kont ) of + ( Fine svgs, [] ) -> + Just <| + StateMachineResult + { childSvgs = + (Env.getDefs state.envr |> Defs.toSvg) :: svgs + , envr = state.envr + } + + _ -> + Nothing + + +{-| Step the state machine. +-} +step : State msg -> State msg +step state = + case ( state.expr, state.kont ) of + {- ----------------------------------------------------------------- -} + {- Terminal state + + Really we will never execute this, because `extractIfDone` will + identify the terminal state first. But this is here to keep the + type-checker happy and everyone sane. + -} + {- ----------------------------------------------------------------- -} + ( Fine _, [] ) -> + state + + {- ----------------------------------------------------------------- -} + {- Initial states -} + {- ----------------------------------------------------------------- -} + {- Empty drawing. -} + ( Init DwgEmpty, _ ) -> + state |> setExpr (Fine []) + + {- Draw a Path. -} + ( Init (DwgPath path), _ ) -> + let + ( styleAttrs, state1 ) = + stateToStyleAttrs state + in + state1 + |> setExpr (Fine (pathToSvg state.envr styleAttrs path)) + |> modEnvr Env.removeEventHandlers + + {- Update the style in the environment. -} + ( Init (DwgStyled atom drawing), _ ) -> + state + |> setExpr (Init drawing) + |> modEnvr (Env.applyStyleAtom atom) + + {- Update the local-to-world transformation in the environment. -} + ( Init (DwgTransformed childToParent drawing), _ ) -> + state + |> setExpr (Init drawing) + |> modEnvr (Env.concatTransform childToParent) + + {- Draw the first drawing on top of the second. -} + ( Init (DwgAtop topDrawing bottomDrawing), _ ) -> + state + -- Suspend the bottom drawing in a coninuation, keeping the + -- event handlers there. + |> suspendKont (KontAtop1 bottomDrawing) + -- Remove the event handlers and process the top drawing. + |> modEnvr Env.removeEventHandlers + |> setExpr (Init topDrawing) + + {- Draw the first drawing beneath the second. -} + ( Init (DwgBeneath bottomDrawing topDrawing), _ ) -> + state + -- Suspend the top drawing in a continuation, keeping the + -- event handlers there. + |> suspendKont (KontBeneath1 topDrawing) + -- Remove the event handlers and process the bottom drawing. + |> modEnvr Env.removeEventHandlers + |> setExpr (Init bottomDrawing) + + {- Add a pending event handler to the environment. -} + ( Init (DwgEventHandler eventHandler drawing), _ ) -> + state + |> setExpr (Init drawing) + |> modEnvr (Env.addEventHandler eventHandler) + + {- Add a host event handler to the environment. -} + ( Init (DwgHostEventHandler eventHandler drawing), _ ) -> + state + |> setExpr (Init drawing) + |> modEnvr (Env.addHostEventHandler eventHandler) + + {- Tag the current local-to-world coordinate system. -} + ( Init (DwgTagCSys cSysName drawing), _ ) -> + state + |> setExpr (Init drawing) + |> modEnvr (Env.tagCSys cSysName) + + {- Freeze a drawing: convert it to SVG at this point. -} + ( Init (DwgFrozen visibility optName drawing), _ ) -> + state + |> suspendKont (KontFrozen visibility optName) + |> modEnvr Env.setLocalToWorldTransformAsInit + |> setExpr (Init drawing) + + ( Init (DwgUse frozenName), _ ) -> + let + ( styleAttrs, state1 ) = + stateToStyleAttrs state + in + state1 + |> setExpr (Fine <| useToSvg state.envr styleAttrs frozenName) + |> modEnvr Env.removeEventHandlers + + {- ----------------------------------------------------------------- -} + {- Continuation states -} + {- ----------------------------------------------------------------- -} + {- Process the first `DwgAtop` continuation. + + At this continuation, we have evaluated the first argument of a + `DwgAtop` value, and have to evaluate the second argument. + -} + ( Fine topSvgs, (KontAtop1 bottomDrawing susEnv) :: _ ) -> + state + |> popKont + |> threadEnvr susEnv + |> suspendKont (KontAtop2 topSvgs) + |> modEnvr Env.removeEventHandlers + |> setExpr (Init bottomDrawing) + + {- Process the second `DwgAtop` continuation. + + At this continuation, we have evaluated both arguments of a + `DwgAtop` value, and have to package them together. + -} + ( Fine bottomSvgs, (KontAtop2 topSvgs susEnv) :: _ ) -> + state + |> popKont + |> threadEnvr susEnv + |> setExpr (Fine <| combineDrawings susEnv topSvgs bottomSvgs) + + {- Process the first `DwgBeneath` continuation. + + At this continuation, we have evaluated the first argument of a + `DwgBeneath` value, and have to evaluate the second argument. + -} + ( Fine bottomSvgs, (KontBeneath1 topDrawing susEnv) :: _ ) -> + state + |> popKont + |> threadEnvr susEnv + |> suspendKont (KontBeneath2 bottomSvgs) + |> modEnvr Env.removeEventHandlers + |> setExpr (Init topDrawing) + + {- Process the second `DwgBeneath` continuation. + + At this continuation, we have evaluated both arguments of a + `DwgBeneath` value, and have to package them together. + -} + ( Fine topSvgs, (KontBeneath2 bottomSvgs susEnv) :: _ ) -> + state + |> popKont + |> threadEnvr susEnv + |> setExpr (Fine <| combineDrawings susEnv topSvgs bottomSvgs) + + {- Process the "freeze" continuation. This attaches an optional ID + to the frozen drawing. + -} + ( Fine svgs, (KontFrozen visibility optName susEnv) :: _ ) -> + state + |> popKont + |> threadEnvr susEnv + |> setExpr + (Fine <| + freezeWithOptionalId susEnv visibility optName svgs + ) + + +{-| Set the expression in the state. +-} +setExpr : Expr msg -> State msg -> State msg +setExpr e oldState = + { oldState | expr = e } + + +{-| Modify the environment inside the state. +-} +modEnvr : (Env msg -> Env msg) -> State msg -> State msg +modEnvr envModFn oldState = + { oldState | envr = envModFn oldState.envr } + + +{-| Thread the environment from completing a continuation through the +suspended environment from before the continuation was started. +-} +threadEnvr : Env msg -> State msg -> State msg +threadEnvr suspendedEnvironment oldState = + { oldState | envr = Env.thread suspendedEnvironment oldState.envr } + + +{-| Create a suspended continuation with the current environment, and prepend +it to the list of pending continuations in the state. +-} +suspendKont : (Env msg -> Kont msg) -> State msg -> State msg +suspendKont envToKont oldState = + { oldState | kont = envToKont oldState.envr :: oldState.kont } + + +{-| Pop the top continuation from the state. +-} +popKont : State msg -> State msg +popKont oldState = + case oldState.kont of + [] -> + oldState + + _ :: ks -> + { oldState | kont = ks } + + +{-| Get the style attributes for the current state's style. +-} +stateToStyleAttrs : State msg -> ( List (Attribute msg), State msg ) +stateToStyleAttrs state = + let + ( attrs, childEnv ) = + SvgStyle.envStyleToSvg state.envr + in + ( attrs, { state | envr = Env.thread state.envr childEnv } ) + + +{-| Convert a `Path` to SVG in the current environment. +-} +pathToSvg : Env msg -> List (Attribute msg) -> Path -> List (Svg msg) +pathToSvg env styleAttrs path = + let + localToWorld = + Env.getLocalToWorld env + + numFixedDigits = + Env.getNFixDigits env + + str = + Path.pathApplyAffineTransform localToWorld path + |> SvgPath.toString numFixedDigits + + attrs = + SvgA.d str :: styleAttrs + in + attachPendingEvents env [ TypedSvg.path attrs [] ] + + +{-| Convert a "use" to SVG. +-} +useToSvg : Env msg -> List (Attribute msg) -> FrozenName -> List (Svg msg) +useToSvg env styleAttrs (FrozenName name) = + attachPendingEvents env + [ TypedSvg.g + [ SvgA.transform + -- Post-multiplying by inverse of initial transform. + [ Extras.convertAffineTransformToSvg + (Math.affMatMul + (Env.getLocalToWorld env) + (Env.getInitWorldToLocal env) + ) + ] + ] + [ TypedSvg.use (SvgA.href ("#" ++ name) :: styleAttrs) [] + ] + ] + + +{-| Combine drawings in the specified order. +-} +combineDrawings : Env msg -> List (Svg msg) -> List (Svg msg) -> List (Svg msg) +combineDrawings env topSvgs bottomSvgs = + bottomSvgs ++ topSvgs |> attachPendingEvents env + + +{-| Attach any pending events from the environment to produced SVG. +-} +attachPendingEvents : Env msg -> List (Svg msg) -> List (Svg msg) +attachPendingEvents env svgs = + if Env.hasPendingEventHandlers env then + [ TypedSvg.g + (eventHandlersToSvgAttrs + (Env.getCSysDict env) + (Env.getEventHandlers env) + ) + svgs + ] + + else + svgs + + +{-| Freeze a drawing that has been converted to SVG. + + - Performs the local-to-world transformation in the group. + - Attaches the optional frozen name as the ID. + +-} +freezeWithOptionalId : + Env msg + -> Visibility + -> Maybe FrozenName + -> List (Svg msg) + -> List (Svg msg) +freezeWithOptionalId env visibility optName svgs = + case optName of + Nothing -> + svgs + + Just (FrozenName name) -> + let + attrs = + case visibility of + Visible -> + [ SvgA.transform + -- Post-multiplying by inverse of initial + -- transform. + [ Extras.convertAffineTransformToSvg + (Math.affMatMul + (Env.getLocalToWorld env) + (Env.getInitWorldToLocal env) + ) + ] + ] + + Hidden -> + [ SvgA.display SvgTypes.DisplayNone ] + in + [ TypedSvg.g + attrs + [ TypedSvg.g + [ SvgA.id name ] + svgs + ] + ] diff --git a/src/Techdraw/Svg/SvgStringPath.elm b/src/Depict/Internal/Svg/Path.elm similarity index 66% rename from src/Techdraw/Svg/SvgStringPath.elm rename to src/Depict/Internal/Svg/Path.elm index 471f53e..1f177da 100644 --- a/src/Techdraw/Svg/SvgStringPath.elm +++ b/src/Depict/Internal/Svg/Path.elm @@ -1,20 +1,15 @@ -module Techdraw.Svg.SvgStringPath exposing - ( SvgStringPath - , svgStringPath, svgStringPathToString - , formatPath +module Depict.Internal.Svg.Path exposing + ( toString , NFixDigits(..) , toFixed ) {-| String representation of SVG paths. -@docs SvgStringPath -@docs svgStringPath, svgStringPathToString +# Converting a Path to SVG -# Formatting a Path - -@docs formatPath +@docs toString # Number Formatting @@ -24,9 +19,8 @@ module Techdraw.Svg.SvgStringPath exposing -} -import List.Nonempty as Nonempty exposing (Nonempty) -import Techdraw.Math as M exposing (OrientationPi, P2) -import Techdraw.Path as P +import Depict.Math as M exposing (OrientationPi, P2) +import Depict.Path as P exposing ( ArcTo , CBezierTo @@ -38,6 +32,7 @@ import Techdraw.Path as P , Start , SubPath ) +import List.Nonempty as Nonempty exposing (Nonempty) {-| String representation of an SVG path. @@ -46,77 +41,66 @@ This type has a special internal representation of an empty string, to make joining path strings neater. -} -type SvgStringPath - = SvgStringPath String - | SvgStringPathEmpty - - -{-| Create an `SvgStringPath` from a `String`. --} -svgStringPath : String -> SvgStringPath -svgStringPath content = - if String.isEmpty content then - SvgStringPathEmpty - - else - SvgStringPath content +type PathString + = PathString String + | PathStringEmpty {-| Convert an `SvgStringPath` to a `String`. -} -svgStringPathToString : SvgStringPath -> String -svgStringPathToString ssp = +pathStringToString : PathString -> String +pathStringToString ssp = case ssp of - SvgStringPath content -> + PathString content -> content - SvgStringPathEmpty -> + PathStringEmpty -> "" {-| Join two string paths together with a space between them. Empty paths are handled separately to avoid adding unnecessary spaces. -} -joinWithSpace : SvgStringPath -> SvgStringPath -> SvgStringPath +joinWithSpace : PathString -> PathString -> PathString joinWithSpace sspA sspB = case ( sspA, sspB ) of - ( SvgStringPathEmpty, SvgStringPathEmpty ) -> - SvgStringPathEmpty + ( PathStringEmpty, PathStringEmpty ) -> + PathStringEmpty - ( SvgStringPath a, SvgStringPathEmpty ) -> - SvgStringPath a + ( PathString a, PathStringEmpty ) -> + PathString a - ( SvgStringPathEmpty, SvgStringPath b ) -> - SvgStringPath b + ( PathStringEmpty, PathString b ) -> + PathString b - ( SvgStringPath a, SvgStringPath b ) -> - SvgStringPath (a ++ " " ++ b) + ( PathString a, PathString b ) -> + PathString (a ++ " " ++ b) {-| Join a list of `SvgStringPath` components with spaces. -} -joinListWithSpace : List SvgStringPath -> SvgStringPath +joinListWithSpace : List PathString -> PathString joinListWithSpace = - List.foldl (\r l -> joinWithSpace l r) SvgStringPathEmpty + List.foldl (\r l -> joinWithSpace l r) PathStringEmpty {-| Join a non-empty list of `SvgStringPath` components with spaces. -} -joinNonemptyWithSpace : Nonempty SvgStringPath -> SvgStringPath +joinNonemptyWithSpace : Nonempty PathString -> PathString joinNonemptyWithSpace = - Nonempty.foldl (\r l -> joinWithSpace l r) SvgStringPathEmpty + Nonempty.foldl (\r l -> joinWithSpace l r) PathStringEmpty {-| Format a list of items into a single `SvgStringPath`. -} -formatList : (a -> SvgStringPath) -> List a -> SvgStringPath +formatList : (a -> PathString) -> List a -> PathString formatList convert = List.map convert >> joinListWithSpace {-| Format a non-empty list of items into a single `SvgStringPath`. -} -formatNonempty : (a -> SvgStringPath) -> Nonempty a -> SvgStringPath +formatNonempty : (a -> PathString) -> Nonempty a -> PathString formatNonempty convert = Nonempty.map convert >> joinNonemptyWithSpace @@ -125,16 +109,21 @@ formatNonempty convert = ---- Path Conversion ---------------------------------------------------------- -{-| Format a `Path` into an `SvgStringPath`. +{-| Format a `Path` into a `String` suitable for a `d = "..."` attribute in +SVG. + +`NFixDigits` specifies the number of digits to use after the decimal place +in the path string that is produced. + -} -formatPath : NFixDigits -> Path -> SvgStringPath -formatPath n (P.Path subPaths) = - formatList (formatSubPath n) subPaths +toString : NFixDigits -> Path -> String +toString n (P.Path subPaths) = + formatList (formatSubPath n) subPaths |> pathStringToString {-| Format a `SubPath` into an `SvgStringPath`. -} -formatSubPath : NFixDigits -> SubPath -> SvgStringPath +formatSubPath : NFixDigits -> SubPath -> PathString formatSubPath n (P.SubPath completion start segments) = joinWithSpace (formatStart n start) @@ -146,7 +135,7 @@ formatSubPath n (P.SubPath completion start segments) = {-| Format a `Segment` into an `SvgStringPath`. -} -formatSegment : NFixDigits -> Segment -> SvgStringPath +formatSegment : NFixDigits -> Segment -> PathString formatSegment n segment = case segment of P.SegLineTo lineTo -> @@ -166,36 +155,36 @@ formatSegment n segment = completion is `Closed`, and an empty `SvgStringPath` if the completion is `Open`. -} -formatCompletion : Completion -> SvgStringPath +formatCompletion : Completion -> PathString formatCompletion completion = case completion of P.Open -> - SvgStringPathEmpty + PathStringEmpty P.Closed -> - SvgStringPath "Z" + PathString "Z" {-| Format a `Start` into an `SvgStringPath` as a "M" command. -} -formatStart : NFixDigits -> Start -> SvgStringPath +formatStart : NFixDigits -> Start -> PathString formatStart n (P.Start p) = - joinWithSpace (SvgStringPath "M") (formatP2 n p) + joinWithSpace (PathString "M") (formatP2 n p) {-| Format a `LineTo` into an `SvgStringPath` as an "L" command. -} -formatLineTo : NFixDigits -> LineTo -> SvgStringPath +formatLineTo : NFixDigits -> LineTo -> PathString formatLineTo n (P.LineTo p) = - joinWithSpace (SvgStringPath "L") (formatP2 n p) + joinWithSpace (PathString "L") (formatP2 n p) {-| Format a `QBezierTo` into an `SvgStringPath` as a "Q" command. -} -formatQBezierTo : NFixDigits -> QBezierTo -> SvgStringPath +formatQBezierTo : NFixDigits -> QBezierTo -> PathString formatQBezierTo n (P.QBezierTo a b) = joinListWithSpace - [ SvgStringPath "Q" + [ PathString "Q" , formatP2 n a , formatP2 n b ] @@ -203,10 +192,10 @@ formatQBezierTo n (P.QBezierTo a b) = {-| Format a `CBezierTo` into an `SvgStringPath` as a "C" command. -} -formatCBezierTo : NFixDigits -> CBezierTo -> SvgStringPath +formatCBezierTo : NFixDigits -> CBezierTo -> PathString formatCBezierTo n (P.CBezierTo a b c) = joinListWithSpace - [ SvgStringPath "C" + [ PathString "C" , formatP2 n a , formatP2 n b , formatP2 n c @@ -219,20 +208,13 @@ The angular measure in an `ArcTo` is given two additional significant figures on top of the value in `NFixDigits`. -} -formatArcTo : NFixDigits -> ArcTo -> SvgStringPath +formatArcTo : NFixDigits -> ArcTo -> PathString formatArcTo n (P.ArcTo arcTo) = - let - (NFixDigits linDigits) = - n - - nAngDigits = - NFixDigits (linDigits + 2) - in joinListWithSpace - [ SvgStringPath "A" + [ PathString "A" , formatFloat n arcTo.rx , formatFloat n arcTo.ry - , formatOrientationPi nAngDigits arcTo.xOrient + , formatOrientationPi n arcTo.xOrient , formatBool arcTo.large , formatBool arcTo.sweep , formatP2 n arcTo.end @@ -241,30 +223,30 @@ formatArcTo n (P.ArcTo arcTo) = {-| Format a `P2` into an `SvgStringPath`. -} -formatP2 : NFixDigits -> P2 -> SvgStringPath +formatP2 : NFixDigits -> P2 -> PathString formatP2 n p = joinWithSpace (formatFloat n (M.p2x p)) (formatFloat n (M.p2y p)) {-| Format a `Float` into an `SvgStringPath`. -} -formatFloat : NFixDigits -> Float -> SvgStringPath +formatFloat : NFixDigits -> Float -> PathString formatFloat n = - SvgStringPath << toFixed n + PathString << toFixed n {-| Format an `OrientationPi` into an `SvgStringPath`. -} -formatOrientationPi : NFixDigits -> OrientationPi -> SvgStringPath +formatOrientationPi : NFixDigits -> OrientationPi -> PathString formatOrientationPi n = - formatFloat n << M.getOrientationPi + formatFloat n << M.toDegrees << M.getOrientationPi {-| Format a `Bool` into an `SvgStringPath`. -} -formatBool : Bool -> SvgStringPath +formatBool : Bool -> PathString formatBool b = - SvgStringPath <| + PathString <| if b then "1" diff --git a/src/Depict/Internal/Svg/Style.elm b/src/Depict/Internal/Svg/Style.elm new file mode 100644 index 0000000..7f297c8 --- /dev/null +++ b/src/Depict/Internal/Svg/Style.elm @@ -0,0 +1,280 @@ +module Depict.Internal.Svg.Style exposing (envStyleToSvg) + +{-| Styling in SVG. + +@docs envStyleToSvg + +-} + +import Depict.Internal.Hash as Hash +import Depict.Internal.Svg.Defs as Defs +import Depict.Internal.Svg.Env as Env exposing (Env) +import Depict.Style as Style + exposing + ( Fill(..) + , LinearGradient + , Option(..) + , Paint(..) + , RadialGradient + , Stroke(..) + , Style(..) + ) +import TypedSvg.Attributes as SvgAttr +import TypedSvg.Core exposing (Attribute, attribute) +import TypedSvg.Types as SvgTypes exposing (px) + + +{-| Convert the current `Style` to SVG. +-} +envStyleToSvg : Env msg -> ( List (Attribute msg), Env msg ) +envStyleToSvg env = + let + (Style style) = + Env.getStyle env + + ( fillAttr, env1 ) = + fillToSvg env style.fill + + ( strokeAttr, env2 ) = + strokeToSvg env1 style.stroke + in + ( fillAttr ++ strokeAttr, env2 ) + + +{-| Convert the `Fill` to SVG. +-} +fillToSvg : Env msg -> Fill -> ( List (Attribute msg), Env msg ) +fillToSvg env (Fill fill) = + let + ( fillAttr, newEnv ) = + optionPaintToAttr env SvgAttr.fill fill.fill + in + ( List.concat + [ fillAttr + , optionToAttr (translateFillRule >> SvgAttr.fillRule) fill.fillRule + ] + , newEnv + ) + + +{-| Convert the `Stroke` to SVG. +-} +strokeToSvg : Env msg -> Stroke -> ( List (Attribute msg), Env msg ) +strokeToSvg env (Stroke stroke) = + let + ( strokeAttr, newEnv ) = + optionPaintToAttr env SvgAttr.stroke stroke.stroke + in + ( List.concat + [ strokeAttr + , optionToAttr (px >> SvgAttr.strokeWidth) stroke.strokeWidth + , optionToAttr + (translateLineCap >> SvgAttr.strokeLinecap) + stroke.lineCap + , lineJoinToAttrs stroke.lineJoin + , optionToAttr + (unDashArray + >> List.map String.fromFloat + >> String.join " " + >> SvgAttr.strokeDasharray + ) + stroke.dashArray + , optionToAttr + (String.fromFloat >> SvgAttr.strokeDashoffset) + stroke.dashOffset + ] + , newEnv + ) + + +{-| Convert `LineJoin` to a list of attributes. + + - We need to include the miter limit here. + - Some options are missing from TypedSvg. + +-} +lineJoinToAttrs : Option Style.LineJoin -> List (Attribute msg) +lineJoinToAttrs optLineJoin = + case optLineJoin of + Inherit -> + [] + + Set (Style.LineJoinMiter limit) -> + [ SvgAttr.strokeLinejoin SvgTypes.StrokeLinejoinMiter + , SvgAttr.strokeMiterlimit (String.fromFloat limit) + ] + + Set (Style.LineJoinMiterClip limit) -> + [ attribute "stroke-linejoin" "miter-clip" + , SvgAttr.strokeMiterlimit (String.fromFloat limit) + ] + + Set Style.LineJoinRound -> + [ SvgAttr.strokeLinejoin SvgTypes.StrokeLinejoinRound ] + + Set Style.LineJoinBevel -> + [ SvgAttr.strokeLinejoin SvgTypes.StrokeLinejoinBevel ] + + Set Style.LineJoinArcs -> + [ attribute "stroke-linejoin" "arcs" ] + + +{-| Translate the `FillRule` to SVG. +-} +translateFillRule : Style.FillRule -> SvgTypes.FillRule +translateFillRule fr = + case fr of + Style.NonZero -> + SvgTypes.FillRuleNonZero + + Style.EvenOdd -> + SvgTypes.FillRuleEvenOdd + + +{-| Translate `LineCap` to SVG. +-} +translateLineCap : Style.LineCap -> SvgTypes.StrokeLinecap +translateLineCap lc = + case lc of + Style.LineCapButt -> + SvgTypes.StrokeLinecapButt + + Style.LineCapRound -> + SvgTypes.StrokeLinecapRound + + Style.LineCapSquare -> + SvgTypes.StrokeLinecapSquare + + +{-| Convert an Option to an attribute. +-} +optionToAttr : (a -> Attribute msg) -> Option a -> List (Attribute msg) +optionToAttr toAttr optValue = + optionToMaybe optValue + |> Maybe.map (\x -> [ toAttr x ]) + |> Maybe.withDefault [] + + +{-| Convert an `Option Paint` to an SVG attribute. +-} +optionPaintToAttr : + Env msg + -> (SvgTypes.Paint -> Attribute msg) + -> Option Paint + -> ( List (Attribute msg), Env msg ) +optionPaintToAttr env toAttr optPaint = + optionToMaybe optPaint + |> Maybe.map (paintToAttr env toAttr) + |> Maybe.withDefault ( [], env ) + + +{-| Convert a `Paint` to an SVG attribute. +-} +paintToAttr : + Env msg + -> (SvgTypes.Paint -> Attribute msg) + -> Paint + -> ( List (Attribute msg), Env msg ) +paintToAttr env toAttr paint = + let + ( svgPaint, newEnv ) = + paintToSvg env paint + in + ( [ toAttr svgPaint ], newEnv ) + + +{-| Convert a `Paint` value to SVG. + +Any gradients have to be transformed using the current local-to-world +transformation. Additionally, the environment must be updated so that the +`` element will contain the gradients. + +-} +paintToSvg : Env msg -> Paint -> ( SvgTypes.Paint, Env msg ) +paintToSvg env paint = + case paint of + Paint color -> + ( SvgTypes.Paint color, env ) + + PaintLinearGradient lg -> + linearGradientToSvg env lg + + PaintRadialGradient rg -> + radialGradientToSvg env rg + + +{-| Convert a `LinearGradient` to SVG. + +We have to transform the gradient using the current local-to-world +transformation. The transformation is applied to the gradient's +`gradientTransform` attribute, leaving everything else alone. + +The environment is updated so that the `` element will contain +the gradient. The gradient's ID is its hash. + +-} +linearGradientToSvg : Env msg -> LinearGradient -> ( SvgTypes.Paint, Env msg ) +linearGradientToSvg env lg = + let + transformedGradient = + Style.linearGradientApplyAffineTransform + (Env.getLocalToWorld env) + lg + + svgPaint = + SvgTypes.Reference <| + Hash.toHex <| + Style.hashLinearGradient transformedGradient + + newEnv = + Env.modDefs (Defs.ensureLinearGradient transformedGradient) env + in + ( svgPaint, newEnv ) + + +{-| Convert a `RadialGradient` to SVG. + +We have to transform the gradient using the current local-to-world +transformation. The transformation is applied to the gradient's +`gradientTransform` attribute, leaving everything else alone. + +The environment is updated so that the `` element will contain +the gradient. The gradient's ID is its hash. + +-} +radialGradientToSvg : Env msg -> RadialGradient -> ( SvgTypes.Paint, Env msg ) +radialGradientToSvg env rg = + let + transformedGradient = + Style.radialGradientApplyAffineTransform + (Env.getLocalToWorld env) + rg + + svgPaint = + SvgTypes.Reference <| + Hash.toHex <| + Style.hashRadialGradient transformedGradient + + newEnv = + Env.modDefs (Defs.ensureRadialGradient transformedGradient) env + in + ( svgPaint, newEnv ) + + +{-| Convert a styling option to a `Maybe`. +-} +optionToMaybe : Option a -> Maybe a +optionToMaybe option = + case option of + Inherit -> + Nothing + + Set value -> + Just value + + +{-| Unapply the dasharray constructor. +-} +unDashArray : Style.DashArray -> List Float +unDashArray (Style.DashArray fs) = + fs diff --git a/src/Techdraw/Math.elm b/src/Depict/Math.elm similarity index 97% rename from src/Techdraw/Math.elm rename to src/Depict/Math.elm index 85a8616..02472e5 100644 --- a/src/Techdraw/Math.elm +++ b/src/Depict/Math.elm @@ -1,5 +1,5 @@ -module Techdraw.Math exposing - ( sq +module Depict.Math exposing + ( sq, toRadians, toDegrees , Tol(..), closeFloat , Angle2Pi, AnglePi, OrientationPi , angle2Pi, anglePi, orientationPi @@ -31,7 +31,7 @@ module Techdraw.Math exposing , p2ApplyAffineTransform , closeP2 , AffineTransform - , affineTransform + , affineTransform, affineTransformMV , affIdentity, affRotation, affScaling, affShearingX, affTranslation , affFromComponent, affFromComponents , affGetLinear, affGetTranslation @@ -40,7 +40,7 @@ module Techdraw.Math exposing , closeAffineTransform ) -{-| Mathematical core for Techdraw. +{-| Mathematical core for Depict. - [Floating-Point Functions](#floating-point-functions) - [Comparison of Floating-Point Values](#comparison-of-floating-point-values) @@ -53,7 +53,7 @@ module Techdraw.Math exposing # Floating Point Functions -@docs sq +@docs sq, toRadians, toDegrees # Comparison of Floating-Point Values @@ -271,7 +271,7 @@ that applies an affine transformation to a point. ## Creation -@docs affineTransform +@docs affineTransform, affineTransformMV @docs affIdentity, affRotation, affScaling, affShearingX, affTranslation @docs affFromComponent, affFromComponents @@ -311,6 +311,20 @@ sq x = x * x +{-| Convert an angle in degrees to radians. +-} +toRadians : Float -> Float +toRadians deg = + deg * pi / 180 + + +{-| Convert an angle in radius to degrees. +-} +toDegrees : Float -> Float +toDegrees rad = + rad * 180 / pi + + ---- Comparison of Floating-Point Values -------------------------------------- @@ -1060,6 +1074,14 @@ affineTransform e11 e12 e21 e22 tx ty = AffineTransform { linear = m22 e11 e12 e21 e22, translation = v2 tx ty } +{-| Create an affine transformation from its linear matrix and translation +vector. +-} +affineTransformMV : M22 -> V2 -> AffineTransform +affineTransformMV m v = + AffineTransform { linear = m, translation = v } + + {-| Return the linear component of an affine transform. -} affGetLinear : AffineTransform -> M22 diff --git a/src/Techdraw/Path.elm b/src/Depict/Path.elm similarity index 99% rename from src/Techdraw/Path.elm rename to src/Depict/Path.elm index 0eddf69..b252fca 100644 --- a/src/Techdraw/Path.elm +++ b/src/Depict/Path.elm @@ -1,4 +1,4 @@ -module Techdraw.Path exposing +module Depict.Path exposing ( Path(..) , SubPath(..) , Completion(..) @@ -58,8 +58,8 @@ Segments inside a sub-path can be any of the following: -} +import Depict.Math as M exposing (AffineTransform, OrientationPi, P2, Tol) import List.Nonempty as Nonempty exposing (Nonempty) -import Techdraw.Math as M exposing (AffineTransform, OrientationPi, P2, Tol) {-| List of sub-paths. diff --git a/src/Techdraw/PathBuilder.elm b/src/Depict/PathBuilder.elm similarity index 98% rename from src/Techdraw/PathBuilder.elm rename to src/Depict/PathBuilder.elm index 94165c2..1d1d974 100644 --- a/src/Techdraw/PathBuilder.elm +++ b/src/Depict/PathBuilder.elm @@ -1,4 +1,4 @@ -module Techdraw.PathBuilder exposing +module Depict.PathBuilder exposing ( PathBuilder , empty , createPath @@ -21,9 +21,8 @@ module Techdraw.PathBuilder exposing -} -import List.Nonempty as Nonempty -import Techdraw.Math exposing (P2, orientationPi, p2) -import Techdraw.Path +import Depict.Math exposing (P2, orientationPi, p2) +import Depict.Path exposing ( ArcTo(..) , CBezierTo(..) @@ -35,6 +34,7 @@ import Techdraw.Path , Start(..) , SubPath(..) ) +import List.Nonempty as Nonempty {-| Building paths. diff --git a/src/Techdraw/Shapes/Simple.elm b/src/Depict/Shapes/Simple.elm similarity index 97% rename from src/Techdraw/Shapes/Simple.elm rename to src/Depict/Shapes/Simple.elm index 718eaf4..2286103 100644 --- a/src/Techdraw/Shapes/Simple.elm +++ b/src/Depict/Shapes/Simple.elm @@ -1,4 +1,4 @@ -module Techdraw.Shapes.Simple exposing +module Depict.Shapes.Simple exposing ( rect, rectRounded , circle, ellipse ) @@ -10,8 +10,8 @@ module Techdraw.Shapes.Simple exposing -} -import Techdraw.Path exposing (Path(..)) -import Techdraw.PathBuilder +import Depict.Path exposing (Path(..)) +import Depict.PathBuilder exposing ( arcTo , close diff --git a/src/Techdraw/Shapes/Spring.elm b/src/Depict/Shapes/Spring.elm similarity index 97% rename from src/Techdraw/Shapes/Spring.elm rename to src/Depict/Shapes/Spring.elm index ce45460..b61ca9c 100644 --- a/src/Techdraw/Shapes/Spring.elm +++ b/src/Depict/Shapes/Spring.elm @@ -1,4 +1,4 @@ -module Techdraw.Shapes.Spring exposing (spring) +module Depict.Shapes.Spring exposing (spring) {-| Spring geometry. @@ -6,9 +6,9 @@ module Techdraw.Shapes.Spring exposing (spring) -} -import Techdraw.Math as M -import Techdraw.Path as P -import Techdraw.PathBuilder as PB +import Depict.Math as M +import Depict.Path as P +import Depict.PathBuilder as PB {-| Path representing a spring. diff --git a/src/Depict/Style.elm b/src/Depict/Style.elm new file mode 100644 index 0000000..28ccebe --- /dev/null +++ b/src/Depict/Style.elm @@ -0,0 +1,632 @@ +module Depict.Style exposing + ( Style(..) + , Option(..) + , Fill(..) + , FillRule(..) + , Stroke(..) + , LineCap(..), LineJoin(..), DashArray(..) + , Paint(..) + , LinearGradientParams, LinearGradient + , RadialGradientParams, RadialGradient + , linearGradient, radialGradient + , linearGradientApplyAffineTransform, radialGradientApplyAffineTransform + , GradientParams, Gradient, Stop(..), gradient + , hashGradient, hashLinearGradient, hashRadialGradient + , gradientParams, linearGradientParams, radialGradientParams + , stopLocation, stopColor + , combineStyle + , inheritAll + , fill, fillRule + , stroke, strokeWidth, lineCap, lineJoin, dashArray, dashOffset + ) + +{-| Styles. + + +# Types + + +## Overall Style + +@docs Style + + +## Style Options + +@docs Option + + +## Fill + +@docs Fill +@docs FillRule + + +## Stroke + +@docs Stroke +@docs LineCap, LineJoin, DashArray + + +## Paint + +@docs Paint + + +## Gradients + +@docs LinearGradientParams, LinearGradient +@docs RadialGradientParams, RadialGradient +@docs linearGradient, radialGradient +@docs linearGradientApplyAffineTransform, radialGradientApplyAffineTransform +@docs GradientParams, Gradient, Stop, gradient +@docs hashGradient, hashLinearGradient, hashRadialGradient +@docs gradientParams, linearGradientParams, radialGradientParams +@docs stopLocation, stopColor + + +# Operations + +@docs combineStyle + + +# Style Setting Functions + +@docs inheritAll +@docs fill, fillRule +@docs stroke, strokeWidth, lineCap, lineJoin, dashArray, dashOffset + +-} + +import Color exposing (Color) +import Depict.Internal.Hash as Hash exposing (Hash, Hasher) +import Depict.Math as Math exposing (AffineTransform, P2) + + + +---- Overall Style ------------------------------------------------------------ + + +{-| Style. +-} +type Style + = Style + { fill : Fill + , stroke : Stroke + } + + + +---- Style Option ------------------------------------------------------------- + + +{-| Style option. + +A style option can be inherited or set. + +-} +type Option a + = Inherit + | Set a + + + +---- Fills -------------------------------------------------------------------- + + +{-| Fill style. +-} +type Fill + = Fill + { fill : Option Paint + , fillRule : Option FillRule + } + + +{-| Fill rule. +-} +type FillRule + = NonZero + | EvenOdd + + + +---- Strokes ------------------------------------------------------------------ + + +{-| Stroke style. +-} +type Stroke + = Stroke + { stroke : Option Paint + , strokeWidth : Option Float + , lineCap : Option LineCap + , lineJoin : Option LineJoin + , dashArray : Option DashArray + , dashOffset : Option Float + } + + +{-| Line cap. +-} +type LineCap + = LineCapButt + | LineCapRound + | LineCapSquare + + +{-| Line join. +-} +type LineJoin + = LineJoinMiter Float + | LineJoinMiterClip Float + | LineJoinRound + | LineJoinBevel + | LineJoinArcs + + +{-| Line dash array. +-} +type DashArray + = DashArray (List Float) + + + +---- Paint -------------------------------------------------------------------- + + +{-| Paint lines or fills. +-} +type Paint + = Paint Color + | PaintLinearGradient LinearGradient + | PaintRadialGradient RadialGradient + + + +---- Gradients ---------------------------------------------------------------- + + +{-| Parameters of a linear gradient. + +A linear gradient is specified by: + + - `start`: a start point. + - `end`: an end point. + - `transform`: additional gradient transform, which maps from the gradient + coordinate system to the local coordinate system. + - `gradient`: the list of gradient stops. + +-} +type alias LinearGradientParams = + { start : P2 + , end : P2 + , transform : AffineTransform + , gradient : Gradient + } + + +{-| Encode LinearGradientParams for hashing. +-} +encLinearGradientParams : Hash.Encoder LinearGradientParams +encLinearGradientParams = + Hash.enc4 + Hash.p2 + Hash.p2 + Hash.affineTransform + Hash.encHash + .start + .end + .transform + (.gradient >> hashGradient) + |> Hash.attachTag "Style.LinearGradientParams" + + +{-| Linear gradient. + +Internally, this contains the parameters of the linear gradient along with +a unique hash. + +-} +type LinearGradient + = LinearGradient Hash LinearGradientParams + + +{-| Create a linear gradient. +-} +linearGradient : LinearGradientParams -> LinearGradient +linearGradient params = + LinearGradient (Hash.fromEncoder encLinearGradientParams <| params) params + + +{-| Apply an affine transformation to a `LinearGradient`. This is done by +adjusting the affine transformation within the gradient itself. +-} +linearGradientApplyAffineTransform : + AffineTransform + -> LinearGradient + -> LinearGradient +linearGradientApplyAffineTransform transform lg = + let + params = + linearGradientParams lg + in + linearGradient + { params + | transform = Math.affMatMul transform params.transform + } + + +{-| Parameters of a radial gradient. + +A radial gradient is drawn between an "inner circle" and an "outer circle". +It is specified by: + + - `innerCenter`: center of the inner circle. + - `innerRadius`: radius of the inner circle. + - `outerCenter`: center of the outer circle. + - `outerRadius`: radius of the outer circle. + - `transform`: additional gradient transform, which maps from the gradient + coordinate system to the local coordinate system. + - `gradient`: the list of gradient stops. + +-} +type alias RadialGradientParams = + { innerCenter : P2 + , innerRadius : Float + , outerCenter : P2 + , outerRadius : Float + , transform : AffineTransform + , gradient : Gradient + } + + +{-| Encode the RadialGradientParams for hashing. +-} +encRadialGradientParams : Hash.Encoder RadialGradientParams +encRadialGradientParams = + Hash.enc6 + Hash.p2 + Hash.f32 + Hash.p2 + Hash.f32 + Hash.affineTransform + Hash.encHash + .innerCenter + .innerRadius + .outerCenter + .outerRadius + .transform + (.gradient >> hashGradient) + |> Hash.attachTag "Style.RadialGradientParams" + + +{-| Radial gradient. + +Internally, this contains the parameters of the radial gradient along with a +unique hash. + +-} +type RadialGradient + = RadialGradient Hash RadialGradientParams + + +{-| Create a radial gradient. +-} +radialGradient : RadialGradientParams -> RadialGradient +radialGradient params = + RadialGradient (Hash.fromEncoder encRadialGradientParams <| params) params + + +{-| Apply an affine transformation to a `RadialGradient`. This is done by +adjusting the affine transformation within the gradient itself. +-} +radialGradientApplyAffineTransform : + AffineTransform + -> RadialGradient + -> RadialGradient +radialGradientApplyAffineTransform transform rg = + let + params = + radialGradientParams rg + in + radialGradient + { params + | transform = Math.affMatMul transform params.transform + } + + +{-| Gradient. + +A gradient contains + + - A list of stops. + - Hashing information for the stops, so that a global unique ID can be created + for the gradient. + +-} +type Gradient + = Gradient Hash GradientParams + + +{-| Parameters for a `Gradient` : a list of `Stop`s. +-} +type alias GradientParams = + List Stop + + +{-| Hash encoder for gradient parameters. +-} +encGradientParams : Hash.Encoder GradientParams +encGradientParams = + Hash.list encStop + |> Hash.attachTag "Style.GradientParams" + + +{-| Gradient stop. + +This specifies a location (usually a number between 0 and 1) for the stop, +and a color that specifies the color of the gradient stop. + +-} +type Stop + = Stop Float Color + + +{-| Hash encoder for a `Stop`. +-} +encStop : Hash.Encoder Stop +encStop = + Hash.enc2 Hash.f32 Hash.color stopLocation stopColor + |> Hash.attachTag "Style.Stop" + + +{-| Return the location of a gradient stop. +-} +stopLocation : Stop -> Float +stopLocation (Stop location _) = + location + + +{-| Return the color of a gradient stop. +-} +stopColor : Stop -> Color +stopColor (Stop _ color) = + color + + +{-| Create a `Gradient` from a list of stops. +-} +gradient : GradientParams -> Gradient +gradient params = + Gradient (Hash.fromEncoder encGradientParams <| params) params + + +{-| Hasher for a `Gradient`: just extracts its pre-computed parameters hash. +-} +hashGradient : Hasher Gradient +hashGradient (Gradient hash _) = + hash + + +{-| Hasher for a `LinearGradient`: just extract its pre-computed parameters +hash. +-} +hashLinearGradient : Hasher LinearGradient +hashLinearGradient (LinearGradient hash _) = + hash + + +{-| Hasher for a `RadialGradient`: just extract its pre-computed parameters +hash. +-} +hashRadialGradient : Hasher RadialGradient +hashRadialGradient (RadialGradient hash _) = + hash + + +{-| Return the parameters for a `Gradient`. +-} +gradientParams : Gradient -> GradientParams +gradientParams (Gradient _ params) = + params + + +{-| Return the parameters for a `LinearGradient`. +-} +linearGradientParams : LinearGradient -> LinearGradientParams +linearGradientParams (LinearGradient _ params) = + params + + +{-| Return the parameters for a `RadialGradient`. +-} +radialGradientParams : RadialGradient -> RadialGradientParams +radialGradientParams (RadialGradient _ params) = + params + + + +---- Combining Styles --------------------------------------------------------- + + +{-| Combine style options from a parent and child. + + outcomeStyle = + combineStyle parentStyle childStyle + +-} +combineStyle : Style -> Style -> Style +combineStyle (Style parent) (Style child) = + Style + { fill = combineFill parent.fill child.fill + , stroke = combineStroke parent.stroke child.stroke + } + + +{-| Combine fill styling options from a parent and child. +-} +combineFill : Fill -> Fill -> Fill +combineFill (Fill parent) (Fill child) = + let + cmb extract = + combineExtracted extract parent child + in + Fill + { fill = cmb .fill + , fillRule = cmb .fillRule + } + + +{-| Combine stroke styling options from a parent and child. +-} +combineStroke : Stroke -> Stroke -> Stroke +combineStroke (Stroke parent) (Stroke child) = + let + cmb extract = + combineExtracted extract parent child + in + Stroke + { stroke = cmb .stroke + , strokeWidth = cmb .strokeWidth + , lineCap = cmb .lineCap + , lineJoin = cmb .lineJoin + , dashArray = cmb .dashArray + , dashOffset = cmb .dashOffset + } + + +{-| Combine a styling option extracted from a type. +-} +combineExtracted : (a -> Option b) -> a -> a -> Option b +combineExtracted extract parent child = + combineOption (extract parent) (extract child) + + +{-| Combine a parent and child styling option. + +1. The child `Set` option always takes precedence. +2. If the child has an `Inherit` option, and the parent is `Set`, then the + child will inherit the parent's `Set` value. +3. The only other case is a pair of `Inherit` options, which will result in + an `Inherit` outcome. + +-} +combineOption : Option a -> Option a -> Option a +combineOption parent child = + case ( parent, child ) of + ( _, Set childValue ) -> + Set childValue + + ( Set parentValue, Inherit ) -> + Set parentValue + + ( Inherit, Inherit ) -> + Inherit + + + +---- Style Setting Functions -------------------------------------------------- + + +{-| The style that inherits everything and sets nothing. + +This is the default style. + +-} +inheritAll : Style +inheritAll = + Style + { fill = fillInheritAll + , stroke = strokeInheritAll + } + + +fillInheritAll : Fill +fillInheritAll = + Fill + { fill = Inherit + , fillRule = Inherit + } + + +strokeInheritAll : Stroke +strokeInheritAll = + Stroke + { stroke = Inherit + , strokeWidth = Inherit + , lineCap = Inherit + , lineJoin = Inherit + , dashArray = Inherit + , dashOffset = Inherit + } + + +{-| Modify the `fill` setting of a `Style`. +-} +styleModifyFill : (Fill -> Fill) -> Style -> Style +styleModifyFill fillFn (Style input) = + { input | fill = fillFn input.fill } |> Style + + +{-| Modify the `stroke` setting of a `Style`. +-} +styleModifyStroke : (Stroke -> Stroke) -> Style -> Style +styleModifyStroke strokeFn (Style input) = + { input | stroke = strokeFn input.stroke } |> Style + + +{-| Set the fill paint. +-} +fill : Paint -> Style -> Style +fill paint = + styleModifyFill <| \(Fill phil) -> Fill { phil | fill = Set paint } + + +{-| Set the fill rule. +-} +fillRule : FillRule -> Style -> Style +fillRule fr = + styleModifyFill <| \(Fill phil) -> Fill { phil | fillRule = Set fr } + + +{-| Set the stroke paint. +-} +stroke : Paint -> Style -> Style +stroke paint = + styleModifyStroke <| \(Stroke st) -> Stroke { st | stroke = Set paint } + + +{-| Set the stroke width. +-} +strokeWidth : Float -> Style -> Style +strokeWidth w = + styleModifyStroke <| \(Stroke st) -> Stroke { st | strokeWidth = Set w } + + +{-| Set the line cap. +-} +lineCap : LineCap -> Style -> Style +lineCap c = + styleModifyStroke <| \(Stroke st) -> Stroke { st | lineCap = Set c } + + +{-| Set the line join. +-} +lineJoin : LineJoin -> Style -> Style +lineJoin j = + styleModifyStroke <| \(Stroke st) -> Stroke { st | lineJoin = Set j } + + +{-| Set the dash array. +-} +dashArray : DashArray -> Style -> Style +dashArray d = + styleModifyStroke <| \(Stroke st) -> Stroke { st | dashArray = Set d } + + +{-| Set the dash offset. +-} +dashOffset : Float -> Style -> Style +dashOffset o = + styleModifyStroke <| \(Stroke st) -> Stroke { st | dashOffset = Set o } diff --git a/src/Depict/Types.elm b/src/Depict/Types.elm new file mode 100644 index 0000000..f7a2278 --- /dev/null +++ b/src/Depict/Types.elm @@ -0,0 +1,223 @@ +module Depict.Types exposing + ( Sizing(..), ViewBox(..), ContainerSize(..) + , sizingScaled, sizingWH + , sizingGetViewBox, sizingGetContainerSize + , containerSizeGetWidth, containerSizeGetHeight + , viewBoxGetXMin, viewBoxGetYMin, viewBoxGetWidth, viewBoxGetHeight + , Order(..), Visibility(..) + , CSysName(..) + , FrozenName(..) + ) + +{-| Additional types. + + +# Sizes + +@docs Sizing, ViewBox, ContainerSize +@docs sizingScaled, sizingWH +@docs sizingGetViewBox, sizingGetContainerSize +@docs containerSizeGetWidth, containerSizeGetHeight +@docs viewBoxGetXMin, viewBoxGetYMin, viewBoxGetWidth, viewBoxGetHeight + + +# Drawing Order + +@docs Order, Visibility + + +# Names + +@docs CSysName +@docs FrozenName + +-} + +---- Sizes -------------------------------------------------------------------- + + +{-| Overall sizing of a drawing. + +This indicates both the: + + - Container size: the size of the drawing container, and + - ViewBox: the viewing window onto the drawing. + +Both sizes are required to fully establish the mouse coordinate transformations. + +-} +type Sizing + = Sizing + { containerSize : ContainerSize + , viewBox : ViewBox + } + + +{-| Viewing box for a drawing. + +The `ViewBox` provides a description of the view that the user has onto the +drawing. + +Initially, every drawing has the coordinate `p2 xMin yMin` in the lower-left, +with the `x` axis increasing to the right and the `y` axis increasing upwards. +The `width` and `height` of the drawing are also specified. + +-} +type ViewBox + = ViewBox + { xMin : Float + , yMin : Float + , width : Float + , height : Float + } + + +{-| Size of the container the drawing will be displayed inside. + +The `ContainerSize` is the size of the HTML element (an `` element) that +will contain the drawing. + +-} +type ContainerSize + = ContainerSize + { width : Int + , height : Int + } + + +{-| Create overall drawing sizing by scaling the viewbox width and height to +produce a container size. +-} +sizingScaled : + { xMin : Float + , yMin : Float + , width : Float + , height : Float + } + -> Float + -> Sizing +sizingScaled vb scale = + Sizing + { containerSize = + ContainerSize + { width = round (vb.width * scale) + , height = round (vb.height * scale) + } + , viewBox = + ViewBox + { xMin = vb.xMin + , yMin = vb.yMin + , width = vb.width + , height = vb.height + } + } + + +{-| Create `Sizing` from an unscaled width and height. + +This is equivalent to placing the origin of the drawing in the lower-left and +having a 1:1 pixel-to-unit correspondence. The same width and height are used +for both the `ViewBox` and `ContainerSize`. + +-} +sizingWH : Float -> Float -> Sizing +sizingWH width height = + sizingScaled { xMin = 0, yMin = 0, width = width, height = height } 1 + + +{-| Return the `ViewBox` from `Sizing`. +-} +sizingGetViewBox : Sizing -> ViewBox +sizingGetViewBox (Sizing sizing) = + sizing.viewBox + + +{-| Return the `ContainerSize` from `Sizing`. +-} +sizingGetContainerSize : Sizing -> ContainerSize +sizingGetContainerSize (Sizing sizing) = + sizing.containerSize + + +{-| Return the width of a `ContainerSize`. +-} +containerSizeGetWidth : ContainerSize -> Int +containerSizeGetWidth (ContainerSize cs) = + cs.width + + +{-| Return the height of a `ContainerSize`. +-} +containerSizeGetHeight : ContainerSize -> Int +containerSizeGetHeight (ContainerSize cs) = + cs.height + + +{-| Return the xMin value from a `ViewBox`. +-} +viewBoxGetXMin : ViewBox -> Float +viewBoxGetXMin (ViewBox vb) = + vb.xMin + + +{-| Return the yMin value from a `ViewBox`. +-} +viewBoxGetYMin : ViewBox -> Float +viewBoxGetYMin (ViewBox vb) = + vb.yMin + + +{-| Return the width value from a `ViewBox`. +-} +viewBoxGetWidth : ViewBox -> Float +viewBoxGetWidth (ViewBox vb) = + vb.width + + +{-| Return the height value from a `ViewBox`. +-} +viewBoxGetHeight : ViewBox -> Float +viewBoxGetHeight (ViewBox vb) = + vb.height + + + +---- Drawing Order ------------------------------------------------------------ + + +{-| When processing a list of drawings, do they appear in top-to-bottom order, +or bottom-to-top order? +-} +type Order + = TopToBottom + | BottomToTop + + + +---- Visibility --------------------------------------------------------------- + + +{-| Visibility of an item. +-} +type Visibility + = Visible + | Hidden + + + +---- Names -------------------------------------------------------------------- + + +{-| Name of a coordinate system. +-} +type CSysName + = CSysName String + + +{-| Name of a frozen drawing. + +Let it go. + +-} +type FrozenName + = FrozenName String diff --git a/src/Techdraw.elm b/src/Techdraw.elm deleted file mode 100644 index 23e2383..0000000 --- a/src/Techdraw.elm +++ /dev/null @@ -1,1825 +0,0 @@ -module Techdraw exposing - ( Drawing - , ViewBox - , render, renderSvgElement - , empty, path, svg, group, map, tagCSys, transform - , prependAnchorNamespace, dropAnchor, weighAnchors - , translate, rotateAbout, scale, skewX - , style - , fill, stroke, strokeWidth, strokeLinecap, strokeLinejoin - , onClick, onContextMenu, onDblClick, onMouseDown - , onMouseEnter, onMouseLeave, onMouseMove - , onMouseOut, onMouseOver, onMouseUp - , onHostMouseLeave, onHostMouseMove, onHostMouseUp - , Style - , styleDefault, styleInheritAll - , styleSetFill, styleSetStroke, styleSetStrokeWidth - , styleSetStrokeLinecap, styleSetStrokeLinejoin - , styleGetFill, styleGetStroke, styleGetStrokeWidth - , styleGetStrokeLinecap, styleGetStrokeLinejoin - , styleAppendAttribute, styleGetAttributes - , MouseInfo, ModifierKeys, MouseButtons - , MouseButtonState(..), KeyPressState(..) - , CSysName(..) - ) - -{-| - - -# Drawing - - -## Types - -@docs Drawing -@docs ViewBox - - -## Creating SVG - -@docs render, renderSvgElement - - -## Creating Drawings - - -### First-class Operations - -@docs empty, path, svg, group, map, tagCSys, transform -@docs prependAnchorNamespace, dropAnchor, weighAnchors - - -### Derived Operations - -@docs translate, rotateAbout, scale, skewX - - -## Styling Drawings - -@docs style -@docs fill, stroke, strokeWidth, strokeLinecap, strokeLinejoin - - -## Handling Events - -@docs onClick, onContextMenu, onDblClick, onMouseDown -@docs onMouseEnter, onMouseLeave, onMouseMove -@docs onMouseOut, onMouseOver, onMouseUp -@docs onHostMouseLeave, onHostMouseMove, onHostMouseUp - - -# Styles - -@docs Style -@docs styleDefault, styleInheritAll -@docs styleSetFill, styleSetStroke, styleSetStrokeWidth -@docs styleSetStrokeLinecap, styleSetStrokeLinejoin -@docs styleGetFill, styleGetStroke, styleGetStrokeWidth -@docs styleGetStrokeLinecap, styleGetStrokeLinejoin -@docs styleAppendAttribute, styleGetAttributes - - -# Event Information - -@docs MouseInfo, ModifierKeys, MouseButtons -@docs MouseButtonState, KeyPressState - - -# Coordinate Systems - -@docs CSysName - --} - -import Bitwise -import Dict exposing (Dict) -import Html exposing (Html) -import Html.Events as HtmlEvents -import Json.Decode as Decode exposing (Decoder) -import Techdraw.Math as Math exposing (AffineTransform(..), P2) -import Techdraw.Path as P exposing (Path(..)) -import Techdraw.Svg.SvgStringPath as SP -import TypedSvg -import TypedSvg.Attributes as SvgAttributes -import TypedSvg.Core as TypedSvgCore exposing (Svg) -import TypedSvg.Types - exposing - ( Align(..) - , Display(..) - , MeetOrSlice(..) - , Paint - , Scale(..) - , StrokeLinecap - , StrokeLinejoin - , px - ) -import VirtualDom exposing (Attribute, mapAttribute) - - - ----- Drawing ------------------------------------------------------------------ - - -{-| Drawing. --} -type Drawing msg - = DrawingEmpty - | DrawingPath Path - | DrawingSvg (AffineTransform -> Svg msg) - | DrawingStyled (Style msg) (Drawing msg) - | DrawingTransformed AffineTransform (Drawing msg) - | DrawingGroup (List (Drawing msg)) - | DrawingEvents (Events msg) (Drawing msg) - | DrawingHostEvents (Events msg) (Drawing msg) - | DrawingTagCSys CSysName - | DrawingPrependAnchorNamespace AnchorNamespace (Drawing msg) - | DrawingDropAnchor AnchorName P2 - | DrawingWeighAnchors ((String -> ( Float, Float )) -> Drawing msg) - - -{-| Empty drawing. --} -empty : Drawing msg -empty = - DrawingEmpty - - -{-| Draw a path. --} -path : Path -> Drawing msg -path = - DrawingPath - - -{-| Draw some SVG directly. - -The function provided takes the local-to-world transformation so that it can -produce custom SVG. - --} -svg : (AffineTransform -> Svg msg) -> Drawing msg -svg = - DrawingSvg - - -{-| Transform a drawing. --} -transform : AffineTransform -> Drawing msg -> Drawing msg -transform parentTransform drawing = - case drawing of - DrawingTransformed childTransform childDrawing -> - DrawingTransformed - (Math.affMatMul parentTransform childTransform) - childDrawing - - _ -> - DrawingTransformed parentTransform drawing - - -{-| Translate a drawing. --} -translate : ( Float, Float ) -> Drawing msg -> Drawing msg -translate ( tx, ty ) = - transform <| Math.affTranslation <| Math.Translation (Math.v2 tx ty) - - -{-| Scale a drawing. --} -scale : ( Float, Float ) -> Drawing msg -> Drawing msg -scale ( sx, sy ) = - transform <| Math.affScaling <| Math.Scaling sx sy - - -{-| Rotate clockwise by a value in degrees about a point. --} -rotateAbout : Float -> ( Float, Float ) -> Drawing msg -> Drawing msg -rotateAbout angle ( xc, yc ) = - let - xform = - Math.affFromComponents - [ Math.AffineTranslation <| Math.Translation (Math.v2 -xc -yc) - , Math.AffineRotation <| - Math.Rotation <| - Math.angle2Pi (angle * pi / 180) - , Math.AffineTranslation <| Math.Translation (Math.v2 xc yc) - ] - in - transform xform - - -{-| Skew along the x-axis by a value in degrees. --} -skewX : Float -> Drawing msg -> Drawing msg -skewX angle = - let - xform = - Math.affShearingX <| Math.ShearingX <| tan <| angle * pi / 180 - in - transform xform - - -{-| Group drawings. --} -group : List (Drawing msg) -> Drawing msg -group = - DrawingGroup - - -{-| Tag a coordinate system. - -A drawing which tags its local coordinate system with a name. - --} -tagCSys : CSysName -> Drawing msg -tagCSys name = - DrawingTagCSys name - - -{-| Prepend a namespace to any anchor names in the drawing. --} -prependAnchorNamespace : String -> Drawing msg -> Drawing msg -prependAnchorNamespace name = - DrawingPrependAnchorNamespace (anchorNamespace name) - - -{-| Drop an anchor at the specified location in the drawing. --} -dropAnchor : String -> ( Float, Float ) -> Drawing msg -dropAnchor name ( locX, locY ) = - DrawingDropAnchor (anchorName name) (Math.p2 locX locY) - - -{-| Create a drawing using anchor locations. - -`weighAnchors` is called with a generation function, that can generate a -drawing based on previously-defined anchor locations. In turn, that -function will be called with a function that can retreive any previously -dropped anchors. - --} -weighAnchors : ((String -> ( Float, Float )) -> Drawing msg) -> Drawing msg -weighAnchors createFn = - DrawingWeighAnchors createFn - - -{-| Set the style of a drawing. - -The style is applied "on the outside". Any styles already defined will take -precedence. - --} -style : Style msg -> Drawing msg -> Drawing msg -style parentStyle drawing = - case drawing of - DrawingStyled childStyle dwg -> - -- Any existing child style applied to the drawing takes - -- precedence. - DrawingStyled (combineStyles parentStyle childStyle) dwg - - _ -> - DrawingStyled parentStyle drawing - - -{-| Set the fill. - -See [`style`](#style) for information on precedence. - --} -fill : Paint -> Drawing msg -> Drawing msg -fill paint drawing = - style (styleDefault |> styleSetFill paint) drawing - - -{-| Set the stroke. - -See [`style`](#style) for information on precedence. - --} -stroke : Paint -> Drawing msg -> Drawing msg -stroke paint drawing = - style (styleDefault |> styleSetStroke paint) drawing - - -{-| Set the stroke width. - -See [`style`](#style) for information on precedence. - --} -strokeWidth : Float -> Drawing msg -> Drawing msg -strokeWidth width drawing = - style (styleDefault |> styleSetStrokeWidth width) drawing - - -{-| Set the stroke line cap. --} -strokeLinecap : StrokeLinecap -> Drawing msg -> Drawing msg -strokeLinecap lc drawing = - style (styleDefault |> styleSetStrokeLinecap lc) drawing - - -{-| Set the stroke line join. --} -strokeLinejoin : StrokeLinejoin -> Drawing msg -> Drawing msg -strokeLinejoin lj drawing = - style (styleDefault |> styleSetStrokeLinejoin lj) drawing - - - ----- Styles ------------------------------------------------------------------- - - -{-| Indicate whether a style setting is inherited or explicitly set. --} -type StyleSetting a - = Inherited - | Set a - - -{-| Convert a `StyleSetting` to a `Maybe` value. --} -styleSettingToMaybe : StyleSetting a -> Maybe a -styleSettingToMaybe setting = - case setting of - Inherited -> - Nothing - - Set value -> - Just value - - -{-| Combine a style setting from a parent and child into a new current style -setting. --} -combineStyleSetting : StyleSetting a -> StyleSetting a -> StyleSetting a -combineStyleSetting parent child = - case ( parent, child ) of - ( _, Set value ) -> - Set value - - ( Set value, Inherited ) -> - Set value - - ( Inherited, Inherited ) -> - Inherited - - -{-| Style. --} -type Style msg - = Style - { fill : StyleSetting Paint - , stroke : StyleSetting Paint - , strokeWidth : StyleSetting Float - , strokeLinecap : StyleSetting StrokeLinecap - , strokeLinejoin : StyleSetting StrokeLinejoin - , extraAttributes : List (Attribute msg) - } - - -{-| Default style. - -This is a synonym for [`styleInheritAll`](#styleInheritAll), which inherits -everything from its parent. - --} -styleDefault : Style msg -styleDefault = - styleInheritAll - - -{-| A style which inherits everything from its parent. --} -styleInheritAll : Style msg -styleInheritAll = - Style - { fill = Inherited - , stroke = Inherited - , strokeWidth = Inherited - , strokeLinecap = Inherited - , strokeLinejoin = Inherited - , extraAttributes = [] - } - - -{-| Set the fill. --} -styleSetFill : Paint -> Style msg -> Style msg -styleSetFill paint (Style styl) = - Style <| { styl | fill = Set paint } - - -{-| Return the fill setting. --} -styleGetFill : Style msg -> Maybe Paint -styleGetFill (Style styl) = - styl.fill |> styleSettingToMaybe - - -{-| Set the stroke. --} -styleSetStroke : Paint -> Style msg -> Style msg -styleSetStroke paint (Style styl) = - Style <| { styl | stroke = Set paint } - - -{-| Return the stroke setting. --} -styleGetStroke : Style msg -> Maybe Paint -styleGetStroke (Style styl) = - styl.stroke |> styleSettingToMaybe - - -{-| Set the stroke width. --} -styleSetStrokeWidth : Float -> Style msg -> Style msg -styleSetStrokeWidth width (Style styl) = - Style <| { styl | strokeWidth = Set width } - - -{-| Return the stroke width. --} -styleGetStrokeWidth : Style msg -> Maybe Float -styleGetStrokeWidth (Style styl) = - styl.strokeWidth |> styleSettingToMaybe - - -{-| Set the stroke line cap. --} -styleSetStrokeLinecap : StrokeLinecap -> Style msg -> Style msg -styleSetStrokeLinecap lc (Style styl) = - Style <| { styl | strokeLinecap = Set lc } - - -{-| Get the stroke line cap. --} -styleGetStrokeLinecap : Style msg -> Maybe StrokeLinecap -styleGetStrokeLinecap (Style styl) = - styl.strokeLinecap |> styleSettingToMaybe - - -{-| Set the stroke line join. --} -styleSetStrokeLinejoin : StrokeLinejoin -> Style msg -> Style msg -styleSetStrokeLinejoin lj (Style styl) = - Style <| { styl | strokeLinejoin = Set lj } - - -{-| Get the stroke line join. --} -styleGetStrokeLinejoin : Style msg -> Maybe StrokeLinejoin -styleGetStrokeLinejoin (Style styl) = - styl.strokeLinejoin |> styleSettingToMaybe - - -{-| Append a custom SVG attribute. - -Typically this is used for setting styling attributes that are not directly -supported by the library. However, any provided attribute will be appended -to the output SVG. - --} -styleAppendAttribute : Attribute msg -> Style msg -> Style msg -styleAppendAttribute attribute (Style styl) = - Style <| { styl | extraAttributes = attribute :: styl.extraAttributes } - - -{-| Return the attributes. - -The attributes are returned in the sequence they should be applied. - --} -styleGetAttributes : Style msg -> List (Attribute msg) -styleGetAttributes (Style styl) = - styl.extraAttributes |> List.reverse - - -{-| Combine settings from a parent style and child style into a new -current style. --} -combineStyles : Style msg -> Style msg -> Style msg -combineStyles (Style parent) (Style child) = - let - comb extract = - combineStyleSetting (extract parent) (extract child) - in - Style - { fill = comb .fill - , stroke = comb .stroke - , strokeWidth = comb .strokeWidth - , strokeLinecap = comb .strokeLinecap - , strokeLinejoin = comb .strokeLinejoin - , extraAttributes = child.extraAttributes ++ parent.extraAttributes - } - - - ----- Path Decoration ---------------------------------------------------------- -{- A decorator is a special styling operation that can operate on a - processed path. - - A decorator runs on a path after: - - - A collapsed style has been computed (taking into account the styles - of groups above the path, etc) - - The local-to-world transformation has been computed. - - The path has been transformed to world space. - - A `Decorator` can then modify the path as it sees fit, to produce a new - [`Drawing`](#Drawing). The original `Drawing` is discarded, so if the - aim is to retain it, then it must be part of the `Drawing` returned by - the `Decorator`. - - TODO: There should probably be a different layout for decorators. For - example, we want to support decorator operations like this: - - - Shorten a path, then add an arrow. This requires a sequencing of - secorators (shorten, THEN add arrow geometry). Currently, there's - no way to do sequencing. - --} -{- - type Decorator msg - = Decorator - (Style msg - -> AffineTransform - -> Path - -> Drawing msg - ) --} ----- Events ------------------------------------------------------------------- - - -{-| Register an `onclick` listener. --} -onClick : (MouseInfo -> msg) -> Drawing msg -> Drawing msg -onClick fn = - fn |> MouseHandler |> MouseClick |> registerListener - - -{-| Register an `oncontextmenu` listener. --} -onContextMenu : (MouseInfo -> msg) -> Drawing msg -> Drawing msg -onContextMenu fn = - fn |> MouseHandler |> MouseContextMenu |> registerListener - - -{-| Register an `ondblclick` listener. --} -onDblClick : (MouseInfo -> msg) -> Drawing msg -> Drawing msg -onDblClick fn = - fn |> MouseHandler |> MouseDblClick |> registerListener - - -{-| Register an `onmousedown` listener. --} -onMouseDown : (MouseInfo -> msg) -> Drawing msg -> Drawing msg -onMouseDown fn = - fn |> MouseHandler |> MouseDown |> registerListener - - -{-| Register an `onmouseenter` listener. --} -onMouseEnter : (MouseInfo -> msg) -> Drawing msg -> Drawing msg -onMouseEnter fn = - fn |> MouseHandler |> MouseEnter |> registerListener - - -{-| Register an `onmouseleave` listener. --} -onMouseLeave : (MouseInfo -> msg) -> Drawing msg -> Drawing msg -onMouseLeave fn = - fn |> MouseHandler |> MouseLeave |> registerListener - - -{-| Register an `onmousemove` listener. --} -onMouseMove : (MouseInfo -> msg) -> Drawing msg -> Drawing msg -onMouseMove fn = - fn |> MouseHandler |> MouseMove |> registerListener - - -{-| Register an `onmouseout` listener. --} -onMouseOut : (MouseInfo -> msg) -> Drawing msg -> Drawing msg -onMouseOut fn = - fn |> MouseHandler |> MouseOut |> registerListener - - -{-| Register an `onmouseover` listener. --} -onMouseOver : (MouseInfo -> msg) -> Drawing msg -> Drawing msg -onMouseOver fn = - fn |> MouseHandler |> MouseOver |> registerListener - - -{-| Register an `onmouseup` listener. --} -onMouseUp : (MouseInfo -> msg) -> Drawing msg -> Drawing msg -onMouseUp fn = - fn |> MouseHandler |> MouseUp |> registerListener - - -{-| Register an `onmouseleave` listener with the host SVG element. --} -onHostMouseLeave : (MouseInfo -> msg) -> Drawing msg -> Drawing msg -onHostMouseLeave fn = - fn |> MouseHandler |> MouseLeave |> registerHostListener - - -{-| Register an `onmousemove` listener with the host SVG element. --} -onHostMouseMove : (MouseInfo -> msg) -> Drawing msg -> Drawing msg -onHostMouseMove fn = - fn |> MouseHandler |> MouseMove |> registerHostListener - - -{-| Register an `onmouseup` listener with the host SVG element. --} -onHostMouseUp : (MouseInfo -> msg) -> Drawing msg -> Drawing msg -onHostMouseUp fn = - fn |> MouseHandler |> MouseUp |> registerHostListener - - -{-| Register an event listener. --} -registerListener : EventListener msg -> Drawing msg -> Drawing msg -registerListener listener drawing = - case drawing of - DrawingEvents events childDrawing -> - DrawingEvents (eventsAddListener listener events) childDrawing - - _ -> - DrawingEvents (newEventsWithListener listener) drawing - - -{-| Register an event listener on the host SVG element. --} -registerHostListener : EventListener msg -> Drawing msg -> Drawing msg -registerHostListener listener drawing = - case drawing of - DrawingHostEvents events childDrawing -> - DrawingHostEvents (eventsAddListener listener events) childDrawing - - _ -> - DrawingHostEvents (newEventsWithListener listener) drawing - - -{-| Events. --} -type Events msg - = Events (List (EventListener msg)) - - -{-| Create an empty `Events`. --} -emptyEvents : Events msg -emptyEvents = - Events [] - - -{-| Create a new `Events` containing a single listener. --} -newEventsWithListener : EventListener msg -> Events msg -newEventsWithListener listener = - Events [ listener ] - - -{-| Add an event listener. --} -eventsAddListener : EventListener msg -> Events msg -> Events msg -eventsAddListener listener (Events es) = - Events <| listener :: es - - -{-| Combine events listeners. --} -combineEvents : Events msg -> Events msg -> Events msg -combineEvents (Events parentList) (Events childList) = - Events (parentList ++ childList) - - -{-| Types of event listeners and their handlers. --} -type EventListener msg - = MouseClick (MouseHandler msg) - | MouseContextMenu (MouseHandler msg) - | MouseDblClick (MouseHandler msg) - | MouseDown (MouseHandler msg) - | MouseEnter (MouseHandler msg) - | MouseLeave (MouseHandler msg) - | MouseMove (MouseHandler msg) - | MouseOut (MouseHandler msg) - | MouseOver (MouseHandler msg) - | MouseUp (MouseHandler msg) - - -{-| Information about a mouse event. - -The fields of this record are as follows: - - - `clientPoint`: The `(clientX, clientY)` position of the mouse event. - - `localPoint`: The point in the local coordinate system. - - `buttons`: Which buttons were pressed. - - `modifiers`: What modifier keys were pressed. - - `pointIn`: A function to fetch the point in a named coordinate system. - --} -type alias MouseInfo = - { offsetPoint : P2 - , localPoint : P2 - , buttons : MouseButtons - , modifiers : ModifierKeys - , pointIn : CSysName -> P2 - } - - -{-| Indicates whether a mouse button was pressed or not pressed. --} -type MouseButtonState - = MouseButtonPressed - | MouseButtonNotPressed - - -{-| Mouse buttons. --} -type alias MouseButtons = - { button1 : MouseButtonState - , button2 : MouseButtonState - , button3 : MouseButtonState - , button4 : MouseButtonState - , button5 : MouseButtonState - } - - -{-| Indicates whether a key was pressed or not pressed. --} -type KeyPressState - = KeyPressed - | KeyNotPressed - - -{-| Modifier key state. --} -type alias ModifierKeys = - { ctrl : KeyPressState - , shift : KeyPressState - , alt : KeyPressState - , meta : KeyPressState - } - - -{-| A MouseHandler event. - -It receieves the local-to-world transform and world mouse coordinates. - --} -type MouseHandler msg - = MouseHandler (MouseInfo -> msg) - - -{-| Convert listed event handlers to attributes. --} -eventsToAttributes : - AffineTransform - -> CSysDict - -> Events msg - -> List (Attribute msg) -eventsToAttributes localToWorld cSysDict (Events es) = - List.map (eventListenerToAttribute localToWorld cSysDict) es - - -eventListenerToAttribute : - AffineTransform - -> CSysDict - -> EventListener msg - -> Attribute msg -eventListenerToAttribute localToWorld cSysDict listener = - let - mouseA name handler = - mouseHandlerToAttribute localToWorld cSysDict name handler - in - case listener of - MouseClick handler -> - mouseA "click" handler - - MouseContextMenu handler -> - mouseA "contextmenu" handler - - MouseDblClick handler -> - mouseA "dblclick" handler - - MouseDown handler -> - mouseA "mousedown" handler - - MouseEnter handler -> - mouseA "mouseenter" handler - - MouseLeave handler -> - mouseA "mouseleave" handler - - MouseMove handler -> - mouseA "mousemove" handler - - MouseOut handler -> - mouseA "mouseout" handler - - MouseOver handler -> - mouseA "mouseover" handler - - MouseUp handler -> - mouseA "mouseup" handler - - -mouseHandlerToAttribute : - AffineTransform - -> CSysDict - -> String - -> MouseHandler msg - -> Attribute msg -mouseHandlerToAttribute localToWorld cSysDict eventName mouseHandler = - HtmlEvents.on - eventName - (mouseHandlerDecoder localToWorld cSysDict mouseHandler) - - -mouseHandlerDecoder : - AffineTransform - -> CSysDict - -> MouseHandler msg - -> Decoder msg -mouseHandlerDecoder localToWorld cSysDict (MouseHandler mkMsg) = - Decode.map mkMsg (mouseInfo localToWorld cSysDict) - - -mouseInfo : AffineTransform -> CSysDict -> Decoder MouseInfo -mouseInfo localToWorld cSysDict = - let - calcLocalPoint : P2 -> P2 - calcLocalPoint clientPoint = - Math.affInvert localToWorld - |> (\mat -> Math.p2ApplyAffineTransform mat clientPoint) - - calcPointIn : CSysName -> P2 -> P2 - calcPointIn name clientPoint = - getCSys name cSysDict - |> Maybe.withDefault localToWorld - |> Math.affInvert - |> (\mat -> Math.p2ApplyAffineTransform mat clientPoint) - in - Decode.map3 - (\clientPoint btns mods -> - { offsetPoint = clientPoint - , localPoint = calcLocalPoint clientPoint - , buttons = btns - , modifiers = mods - , pointIn = \name -> calcPointIn name clientPoint - } - ) - offsetP2 - mouseButtons - modifiers - - -offsetP2 : Decoder P2 -offsetP2 = - Decode.map2 Math.p2 offsetXFloat offsetYFloat - - -offsetXFloat : Decoder Float -offsetXFloat = - Decode.map toFloat offsetX - - -offsetYFloat : Decoder Float -offsetYFloat = - Decode.map toFloat offsetY - - -mouseButtons : Decoder MouseButtons -mouseButtons = - let - buttonState : Int -> Int -> MouseButtonState - buttonState buttonNumber input = - if - Bitwise.and - input - (Bitwise.shiftLeftBy (buttonNumber - 1) 0x01) - == 0 - then - MouseButtonNotPressed - - else - MouseButtonPressed - in - Decode.map - (\b -> - { button1 = buttonState 1 b - , button2 = buttonState 2 b - , button3 = buttonState 3 b - , button4 = buttonState 4 b - , button5 = buttonState 5 b - } - ) - buttons - - -modifiers : Decoder ModifierKeys -modifiers = - let - boolToKeyPressState : Bool -> KeyPressState - boolToKeyPressState boolValue = - if boolValue then - KeyPressed - - else - KeyNotPressed - in - Decode.map4 - (\ctrl shift alt meta -> - { ctrl = ctrl |> boolToKeyPressState - , shift = shift |> boolToKeyPressState - , alt = alt |> boolToKeyPressState - , meta = meta |> boolToKeyPressState - } - ) - ctrlKey - shiftKey - altKey - metaKey - - -offsetX : Decoder Int -offsetX = - Decode.field "offsetX" Decode.int - - -offsetY : Decoder Int -offsetY = - Decode.field "offsetY" Decode.int - - -buttons : Decoder Int -buttons = - Decode.field "buttons" Decode.int - - -ctrlKey : Decoder Bool -ctrlKey = - Decode.field "ctrlKey" Decode.bool - - -shiftKey : Decoder Bool -shiftKey = - Decode.field "shiftKey" Decode.bool - - -altKey : Decoder Bool -altKey = - Decode.field "altKey" Decode.bool - - -metaKey : Decoder Bool -metaKey = - Decode.field "metaKey" Decode.bool - - - ----- Rendering ---------------------------------------------------------------- - - -{-| Viewbox for a drawing. - -This should typiecally be the same viewbox that SVG uses. - -The default coordinate system of a `Drawing` has the origin at the bottom -left. The x-axis increases to the right, and the y-axis increases upwards. - --} -type alias ViewBox = - { minX : Float - , minY : Float - , width : Float - , height : Float - } - - -{-| Render a diagram to a stand-alone SVG image. - -This creates an SVG element whose pixel size is the same as the -height and width of the `ViewBox`. - --} -render : ViewBox -> Drawing msg -> Html msg -render viewBox drawing = - let - ( svgContent, hostAttrs ) = - renderSvgElement viewBox drawing - in - TypedSvg.svg - ([ SvgAttributes.width (px viewBox.width) - , SvgAttributes.height (px viewBox.height) - , SvgAttributes.viewBox - viewBox.minX - viewBox.minY - viewBox.width - viewBox.height - , SvgAttributes.preserveAspectRatio (Align ScaleMid ScaleMid) Meet - ] - ++ hostAttrs - ) - [ svgContent - ] - - -{-| Render a diagram to an SVG element. --} -renderSvgElement : ViewBox -> Drawing msg -> ( Svg msg, List (Attribute msg) ) -renderSvgElement viewBox drawing = - renderRecurseDiscardWithDefault (initState viewBox) drawing - - -{-| Overall state of the evaluator. - -This is split into: - -1. Nested state, which strictly follows the nesting of the Drawing. -2. Threaded state, which is threaded in the direction of a depth-first - traversal. - --} -type State msg - = State - { nested : NestedState msg - , threaded : ThreadedState msg - } - - -stateGetNested : State msg -> NestedState msg -stateGetNested (State state) = - state.nested - - -stateGetThreaded : State msg -> ThreadedState msg -stateGetThreaded (State state) = - state.threaded - - -{-| State that strictly follows the nesting structure. --} -type NestedState msg - = NestedState - { style : Style msg - , events : Events msg - , localToWorld : AffineTransform - , anchorNS : List AnchorNamespace - , viewBox : ViewBox - } - - -nestedGetStyle : NestedState msg -> Style msg -nestedGetStyle (NestedState nested) = - nested.style - - -nestedGetEvents : NestedState msg -> Events msg -nestedGetEvents (NestedState nested) = - nested.events - - -nestedGetLocalToWorld : NestedState msg -> AffineTransform -nestedGetLocalToWorld (NestedState nested) = - nested.localToWorld - - -nestedGetAnchorNamespaces : NestedState msg -> List AnchorNamespace -nestedGetAnchorNamespaces (NestedState nested) = - nested.anchorNS - - -nestedGetViewBox : NestedState msg -> ViewBox -nestedGetViewBox (NestedState nested) = - nested.viewBox - - -nestedCombineStyles : Style msg -> NestedState msg -> NestedState msg -nestedCombineStyles childStyle (NestedState parent) = - NestedState { parent | style = combineStyles parent.style childStyle } - - -nestedCombineEvents : Events msg -> NestedState msg -> NestedState msg -nestedCombineEvents childEvents (NestedState parent) = - NestedState { parent | events = combineEvents parent.events childEvents } - - -nestedSetLocalToWorld : AffineTransform -> NestedState msg -> NestedState msg -nestedSetLocalToWorld l2w (NestedState parent) = - NestedState { parent | localToWorld = l2w } - - -nestedComposeTransform : AffineTransform -> NestedState msg -> NestedState msg -nestedComposeTransform childTransform (NestedState parent) = - nestedSetLocalToWorld - (Math.affMatMul parent.localToWorld childTransform) - (NestedState parent) - - -nestedPrependAnchorNamespace : - AnchorNamespace - -> NestedState msg - -> NestedState msg -nestedPrependAnchorNamespace namespace (NestedState parent) = - NestedState - { parent - | anchorNS = namespace :: parent.anchorNS - } - - -{-| State that is threaded through a depth-first evaluation. --} -type ThreadedState msg - = ThreadedState - { coordinateSystems : CSysDict - , droppedAnchors : AnchorDict - , hostAttributes : List (Attribute msg) - } - - -threadedGetCoordinateSystems : ThreadedState msg -> CSysDict -threadedGetCoordinateSystems (ThreadedState threaded) = - threaded.coordinateSystems - - -threadedGetDroppedAnchors : ThreadedState msg -> AnchorDict -threadedGetDroppedAnchors (ThreadedState threaded) = - threaded.droppedAnchors - - -threadedGetHostAttributes : ThreadedState msg -> List (Attribute msg) -threadedGetHostAttributes (ThreadedState threaded) = - threaded.hostAttributes - - -threadedInsertCoordinateSystem : - ( CSysName, AffineTransform ) - -> ThreadedState msg - -> ThreadedState msg -threadedInsertCoordinateSystem pair (ThreadedState parent) = - ThreadedState - { parent - | coordinateSystems = insertCSys pair parent.coordinateSystems - } - - -threadedDropAnchor : - ( AnchorName, P2 ) - -> ThreadedState msg - -> ThreadedState msg -threadedDropAnchor pair (ThreadedState parent) = - ThreadedState - { parent - | droppedAnchors = - insertAnchorWorldLocation pair parent.droppedAnchors - } - - -threadedAddHostAttributes : - List (Attribute msg) - -> ThreadedState msg - -> ThreadedState msg -threadedAddHostAttributes attrs (ThreadedState parent) = - ThreadedState - { parent | hostAttributes = attrs ++ parent.hostAttributes } - - -initState : ViewBox -> State msg -initState viewBox = - State - { nested = - NestedState - { style = styleDefault - , events = emptyEvents - , localToWorld = initLocalToWorld viewBox - , anchorNS = [] - , viewBox = viewBox - } - , threaded = - ThreadedState - { coordinateSystems = emptyCSysDict - , droppedAnchors = emptyAnchorDict - , hostAttributes = [] - } - } - - -initLocalToWorld : ViewBox -> AffineTransform -initLocalToWorld vb = - Math.affFromComponents - [ Math.AffineScaling <| Math.Scaling 1 -1 - , Math.AffineTranslation <| Math.Translation (Math.v2 0 vb.height) - , Math.AffineTranslation <| Math.Translation (Math.v2 vb.minX vb.minY) - ] - - -stateSetThreaded : ThreadedState msg -> State msg -> State msg -stateSetThreaded newThreadedState (State old) = - State { old | threaded = newThreadedState } - - -stateSetNested : NestedState msg -> State msg -> State msg -stateSetNested newNestedState (State old) = - State { old | nested = newNestedState } - - -stateUpdateNested : - (NestedState msg -> NestedState msg) - -> State msg - -> State msg -stateUpdateNested updater (State old) = - stateSetNested (updater old.nested) (State old) - - -stateUpdateThreaded : - (ThreadedState msg -> ThreadedState msg) - -> State msg - -> State msg -stateUpdateThreaded updater (State old) = - stateSetThreaded (updater old.threaded) (State old) - - -stateCombineStyles : Style msg -> State msg -> State msg -stateCombineStyles childStyle = - stateUpdateNested <| nestedCombineStyles childStyle - - -stateCombineEvents : Events msg -> State msg -> State msg -stateCombineEvents childEvents = - stateUpdateNested <| nestedCombineEvents childEvents - - -stateComposeTransform : AffineTransform -> State msg -> State msg -stateComposeTransform childTransform = - stateUpdateNested <| nestedComposeTransform childTransform - - -statePrependAnchorNamespace : AnchorNamespace -> State msg -> State msg -statePrependAnchorNamespace ns = - stateUpdateNested <| nestedPrependAnchorNamespace ns - - -renderRecurse : - State msg - -> Drawing msg - -> ( ThreadedState msg, Maybe (Svg msg) ) -renderRecurse state drawing = - case drawing of - DrawingEmpty -> - renderRecurseEmpty state - - DrawingPath drawPath -> - renderRecursePath state drawPath - - DrawingSvg svgFunction -> - renderRecurseSvg state svgFunction - - DrawingStyled sty child -> - renderRecurseStyled state sty child - - DrawingTransformed affineTransform child -> - renderRecurseTransformed state affineTransform child - - DrawingGroup children -> - renderRecurseGroup state children - - DrawingEvents events child -> - renderRecurseEvents state events child - - DrawingHostEvents events child -> - renderRecurseHostEvents state events child - - DrawingTagCSys csysName -> - renderRecurseTagCSys state csysName - - DrawingPrependAnchorNamespace nameCmp child -> - renderRecursePrependAnchorNamespace state nameCmp child - - DrawingDropAnchor nameCmp location -> - renderRecurseDropAnchor state nameCmp location - - DrawingWeighAnchors createFn -> - renderRecurseWeighAnchors state createFn - - -{-| Same as `renderRecurse`, but it packs the threaded state back into the -original state. --} -renderRecurseState : State msg -> Drawing msg -> ( State msg, Maybe (Svg msg) ) -renderRecurseState state dwg = - let - ( threadedState, result ) = - renderRecurse state dwg - in - ( stateSetThreaded threadedState state, result ) - - -{-| Same as `renderRecurse`, but discards the final threaded state. --} -renderRecurseDiscard : - State msg - -> Drawing msg - -> ( Maybe (Svg msg), List (Attribute msg) ) -renderRecurseDiscard state dwg = - let - ( threadedState, result ) = - renderRecurse state dwg - in - ( result, threadedGetHostAttributes threadedState ) - - -{-| Same as `renderRecurseDiscard`, but returns a default, empty SVG -if no SVG was produced. --} -renderRecurseDiscardWithDefault : - State msg - -> Drawing msg - -> ( Svg msg, List (Attribute msg) ) -renderRecurseDiscardWithDefault state dwg = - let - ( maybeSvg, hostAttrs ) = - renderRecurseDiscard state dwg - in - ( Maybe.withDefault emptySvg maybeSvg, hostAttrs ) - - -{-| A notionally-empty SVG. --} -emptySvg : Svg msg -emptySvg = - TypedSvg.g [ SvgAttributes.display DisplayNone ] [] - - -renderRecurseEmpty : State msg -> ( ThreadedState msg, Maybe (Svg msg) ) -renderRecurseEmpty state = - ( stateGetThreaded state, Nothing ) - - -renderRecursePath : - State msg - -> Path - -> ( ThreadedState msg, Maybe (Svg msg) ) -renderRecursePath state pth = - let - l2w = - state |> stateGetNested >> nestedGetLocalToWorld - - csys = - state |> stateGetThreaded >> threadedGetCoordinateSystems - - styleAttr = - state |> stateGetNested >> nestedGetStyle >> styleToAttributes - - eventAttr = - state - |> stateGetNested - >> nestedGetEvents - >> eventsToAttributes l2w csys - - pathAttr = - pth - |> P.pathApplyAffineTransform l2w - >> SP.formatPath (SP.NFixDigits 2) - >> SP.svgStringPathToString - >> SvgAttributes.d - - outMaybeSvg = - if P.pathIsEmpty pth then - Nothing - - else - Just <| - TypedSvg.path (pathAttr :: styleAttr ++ eventAttr) [] - in - ( stateGetThreaded state, outMaybeSvg ) - - -renderRecurseSvg : - State msg - -> (AffineTransform -> Svg msg) - -> ( ThreadedState msg, Maybe (Svg msg) ) -renderRecurseSvg state svgFunction = - ( stateGetThreaded state - , svgFunction - (stateGetNested >> nestedGetLocalToWorld <| state) - |> Just - ) - - -renderRecurseStyled : - State msg - -> Style msg - -> Drawing msg - -> ( ThreadedState msg, Maybe (Svg msg) ) -renderRecurseStyled state sty childDrawing = - renderRecurse (stateCombineStyles sty state) childDrawing - - -renderRecurseTransformed : - State msg - -> AffineTransform - -> Drawing msg - -> ( ThreadedState msg, Maybe (Svg msg) ) -renderRecurseTransformed state xf childDrawing = - renderRecurse (stateComposeTransform xf state) childDrawing - - -renderRecurseGroup : - State msg - -> List (Drawing msg) - -> ( ThreadedState msg, Maybe (Svg msg) ) -renderRecurseGroup state drawings = - let - renderRecurseGroupFold : - Drawing msg - -> ( State msg, List (Maybe (Svg msg)) ) - -> ( State msg, List (Maybe (Svg msg)) ) - renderRecurseGroupFold dwg ( stepInState, accum ) = - let - ( stepOutState, producedSvg ) = - renderRecurseState stepInState dwg - in - ( stepOutState, producedSvg :: accum ) - - groupSvg : List (Maybe (Svg msg)) -> Maybe (Svg msg) - groupSvg maybeSvgs = - List.filterMap identity maybeSvgs - |> (\svgList -> - if List.isEmpty svgList then - Nothing - - else - List.reverse svgList |> TypedSvg.g [] |> Just - ) - in - List.foldl renderRecurseGroupFold ( state, [] ) drawings - |> (\( finalState, maybeSvgs ) -> - ( stateGetThreaded finalState - , groupSvg maybeSvgs - ) - ) - - -renderRecurseEvents : - State msg - -> Events msg - -> Drawing msg - -> ( ThreadedState msg, Maybe (Svg msg) ) -renderRecurseEvents state events childDrawing = - renderRecurse (stateCombineEvents events state) childDrawing - - -renderRecurseHostEvents : - State msg - -> Events msg - -> Drawing msg - -> ( ThreadedState msg, Maybe (Svg msg) ) -renderRecurseHostEvents state events childDrawing = - let - hostAttrs = - eventsToAttributes - (state |> stateGetNested >> nestedGetLocalToWorld) - (state |> stateGetThreaded >> threadedGetCoordinateSystems) - events - - newState = - state |> stateUpdateThreaded (threadedAddHostAttributes hostAttrs) - in - renderRecurse newState childDrawing - - -renderRecurseTagCSys : - State msg - -> CSysName - -> ( ThreadedState msg, Maybe (Svg msg) ) -renderRecurseTagCSys state cSysName = - ( stateGetThreaded state - |> threadedInsertCoordinateSystem - ( cSysName - , (stateGetNested >> nestedGetLocalToWorld) state - ) - , Nothing - ) - - -renderRecursePrependAnchorNamespace : - State msg - -> AnchorNamespace - -> Drawing msg - -> ( ThreadedState msg, Maybe (Svg msg) ) -renderRecursePrependAnchorNamespace state ns childDrawing = - renderRecurse (statePrependAnchorNamespace ns state) childDrawing - - -renderRecurseDropAnchor : - State msg - -> AnchorName - -> P2 - -> ( ThreadedState msg, Maybe (Svg msg) ) -renderRecurseDropAnchor state name localPt = - ( state - |> stateGetThreaded - |> threadedDropAnchor - ( anchorNamePrependAll - (state |> stateGetNested >> nestedGetAnchorNamespaces) - name - , Math.p2ApplyAffineTransform - (state |> stateGetNested >> nestedGetLocalToWorld) - localPt - ) - , Nothing - ) - - -renderRecurseWeighAnchors : - State msg - -> ((String -> ( Float, Float )) -> Drawing msg) - -> ( ThreadedState msg, Maybe (Svg msg) ) -renderRecurseWeighAnchors state createFn = - let - anchorFn : String -> ( Float, Float ) - anchorFn aname = - state - |> stateGetThreaded - >> threadedGetDroppedAnchors - >> getAnchorWorldLocation (anchorName aname) - >> Maybe.map - (Math.p2ApplyAffineTransform - (state - |> stateGetNested - >> nestedGetLocalToWorld - >> Math.affInvert - ) - ) - >> Maybe.map (\p -> ( Math.p2x p, Math.p2y p )) - >> Maybe.withDefault ( 0, 0 ) - - createdDrawing : Drawing msg - createdDrawing = - createFn anchorFn - in - renderRecurse state createdDrawing - - -{-| Convert a style to a list of SVG attributes. --} -styleToAttributes : Style msg -> List (Attribute msg) -styleToAttributes styl = - let - toAttr : - (Style msg -> Maybe a) - -> (a -> Attribute msg) - -> Maybe (Attribute msg) - toAttr extract produce = - extract styl |> Maybe.map produce - - styleAttrs = - List.filterMap (\x -> x) - [ toAttr styleGetFill SvgAttributes.fill - , toAttr styleGetStroke SvgAttributes.stroke - , toAttr styleGetStrokeWidth - (\x -> SvgAttributes.strokeWidth (px x)) - , toAttr styleGetStrokeLinecap SvgAttributes.strokeLinecap - , toAttr styleGetStrokeLinejoin SvgAttributes.strokeLinejoin - ] - in - styleAttrs ++ List.reverse (styleGetAttributes styl) - - -{-| Map a function over the message type of a drawing. --} -map : (a -> msg) -> Drawing a -> Drawing msg -map f drawing = - case drawing of - DrawingEmpty -> - DrawingEmpty - - DrawingPath pth -> - DrawingPath pth - - DrawingSvg mkSvg -> - DrawingSvg <| - \xform -> mkSvg xform |> TypedSvgCore.map f - - DrawingStyled sty child -> - DrawingStyled (mapStyle f sty) (map f child) - - DrawingTransformed xform child -> - DrawingTransformed xform (map f child) - - DrawingGroup children -> - DrawingGroup <| List.map (map f) children - - DrawingEvents events child -> - DrawingEvents (mapEvents f events) (map f child) - - DrawingHostEvents events child -> - DrawingHostEvents (mapEvents f events) (map f child) - - DrawingTagCSys name -> - DrawingTagCSys name - - DrawingPrependAnchorNamespace ns child -> - DrawingPrependAnchorNamespace ns (map f child) - - DrawingDropAnchor name location -> - DrawingDropAnchor name location - - DrawingWeighAnchors fn -> - DrawingWeighAnchors <| \extractFn -> fn extractFn |> map f - - -mapStyle : (a -> msg) -> Style a -> Style msg -mapStyle f (Style sty) = - Style - { fill = sty.fill - , stroke = sty.stroke - , strokeWidth = sty.strokeWidth - , strokeLinecap = sty.strokeLinecap - , strokeLinejoin = sty.strokeLinejoin - , extraAttributes = List.map (mapAttribute f) sty.extraAttributes - } - - -mapEvents : (a -> msg) -> Events a -> Events msg -mapEvents f (Events listeners) = - Events <| List.map (mapEventListener f) listeners - - -mapEventListener : (a -> msg) -> EventListener a -> EventListener msg -mapEventListener f listener = - case listener of - MouseClick h -> - MouseClick <| mapMouseHandler f h - - MouseContextMenu h -> - MouseContextMenu <| mapMouseHandler f h - - MouseDblClick h -> - MouseDblClick <| mapMouseHandler f h - - MouseDown h -> - MouseDown <| mapMouseHandler f h - - MouseEnter h -> - MouseEnter <| mapMouseHandler f h - - MouseLeave h -> - MouseLeave <| mapMouseHandler f h - - MouseMove h -> - MouseMove <| mapMouseHandler f h - - MouseOut h -> - MouseOut <| mapMouseHandler f h - - MouseOver h -> - MouseOver <| mapMouseHandler f h - - MouseUp h -> - MouseUp <| mapMouseHandler f h - - -mapMouseHandler : (a -> msg) -> MouseHandler a -> MouseHandler msg -mapMouseHandler f (MouseHandler fn) = - MouseHandler (fn >> f) - - - ----- Coordinate systems ------------------------------------------------------- - - -{-| Name of a coordinate system. --} -type CSysName - = CSysName String - - -{-| Dictionary of coordinate systems. --} -type CSysDict - = CSysDict (Dict String AffineTransform) - - -{-| Empty coordinate system dictionary. --} -emptyCSysDict : CSysDict -emptyCSysDict = - CSysDict <| Dict.empty - - -{-| Insert a coordinate system into a dictionary. --} -insertCSys : ( CSysName, AffineTransform ) -> CSysDict -> CSysDict -insertCSys ( CSysName name, localToWorld ) (CSysDict dict) = - CSysDict <| Dict.insert name localToWorld dict - - -{-| Get a coordinate system from a dictionary. --} -getCSys : CSysName -> CSysDict -> Maybe AffineTransform -getCSys (CSysName name) (CSysDict dict) = - Dict.get name dict - - - ----- Anchors ------------------------------------------------------------------ - - -{-| Anchor namespace. --} -type AnchorNamespace - = AnchorNamespace String - - -{-| Create an `AnchorNamespace`. - -The string name of an `AnchorNamespace` cannot contain `'.'` characters. If a -string is supplied containing these characters, they will be filtered out. - --} -anchorNamespace : String -> AnchorNamespace -anchorNamespace ns = - String.filter (\c -> c /= '.') ns |> AnchorNamespace - - -{-| Anchor name. --} -type AnchorName - = AnchorName (List AnchorNamespace) String - - -{-| Create an `AnchorName`. - -If any `'.'` characters are supplied in the name then they are assumed to -separate namespaces. - --} -anchorName : String -> AnchorName -anchorName name = - String.split "." name - |> (\strs -> - case List.reverse strs of - [] -> - AnchorName [] "" - - n :: [] -> - AnchorName [] n - - n :: ns -> - AnchorName - (List.reverse ns |> List.map anchorNamespace) - n - ) - - -{-| Prepend a new namespace to an existing anchor name. --} -anchorNamePrependAll : List AnchorNamespace -> AnchorName -> AnchorName -anchorNamePrependAll newns (AnchorName ns n) = - AnchorName (newns ++ ns) n - - -{-| Convert an anchor name to a string. --} -anchorNameToString : AnchorName -> String -anchorNameToString (AnchorName ns n) = - (List.map (\(AnchorNamespace namespaceStr) -> namespaceStr) ns - |> String.join "." - ) - ++ "." - ++ n - - -{-| Dictionary of anchor names (as strings) to their world coordinates. --} -type AnchorDict - = AnchorDict (Dict String P2) - - -{-| Create an empty `AnchorDict`. --} -emptyAnchorDict : AnchorDict -emptyAnchorDict = - AnchorDict <| Dict.empty - - -{-| Insert an anchor location into the dictionary. --} -insertAnchorWorldLocation : ( AnchorName, P2 ) -> AnchorDict -> AnchorDict -insertAnchorWorldLocation ( aname, location ) (AnchorDict dict) = - AnchorDict <| Dict.insert (anchorNameToString aname) location dict - - -{-| Get the location of an anchor from the dictionary in world coordinates. --} -getAnchorWorldLocation : AnchorName -> AnchorDict -> Maybe P2 -getAnchorWorldLocation aname (AnchorDict dict) = - Dict.get (anchorNameToString aname) dict diff --git a/src/Techdraw/Widgets/DragPt.elm b/src/Techdraw/Widgets/DragPt.elm deleted file mode 100644 index 548f850..0000000 --- a/src/Techdraw/Widgets/DragPt.elm +++ /dev/null @@ -1,235 +0,0 @@ -module Techdraw.Widgets.DragPt exposing - ( Model - , Msg(..) - , Style(..) - , init, defaultStyle - , update, updateModel - , view - ) - -{-| A draggable-point widget. - -@docs Model -@docs Msg -@docs Style -@docs init, defaultStyle -@docs update, updateModel -@docs view - --} - -import Color exposing (Color) -import Techdraw as T exposing (Drawing) -import Techdraw.Math as Math exposing (P2) -import Techdraw.Shapes.Simple exposing (circle) -import TypedSvg.Types exposing (Paint(..)) - - -{-| Messages. --} -type Msg - = MsgMovedTo P2 - | MsgInternal InternalMsg - - -{-| Model. --} -type alias Model = - { location : P2 - , style : Style - , internal : InternalModel - } - - -{-| Style. --} -type Style - = Style - { radius : Float - , strokeWidth : Float - , colorStroke : Color - , colorFillNeutral : Color - , colorFillMouseOver : Color - , colorFillDragged : Color - } - - -{-| Create an initial model. --} -init : Style -> P2 -> Model -init style location = - { style = style - , location = location - , internal = - InternalModel - { state = StateNeutral - } - } - - -{-| Default style. --} -defaultStyle : Style -defaultStyle = - Style - { radius = 6 - , strokeWidth = 1 - , colorStroke = Color.black - , colorFillNeutral = Color.lightGray - , colorFillMouseOver = Color.lightGreen - , colorFillDragged = Color.lightOrange - } - - -type InternalMsg - = InternalMsgMouseEnter - | InternalMsgMouseLeave - | InternalMsgStartDrag - | InternalMsgStopDrag - | InternalMsgNoop - - -type InternalModel - = InternalModel - { state : State - } - - -type State - = StateNeutral - | StateMouseOver - | StateDragging - - -{-| Update function. --} -update : Msg -> Model -> ( Model, Cmd Msg ) -update msg model = - ( updateModel msg model, Cmd.none ) - - -{-| Update the model only. --} -updateModel : Msg -> Model -> Model -updateModel msg model = - case msg of - MsgMovedTo p -> - { model | location = p } - - MsgInternal internalMsg -> - { model - | internal = - updateInternal internalMsg model model.internal - } - - -updateInternal : InternalMsg -> Model -> InternalModel -> InternalModel -updateInternal internalMsg model (InternalModel iModel) = - case internalMsg of - InternalMsgMouseEnter -> - InternalModel { iModel | state = StateMouseOver } - - InternalMsgMouseLeave -> - InternalModel { iModel | state = StateNeutral } - - InternalMsgStartDrag -> - InternalModel { iModel | state = StateDragging } - - InternalMsgStopDrag -> - InternalModel { iModel | state = StateMouseOver } - - InternalMsgNoop -> - InternalModel iModel - - -{-| View function. --} -view : Model -> Drawing Msg -view model = - let - (Style style) = - model.style - - (InternalModel iModel) = - model.internal - - fillColor = - case iModel.state of - StateNeutral -> - style.colorFillNeutral - - StateMouseOver -> - style.colorFillMouseOver - - StateDragging -> - style.colorFillDragged - - appendEvents : Drawing Msg -> Drawing Msg - appendEvents dwg = - case iModel.state of - StateNeutral -> - dwg - |> T.onMouseEnter - (\minfo -> - if - minfo.buttons.button1 - == T.MouseButtonNotPressed - then - MsgInternal InternalMsgMouseEnter - - else - MsgInternal InternalMsgNoop - ) - - StateMouseOver -> - dwg - |> T.onMouseLeave - (\_ -> MsgInternal InternalMsgMouseLeave) - |> T.onMouseDown - (\minfo -> - if - minfo.buttons.button1 - == T.MouseButtonPressed - then - MsgInternal <| InternalMsgStartDrag - - else - MsgInternal InternalMsgNoop - ) - - StateDragging -> - dwg - |> T.onMouseUp (\_ -> MsgInternal InternalMsgStopDrag) - |> T.onHostMouseMove - (\minfo -> - let - delta = - Math.v2Sub - (Math.p2v minfo.localPoint) - (Math.p2v model.location) - - newPt = - Math.v2Add - delta - (Math.p2v model.location) - in - MsgMovedTo (Math.v2p newPt) - ) - in - T.group - [ T.path - (circle - { r = style.radius - , cx = Math.p2x model.location - , cy = Math.p2y model.location - } - ) - |> T.strokeWidth style.strokeWidth - |> T.stroke (Paint style.colorStroke) - |> T.fill (Paint fillColor) - |> appendEvents - , T.dropAnchor "location" - ( Math.p2x model.location - , Math.p2y model.location - ) - ] diff --git a/tests/Techdraw/Anticipate.elm b/tests/Depict/Anticipate.elm similarity index 99% rename from tests/Techdraw/Anticipate.elm rename to tests/Depict/Anticipate.elm index 8122c5b..672874f 100644 --- a/tests/Techdraw/Anticipate.elm +++ b/tests/Depict/Anticipate.elm @@ -1,4 +1,4 @@ -module Techdraw.Anticipate exposing (..) +module Depict.Anticipate exposing (..) {-| A better version of `Expect` for testing. -} diff --git a/tests/Techdraw/Math/Compare.elm b/tests/Depict/Math/Compare.elm similarity index 97% rename from tests/Techdraw/Math/Compare.elm rename to tests/Depict/Math/Compare.elm index a82aa79..d5825ee 100644 --- a/tests/Techdraw/Math/Compare.elm +++ b/tests/Depict/Math/Compare.elm @@ -1,4 +1,4 @@ -module Techdraw.Math.Compare exposing +module Depict.Math.Compare exposing ( defaultTol, testClose , float, floatTol , angle2Pi, angle2PiTol @@ -37,8 +37,8 @@ produce `Anticipate` values. -} import Debug -import Techdraw.Anticipate as Anticipate exposing (Anticipate) -import Techdraw.Math as M +import Depict.Anticipate as Anticipate exposing (Anticipate) +import Depict.Math as M diff --git a/tests/Techdraw/Math/Fuzzer.elm b/tests/Depict/Math/Fuzzer.elm similarity index 98% rename from tests/Techdraw/Math/Fuzzer.elm rename to tests/Depict/Math/Fuzzer.elm index fba0fb8..e810f7d 100644 --- a/tests/Techdraw/Math/Fuzzer.elm +++ b/tests/Depict/Math/Fuzzer.elm @@ -1,4 +1,4 @@ -module Techdraw.Math.Fuzzer exposing +module Depict.Math.Fuzzer exposing ( floatWideAngle , angle2Pi, anglePi, orientationPi , rotation, scaling, shearingX, translation @@ -22,8 +22,8 @@ module Techdraw.Math.Fuzzer exposing -} +import Depict.Math as M import Fuzz exposing (Fuzzer) -import Techdraw.Math as M {-| Fuzzer for a `Float` that covers a wide angle range. diff --git a/tests/Techdraw/Path/Compare.elm b/tests/Depict/Path/Compare.elm similarity index 76% rename from tests/Techdraw/Path/Compare.elm rename to tests/Depict/Path/Compare.elm index b87dfae..a4a9db3 100644 --- a/tests/Techdraw/Path/Compare.elm +++ b/tests/Depict/Path/Compare.elm @@ -1,4 +1,4 @@ -module Techdraw.Path.Compare exposing +module Depict.Path.Compare exposing ( defaultTol , path, pathTol ) @@ -13,10 +13,10 @@ This module contains functions which compare the path types and produce -} -import Techdraw.Anticipate exposing (Anticipate) -import Techdraw.Math as M -import Techdraw.Math.Compare exposing (testClose) -import Techdraw.Path as P +import Depict.Anticipate exposing (Anticipate) +import Depict.Math as M +import Depict.Math.Compare exposing (testClose) +import Depict.Path as P {-| Default tolerance when no explicit tolerance is given. diff --git a/tests/Techdraw/Path/Fuzzer.elm b/tests/Depict/Path/Fuzzer.elm similarity index 97% rename from tests/Techdraw/Path/Fuzzer.elm rename to tests/Depict/Path/Fuzzer.elm index 3071abb..e3f326b 100644 --- a/tests/Techdraw/Path/Fuzzer.elm +++ b/tests/Depict/Path/Fuzzer.elm @@ -1,4 +1,4 @@ -module Techdraw.Path.Fuzzer exposing +module Depict.Path.Fuzzer exposing ( MinRadius(..), MinEccentricity(..) , path, pathNormalizedRadii ) @@ -10,12 +10,12 @@ module Techdraw.Path.Fuzzer exposing -} +import Depict.Math as M +import Depict.Math.Fuzzer as MF +import Depict.Path as P +import Depict.Util exposing (unsafeForceMaybe) import Fuzz exposing (Fuzzer) import List.Nonempty as Nonempty exposing (Nonempty) -import Techdraw.Math as M -import Techdraw.Math.Fuzzer as MF -import Techdraw.Path as P -import Techdraw.Util exposing (unsafeForceMaybe) {-| Minimum radius for a generated point. diff --git a/tests/Techdraw/TestMath.elm b/tests/Depict/TestMath.elm similarity index 98% rename from tests/Techdraw/TestMath.elm rename to tests/Depict/TestMath.elm index d9adbf0..109c8b5 100644 --- a/tests/Techdraw/TestMath.elm +++ b/tests/Depict/TestMath.elm @@ -1,10 +1,10 @@ -module Techdraw.TestMath exposing (suite) +module Depict.TestMath exposing (suite) +import Depict.Anticipate as A +import Depict.Math as M +import Depict.Math.Compare as MC +import Depict.Math.Fuzzer as MF import Fuzz -import Techdraw.Anticipate as A -import Techdraw.Math as M -import Techdraw.Math.Compare as MC -import Techdraw.Math.Fuzzer as MF import Test exposing (Test) diff --git a/tests/Techdraw/TestPath.elm b/tests/Depict/TestPath.elm similarity index 72% rename from tests/Techdraw/TestPath.elm rename to tests/Depict/TestPath.elm index ab07682..eb03b83 100644 --- a/tests/Techdraw/TestPath.elm +++ b/tests/Depict/TestPath.elm @@ -1,11 +1,11 @@ -module Techdraw.TestPath exposing (suite) +module Depict.TestPath exposing (suite) -import Techdraw.Anticipate as A -import Techdraw.Math as M -import Techdraw.Math.Fuzzer as MF -import Techdraw.Path as P -import Techdraw.Path.Compare as PC -import Techdraw.Path.Fuzzer as PF +import Depict.Anticipate as A +import Depict.Math as M +import Depict.Math.Fuzzer as MF +import Depict.Path as P +import Depict.Path.Compare as PC +import Depict.Path.Fuzzer as PF import Test exposing (Test) diff --git a/tests/Techdraw/Util.elm b/tests/Depict/Util.elm similarity index 91% rename from tests/Techdraw/Util.elm rename to tests/Depict/Util.elm index 823f4c8..624caab 100644 --- a/tests/Techdraw/Util.elm +++ b/tests/Depict/Util.elm @@ -1,4 +1,4 @@ -module Techdraw.Util exposing (unsafeForceMaybe) +module Depict.Util exposing (unsafeForceMaybe) {-| Utility functions. diff --git a/tests/Suite.elm b/tests/Suite.elm index 5e0e861..004892a 100644 --- a/tests/Suite.elm +++ b/tests/Suite.elm @@ -1,13 +1,13 @@ module Suite exposing (suite) -import Techdraw.TestMath -import Techdraw.TestPath +import Depict.TestMath +import Depict.TestPath import Test exposing (Test, describe) suite : Test suite = describe "Techdraw" - [ Techdraw.TestMath.suite - , Techdraw.TestPath.suite + [ Depict.TestMath.suite + , Depict.TestPath.suite ]