From fb01c990fa6873070d7d5a99a9700ae46ff329ee Mon Sep 17 00:00:00 2001 From: Jonathan Merritt Date: Sat, 31 Aug 2024 22:34:57 +1000 Subject: [PATCH 01/21] Add external Style definition --- elm.json | 1 + src/Techdraw/Style.elm | 439 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 440 insertions(+) create mode 100644 src/Techdraw/Style.elm diff --git a/elm.json b/elm.json index 314b179..26a9e29 100644 --- a/elm.json +++ b/elm.json @@ -11,6 +11,7 @@ "Techdraw.PathBuilder", "Techdraw.Shapes.Simple", "Techdraw.Shapes.Spring", + "Techdraw.Style", "Techdraw.Svg.SvgStringPath", "Techdraw.Widgets.DragPt" ], diff --git a/src/Techdraw/Style.elm b/src/Techdraw/Style.elm new file mode 100644 index 0000000..048f0b0 --- /dev/null +++ b/src/Techdraw/Style.elm @@ -0,0 +1,439 @@ +module Techdraw.Style exposing + ( Style(..) + , Option(..) + , Fill(..) + , FillRule(..) + , Stroke(..) + , LineCap, LineJoin, DashArray + , Paint(..) + , LinearGradient(..), RadialGradient(..) + , Gradient, Stop(..), gradient + , 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 LinearGradient, RadialGradient +@docs Gradient, Stop, gradient + + +# Operations + +@docs combineStyle + + +# Style Setting Functions + +@docs inheritAll +@docs fill, fillRule +@docs stroke, strokeWidth, lineCap, lineJoin, dashArray, dashOffset + +-} + +import Color exposing (Color) +import Techdraw.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 ---------------------------------------------------------------- + + +{-| 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 LinearGradient + = LinearGradient + { start : P2 + , end : P2 + , transform : AffineTransform + , gradient : Gradient + } + + +{-| 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 RadialGradient + = RadialGradient + { innerCenter : P2 + , innerRadius : Float + , outerCenter : P2 + , outerRadius : Float + , transform : AffineTransform + , gradient : Gradient + } + + +{-| Gradient. + +A gradient is a list of stops sorted by location. +Use the [`gradient`](#gradient) smart constructor to create a `Gradient`. + +-} +type Gradient + = Gradient (List Stop) + + +{-| 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 + + +{-| Return the location of a gradient stop. +-} +getStopLocation : Stop -> Float +getStopLocation (Stop location _) = + location + + +{-| Create a `Gradient` from a list of stops. +-} +gradient : List Stop -> Gradient +gradient = + Gradient << List.sortBy getStopLocation + + + +---- 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 } From 73389745396cc6fc0170f26a875436439b67ae15 Mon Sep 17 00:00:00 2001 From: Jonathan Merritt Date: Mon, 2 Sep 2024 21:50:30 +1000 Subject: [PATCH 02/21] WIP --- elm.json | 12 +- src/Techdraw.elm | 2 +- src/Techdraw/CSys.elm | 13 + src/Techdraw/Datum.elm | 49 ++ src/Techdraw/Decorator.elm | 22 + src/Techdraw/Event.elm | 129 ++++ src/Techdraw/Internal/Codec.elm | 127 ++++ src/Techdraw/Internal/Drawing.elm | 331 ++++++++++ src/Techdraw/Internal/SvgDrawing.elm | 608 ++++++++++++++++++ src/Techdraw/Internal/SvgEvent.elm | 17 + .../{Svg => Internal}/SvgStringPath.elm | 2 +- src/Techdraw/Internal/SvgStyle.elm | 128 ++++ src/Techdraw/Math.elm | 107 ++- src/Techdraw/Style.elm | 285 +++++++- src/TechdrawNew.elm | 108 ++++ 15 files changed, 1911 insertions(+), 29 deletions(-) create mode 100644 src/Techdraw/CSys.elm create mode 100644 src/Techdraw/Datum.elm create mode 100644 src/Techdraw/Decorator.elm create mode 100644 src/Techdraw/Event.elm create mode 100644 src/Techdraw/Internal/Codec.elm create mode 100644 src/Techdraw/Internal/Drawing.elm create mode 100644 src/Techdraw/Internal/SvgDrawing.elm create mode 100644 src/Techdraw/Internal/SvgEvent.elm rename src/Techdraw/{Svg => Internal}/SvgStringPath.elm (99%) create mode 100644 src/Techdraw/Internal/SvgStyle.elm create mode 100644 src/TechdrawNew.elm diff --git a/elm.json b/elm.json index 26a9e29..8b6ba3a 100644 --- a/elm.json +++ b/elm.json @@ -6,26 +6,34 @@ "version": "1.0.0", "exposed-modules": [ "Techdraw", + "TechdrawNew", + "Techdraw.Event", + "Techdraw.Internal.Codec", + "Techdraw.Internal.Drawing", + "Techdraw.Internal.SvgDrawing", + "Techdraw.Internal.SvgStringPath", + "Techdraw.Internal.SvgStyle", "Techdraw.Math", "Techdraw.Path", "Techdraw.PathBuilder", "Techdraw.Shapes.Simple", "Techdraw.Shapes.Spring", "Techdraw.Style", - "Techdraw.Svg.SvgStringPath", "Techdraw.Widgets.DragPt" ], "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/src/Techdraw.elm b/src/Techdraw.elm index 23e2383..b8b4f2d 100644 --- a/src/Techdraw.elm +++ b/src/Techdraw.elm @@ -96,9 +96,9 @@ import Dict exposing (Dict) import Html exposing (Html) import Html.Events as HtmlEvents import Json.Decode as Decode exposing (Decoder) +import Techdraw.Internal.SvgStringPath as SP 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) diff --git a/src/Techdraw/CSys.elm b/src/Techdraw/CSys.elm new file mode 100644 index 0000000..2885615 --- /dev/null +++ b/src/Techdraw/CSys.elm @@ -0,0 +1,13 @@ +module Techdraw.CSys exposing (CSysName(..)) + +{-| Named coordinate systems. + +@docs CSysName + +-} + + +{-| Name of a coordinate system. +-} +type CSysName + = CSysName String diff --git a/src/Techdraw/Datum.elm b/src/Techdraw/Datum.elm new file mode 100644 index 0000000..fde86fc --- /dev/null +++ b/src/Techdraw/Datum.elm @@ -0,0 +1,49 @@ +module Techdraw.Datum exposing + ( DatumName(..), DatumPrefix(..) + , datumNameToString + , createStringName + ) + +{-| Named datum points in a drawing. + +@docs DatumName, DatumPrefix +@docs datumNameToString +@docs createStringName + +-} + + +{-| Name of a datum. +-} +type DatumName + = DatumName String + + +{-| Prefix to provide namespacing for datum names. +-} +type DatumPrefix + = DatumPrefix String + + +{-| Convert a `DatumName` to a `String`. +-} +datumNameToString : DatumName -> String +datumNameToString (DatumName name) = + name + + +{-| Convert a `DatumPrefix` to a `String`. +-} +datumPrefixToString : DatumPrefix -> String +datumPrefixToString (DatumPrefix str) = + str + + +{-| Create the string name of a final datum point from its list of +prefixes and its datum name. +-} +createStringName : List DatumPrefix -> DatumName -> String +createStringName dps n = + List.map datumPrefixToString dps + |> String.concat + |> (\prefix -> prefix ++ datumNameToString n) diff --git a/src/Techdraw/Decorator.elm b/src/Techdraw/Decorator.elm new file mode 100644 index 0000000..f701eb2 --- /dev/null +++ b/src/Techdraw/Decorator.elm @@ -0,0 +1,22 @@ +module Techdraw.Decorator exposing (..) + +{-| Path decorators (arrow-heads, length shortening, etc. +-} + +import Techdraw.Math exposing (AffineTransform) +import Techdraw.Path exposing (Path) +import Techdraw.Style exposing (Style) + + +{-| Decorator for a path. +-} +type Decorator + = Decorator (RenderPath -> List RenderPath) + + +type RenderPath + = RenderPath + { style : Style + , localToWorld : AffineTransform + , localPath : Path + } diff --git a/src/Techdraw/Event.elm b/src/Techdraw/Event.elm new file mode 100644 index 0000000..0d64946 --- /dev/null +++ b/src/Techdraw/Event.elm @@ -0,0 +1,129 @@ +module Techdraw.Event exposing + ( EventHandler(..) + , MouseHandler(..), MouseInfo(..) + , Buttons, BState(..), Modifiers, KState(..) + , map + ) + +{-| Events. + +@docs EventHandler +@docs MouseHandler, MouseInfo +@docs Buttons, BState, Modifiers, KState +@docs map + +-} + +import Techdraw.CSys exposing (CSysName) +import Techdraw.Math exposing (P2) + + +{-| 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/Techdraw/Internal/Codec.elm b/src/Techdraw/Internal/Codec.elm new file mode 100644 index 0000000..4a83d31 --- /dev/null +++ b/src/Techdraw/Internal/Codec.elm @@ -0,0 +1,127 @@ +module Techdraw.Internal.Codec exposing + ( endianness, encf32, decf32, encu32, decu32 + , encColor, decColor + , encList, decList + ) + +{-| Encoding and decoding from `Bytes`. + +This functionality currently exists for the purposes of hashing. + +@docs endianness, encf32, decf32, encu32, decu32 +@docs encColor, decColor +@docs encList, decList + +-} + +import Bytes exposing (Endianness) +import Bytes.Decode as Decode exposing (Decoder) +import Bytes.Encode as Encode exposing (Encoder) +import Color exposing (Color) + + + +---- General ------------------------------------------------------------------ + + +{-| Default endianness. +-} +endianness : Endianness +endianness = + Bytes.BE + + +{-| Encode a `Float32` value with default endianness. +-} +encf32 : Float -> Encoder +encf32 = + Encode.float32 endianness + + +{-| Decode a `Float32` value with default endianness. +-} +decf32 : Decoder Float +decf32 = + Decode.float32 endianness + + +{-| Encode a u32 with default endianness. +-} +encu32 : Int -> Encoder +encu32 = + Encode.unsignedInt32 endianness + + +{-| Decode a u32 with default endianness. +-} +decu32 : Decoder Int +decu32 = + Decode.unsignedInt32 endianness + + + +---- External Types ----------------------------------------------------------- + + +{-| Encode a `Color`. +-} +encColor : Color -> Encoder +encColor color = + let + rgba = + Color.toRgba color + in + Encode.sequence + [ encf32 rgba.red + , encf32 rgba.green + , encf32 rgba.blue + , encf32 rgba.alpha + ] + + +{-| Decode a `Color`. +-} +decColor : Decoder Color +decColor = + Decode.map4 + (\r g b a -> Color.fromRgba { red = r, green = g, blue = b, alpha = a }) + decf32 + decf32 + decf32 + decf32 + + + +---- List Encoders and Decoders ----------------------------------------------- + + +{-| Encode a list prefixed by its length. +-} +encList : (a -> Encoder) -> List a -> Encoder +encList encElem lst = + let + n = + List.length lst + in + Encode.sequence <| encu32 n :: List.map encElem lst + + +{-| Decode a list prefixed by its length. +-} +decList : Decoder a -> Decoder (List a) +decList decElem = + decu32 |> Decode.andThen (decListN decElem) + + +{-| Decode a list with a decoder for one element and an element count. +-} +decListN : Decoder a -> Int -> Decoder (List a) +decListN decElem nElem = + Decode.loop ( nElem, [] ) + (\( nLeft, accum ) -> + if nLeft == 0 then + Decode.succeed <| Decode.Done <| List.reverse accum + + else + Decode.map (\x -> Decode.Loop ( nLeft - 1, x :: accum )) decElem + ) diff --git a/src/Techdraw/Internal/Drawing.elm b/src/Techdraw/Internal/Drawing.elm new file mode 100644 index 0000000..82e029f --- /dev/null +++ b/src/Techdraw/Internal/Drawing.elm @@ -0,0 +1,331 @@ +module Techdraw.Internal.Drawing exposing + ( IDrawing(..) + , map + ) + +{-| Internal drawing type. + +The internal drawing type is the same as the external one, but we wrap it for +the external API so that it has a nicer user experience. + +@docs IDrawing +@docs map + +-} + +import Techdraw.CSys exposing (CSysName) +import Techdraw.Datum exposing (DatumName, DatumPrefix(..)) +import Techdraw.Decorator exposing (Decorator(..)) +import Techdraw.Event as Event exposing (EventHandler(..)) +import Techdraw.Math exposing (AffineTransform, P2) +import Techdraw.Path exposing (Path) +import Techdraw.Style exposing (Style) + + +{-| Internal Drawing type. +-} +type IDrawing msg + = IDrawingEmpty + | IDrawingPath Path + | IDrawingTagCSys CSysName + | IDrawingBake (IDrawing msg) + | IDrawingStyled Style (IDrawing msg) + | IDrawingTransformed AffineTransform (IDrawing msg) + | IDrawingDecorated Decorator (IDrawing msg) + | IDrawingHostEventHandler (EventHandler msg) (IDrawing msg) + | IDrawingEventHandler (EventHandler msg) (IDrawing msg) + | IDrawingAtop (IDrawing msg) (IDrawing msg) -- below above + | IDrawingBeneath (IDrawing msg) (IDrawing msg) -- above below + | IDrawingDatum DatumName P2 + | IDrawingDatumPrefix DatumPrefix (IDrawing msg) + | IDrawingWithDatumAccess ((DatumName -> P2) -> IDrawing msg) + + + +---- Non-Recursive Map -------------------------------------------------------- + + +{-| Map a function over the event type of a drawing. + +This is implemented using a non-recursive, continuation-based machine, so that +stack overflows are unlikely to occur due to deep drawing trees. + +-} +map : (a -> b) -> IDrawing a -> IDrawing b +map f iDrawing = + let + -- Loop should be tail-recursive. + loop : State a b -> IDrawing b + loop state = + case finished state of + Just drawing -> + drawing + + Nothing -> + let + newState = + step state + in + loop newState + in + inject f iDrawing |> loop + + +{-| State for the non-recursive map operation. + +The state consists of: + + - `mapf`: the function used for mapping + - `expr`: the current expression + - `kont`: the stack of pending continuations + +-} +type State a b + = State + { mapf : a -> b + , expr : Expr a b + , kont : List (Kont a b) + } + + +{-| Expression for the non-recursive map. + +An expression can be: + + - `Final`: A completed drawing, with the final message type, `b` + - `Initial`: An initial drawing, with the initial message type, `a` + +-} +type Expr a b + = Final (IDrawing b) + | Initial (IDrawing a) + + +{-| Suspended continuations for the non-recursive map. +-} +type Kont a b + = KontBake + | KontStyled Style + | KontTransformed AffineTransform + | KontDecorated Decorator + | KontHostEventHandler (EventHandler b) + | KontEventHandler (EventHandler b) + | KontAtop1 (IDrawing a) + | KontAtop2 (IDrawing b) + | KontBeneath1 (IDrawing a) + | KontBeneath2 (IDrawing b) + | KontDatumPrefix DatumPrefix + + +{-| Inject an initial drawing into the state. +-} +inject : (a -> b) -> IDrawing a -> State a b +inject mapf drawing = + State { mapf = mapf, expr = Initial drawing, kont = [] } + + +{-| Step of the mapping operation. + +The basic internal functionality of `step` is very simple. There are two main +cases: + +1. If an `Initial` drawing type is encountered, push any required + continuation onto the stack and start evaluating a sub-component of + the `Initial` expression into a `Final` expression. +2. If a `Final` expression is encountered, combine it with the next + pending continuation. + +Exhaustiveness checking on the types in the `case` expression is a very +powerful check to make sure we're handing everything here. + +-} +step : State a b -> State a b +step (State state) = + case ( state.expr, state.kont ) of + {- Transform Initial States; introduce continuations -} + ( Initial IDrawingEmpty, _ ) -> + State { state | expr = Final <| IDrawingEmpty } + + ( Initial (IDrawingPath path), _ ) -> + State { state | expr = Final <| IDrawingPath path } + + ( Initial (IDrawingTagCSys csysName), _ ) -> + State { state | expr = Final <| IDrawingTagCSys csysName } + + ( Initial (IDrawingDatum datumName point), _ ) -> + State { state | expr = Final <| IDrawingDatum datumName point } + + ( Initial (IDrawingWithDatumAccess f), _ ) -> + State + { state + | expr = + Final <| + IDrawingWithDatumAccess <| + \access -> + f access |> map state.mapf + } + + ( Initial (IDrawingBake drawing), ks ) -> + State + { state + | expr = Initial drawing + , kont = KontBake :: ks + } + + ( Initial (IDrawingStyled style drawing), ks ) -> + State + { state + | expr = Initial drawing + , kont = KontStyled style :: ks + } + + ( Initial (IDrawingTransformed transform drawing), ks ) -> + State + { state + | expr = Initial drawing + , kont = KontTransformed transform :: ks + } + + ( Initial (IDrawingDecorated decoration drawing), ks ) -> + State + { state + | expr = Initial drawing + , kont = KontDecorated decoration :: ks + } + + ( Initial (IDrawingHostEventHandler handler drawing), ks ) -> + State + { state + | expr = Initial drawing + , kont = + KontHostEventHandler + (Event.map state.mapf handler) + :: ks + } + + ( Initial (IDrawingEventHandler handler drawing), ks ) -> + State + { state + | expr = Initial drawing + , kont = + KontEventHandler + (Event.map state.mapf handler) + :: ks + } + + ( Initial (IDrawingAtop x y), ks ) -> + State + { state + | expr = Initial x + , kont = KontAtop1 y :: ks + } + + ( Initial (IDrawingBeneath x y), ks ) -> + State + { state + | expr = Initial x + , kont = KontBeneath1 y :: ks + } + + ( Initial (IDrawingDatumPrefix prefix drawing), ks ) -> + State + { state + | expr = Initial drawing + , kont = KontDatumPrefix prefix :: ks + } + + {- Complete continuations -} + ( Final _, [] ) -> + State state + + ( Final drawing, KontBake :: ks ) -> + State + { state + | kont = ks + , expr = Final <| IDrawingBake drawing + } + + ( Final drawing, (KontStyled style) :: ks ) -> + State + { state + | kont = ks + , expr = Final <| IDrawingStyled style drawing + } + + ( Final drawing, (KontTransformed transform) :: ks ) -> + State + { state + | kont = ks + , expr = Final <| IDrawingTransformed transform drawing + } + + ( Final drawing, (KontDecorated decoration) :: ks ) -> + State + { state + | kont = ks + , expr = Final <| IDrawingDecorated decoration drawing + } + + ( Final drawing, (KontHostEventHandler handler) :: ks ) -> + State + { state + | kont = ks + , expr = Final <| IDrawingHostEventHandler handler drawing + } + + ( Final drawing, (KontEventHandler handler) :: ks ) -> + State + { state + | kont = ks + , expr = Final <| IDrawingEventHandler handler drawing + } + + ( Final drawing, (KontAtop1 y) :: ks ) -> + State + { state + | kont = KontAtop2 drawing :: ks + , expr = Initial y + } + + ( Final drawing, (KontAtop2 x) :: ks ) -> + State + { state + | kont = ks + , expr = Final <| IDrawingAtop x drawing + } + + ( Final drawing, (KontBeneath1 y) :: ks ) -> + State + { state + | kont = KontAtop2 drawing :: ks + , expr = Initial y + } + + ( Final drawing, (KontBeneath2 x) :: ks ) -> + State + { state + | kont = ks + , expr = Final <| IDrawingBeneath x drawing + } + + ( Final drawing, (KontDatumPrefix datumPrefix) :: ks ) -> + State + { state + | kont = ks + , expr = Final <| IDrawingDatumPrefix datumPrefix drawing + } + + +{-| Return the drawing if mapping has finished. + +A completed state has a `Final` drawing and an empty continuation stack. + +-} +finished : State a b -> Maybe (IDrawing b) +finished (State state) = + case ( state.expr, state.kont ) of + ( Final drawing, [] ) -> + Just drawing + + _ -> + Nothing diff --git a/src/Techdraw/Internal/SvgDrawing.elm b/src/Techdraw/Internal/SvgDrawing.elm new file mode 100644 index 0000000..6356d25 --- /dev/null +++ b/src/Techdraw/Internal/SvgDrawing.elm @@ -0,0 +1,608 @@ +module Techdraw.Internal.SvgDrawing exposing + ( ViewBox(..), ContainerSize(..), Sizes(..) + , toSvg + ) + +{-| Converting Drawings to SVG. + +@docs ViewBox, ContainerSize, Sizes +@docs toSvg + +-} + +import Dict exposing (Dict) +import Html exposing (Html) +import Html.Attributes as HtmlAttributes +import Techdraw.CSys exposing (CSysName(..)) +import Techdraw.Datum as Datum exposing (DatumName, DatumPrefix) +import Techdraw.Decorator exposing (Decorator) +import Techdraw.Event exposing (EventHandler) +import Techdraw.Internal.Drawing exposing (IDrawing(..)) +import Techdraw.Internal.SvgEvent as SvgEvent +import Techdraw.Internal.SvgStringPath as SvgStringPath exposing (NFixDigits(..)) +import Techdraw.Internal.SvgStyle as SvgStyle exposing (Defs, SvgStyle(..)) +import Techdraw.Math as Math exposing (AffineTransform, P2) +import Techdraw.Path as Path exposing (Path) +import Techdraw.Style as Style exposing (Gradient, Style) +import TypedSvg as Svg +import TypedSvg.Attributes as SvgAttributes +import TypedSvg.Core exposing (Attribute, Svg) + + +{-| Sizes for a drawing. + +A drawing size is defined by: + + - The size of its container, and + - The view box which describes the drawing's initial coordinate system. + +-} +type Sizes + = Sizes + { containerSize : ContainerSize + , viewBox : ViewBox + } + + +{-| Size for a container of a drawing, in pixels. +-} +type ContainerSize + = ContainerSize + { width : Int + , height : Int + } + + +{-| Viewbox defining the initial coordinate system of a drawing. +-} +type ViewBox + = ViewBox + { minX : Float + , minY : Float + , width : Float + , height : Float + } + + +{-| Convert `Sizes` to a list of attributes. +-} +sizesAttributes : Sizes -> List (Attribute msg) +sizesAttributes (Sizes sz) = + containerSizeAttributes sz.containerSize ++ [ viewBoxAttribute sz.viewBox ] + + +{-| Convert `ContainerSize` to a list of attributes. +-} +containerSizeAttributes : ContainerSize -> List (Attribute msg) +containerSizeAttributes (ContainerSize sz) = + [ HtmlAttributes.width sz.width + , HtmlAttributes.height sz.height + ] + + +{-| Convert `ViewBox` to a viewBox attribute. +-} +viewBoxAttribute : ViewBox -> Attribute msg +viewBoxAttribute (ViewBox vb) = + SvgAttributes.viewBox vb.minX vb.minY vb.width vb.height + + +{-| Convert a drawing to SVG. +-} +toSvg : Sizes -> IDrawing msg -> Html msg +toSvg sizes iDrawing = + Svg.svg + (sizesAttributes sizes) + (componentsToSvg sizes iDrawing) + + + +---- State Machine for SVG Evaluation ----------------------------------------- + + +{-| Convert drawing components to a list of SVG components. +-} +componentsToSvg : Sizes -> IDrawing msg -> List (Svg msg) +componentsToSvg sizes iDrawing = + let + -- Loop should be tail-recursive + loop : State msg -> List (Svg msg) + loop state = + case finished state of + Just svgs -> + svgs + + Nothing -> + let + newState = + step state + in + loop newState + in + inject sizes iDrawing |> loop + + +{-| Inject sizes and the drawing commands into an initial state. +-} +inject : Sizes -> IDrawing msg -> State msg +inject sizes iDrawing = + State + { expr = Initial iDrawing + , kont = [] + , envr = + Envr + { nfdg = NFixDigits 2 + , tl2w = initialTransform sizes + , styl = Style.inheritAll + , defs = SvgStyle.emptyDefs + , evts = [] + , hvts = [] + , decr = Nothing + , csys = Dict.empty + , dprf = [] + , datm = Dict.empty + } + } + + +{-| Compute the initial transformation from the sizes. +-} +initialTransform : Sizes -> AffineTransform +initialTransform (Sizes sizes) = + let + (ViewBox vb) = + sizes.viewBox + in + Math.affFromComponents + [ Math.AffineScaling <| + Math.Scaling 1 -1 + , Math.AffineTranslation <| + Math.Translation (Math.v2 vb.minX (vb.height + vb.minY)) + ] + + +{-| Expression in the continuation machine. + +An expression can be either: + + - `Initial`: drawing expression to be converted + - `Final`: list of produced Svg elements + +-} +type Expr msg + = Initial (IDrawing msg) + | Final (List (Svg msg)) + + +{-| Continuations in the continuation machine. + +Continuations represent pending steps to be completed after the current +expression has reached a `Final` form. Continuations hold the environment +that existed when they were invoked. + +-} +type Kont msg + = KontAtop1 (Envr msg) (IDrawing msg) + | KontAtop2 (Envr msg) (List (Svg msg)) + | KontBeneath1 (Envr msg) (IDrawing msg) + | KontBeneath2 (Envr msg) (List (Svg msg)) + | KontWithDatumAccess (Envr msg) + + +{-| State for the evaluation machine. +-} +type State msg + = State + { expr : Expr msg + , kont : List (Kont msg) + , envr : Envr msg + } + + +{-| If the state machine has finished computing, return its list of +Svg components. +-} +finished : State msg -> Maybe (List (Svg msg)) +finished (State state) = + case ( state.expr, state.kont ) of + ( Final svgs, [] ) -> + Just svgs + + _ -> + Nothing + + +{-| Environment. + + - `nfdg`: Number of fixed digits to use when drawing path elements. + - `tl2w`: Local-to-world affine transformation. + - `styl`: Current style. + - `defs`: Items to include in a `` element. + - `evts`: Pending event handlers to be attached to a drawing. + - `hvts`: Pending host event handlers to be attached to a host SVG element. + - `decr`: Optional decorator (one only for now) on paths. + - `csys`: Dictionary of coordinate system names to their local-to-world + transformations. + - `dprf`: List of datum name prefixes to apply to any datum points declared. + - `datm`: Dictionary of datum points in world space. + +-} +type Envr msg + = Envr + { nfdg : NFixDigits + , tl2w : AffineTransform + , styl : Style + , defs : Defs + , evts : List (EventHandler msg) + , hvts : List (EventHandler msg) + , decr : Maybe Decorator + , csys : Dict String AffineTransform + , dprf : List DatumPrefix + , datm : Dict String P2 + } + + +step : State msg -> State msg +step (State state) = + let + (Envr envr) = + state.envr + in + case ( state.expr, state.kont ) of + {- Transform initial states; introduce continuations -} + ( Initial IDrawingEmpty, _ ) -> + State { state | expr = Final [] } + + ( Initial (IDrawingPath path), _ ) -> + let + ( svgPath, childEnvr ) = + envrPathToSvg state.envr path + in + State + { state + | expr = Final <| [ svgPath ] + , envr = envrThread state.envr childEnvr + } + + ( Initial (IDrawingTagCSys csysName), _ ) -> + State + { state + | expr = Final [] + , envr = envrAddCSys csysName envr.tl2w state.envr + } + + ( Initial (IDrawingBake _), _ ) -> + Debug.todo "TODO: IDrawingBake" + + ( Initial (IDrawingStyled style drawing), _ ) -> + State + { state + | expr = Initial drawing + , envr = envrCombineStyle style state.envr + } + + ( Initial (IDrawingTransformed transform drawing), _ ) -> + State + { state + | expr = Initial drawing + , envr = envrCombineTransform transform state.envr + } + + ( Initial (IDrawingDecorated decorator drawing), _ ) -> + State + { state + | expr = Initial drawing + , envr = envrSetDecorator decorator state.envr + } + + ( Initial (IDrawingHostEventHandler handler drawing), _ ) -> + State + { state + | expr = Initial drawing + , envr = envrAppendHostEventHandler handler state.envr + } + + ( Initial (IDrawingEventHandler handler drawing), _ ) -> + State + { state + | expr = Initial drawing + , envr = envrAppendEventHandler handler state.envr + } + + ( Initial (IDrawingAtop x y), ks ) -> + State + { state + | expr = Initial x + , kont = KontAtop1 state.envr y :: ks + } + + ( Initial (IDrawingBeneath x y), ks ) -> + State + { state + | expr = Initial x + , kont = KontBeneath1 state.envr y :: ks + } + + ( Initial (IDrawingDatum datumName point), _ ) -> + State + { state + | expr = Final [] + , envr = envrSetDatum datumName point state.envr + } + + ( Initial (IDrawingDatumPrefix prefix drawing), _ ) -> + State + { state + | expr = Initial drawing + , envr = envrPrependDatumPrefix prefix state.envr + } + + ( Initial (IDrawingWithDatumAccess createFn), ks ) -> + State + { state + | expr = Initial <| createFn (envrDatumAccessFn state.envr) + , kont = KontWithDatumAccess state.envr :: ks + } + + {- Complete continuations -} + ( Final svgs, (KontAtop1 kenvr y) :: ks ) -> + let + tenvr = + envrThread kenvr state.envr + in + State + { state + | expr = Initial y + , envr = tenvr + , kont = KontAtop2 tenvr svgs :: ks + } + + ( Final svgs, (KontAtop2 kenvr xs) :: ks ) -> + let + tenvr = + envrThread kenvr state.envr + in + State + { state + | expr = Final <| envrStack state.envr xs svgs + , envr = tenvr + , kont = ks + } + + ( Final svgs, (KontBeneath1 kenvr y) :: ks ) -> + let + tenvr = + envrThread kenvr state.envr + in + State + { state + | expr = Initial y + , envr = tenvr + , kont = KontBeneath2 tenvr svgs :: ks + } + + ( Final svgs, (KontBeneath2 kenvr xs) :: ks ) -> + let + tenvr = + envrThread kenvr state.envr + in + State + { state + | expr = Final <| envrStack state.envr svgs xs + , envr = tenvr + , kont = ks + } + + ( Final _, (KontWithDatumAccess kenvr) :: ks ) -> + State + { state + | envr = envrThread kenvr state.envr + , kont = ks + } + + {- Final, completed state. -} + ( Final _, [] ) -> + State state + + +{-| Add a named coordinate system to the environment. +-} +envrAddCSys : CSysName -> AffineTransform -> Envr msg -> Envr msg +envrAddCSys (CSysName name) l2w (Envr parent) = + Envr { parent | csys = Dict.insert name l2w parent.csys } + + +{-| Combine a child style with that of its parent in the environment. +-} +envrCombineStyle : Style -> Envr msg -> Envr msg +envrCombineStyle child (Envr parent) = + Envr { parent | styl = Style.combineStyle parent.styl child } + + +{-| Combine a child transformation with that of its parent in the +environment. +-} +envrCombineTransform : AffineTransform -> Envr msg -> Envr msg +envrCombineTransform child (Envr parent) = + Envr { parent | tl2w = Math.affMatMul parent.tl2w child } + + +{-| Set the decorator in the current environment. +-} +envrSetDecorator : Decorator -> Envr msg -> Envr msg +envrSetDecorator decorator (Envr parent) = + Envr { parent | decr = Just decorator } + + +{-| Append a host event handler to the environment. +-} +envrAppendHostEventHandler : EventHandler msg -> Envr msg -> Envr msg +envrAppendHostEventHandler handler (Envr parent) = + Envr { parent | hvts = handler :: parent.hvts } + + +{-| Append a drawing event handler to the environment +-} +envrAppendEventHandler : EventHandler msg -> Envr msg -> Envr msg +envrAppendEventHandler handler (Envr parent) = + Envr { parent | evts = handler :: parent.evts } + + +{-| Set a datum point in the environment as its world-space name. +-} +envrSetDatum : DatumName -> P2 -> Envr msg -> Envr msg +envrSetDatum datumName point (Envr parent) = + Envr + { parent + | datm = + Dict.insert + (Datum.createStringName parent.dprf datumName) + (Math.p2ApplyAffineTransform parent.tl2w point) + parent.datm + } + + +{-| Prepend a datum prefix string to the environment. +-} +envrPrependDatumPrefix : DatumPrefix -> Envr msg -> Envr msg +envrPrependDatumPrefix prefix (Envr parent) = + Envr { parent | dprf = prefix :: parent.dprf } + + +{-| Provide a datum access function for the environment. +-} +envrDatumAccessFn : Envr msg -> (DatumName -> P2) +envrDatumAccessFn (Envr envr) = + let + tw2l = + Math.affInvert envr.tl2w + in + \name -> + Dict.get (Datum.datumNameToString name) envr.datm + |> Maybe.withDefault (Math.p2 0 0) + |> Math.p2ApplyAffineTransform tw2l + + +{-| Thread an environment. + +When processing has completed on a child node, it produces the `chld` +environment. This is combined with the `kont` environment from the +continuation to produce the environment that the continuation should be +processed with. + +Items that should be inherited parent-to-child come from the `kont` +environment. Items that should be inherited via a depth-first evaluation +order come from the `chld` environment. + +-} +envrThread : Envr msg -> Envr msg -> Envr msg +envrThread (Envr kont) (Envr chld) = + Envr + { nfdg = kont.nfdg + , tl2w = kont.tl2w + , styl = kont.styl + , defs = chld.defs + , evts = kont.evts + , hvts = kont.hvts + , decr = kont.decr + , csys = chld.csys + , dprf = kont.dprf + , datm = chld.datm + } + + +{-| Convert a `Path` to SVG, applying correct attributes for the +environment. +-} +envrPathToSvg : Envr msg -> Path -> ( Svg msg, Envr msg ) +envrPathToSvg envr path = + let + (Envr env) = + envr + + ( attrs, newEnvr ) = + envrPathAttributes envr + + transformedPath = + Path.pathApplyAffineTransform env.tl2w path + in + ( pathToSvg env.nfdg attrs transformedPath, newEnvr ) + + +{-| Convert the style information from an `Envr` into a list of SVG +Attributes and any required child elements. Child elements are required +for gradients. + +It returns a new `Envr` containing any gradients added to the internal +dictionary. + +-} +envrStyleToAttributes : Envr msg -> ( List (Attribute msg), Envr msg ) +envrStyleToAttributes (Envr envr) = + let + (SvgStyle svgStyle) = + SvgStyle.styleToSvgAttributes envr.styl + in + ( svgStyle.attributes + , Envr + { envr + | defs = SvgStyle.defsUnion svgStyle.defs envr.defs + } + ) + + +{-| Convert the list of item events from an `Envr` into a list of SVG } +Attributes. +-} +envrEventsToAttributes : Envr msg -> List (Attribute msg) +envrEventsToAttributes (Envr envr) = + SvgEvent.eventHandlersToSvgAttributes envr.evts + + +{-| Fetch all the parts from the environment that should be applied to +a `Path`. +-} +envrPathAttributes : + Envr msg + -> ( List (Attribute msg), Envr msg ) +envrPathAttributes envr = + let + ( styleAttr, newEnvr ) = + envrStyleToAttributes envr + in + ( styleAttr ++ envrEventsToAttributes envr, newEnvr ) + + +{-| Convert a Path to an Svg node, with a list of attributes for styles +and events. +-} +pathToSvg : + NFixDigits + -> List (Attribute msg) + -> Path + -> Svg msg +pathToSvg nFixDigits attrs path = + Svg.path + (SvgAttributes.d + (SvgStringPath.formatPath nFixDigits path + |> SvgStringPath.svgStringPathToString + ) + :: attrs + ) + [] + + +{-| Use the environment to stack nodes. + +If the environment has event handlers, these are discharged directly by +creating an SVG group. However, if there are no event handlers, the two +lists of SVG are just appended. + +-} +envrStack : Envr msg -> List (Svg msg) -> List (Svg msg) -> List (Svg msg) +envrStack (Envr envr) below above = + if List.isEmpty envr.evts then + below ++ above + + else + [ Svg.g (envrEventsToAttributes (Envr envr)) (below ++ above) ] diff --git a/src/Techdraw/Internal/SvgEvent.elm b/src/Techdraw/Internal/SvgEvent.elm new file mode 100644 index 0000000..c648084 --- /dev/null +++ b/src/Techdraw/Internal/SvgEvent.elm @@ -0,0 +1,17 @@ +module Techdraw.Internal.SvgEvent exposing (eventHandlersToSvgAttributes) + +{-| Convert event information to SVG. + +@docs eventHandlersToSvgAttributes + +-} + +import Techdraw.Event exposing (EventHandler) +import TypedSvg.Core exposing (Attribute) + + +{-| Convert a list of event handlers to a list of SVG `Attribute`s. +-} +eventHandlersToSvgAttributes : List (EventHandler msg) -> List (Attribute msg) +eventHandlersToSvgAttributes = + Debug.todo "TODO" diff --git a/src/Techdraw/Svg/SvgStringPath.elm b/src/Techdraw/Internal/SvgStringPath.elm similarity index 99% rename from src/Techdraw/Svg/SvgStringPath.elm rename to src/Techdraw/Internal/SvgStringPath.elm index 471f53e..52d2d23 100644 --- a/src/Techdraw/Svg/SvgStringPath.elm +++ b/src/Techdraw/Internal/SvgStringPath.elm @@ -1,4 +1,4 @@ -module Techdraw.Svg.SvgStringPath exposing +module Techdraw.Internal.SvgStringPath exposing ( SvgStringPath , svgStringPath, svgStringPathToString , formatPath diff --git a/src/Techdraw/Internal/SvgStyle.elm b/src/Techdraw/Internal/SvgStyle.elm new file mode 100644 index 0000000..293dfff --- /dev/null +++ b/src/Techdraw/Internal/SvgStyle.elm @@ -0,0 +1,128 @@ +module Techdraw.Internal.SvgStyle exposing + ( Defs, SvgStyle(..) + , emptyDefs, defsUnion + , styleToSvgAttributes + ) + +{-| Convert styling information to SVG. + +@docs Defs, SvgStyle +@docs emptyDefs, defsUnion +@docs styleToSvgAttributes + +-} + +import Dict exposing (Dict) +import Techdraw.Math as Math +import Techdraw.Style as Style + exposing + ( Gradient + , LinearGradient(..) + , RadialGradient + , Style + ) +import TypedSvg as Svg +import TypedSvg.Attributes as SvgAttributes +import TypedSvg.Core exposing (Attribute, Svg) +import TypedSvg.Types exposing (px) + + + +---- Defs collection ---------------------------------------------------------- + + +{-| Item that can be included in `defs`. +-} +type DefItem + = DefGradient Gradient + | DefLinearGradient LinearGradient + | DefRadialGradient RadialGradient + + +{-| A dictionary of hashes to defs items. +-} +type Defs + = Defs (Dict String DefItem) + + +{-| Empty defs items. +-} +emptyDefs : Defs +emptyDefs = + Defs Dict.empty + + +{-| Combine defs. +-} +defsUnion : Defs -> Defs -> Defs +defsUnion (Defs d1) (Defs d2) = + Defs (Dict.union d1 d2) + + +{-| Include a gradient in the defs items. +-} +defsIncludeGradient : Gradient -> Defs -> Defs +defsIncludeGradient gradient (Defs dict) = + let + key = + Style.gradientHexHash gradient + in + if Dict.member key dict then + Defs dict + + else + Defs <| Dict.insert key (DefGradient gradient) dict + + +{-| Include a LinearGradient and its child Gradient in defs items. +-} +defsIncludeLinearGradient : LinearGradient -> Defs -> Defs +defsIncludeLinearGradient linearGradient (Defs dict) = + let + key = + Style.linearGradientHexHash linearGradient + in + if Dict.member key dict then + Defs dict + + else + (Defs <| Dict.insert key (DefLinearGradient linearGradient) dict) + |> defsIncludeGradient + (Style.linearGradientParams linearGradient |> .gradient) + + +{-| Include a RadialGradient and its child Gradient in defs items. +-} +defsIncludeRadialGradient : RadialGradient -> Defs -> Defs +defsIncludeRadialGradient radialGradient (Defs dict) = + let + key = + Style.radialGradientHexHash radialGradient + in + if Dict.member key dict then + Defs dict + + else + (Defs <| Dict.insert key (DefRadialGradient radialGradient) dict) + |> defsIncludeGradient + (Style.radialGradientParams radialGradient |> .gradient) + + + +---- + + +{-| Return value from SVG styling. +-} +type SvgStyle msg + = SvgStyle + { attributes : List (Attribute msg) + , defs : Defs + } + + +{-| Convert a `Style` to a list of SVG `Attribute`s. +-} +styleToSvgAttributes : Style -> SvgStyle msg +styleToSvgAttributes = + Debug.todo "TODO" diff --git a/src/Techdraw/Math.elm b/src/Techdraw/Math.elm index 85a8616..ff4bc2b 100644 --- a/src/Techdraw/Math.elm +++ b/src/Techdraw/Math.elm @@ -31,13 +31,17 @@ module Techdraw.Math exposing , p2ApplyAffineTransform , closeP2 , AffineTransform - , affineTransform + , affineTransform, affineTransformMV , affIdentity, affRotation, affScaling, affShearingX, affTranslation , affFromComponent, affFromComponents , affGetLinear, affGetTranslation , affMatMul , affInvert , closeAffineTransform + , encP2, decP2 + , encV2, decV2 + , encM22, decM22 + , encAffineTransform, decAffineTransform ) {-| Mathematical core for Techdraw. @@ -271,7 +275,7 @@ that applies an affine transformation to a point. ## Creation -@docs affineTransform +@docs affineTransform, affineTransformMV @docs affIdentity, affRotation, affScaling, affShearingX, affTranslation @docs affFromComponent, affFromComponents @@ -295,8 +299,25 @@ that applies an affine transformation to a point. @docs closeAffineTransform + +# Codecs + +We can read and write binary forms of some types, which is useful for +hashing: + +@docs encP2, decP2 +@docs encV2, decV2 +@docs encM22, decM22 +@docs encAffineTransform, decAffineTransform + -} +import Bytes.Decode as Decode exposing (Decoder) +import Bytes.Encode as Encode exposing (Encoder) +import Techdraw.Internal.Codec as Codec + + + ---- Floating-point functions ------------------------------------------------- @@ -1060,6 +1081,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 @@ -1189,3 +1218,77 @@ element-wise. closeAffineTransform : Tol -> AffineTransform -> AffineTransform -> Bool closeAffineTransform tol (AffineTransform a) (AffineTransform b) = closeM22 tol a.linear b.linear && closeV2 tol a.translation b.translation + + + +---- Codecs ------------------------------------------------------------------- + + +{-| Encode a `P2` point. +-} +encP2 : P2 -> Encoder +encP2 p = + Encode.sequence + [ p2x p |> Codec.encf32 + , p2y p |> Codec.encf32 + ] + + +{-| Decode a `P2` point. +-} +decP2 : Decoder P2 +decP2 = + Decode.map2 p2 Codec.decf32 Codec.decf32 + + +{-| Encode a `V2` vector. +-} +encV2 : V2 -> Encoder +encV2 v = + Encode.sequence + [ v2e1 v |> Codec.encf32 + , v2e2 v |> Codec.encf32 + ] + + +{-| Decode a `V2` vector. +-} +decV2 : Decoder V2 +decV2 = + Decode.map2 v2 Codec.decf32 Codec.decf32 + + +{-| Encode an `M22` matrix. +-} +encM22 : M22 -> Encoder +encM22 m = + Encode.sequence + [ m22e11 m |> Codec.encf32 + , m22e12 m |> Codec.encf32 + , m22e21 m |> Codec.encf32 + , m22e22 m |> Codec.encf32 + ] + + +{-| Decode an `M22` matrix. +-} +decM22 : Decoder M22 +decM22 = + Decode.map4 m22 Codec.decf32 Codec.decf32 Codec.decf32 Codec.decf32 + + +{-| Encode an affine transform. +-} +encAffineTransform : AffineTransform -> Encoder +encAffineTransform aff = + Encode.sequence + [ affGetLinear aff |> encM22 + , affGetTranslation aff |> encV2 + ] + + +{-| Decode an affine transform. +-} +decAffineTransform : Decoder AffineTransform +decAffineTransform = + Decode.map2 affineTransformMV decM22 decV2 diff --git a/src/Techdraw/Style.elm b/src/Techdraw/Style.elm index 048f0b0..6836db8 100644 --- a/src/Techdraw/Style.elm +++ b/src/Techdraw/Style.elm @@ -4,10 +4,15 @@ module Techdraw.Style exposing , Fill(..) , FillRule(..) , Stroke(..) - , LineCap, LineJoin, DashArray + , LineCap(..), LineJoin(..), DashArray(..) , Paint(..) - , LinearGradient(..), RadialGradient(..) + , LinearGradientParams, LinearGradient + , RadialGradientParams, RadialGradient + , linearGradient, radialGradient , Gradient, Stop(..), gradient + , gradientHexHash + , linearGradientHexHash, linearGradientParams + , radialGradientHexHash, radialGradientParams , combineStyle , inheritAll , fill, fillRule @@ -49,8 +54,13 @@ module Techdraw.Style exposing ## Gradients -@docs LinearGradient, RadialGradient +@docs LinearGradientParams, LinearGradient +@docs RadialGradientParams, RadialGradient +@docs linearGradient, radialGradient @docs Gradient, Stop, gradient +@docs gradientHexHash +@docs linearGradientHexHash, linearGradientParams +@docs radialGradientHexHash, radialGradientParams # Operations @@ -66,8 +76,11 @@ module Techdraw.Style exposing -} +import Bytes.Encode as Encode exposing (Encoder) import Color exposing (Color) -import Techdraw.Math exposing (AffineTransform, P2) +import SHA1 +import Techdraw.Internal.Codec as Codec +import Techdraw.Math as Math exposing (AffineTransform, P2) @@ -174,6 +187,16 @@ type Paint ---- Gradients ---------------------------------------------------------------- +{-| Parameters of a linear gradient. +-} +type alias LinearGradientParams = + { start : P2 + , end : P2 + , transform : AffineTransform + , gradient : Gradient + } + + {-| Linear gradient. A linear gradient is specified by: @@ -186,12 +209,36 @@ A linear gradient is specified by: -} type LinearGradient - = LinearGradient - { start : P2 - , end : P2 - , transform : AffineTransform - , gradient : Gradient - } + = LinearGradient SHA1.Digest UnhashedLinearGradient + + +{-| Unhashed linear gradient. +-} +type UnhashedLinearGradient + = UnhashedLinearGradient LinearGradientParams + + +{-| Create a linear gradient. +-} +linearGradient : LinearGradientParams -> LinearGradient +linearGradient record = + let + ulg = + UnhashedLinearGradient record + in + LinearGradient (hashUnhashedLinearGradient ulg) ulg + + +{-| Parameters of a radial gradient. +-} +type alias RadialGradientParams = + { innerCenter : P2 + , innerRadius : Float + , outerCenter : P2 + , outerRadius : Float + , transform : AffineTransform + , gradient : Gradient + } {-| Radial gradient. @@ -209,24 +256,43 @@ It is specified by: -} type RadialGradient - = RadialGradient - { innerCenter : P2 - , innerRadius : Float - , outerCenter : P2 - , outerRadius : Float - , transform : AffineTransform - , gradient : Gradient - } + = RadialGradient SHA1.Digest UnhashedRadialGradient + + +{-| Unhashed radial gradient. +-} +type UnhashedRadialGradient + = UnhashedRadialGradient RadialGradientParams + + +{-| Create a radial gradient. +-} +radialGradient : RadialGradientParams -> RadialGradient +radialGradient record = + let + urg = + UnhashedRadialGradient record + in + RadialGradient (hashUnhashedRadialGradient urg) urg {-| Gradient. -A gradient is a list of stops sorted by location. -Use the [`gradient`](#gradient) smart constructor to create a `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 (List Stop) + = Gradient SHA1.Digest UnhashedGradient + + +{-| Gradient without any hashing information. +-} +type UnhashedGradient + = UnhashedGradient (List Stop) {-| Gradient stop. @@ -249,8 +315,90 @@ getStopLocation (Stop location _) = {-| Create a `Gradient` from a list of stops. -} gradient : List Stop -> Gradient -gradient = - Gradient << List.sortBy getStopLocation +gradient rawStops = + let + unhashed = + UnhashedGradient <| List.sortBy getStopLocation rawStops + in + Gradient (hashUnhashedGradient unhashed) unhashed + + +{-| Return a hex string containing the hash of a `Gradient`. + + import Color + + gradientHexHash <| + gradient + [ Stop 0.0 Color.black + , Stop 0.5 Color.blue + , Stop 0.7 Color.red + , Stop 1.0 Color.green + ] + --> "4233f96f9909e03055aeb16861262ec25214bcc4" + +The hash should be the same if `Stop`s are re-ordered; eg: + + import Color + + gradientHexHash <| + gradient + [ Stop 1.0 Color.green + , Stop 0.0 Color.black + , Stop 0.7 Color.red + , Stop 0.5 Color.blue + ] + --> "4233f96f9909e03055aeb16861262ec25214bcc4" + +But will be different if the `Stop`s are different: + + impoct Color + + gradientHexHash <| + gradient + [ Stop 0.0 Color.black + , Stop 1.0 Color.white + ] + --> "59bc04f8c6298d5bcbe6f89ed20ec316cc8a5959" + +-} +gradientHexHash : Gradient -> String +gradientHexHash (Gradient digest _) = + SHA1.toHex digest + + +{-| Return the hex hash of a linear gradient. +-} +linearGradientHexHash : LinearGradient -> String +linearGradientHexHash (LinearGradient digest _) = + SHA1.toHex digest + + +{-| Return the parameters of a linear gradient. +-} +linearGradientParams : LinearGradient -> LinearGradientParams +linearGradientParams (LinearGradient _ (UnhashedLinearGradient params)) = + params + + +{-| Return the hex hash of a radial gradient. +-} +radialGradientHexHash : RadialGradient -> String +radialGradientHexHash (RadialGradient digest _) = + SHA1.toHex digest + + +{-| Return the parameters of a radial gradient. +-} +radialGradientParams : RadialGradient -> RadialGradientParams +radialGradientParams (RadialGradient _ (UnhashedRadialGradient params)) = + params + + +{-| Return the SHA1 Digest of a `Gradient`. +-} +gradientSHA1Digest : Gradient -> SHA1.Digest +gradientSHA1Digest (Gradient digest _) = + digest @@ -437,3 +585,94 @@ dashArray d = dashOffset : Float -> Style -> Style dashOffset o = styleModifyStroke <| \(Stroke st) -> Stroke { st | dashOffset = Set o } + + + +---- Hashing ------------------------------------------------------------------ + + +{-| Hash an `UnhashedLinearGradient`. +-} +hashUnhashedLinearGradient : UnhashedLinearGradient -> SHA1.Digest +hashUnhashedLinearGradient = + encLinearGradient >> Encode.encode >> SHA1.fromBytes + + +{-| Hash an `UnhashedRadialGradient`. +-} +hashUnhashedRadialGradient : UnhashedRadialGradient -> SHA1.Digest +hashUnhashedRadialGradient = + encRadialGradient >> Encode.encode >> SHA1.fromBytes + + +{-| Hash an `UnhashedGradient`. +-} +hashUnhashedGradient : UnhashedGradient -> SHA1.Digest +hashUnhashedGradient = + encGradient >> Encode.encode >> SHA1.fromBytes + + +{-| Encode a `RadialGradient`. Only for hashing. + +This is not a complete encoding, because it encodes the hash of the gradient. + +-} +encRadialGradient : UnhashedRadialGradient -> Encoder +encRadialGradient (UnhashedRadialGradient g) = + Encode.sequence + [ Math.encP2 g.innerCenter + , Codec.encf32 g.innerRadius + , Math.encP2 g.outerCenter + , Codec.encf32 g.outerRadius + , Math.encAffineTransform g.transform + , encSHA1Digest <| gradientSHA1Digest <| g.gradient + ] + + +{-| Encode a `LinearGradient`. Only for hashing. + +This is not a complete encoding, because it encodes the hash of the gradient. + +-} +encLinearGradient : UnhashedLinearGradient -> Encoder +encLinearGradient (UnhashedLinearGradient g) = + Encode.sequence + [ Math.encP2 g.start + , Math.encP2 g.end + , Math.encAffineTransform g.transform + , encSHA1Digest <| gradientSHA1Digest <| g.gradient + ] + + +{-| Encode a `SHA1.Digest`. Only for hashing. +-} +encSHA1Digest : SHA1.Digest -> Encoder +encSHA1Digest digest = + let + d = + SHA1.toInt32s digest + in + Encode.sequence + [ Codec.encu32 d.a + , Codec.encu32 d.b + , Codec.encu32 d.c + , Codec.encu32 d.d + , Codec.encu32 d.e + ] + + +{-| Encode an `UnhashedGradient`. Only for hashing. +-} +encGradient : UnhashedGradient -> Encoder +encGradient (UnhashedGradient stops) = + Codec.encList encStop stops + + +{-| Encode a `Stop`. Only for hashing. +-} +encStop : Stop -> Encoder +encStop (Stop location color) = + Encode.sequence + [ Codec.encf32 location + , Codec.encColor color + ] diff --git a/src/TechdrawNew.elm b/src/TechdrawNew.elm new file mode 100644 index 0000000..4dff5b2 --- /dev/null +++ b/src/TechdrawNew.elm @@ -0,0 +1,108 @@ +module TechdrawNew exposing + ( Drawing + , Sizes + , toSvg + , empty, path, tagCSys, styled, transformed + , map + ) + +{-| Techdraw (new API). + +@docs Drawing +@docs Sizes +@docs toSvg +@docs empty, path, tagCSys, styled, transformed +@docs map + +-} + +import Html exposing (Html) +import Techdraw.CSys exposing (CSysName) +import Techdraw.Internal.Drawing as ID exposing (IDrawing(..)) +import Techdraw.Internal.SvgDrawing as SD +import Techdraw.Math exposing (AffineTransform) +import Techdraw.Path exposing (Path) +import Techdraw.Style exposing (Style) + + +{-| Drawing type. +-} +type Drawing msg + = Drawing (IDrawing msg) + + +{-| Sizes of a drawing. +-} +type alias Sizes = + { containerWidth : Int + , containerHeight : Int + , viewBoxMinX : Float + , viewBoxMinY : Float + , viewBoxWidth : Float + , viewBoxHeight : Float + } + + +{-| Convert a drawing to an SVG element in HTML. +-} +toSvg : Sizes -> Drawing msg -> Html msg +toSvg sz (Drawing iDrawing) = + SD.toSvg + (SD.Sizes + { containerSize = + SD.ContainerSize + { width = sz.containerHeight + , height = sz.containerHeight + } + , viewBox = + SD.ViewBox + { minX = sz.viewBoxMinX + , minY = sz.viewBoxMinY + , width = sz.viewBoxWidth + , height = sz.viewBoxHeight + } + } + ) + iDrawing + + +{-| Empty drawing. +-} +empty : Drawing msg +empty = + Drawing <| IDrawingEmpty + + +{-| Create a drawing from a `Path`. +-} +path : Path -> Drawing msg +path = + Drawing << IDrawingPath + + +{-| Tag a coordinate system. +-} +tagCSys : CSysName -> Drawing msg +tagCSys = + Drawing << IDrawingTagCSys + + +{-| Apply a style to a drawing. +-} +styled : Style -> Drawing msg -> Drawing msg +styled sty (Drawing iDrawing) = + Drawing <| IDrawingStyled sty iDrawing + + +{-| Apply an affine transformation to a drawing. +-} +transformed : AffineTransform -> Drawing msg -> Drawing msg +transformed xform (Drawing iDrawing) = + Drawing <| IDrawingTransformed xform iDrawing + + +{-| Map a function across the event type of the drawing. +-} +map : (a -> b) -> Drawing a -> Drawing b +map f (Drawing iDrawing) = + Drawing <| ID.map f iDrawing From d06fb74a12dc5ae76ca2282cba3e184e71519fe2 Mon Sep 17 00:00:00 2001 From: Jonathan Merritt Date: Tue, 3 Sep 2024 07:34:08 +1000 Subject: [PATCH 03/21] WIP --- src/Techdraw/Internal/SvgDrawing.elm | 32 ++++++++++++++++---- src/Techdraw/Style.elm | 44 ++++++++++++++++------------ 2 files changed, 53 insertions(+), 23 deletions(-) diff --git a/src/Techdraw/Internal/SvgDrawing.elm b/src/Techdraw/Internal/SvgDrawing.elm index 6356d25..c0982d8 100644 --- a/src/Techdraw/Internal/SvgDrawing.elm +++ b/src/Techdraw/Internal/SvgDrawing.elm @@ -91,22 +91,36 @@ viewBoxAttribute (ViewBox vb) = -} toSvg : Sizes -> IDrawing msg -> Html msg toSvg sizes iDrawing = + let + (SvgResult result) = + componentsToSvg sizes iDrawing + in + -- TODO : Handle defs and container events Svg.svg (sizesAttributes sizes) - (componentsToSvg sizes iDrawing) + result.children ---- State Machine for SVG Evaluation ----------------------------------------- +{-| Result of conversion to SVG. +-} +type SvgResult msg + = SvgResult + { children : List (Svg msg) + , defs : Defs + } + + {-| Convert drawing components to a list of SVG components. -} -componentsToSvg : Sizes -> IDrawing msg -> List (Svg msg) +componentsToSvg : Sizes -> IDrawing msg -> SvgResult msg componentsToSvg sizes iDrawing = let -- Loop should be tail-recursive - loop : State msg -> List (Svg msg) + loop : State msg -> SvgResult msg loop state = case finished state of Just svgs -> @@ -202,11 +216,19 @@ type State msg {-| If the state machine has finished computing, return its list of Svg components. -} -finished : State msg -> Maybe (List (Svg msg)) +finished : State msg -> Maybe (SvgResult msg) finished (State state) = case ( state.expr, state.kont ) of ( Final svgs, [] ) -> - Just svgs + Just <| + let + (Envr envr) = + state.envr + in + SvgResult + { children = svgs + , defs = envr.defs + } _ -> Nothing diff --git a/src/Techdraw/Style.elm b/src/Techdraw/Style.elm index 6836db8..7f3cd79 100644 --- a/src/Techdraw/Style.elm +++ b/src/Techdraw/Style.elm @@ -188,6 +188,15 @@ type Paint {-| 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 @@ -199,13 +208,8 @@ type alias LinearGradientParams = {-| 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. +Internally, this contains the parameters of the linear gradient along with +a unique hash. -} type LinearGradient @@ -230,6 +234,18 @@ linearGradient record = {-| 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 @@ -243,16 +259,8 @@ type alias RadialGradientParams = {-| 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. +Internally, this contains the parameters of the radial gradient along with a +unique hash. -} type RadialGradient @@ -351,7 +359,7 @@ The hash should be the same if `Stop`s are re-ordered; eg: But will be different if the `Stop`s are different: - impoct Color + import Color gradientHexHash <| gradient From 5ce79f289474cfdc376970f824f3943e63226699 Mon Sep 17 00:00:00 2001 From: Jonathan Merritt Date: Tue, 3 Sep 2024 10:33:34 +1000 Subject: [PATCH 04/21] Start of refactor: better hashing --- elm.json | 16 +- src/Techdraw.elm | 1825 ----------------- src/Techdraw/Decorator.elm | 5 +- src/Techdraw/Internal/Drawing.elm | 331 --- src/Techdraw/Internal/Hash.elm | 266 +++ .../{SvgStringPath.elm => Svg/Path.elm} | 98 +- src/Techdraw/Internal/SvgDrawing.elm | 630 ------ src/Techdraw/Internal/SvgEvent.elm | 17 - src/Techdraw/Internal/SvgStyle.elm | 128 -- src/Techdraw/Math.elm | 95 - src/Techdraw/Style.elm | 297 +-- src/Techdraw/Widgets/DragPt.elm | 235 --- src/TechdrawNew.elm | 108 - 13 files changed, 407 insertions(+), 3644 deletions(-) delete mode 100644 src/Techdraw.elm delete mode 100644 src/Techdraw/Internal/Drawing.elm create mode 100644 src/Techdraw/Internal/Hash.elm rename src/Techdraw/Internal/{SvgStringPath.elm => Svg/Path.elm} (75%) delete mode 100644 src/Techdraw/Internal/SvgDrawing.elm delete mode 100644 src/Techdraw/Internal/SvgEvent.elm delete mode 100644 src/Techdraw/Internal/SvgStyle.elm delete mode 100644 src/Techdraw/Widgets/DragPt.elm delete mode 100644 src/TechdrawNew.elm diff --git a/elm.json b/elm.json index 8b6ba3a..a2e903b 100644 --- a/elm.json +++ b/elm.json @@ -5,21 +5,19 @@ "license": "BSD-3-Clause", "version": "1.0.0", "exposed-modules": [ - "Techdraw", - "TechdrawNew", + "Techdraw.CSys", + "Techdraw.Datum", + "Techdraw.Decorator", "Techdraw.Event", - "Techdraw.Internal.Codec", - "Techdraw.Internal.Drawing", - "Techdraw.Internal.SvgDrawing", - "Techdraw.Internal.SvgStringPath", - "Techdraw.Internal.SvgStyle", "Techdraw.Math", "Techdraw.Path", "Techdraw.PathBuilder", + "Techdraw.Style", "Techdraw.Shapes.Simple", "Techdraw.Shapes.Spring", - "Techdraw.Style", - "Techdraw.Widgets.DragPt" + "Techdraw.Internal.Codec", + "Techdraw.Internal.Hash", + "Techdraw.Internal.Svg.Path" ], "source-directories": ["src"], "elm-version": "0.19.1 <= v < 0.20.0", diff --git a/src/Techdraw.elm b/src/Techdraw.elm deleted file mode 100644 index b8b4f2d..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.Internal.SvgStringPath as SP -import Techdraw.Math as Math exposing (AffineTransform(..), P2) -import Techdraw.Path as P exposing (Path(..)) -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/Decorator.elm b/src/Techdraw/Decorator.elm index f701eb2..807635b 100644 --- a/src/Techdraw/Decorator.elm +++ b/src/Techdraw/Decorator.elm @@ -1,6 +1,9 @@ -module Techdraw.Decorator exposing (..) +module Techdraw.Decorator exposing (Decorator) {-| Path decorators (arrow-heads, length shortening, etc. + +@docs Decorator + -} import Techdraw.Math exposing (AffineTransform) diff --git a/src/Techdraw/Internal/Drawing.elm b/src/Techdraw/Internal/Drawing.elm deleted file mode 100644 index 82e029f..0000000 --- a/src/Techdraw/Internal/Drawing.elm +++ /dev/null @@ -1,331 +0,0 @@ -module Techdraw.Internal.Drawing exposing - ( IDrawing(..) - , map - ) - -{-| Internal drawing type. - -The internal drawing type is the same as the external one, but we wrap it for -the external API so that it has a nicer user experience. - -@docs IDrawing -@docs map - --} - -import Techdraw.CSys exposing (CSysName) -import Techdraw.Datum exposing (DatumName, DatumPrefix(..)) -import Techdraw.Decorator exposing (Decorator(..)) -import Techdraw.Event as Event exposing (EventHandler(..)) -import Techdraw.Math exposing (AffineTransform, P2) -import Techdraw.Path exposing (Path) -import Techdraw.Style exposing (Style) - - -{-| Internal Drawing type. --} -type IDrawing msg - = IDrawingEmpty - | IDrawingPath Path - | IDrawingTagCSys CSysName - | IDrawingBake (IDrawing msg) - | IDrawingStyled Style (IDrawing msg) - | IDrawingTransformed AffineTransform (IDrawing msg) - | IDrawingDecorated Decorator (IDrawing msg) - | IDrawingHostEventHandler (EventHandler msg) (IDrawing msg) - | IDrawingEventHandler (EventHandler msg) (IDrawing msg) - | IDrawingAtop (IDrawing msg) (IDrawing msg) -- below above - | IDrawingBeneath (IDrawing msg) (IDrawing msg) -- above below - | IDrawingDatum DatumName P2 - | IDrawingDatumPrefix DatumPrefix (IDrawing msg) - | IDrawingWithDatumAccess ((DatumName -> P2) -> IDrawing msg) - - - ----- Non-Recursive Map -------------------------------------------------------- - - -{-| Map a function over the event type of a drawing. - -This is implemented using a non-recursive, continuation-based machine, so that -stack overflows are unlikely to occur due to deep drawing trees. - --} -map : (a -> b) -> IDrawing a -> IDrawing b -map f iDrawing = - let - -- Loop should be tail-recursive. - loop : State a b -> IDrawing b - loop state = - case finished state of - Just drawing -> - drawing - - Nothing -> - let - newState = - step state - in - loop newState - in - inject f iDrawing |> loop - - -{-| State for the non-recursive map operation. - -The state consists of: - - - `mapf`: the function used for mapping - - `expr`: the current expression - - `kont`: the stack of pending continuations - --} -type State a b - = State - { mapf : a -> b - , expr : Expr a b - , kont : List (Kont a b) - } - - -{-| Expression for the non-recursive map. - -An expression can be: - - - `Final`: A completed drawing, with the final message type, `b` - - `Initial`: An initial drawing, with the initial message type, `a` - --} -type Expr a b - = Final (IDrawing b) - | Initial (IDrawing a) - - -{-| Suspended continuations for the non-recursive map. --} -type Kont a b - = KontBake - | KontStyled Style - | KontTransformed AffineTransform - | KontDecorated Decorator - | KontHostEventHandler (EventHandler b) - | KontEventHandler (EventHandler b) - | KontAtop1 (IDrawing a) - | KontAtop2 (IDrawing b) - | KontBeneath1 (IDrawing a) - | KontBeneath2 (IDrawing b) - | KontDatumPrefix DatumPrefix - - -{-| Inject an initial drawing into the state. --} -inject : (a -> b) -> IDrawing a -> State a b -inject mapf drawing = - State { mapf = mapf, expr = Initial drawing, kont = [] } - - -{-| Step of the mapping operation. - -The basic internal functionality of `step` is very simple. There are two main -cases: - -1. If an `Initial` drawing type is encountered, push any required - continuation onto the stack and start evaluating a sub-component of - the `Initial` expression into a `Final` expression. -2. If a `Final` expression is encountered, combine it with the next - pending continuation. - -Exhaustiveness checking on the types in the `case` expression is a very -powerful check to make sure we're handing everything here. - --} -step : State a b -> State a b -step (State state) = - case ( state.expr, state.kont ) of - {- Transform Initial States; introduce continuations -} - ( Initial IDrawingEmpty, _ ) -> - State { state | expr = Final <| IDrawingEmpty } - - ( Initial (IDrawingPath path), _ ) -> - State { state | expr = Final <| IDrawingPath path } - - ( Initial (IDrawingTagCSys csysName), _ ) -> - State { state | expr = Final <| IDrawingTagCSys csysName } - - ( Initial (IDrawingDatum datumName point), _ ) -> - State { state | expr = Final <| IDrawingDatum datumName point } - - ( Initial (IDrawingWithDatumAccess f), _ ) -> - State - { state - | expr = - Final <| - IDrawingWithDatumAccess <| - \access -> - f access |> map state.mapf - } - - ( Initial (IDrawingBake drawing), ks ) -> - State - { state - | expr = Initial drawing - , kont = KontBake :: ks - } - - ( Initial (IDrawingStyled style drawing), ks ) -> - State - { state - | expr = Initial drawing - , kont = KontStyled style :: ks - } - - ( Initial (IDrawingTransformed transform drawing), ks ) -> - State - { state - | expr = Initial drawing - , kont = KontTransformed transform :: ks - } - - ( Initial (IDrawingDecorated decoration drawing), ks ) -> - State - { state - | expr = Initial drawing - , kont = KontDecorated decoration :: ks - } - - ( Initial (IDrawingHostEventHandler handler drawing), ks ) -> - State - { state - | expr = Initial drawing - , kont = - KontHostEventHandler - (Event.map state.mapf handler) - :: ks - } - - ( Initial (IDrawingEventHandler handler drawing), ks ) -> - State - { state - | expr = Initial drawing - , kont = - KontEventHandler - (Event.map state.mapf handler) - :: ks - } - - ( Initial (IDrawingAtop x y), ks ) -> - State - { state - | expr = Initial x - , kont = KontAtop1 y :: ks - } - - ( Initial (IDrawingBeneath x y), ks ) -> - State - { state - | expr = Initial x - , kont = KontBeneath1 y :: ks - } - - ( Initial (IDrawingDatumPrefix prefix drawing), ks ) -> - State - { state - | expr = Initial drawing - , kont = KontDatumPrefix prefix :: ks - } - - {- Complete continuations -} - ( Final _, [] ) -> - State state - - ( Final drawing, KontBake :: ks ) -> - State - { state - | kont = ks - , expr = Final <| IDrawingBake drawing - } - - ( Final drawing, (KontStyled style) :: ks ) -> - State - { state - | kont = ks - , expr = Final <| IDrawingStyled style drawing - } - - ( Final drawing, (KontTransformed transform) :: ks ) -> - State - { state - | kont = ks - , expr = Final <| IDrawingTransformed transform drawing - } - - ( Final drawing, (KontDecorated decoration) :: ks ) -> - State - { state - | kont = ks - , expr = Final <| IDrawingDecorated decoration drawing - } - - ( Final drawing, (KontHostEventHandler handler) :: ks ) -> - State - { state - | kont = ks - , expr = Final <| IDrawingHostEventHandler handler drawing - } - - ( Final drawing, (KontEventHandler handler) :: ks ) -> - State - { state - | kont = ks - , expr = Final <| IDrawingEventHandler handler drawing - } - - ( Final drawing, (KontAtop1 y) :: ks ) -> - State - { state - | kont = KontAtop2 drawing :: ks - , expr = Initial y - } - - ( Final drawing, (KontAtop2 x) :: ks ) -> - State - { state - | kont = ks - , expr = Final <| IDrawingAtop x drawing - } - - ( Final drawing, (KontBeneath1 y) :: ks ) -> - State - { state - | kont = KontAtop2 drawing :: ks - , expr = Initial y - } - - ( Final drawing, (KontBeneath2 x) :: ks ) -> - State - { state - | kont = ks - , expr = Final <| IDrawingBeneath x drawing - } - - ( Final drawing, (KontDatumPrefix datumPrefix) :: ks ) -> - State - { state - | kont = ks - , expr = Final <| IDrawingDatumPrefix datumPrefix drawing - } - - -{-| Return the drawing if mapping has finished. - -A completed state has a `Final` drawing and an empty continuation stack. - --} -finished : State a b -> Maybe (IDrawing b) -finished (State state) = - case ( state.expr, state.kont ) of - ( Final drawing, [] ) -> - Just drawing - - _ -> - Nothing diff --git a/src/Techdraw/Internal/Hash.elm b/src/Techdraw/Internal/Hash.elm new file mode 100644 index 0000000..a7f6fb4 --- /dev/null +++ b/src/Techdraw/Internal/Hash.elm @@ -0,0 +1,266 @@ +module Techdraw.Internal.Hash exposing + ( Hash, Hasher, Manifest, Encoder + , fromEncoder + , f32, u32 + , encHash + , sequence, list + , enc2, enc4, enc6 + , attachTag + , color + , p2, v2, m22, affineTransform + ) + +{-| Hashing values. + + +# Hashing Types and Functions + +@docs Hash, Hasher, Manifest, Encoder +@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 SHA1 +import Techdraw.Math as Math exposing (AffineTransform, M22, P2, V2) + + + +---- Hashing Machinery -------------------------------------------------------- + + +{-| A hash digest. +-} +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 + + +{-| 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/Techdraw/Internal/SvgStringPath.elm b/src/Techdraw/Internal/Svg/Path.elm similarity index 75% rename from src/Techdraw/Internal/SvgStringPath.elm rename to src/Techdraw/Internal/Svg/Path.elm index 52d2d23..58eacc4 100644 --- a/src/Techdraw/Internal/SvgStringPath.elm +++ b/src/Techdraw/Internal/Svg/Path.elm @@ -1,5 +1,5 @@ -module Techdraw.Internal.SvgStringPath exposing - ( SvgStringPath +module Techdraw.Internal.Svg.Path exposing + ( PathString , svgStringPath, svgStringPathToString , formatPath , NFixDigits(..) @@ -8,7 +8,7 @@ module Techdraw.Internal.SvgStringPath exposing {-| String representation of SVG paths. -@docs SvgStringPath +@docs PathString @docs svgStringPath, svgStringPathToString @@ -46,77 +46,77 @@ This type has a special internal representation of an empty string, to make joining path strings neater. -} -type SvgStringPath - = SvgStringPath String - | SvgStringPathEmpty +type PathString + = PathString String + | PathStringEmpty {-| Create an `SvgStringPath` from a `String`. -} -svgStringPath : String -> SvgStringPath +svgStringPath : String -> PathString svgStringPath content = if String.isEmpty content then - SvgStringPathEmpty + PathStringEmpty else - SvgStringPath content + PathString content {-| Convert an `SvgStringPath` to a `String`. -} -svgStringPathToString : SvgStringPath -> String +svgStringPathToString : PathString -> String svgStringPathToString 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 @@ -127,14 +127,14 @@ formatNonempty convert = {-| Format a `Path` into an `SvgStringPath`. -} -formatPath : NFixDigits -> Path -> SvgStringPath +formatPath : NFixDigits -> Path -> PathString formatPath n (P.Path subPaths) = formatList (formatSubPath n) subPaths {-| 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 +146,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 +166,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 +203,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,7 +219,7 @@ 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) = @@ -229,7 +229,7 @@ formatArcTo n (P.ArcTo arcTo) = NFixDigits (linDigits + 2) in joinListWithSpace - [ SvgStringPath "A" + [ PathString "A" , formatFloat n arcTo.rx , formatFloat n arcTo.ry , formatOrientationPi nAngDigits arcTo.xOrient @@ -241,30 +241,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 {-| Format a `Bool` into an `SvgStringPath`. -} -formatBool : Bool -> SvgStringPath +formatBool : Bool -> PathString formatBool b = - SvgStringPath <| + PathString <| if b then "1" diff --git a/src/Techdraw/Internal/SvgDrawing.elm b/src/Techdraw/Internal/SvgDrawing.elm deleted file mode 100644 index c0982d8..0000000 --- a/src/Techdraw/Internal/SvgDrawing.elm +++ /dev/null @@ -1,630 +0,0 @@ -module Techdraw.Internal.SvgDrawing exposing - ( ViewBox(..), ContainerSize(..), Sizes(..) - , toSvg - ) - -{-| Converting Drawings to SVG. - -@docs ViewBox, ContainerSize, Sizes -@docs toSvg - --} - -import Dict exposing (Dict) -import Html exposing (Html) -import Html.Attributes as HtmlAttributes -import Techdraw.CSys exposing (CSysName(..)) -import Techdraw.Datum as Datum exposing (DatumName, DatumPrefix) -import Techdraw.Decorator exposing (Decorator) -import Techdraw.Event exposing (EventHandler) -import Techdraw.Internal.Drawing exposing (IDrawing(..)) -import Techdraw.Internal.SvgEvent as SvgEvent -import Techdraw.Internal.SvgStringPath as SvgStringPath exposing (NFixDigits(..)) -import Techdraw.Internal.SvgStyle as SvgStyle exposing (Defs, SvgStyle(..)) -import Techdraw.Math as Math exposing (AffineTransform, P2) -import Techdraw.Path as Path exposing (Path) -import Techdraw.Style as Style exposing (Gradient, Style) -import TypedSvg as Svg -import TypedSvg.Attributes as SvgAttributes -import TypedSvg.Core exposing (Attribute, Svg) - - -{-| Sizes for a drawing. - -A drawing size is defined by: - - - The size of its container, and - - The view box which describes the drawing's initial coordinate system. - --} -type Sizes - = Sizes - { containerSize : ContainerSize - , viewBox : ViewBox - } - - -{-| Size for a container of a drawing, in pixels. --} -type ContainerSize - = ContainerSize - { width : Int - , height : Int - } - - -{-| Viewbox defining the initial coordinate system of a drawing. --} -type ViewBox - = ViewBox - { minX : Float - , minY : Float - , width : Float - , height : Float - } - - -{-| Convert `Sizes` to a list of attributes. --} -sizesAttributes : Sizes -> List (Attribute msg) -sizesAttributes (Sizes sz) = - containerSizeAttributes sz.containerSize ++ [ viewBoxAttribute sz.viewBox ] - - -{-| Convert `ContainerSize` to a list of attributes. --} -containerSizeAttributes : ContainerSize -> List (Attribute msg) -containerSizeAttributes (ContainerSize sz) = - [ HtmlAttributes.width sz.width - , HtmlAttributes.height sz.height - ] - - -{-| Convert `ViewBox` to a viewBox attribute. --} -viewBoxAttribute : ViewBox -> Attribute msg -viewBoxAttribute (ViewBox vb) = - SvgAttributes.viewBox vb.minX vb.minY vb.width vb.height - - -{-| Convert a drawing to SVG. --} -toSvg : Sizes -> IDrawing msg -> Html msg -toSvg sizes iDrawing = - let - (SvgResult result) = - componentsToSvg sizes iDrawing - in - -- TODO : Handle defs and container events - Svg.svg - (sizesAttributes sizes) - result.children - - - ----- State Machine for SVG Evaluation ----------------------------------------- - - -{-| Result of conversion to SVG. --} -type SvgResult msg - = SvgResult - { children : List (Svg msg) - , defs : Defs - } - - -{-| Convert drawing components to a list of SVG components. --} -componentsToSvg : Sizes -> IDrawing msg -> SvgResult msg -componentsToSvg sizes iDrawing = - let - -- Loop should be tail-recursive - loop : State msg -> SvgResult msg - loop state = - case finished state of - Just svgs -> - svgs - - Nothing -> - let - newState = - step state - in - loop newState - in - inject sizes iDrawing |> loop - - -{-| Inject sizes and the drawing commands into an initial state. --} -inject : Sizes -> IDrawing msg -> State msg -inject sizes iDrawing = - State - { expr = Initial iDrawing - , kont = [] - , envr = - Envr - { nfdg = NFixDigits 2 - , tl2w = initialTransform sizes - , styl = Style.inheritAll - , defs = SvgStyle.emptyDefs - , evts = [] - , hvts = [] - , decr = Nothing - , csys = Dict.empty - , dprf = [] - , datm = Dict.empty - } - } - - -{-| Compute the initial transformation from the sizes. --} -initialTransform : Sizes -> AffineTransform -initialTransform (Sizes sizes) = - let - (ViewBox vb) = - sizes.viewBox - in - Math.affFromComponents - [ Math.AffineScaling <| - Math.Scaling 1 -1 - , Math.AffineTranslation <| - Math.Translation (Math.v2 vb.minX (vb.height + vb.minY)) - ] - - -{-| Expression in the continuation machine. - -An expression can be either: - - - `Initial`: drawing expression to be converted - - `Final`: list of produced Svg elements - --} -type Expr msg - = Initial (IDrawing msg) - | Final (List (Svg msg)) - - -{-| Continuations in the continuation machine. - -Continuations represent pending steps to be completed after the current -expression has reached a `Final` form. Continuations hold the environment -that existed when they were invoked. - --} -type Kont msg - = KontAtop1 (Envr msg) (IDrawing msg) - | KontAtop2 (Envr msg) (List (Svg msg)) - | KontBeneath1 (Envr msg) (IDrawing msg) - | KontBeneath2 (Envr msg) (List (Svg msg)) - | KontWithDatumAccess (Envr msg) - - -{-| State for the evaluation machine. --} -type State msg - = State - { expr : Expr msg - , kont : List (Kont msg) - , envr : Envr msg - } - - -{-| If the state machine has finished computing, return its list of -Svg components. --} -finished : State msg -> Maybe (SvgResult msg) -finished (State state) = - case ( state.expr, state.kont ) of - ( Final svgs, [] ) -> - Just <| - let - (Envr envr) = - state.envr - in - SvgResult - { children = svgs - , defs = envr.defs - } - - _ -> - Nothing - - -{-| Environment. - - - `nfdg`: Number of fixed digits to use when drawing path elements. - - `tl2w`: Local-to-world affine transformation. - - `styl`: Current style. - - `defs`: Items to include in a `` element. - - `evts`: Pending event handlers to be attached to a drawing. - - `hvts`: Pending host event handlers to be attached to a host SVG element. - - `decr`: Optional decorator (one only for now) on paths. - - `csys`: Dictionary of coordinate system names to their local-to-world - transformations. - - `dprf`: List of datum name prefixes to apply to any datum points declared. - - `datm`: Dictionary of datum points in world space. - --} -type Envr msg - = Envr - { nfdg : NFixDigits - , tl2w : AffineTransform - , styl : Style - , defs : Defs - , evts : List (EventHandler msg) - , hvts : List (EventHandler msg) - , decr : Maybe Decorator - , csys : Dict String AffineTransform - , dprf : List DatumPrefix - , datm : Dict String P2 - } - - -step : State msg -> State msg -step (State state) = - let - (Envr envr) = - state.envr - in - case ( state.expr, state.kont ) of - {- Transform initial states; introduce continuations -} - ( Initial IDrawingEmpty, _ ) -> - State { state | expr = Final [] } - - ( Initial (IDrawingPath path), _ ) -> - let - ( svgPath, childEnvr ) = - envrPathToSvg state.envr path - in - State - { state - | expr = Final <| [ svgPath ] - , envr = envrThread state.envr childEnvr - } - - ( Initial (IDrawingTagCSys csysName), _ ) -> - State - { state - | expr = Final [] - , envr = envrAddCSys csysName envr.tl2w state.envr - } - - ( Initial (IDrawingBake _), _ ) -> - Debug.todo "TODO: IDrawingBake" - - ( Initial (IDrawingStyled style drawing), _ ) -> - State - { state - | expr = Initial drawing - , envr = envrCombineStyle style state.envr - } - - ( Initial (IDrawingTransformed transform drawing), _ ) -> - State - { state - | expr = Initial drawing - , envr = envrCombineTransform transform state.envr - } - - ( Initial (IDrawingDecorated decorator drawing), _ ) -> - State - { state - | expr = Initial drawing - , envr = envrSetDecorator decorator state.envr - } - - ( Initial (IDrawingHostEventHandler handler drawing), _ ) -> - State - { state - | expr = Initial drawing - , envr = envrAppendHostEventHandler handler state.envr - } - - ( Initial (IDrawingEventHandler handler drawing), _ ) -> - State - { state - | expr = Initial drawing - , envr = envrAppendEventHandler handler state.envr - } - - ( Initial (IDrawingAtop x y), ks ) -> - State - { state - | expr = Initial x - , kont = KontAtop1 state.envr y :: ks - } - - ( Initial (IDrawingBeneath x y), ks ) -> - State - { state - | expr = Initial x - , kont = KontBeneath1 state.envr y :: ks - } - - ( Initial (IDrawingDatum datumName point), _ ) -> - State - { state - | expr = Final [] - , envr = envrSetDatum datumName point state.envr - } - - ( Initial (IDrawingDatumPrefix prefix drawing), _ ) -> - State - { state - | expr = Initial drawing - , envr = envrPrependDatumPrefix prefix state.envr - } - - ( Initial (IDrawingWithDatumAccess createFn), ks ) -> - State - { state - | expr = Initial <| createFn (envrDatumAccessFn state.envr) - , kont = KontWithDatumAccess state.envr :: ks - } - - {- Complete continuations -} - ( Final svgs, (KontAtop1 kenvr y) :: ks ) -> - let - tenvr = - envrThread kenvr state.envr - in - State - { state - | expr = Initial y - , envr = tenvr - , kont = KontAtop2 tenvr svgs :: ks - } - - ( Final svgs, (KontAtop2 kenvr xs) :: ks ) -> - let - tenvr = - envrThread kenvr state.envr - in - State - { state - | expr = Final <| envrStack state.envr xs svgs - , envr = tenvr - , kont = ks - } - - ( Final svgs, (KontBeneath1 kenvr y) :: ks ) -> - let - tenvr = - envrThread kenvr state.envr - in - State - { state - | expr = Initial y - , envr = tenvr - , kont = KontBeneath2 tenvr svgs :: ks - } - - ( Final svgs, (KontBeneath2 kenvr xs) :: ks ) -> - let - tenvr = - envrThread kenvr state.envr - in - State - { state - | expr = Final <| envrStack state.envr svgs xs - , envr = tenvr - , kont = ks - } - - ( Final _, (KontWithDatumAccess kenvr) :: ks ) -> - State - { state - | envr = envrThread kenvr state.envr - , kont = ks - } - - {- Final, completed state. -} - ( Final _, [] ) -> - State state - - -{-| Add a named coordinate system to the environment. --} -envrAddCSys : CSysName -> AffineTransform -> Envr msg -> Envr msg -envrAddCSys (CSysName name) l2w (Envr parent) = - Envr { parent | csys = Dict.insert name l2w parent.csys } - - -{-| Combine a child style with that of its parent in the environment. --} -envrCombineStyle : Style -> Envr msg -> Envr msg -envrCombineStyle child (Envr parent) = - Envr { parent | styl = Style.combineStyle parent.styl child } - - -{-| Combine a child transformation with that of its parent in the -environment. --} -envrCombineTransform : AffineTransform -> Envr msg -> Envr msg -envrCombineTransform child (Envr parent) = - Envr { parent | tl2w = Math.affMatMul parent.tl2w child } - - -{-| Set the decorator in the current environment. --} -envrSetDecorator : Decorator -> Envr msg -> Envr msg -envrSetDecorator decorator (Envr parent) = - Envr { parent | decr = Just decorator } - - -{-| Append a host event handler to the environment. --} -envrAppendHostEventHandler : EventHandler msg -> Envr msg -> Envr msg -envrAppendHostEventHandler handler (Envr parent) = - Envr { parent | hvts = handler :: parent.hvts } - - -{-| Append a drawing event handler to the environment --} -envrAppendEventHandler : EventHandler msg -> Envr msg -> Envr msg -envrAppendEventHandler handler (Envr parent) = - Envr { parent | evts = handler :: parent.evts } - - -{-| Set a datum point in the environment as its world-space name. --} -envrSetDatum : DatumName -> P2 -> Envr msg -> Envr msg -envrSetDatum datumName point (Envr parent) = - Envr - { parent - | datm = - Dict.insert - (Datum.createStringName parent.dprf datumName) - (Math.p2ApplyAffineTransform parent.tl2w point) - parent.datm - } - - -{-| Prepend a datum prefix string to the environment. --} -envrPrependDatumPrefix : DatumPrefix -> Envr msg -> Envr msg -envrPrependDatumPrefix prefix (Envr parent) = - Envr { parent | dprf = prefix :: parent.dprf } - - -{-| Provide a datum access function for the environment. --} -envrDatumAccessFn : Envr msg -> (DatumName -> P2) -envrDatumAccessFn (Envr envr) = - let - tw2l = - Math.affInvert envr.tl2w - in - \name -> - Dict.get (Datum.datumNameToString name) envr.datm - |> Maybe.withDefault (Math.p2 0 0) - |> Math.p2ApplyAffineTransform tw2l - - -{-| Thread an environment. - -When processing has completed on a child node, it produces the `chld` -environment. This is combined with the `kont` environment from the -continuation to produce the environment that the continuation should be -processed with. - -Items that should be inherited parent-to-child come from the `kont` -environment. Items that should be inherited via a depth-first evaluation -order come from the `chld` environment. - --} -envrThread : Envr msg -> Envr msg -> Envr msg -envrThread (Envr kont) (Envr chld) = - Envr - { nfdg = kont.nfdg - , tl2w = kont.tl2w - , styl = kont.styl - , defs = chld.defs - , evts = kont.evts - , hvts = kont.hvts - , decr = kont.decr - , csys = chld.csys - , dprf = kont.dprf - , datm = chld.datm - } - - -{-| Convert a `Path` to SVG, applying correct attributes for the -environment. --} -envrPathToSvg : Envr msg -> Path -> ( Svg msg, Envr msg ) -envrPathToSvg envr path = - let - (Envr env) = - envr - - ( attrs, newEnvr ) = - envrPathAttributes envr - - transformedPath = - Path.pathApplyAffineTransform env.tl2w path - in - ( pathToSvg env.nfdg attrs transformedPath, newEnvr ) - - -{-| Convert the style information from an `Envr` into a list of SVG -Attributes and any required child elements. Child elements are required -for gradients. - -It returns a new `Envr` containing any gradients added to the internal -dictionary. - --} -envrStyleToAttributes : Envr msg -> ( List (Attribute msg), Envr msg ) -envrStyleToAttributes (Envr envr) = - let - (SvgStyle svgStyle) = - SvgStyle.styleToSvgAttributes envr.styl - in - ( svgStyle.attributes - , Envr - { envr - | defs = SvgStyle.defsUnion svgStyle.defs envr.defs - } - ) - - -{-| Convert the list of item events from an `Envr` into a list of SVG } -Attributes. --} -envrEventsToAttributes : Envr msg -> List (Attribute msg) -envrEventsToAttributes (Envr envr) = - SvgEvent.eventHandlersToSvgAttributes envr.evts - - -{-| Fetch all the parts from the environment that should be applied to -a `Path`. --} -envrPathAttributes : - Envr msg - -> ( List (Attribute msg), Envr msg ) -envrPathAttributes envr = - let - ( styleAttr, newEnvr ) = - envrStyleToAttributes envr - in - ( styleAttr ++ envrEventsToAttributes envr, newEnvr ) - - -{-| Convert a Path to an Svg node, with a list of attributes for styles -and events. --} -pathToSvg : - NFixDigits - -> List (Attribute msg) - -> Path - -> Svg msg -pathToSvg nFixDigits attrs path = - Svg.path - (SvgAttributes.d - (SvgStringPath.formatPath nFixDigits path - |> SvgStringPath.svgStringPathToString - ) - :: attrs - ) - [] - - -{-| Use the environment to stack nodes. - -If the environment has event handlers, these are discharged directly by -creating an SVG group. However, if there are no event handlers, the two -lists of SVG are just appended. - --} -envrStack : Envr msg -> List (Svg msg) -> List (Svg msg) -> List (Svg msg) -envrStack (Envr envr) below above = - if List.isEmpty envr.evts then - below ++ above - - else - [ Svg.g (envrEventsToAttributes (Envr envr)) (below ++ above) ] diff --git a/src/Techdraw/Internal/SvgEvent.elm b/src/Techdraw/Internal/SvgEvent.elm deleted file mode 100644 index c648084..0000000 --- a/src/Techdraw/Internal/SvgEvent.elm +++ /dev/null @@ -1,17 +0,0 @@ -module Techdraw.Internal.SvgEvent exposing (eventHandlersToSvgAttributes) - -{-| Convert event information to SVG. - -@docs eventHandlersToSvgAttributes - --} - -import Techdraw.Event exposing (EventHandler) -import TypedSvg.Core exposing (Attribute) - - -{-| Convert a list of event handlers to a list of SVG `Attribute`s. --} -eventHandlersToSvgAttributes : List (EventHandler msg) -> List (Attribute msg) -eventHandlersToSvgAttributes = - Debug.todo "TODO" diff --git a/src/Techdraw/Internal/SvgStyle.elm b/src/Techdraw/Internal/SvgStyle.elm deleted file mode 100644 index 293dfff..0000000 --- a/src/Techdraw/Internal/SvgStyle.elm +++ /dev/null @@ -1,128 +0,0 @@ -module Techdraw.Internal.SvgStyle exposing - ( Defs, SvgStyle(..) - , emptyDefs, defsUnion - , styleToSvgAttributes - ) - -{-| Convert styling information to SVG. - -@docs Defs, SvgStyle -@docs emptyDefs, defsUnion -@docs styleToSvgAttributes - --} - -import Dict exposing (Dict) -import Techdraw.Math as Math -import Techdraw.Style as Style - exposing - ( Gradient - , LinearGradient(..) - , RadialGradient - , Style - ) -import TypedSvg as Svg -import TypedSvg.Attributes as SvgAttributes -import TypedSvg.Core exposing (Attribute, Svg) -import TypedSvg.Types exposing (px) - - - ----- Defs collection ---------------------------------------------------------- - - -{-| Item that can be included in `defs`. --} -type DefItem - = DefGradient Gradient - | DefLinearGradient LinearGradient - | DefRadialGradient RadialGradient - - -{-| A dictionary of hashes to defs items. --} -type Defs - = Defs (Dict String DefItem) - - -{-| Empty defs items. --} -emptyDefs : Defs -emptyDefs = - Defs Dict.empty - - -{-| Combine defs. --} -defsUnion : Defs -> Defs -> Defs -defsUnion (Defs d1) (Defs d2) = - Defs (Dict.union d1 d2) - - -{-| Include a gradient in the defs items. --} -defsIncludeGradient : Gradient -> Defs -> Defs -defsIncludeGradient gradient (Defs dict) = - let - key = - Style.gradientHexHash gradient - in - if Dict.member key dict then - Defs dict - - else - Defs <| Dict.insert key (DefGradient gradient) dict - - -{-| Include a LinearGradient and its child Gradient in defs items. --} -defsIncludeLinearGradient : LinearGradient -> Defs -> Defs -defsIncludeLinearGradient linearGradient (Defs dict) = - let - key = - Style.linearGradientHexHash linearGradient - in - if Dict.member key dict then - Defs dict - - else - (Defs <| Dict.insert key (DefLinearGradient linearGradient) dict) - |> defsIncludeGradient - (Style.linearGradientParams linearGradient |> .gradient) - - -{-| Include a RadialGradient and its child Gradient in defs items. --} -defsIncludeRadialGradient : RadialGradient -> Defs -> Defs -defsIncludeRadialGradient radialGradient (Defs dict) = - let - key = - Style.radialGradientHexHash radialGradient - in - if Dict.member key dict then - Defs dict - - else - (Defs <| Dict.insert key (DefRadialGradient radialGradient) dict) - |> defsIncludeGradient - (Style.radialGradientParams radialGradient |> .gradient) - - - ----- - - -{-| Return value from SVG styling. --} -type SvgStyle msg - = SvgStyle - { attributes : List (Attribute msg) - , defs : Defs - } - - -{-| Convert a `Style` to a list of SVG `Attribute`s. --} -styleToSvgAttributes : Style -> SvgStyle msg -styleToSvgAttributes = - Debug.todo "TODO" diff --git a/src/Techdraw/Math.elm b/src/Techdraw/Math.elm index ff4bc2b..4d7e055 100644 --- a/src/Techdraw/Math.elm +++ b/src/Techdraw/Math.elm @@ -38,10 +38,6 @@ module Techdraw.Math exposing , affMatMul , affInvert , closeAffineTransform - , encP2, decP2 - , encV2, decV2 - , encM22, decM22 - , encAffineTransform, decAffineTransform ) {-| Mathematical core for Techdraw. @@ -299,25 +295,8 @@ that applies an affine transformation to a point. @docs closeAffineTransform - -# Codecs - -We can read and write binary forms of some types, which is useful for -hashing: - -@docs encP2, decP2 -@docs encV2, decV2 -@docs encM22, decM22 -@docs encAffineTransform, decAffineTransform - -} -import Bytes.Decode as Decode exposing (Decoder) -import Bytes.Encode as Encode exposing (Encoder) -import Techdraw.Internal.Codec as Codec - - - ---- Floating-point functions ------------------------------------------------- @@ -1218,77 +1197,3 @@ element-wise. closeAffineTransform : Tol -> AffineTransform -> AffineTransform -> Bool closeAffineTransform tol (AffineTransform a) (AffineTransform b) = closeM22 tol a.linear b.linear && closeV2 tol a.translation b.translation - - - ----- Codecs ------------------------------------------------------------------- - - -{-| Encode a `P2` point. --} -encP2 : P2 -> Encoder -encP2 p = - Encode.sequence - [ p2x p |> Codec.encf32 - , p2y p |> Codec.encf32 - ] - - -{-| Decode a `P2` point. --} -decP2 : Decoder P2 -decP2 = - Decode.map2 p2 Codec.decf32 Codec.decf32 - - -{-| Encode a `V2` vector. --} -encV2 : V2 -> Encoder -encV2 v = - Encode.sequence - [ v2e1 v |> Codec.encf32 - , v2e2 v |> Codec.encf32 - ] - - -{-| Decode a `V2` vector. --} -decV2 : Decoder V2 -decV2 = - Decode.map2 v2 Codec.decf32 Codec.decf32 - - -{-| Encode an `M22` matrix. --} -encM22 : M22 -> Encoder -encM22 m = - Encode.sequence - [ m22e11 m |> Codec.encf32 - , m22e12 m |> Codec.encf32 - , m22e21 m |> Codec.encf32 - , m22e22 m |> Codec.encf32 - ] - - -{-| Decode an `M22` matrix. --} -decM22 : Decoder M22 -decM22 = - Decode.map4 m22 Codec.decf32 Codec.decf32 Codec.decf32 Codec.decf32 - - -{-| Encode an affine transform. --} -encAffineTransform : AffineTransform -> Encoder -encAffineTransform aff = - Encode.sequence - [ affGetLinear aff |> encM22 - , affGetTranslation aff |> encV2 - ] - - -{-| Decode an affine transform. --} -decAffineTransform : Decoder AffineTransform -decAffineTransform = - Decode.map2 affineTransformMV decM22 decV2 diff --git a/src/Techdraw/Style.elm b/src/Techdraw/Style.elm index 7f3cd79..3bb2a84 100644 --- a/src/Techdraw/Style.elm +++ b/src/Techdraw/Style.elm @@ -9,10 +9,7 @@ module Techdraw.Style exposing , LinearGradientParams, LinearGradient , RadialGradientParams, RadialGradient , linearGradient, radialGradient - , Gradient, Stop(..), gradient - , gradientHexHash - , linearGradientHexHash, linearGradientParams - , radialGradientHexHash, radialGradientParams + , GradientParams, Gradient, Stop(..), gradient , combineStyle , inheritAll , fill, fillRule @@ -57,10 +54,7 @@ module Techdraw.Style exposing @docs LinearGradientParams, LinearGradient @docs RadialGradientParams, RadialGradient @docs linearGradient, radialGradient -@docs Gradient, Stop, gradient -@docs gradientHexHash -@docs linearGradientHexHash, linearGradientParams -@docs radialGradientHexHash, radialGradientParams +@docs GradientParams, Gradient, Stop, gradient # Operations @@ -76,11 +70,9 @@ module Techdraw.Style exposing -} -import Bytes.Encode as Encode exposing (Encoder) import Color exposing (Color) -import SHA1 -import Techdraw.Internal.Codec as Codec -import Techdraw.Math as Math exposing (AffineTransform, P2) +import Techdraw.Internal.Hash as Hash exposing (Hash, Hasher) +import Techdraw.Math exposing (AffineTransform, P2) @@ -206,6 +198,22 @@ type alias LinearGradientParams = } +{-| 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 @@ -213,24 +221,14 @@ a unique hash. -} type LinearGradient - = LinearGradient SHA1.Digest UnhashedLinearGradient - - -{-| Unhashed linear gradient. --} -type UnhashedLinearGradient - = UnhashedLinearGradient LinearGradientParams + = LinearGradient Hash LinearGradientParams {-| Create a linear gradient. -} linearGradient : LinearGradientParams -> LinearGradient -linearGradient record = - let - ulg = - UnhashedLinearGradient record - in - LinearGradient (hashUnhashedLinearGradient ulg) ulg +linearGradient params = + LinearGradient (Hash.fromEncoder encLinearGradientParams <| params) params {-| Parameters of a radial gradient. @@ -257,6 +255,26 @@ type alias RadialGradientParams = } +{-| 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 @@ -264,24 +282,14 @@ unique hash. -} type RadialGradient - = RadialGradient SHA1.Digest UnhashedRadialGradient - - -{-| Unhashed radial gradient. --} -type UnhashedRadialGradient - = UnhashedRadialGradient RadialGradientParams + = RadialGradient Hash RadialGradientParams {-| Create a radial gradient. -} radialGradient : RadialGradientParams -> RadialGradient -radialGradient record = - let - urg = - UnhashedRadialGradient record - in - RadialGradient (hashUnhashedRadialGradient urg) urg +radialGradient params = + RadialGradient (Hash.fromEncoder encRadialGradientParams <| params) params {-| Gradient. @@ -294,119 +302,67 @@ A gradient contains -} type Gradient - = Gradient SHA1.Digest UnhashedGradient + = Gradient Hash GradientParams -{-| Gradient without any hashing information. +{-| Hasher for a gradient just extracts its pre-computed parameters hash. -} -type UnhashedGradient - = UnhashedGradient (List Stop) +hashGradient : Hasher Gradient +hashGradient (Gradient hash _) = + hash -{-| 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. - +{-| Parameters for a `Gradient` : a list of `Stop`s. -} -type Stop - = Stop Float Color +type alias GradientParams = + List Stop -{-| Return the location of a gradient stop. +{-| Hash encoder for gradient parameters. -} -getStopLocation : Stop -> Float -getStopLocation (Stop location _) = - location - - -{-| Create a `Gradient` from a list of stops. --} -gradient : List Stop -> Gradient -gradient rawStops = - let - unhashed = - UnhashedGradient <| List.sortBy getStopLocation rawStops - in - Gradient (hashUnhashedGradient unhashed) unhashed +encGradientParams : Hash.Encoder GradientParams +encGradientParams = + Hash.list encStop + |> Hash.attachTag "Style.GradientParams" -{-| Return a hex string containing the hash of a `Gradient`. - - import Color - - gradientHexHash <| - gradient - [ Stop 0.0 Color.black - , Stop 0.5 Color.blue - , Stop 0.7 Color.red - , Stop 1.0 Color.green - ] - --> "4233f96f9909e03055aeb16861262ec25214bcc4" - -The hash should be the same if `Stop`s are re-ordered; eg: - - import Color - - gradientHexHash <| - gradient - [ Stop 1.0 Color.green - , Stop 0.0 Color.black - , Stop 0.7 Color.red - , Stop 0.5 Color.blue - ] - --> "4233f96f9909e03055aeb16861262ec25214bcc4" - -But will be different if the `Stop`s are different: - - import Color - - gradientHexHash <| - gradient - [ Stop 0.0 Color.black - , Stop 1.0 Color.white - ] - --> "59bc04f8c6298d5bcbe6f89ed20ec316cc8a5959" - --} -gradientHexHash : Gradient -> String -gradientHexHash (Gradient digest _) = - SHA1.toHex digest +{-| 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. -{-| Return the hex hash of a linear gradient. -} -linearGradientHexHash : LinearGradient -> String -linearGradientHexHash (LinearGradient digest _) = - SHA1.toHex digest +type Stop + = Stop Float Color -{-| Return the parameters of a linear gradient. +{-| Hash encoder for a `Stop`. -} -linearGradientParams : LinearGradient -> LinearGradientParams -linearGradientParams (LinearGradient _ (UnhashedLinearGradient params)) = - params +encStop : Hash.Encoder Stop +encStop = + Hash.enc2 Hash.f32 Hash.color getStopLocation getStopColor + |> Hash.attachTag "Style.Stop" -{-| Return the hex hash of a radial gradient. +{-| Return the location of a gradient stop. -} -radialGradientHexHash : RadialGradient -> String -radialGradientHexHash (RadialGradient digest _) = - SHA1.toHex digest +getStopLocation : Stop -> Float +getStopLocation (Stop location _) = + location -{-| Return the parameters of a radial gradient. +{-| Return the color of a gradient stop. -} -radialGradientParams : RadialGradient -> RadialGradientParams -radialGradientParams (RadialGradient _ (UnhashedRadialGradient params)) = - params +getStopColor : Stop -> Color +getStopColor (Stop _ color) = + color -{-| Return the SHA1 Digest of a `Gradient`. +{-| Create a `Gradient` from a list of stops. -} -gradientSHA1Digest : Gradient -> SHA1.Digest -gradientSHA1Digest (Gradient digest _) = - digest +gradient : GradientParams -> Gradient +gradient params = + Gradient (Hash.fromEncoder encGradientParams <| params) params @@ -593,94 +549,3 @@ dashArray d = dashOffset : Float -> Style -> Style dashOffset o = styleModifyStroke <| \(Stroke st) -> Stroke { st | dashOffset = Set o } - - - ----- Hashing ------------------------------------------------------------------ - - -{-| Hash an `UnhashedLinearGradient`. --} -hashUnhashedLinearGradient : UnhashedLinearGradient -> SHA1.Digest -hashUnhashedLinearGradient = - encLinearGradient >> Encode.encode >> SHA1.fromBytes - - -{-| Hash an `UnhashedRadialGradient`. --} -hashUnhashedRadialGradient : UnhashedRadialGradient -> SHA1.Digest -hashUnhashedRadialGradient = - encRadialGradient >> Encode.encode >> SHA1.fromBytes - - -{-| Hash an `UnhashedGradient`. --} -hashUnhashedGradient : UnhashedGradient -> SHA1.Digest -hashUnhashedGradient = - encGradient >> Encode.encode >> SHA1.fromBytes - - -{-| Encode a `RadialGradient`. Only for hashing. - -This is not a complete encoding, because it encodes the hash of the gradient. - --} -encRadialGradient : UnhashedRadialGradient -> Encoder -encRadialGradient (UnhashedRadialGradient g) = - Encode.sequence - [ Math.encP2 g.innerCenter - , Codec.encf32 g.innerRadius - , Math.encP2 g.outerCenter - , Codec.encf32 g.outerRadius - , Math.encAffineTransform g.transform - , encSHA1Digest <| gradientSHA1Digest <| g.gradient - ] - - -{-| Encode a `LinearGradient`. Only for hashing. - -This is not a complete encoding, because it encodes the hash of the gradient. - --} -encLinearGradient : UnhashedLinearGradient -> Encoder -encLinearGradient (UnhashedLinearGradient g) = - Encode.sequence - [ Math.encP2 g.start - , Math.encP2 g.end - , Math.encAffineTransform g.transform - , encSHA1Digest <| gradientSHA1Digest <| g.gradient - ] - - -{-| Encode a `SHA1.Digest`. Only for hashing. --} -encSHA1Digest : SHA1.Digest -> Encoder -encSHA1Digest digest = - let - d = - SHA1.toInt32s digest - in - Encode.sequence - [ Codec.encu32 d.a - , Codec.encu32 d.b - , Codec.encu32 d.c - , Codec.encu32 d.d - , Codec.encu32 d.e - ] - - -{-| Encode an `UnhashedGradient`. Only for hashing. --} -encGradient : UnhashedGradient -> Encoder -encGradient (UnhashedGradient stops) = - Codec.encList encStop stops - - -{-| Encode a `Stop`. Only for hashing. --} -encStop : Stop -> Encoder -encStop (Stop location color) = - Encode.sequence - [ Codec.encf32 location - , Codec.encColor color - ] 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/src/TechdrawNew.elm b/src/TechdrawNew.elm deleted file mode 100644 index 4dff5b2..0000000 --- a/src/TechdrawNew.elm +++ /dev/null @@ -1,108 +0,0 @@ -module TechdrawNew exposing - ( Drawing - , Sizes - , toSvg - , empty, path, tagCSys, styled, transformed - , map - ) - -{-| Techdraw (new API). - -@docs Drawing -@docs Sizes -@docs toSvg -@docs empty, path, tagCSys, styled, transformed -@docs map - --} - -import Html exposing (Html) -import Techdraw.CSys exposing (CSysName) -import Techdraw.Internal.Drawing as ID exposing (IDrawing(..)) -import Techdraw.Internal.SvgDrawing as SD -import Techdraw.Math exposing (AffineTransform) -import Techdraw.Path exposing (Path) -import Techdraw.Style exposing (Style) - - -{-| Drawing type. --} -type Drawing msg - = Drawing (IDrawing msg) - - -{-| Sizes of a drawing. --} -type alias Sizes = - { containerWidth : Int - , containerHeight : Int - , viewBoxMinX : Float - , viewBoxMinY : Float - , viewBoxWidth : Float - , viewBoxHeight : Float - } - - -{-| Convert a drawing to an SVG element in HTML. --} -toSvg : Sizes -> Drawing msg -> Html msg -toSvg sz (Drawing iDrawing) = - SD.toSvg - (SD.Sizes - { containerSize = - SD.ContainerSize - { width = sz.containerHeight - , height = sz.containerHeight - } - , viewBox = - SD.ViewBox - { minX = sz.viewBoxMinX - , minY = sz.viewBoxMinY - , width = sz.viewBoxWidth - , height = sz.viewBoxHeight - } - } - ) - iDrawing - - -{-| Empty drawing. --} -empty : Drawing msg -empty = - Drawing <| IDrawingEmpty - - -{-| Create a drawing from a `Path`. --} -path : Path -> Drawing msg -path = - Drawing << IDrawingPath - - -{-| Tag a coordinate system. --} -tagCSys : CSysName -> Drawing msg -tagCSys = - Drawing << IDrawingTagCSys - - -{-| Apply a style to a drawing. --} -styled : Style -> Drawing msg -> Drawing msg -styled sty (Drawing iDrawing) = - Drawing <| IDrawingStyled sty iDrawing - - -{-| Apply an affine transformation to a drawing. --} -transformed : AffineTransform -> Drawing msg -> Drawing msg -transformed xform (Drawing iDrawing) = - Drawing <| IDrawingTransformed xform iDrawing - - -{-| Map a function across the event type of the drawing. --} -map : (a -> b) -> Drawing a -> Drawing b -map f (Drawing iDrawing) = - Drawing <| ID.map f iDrawing From f695b3ac34a176c7052eb9fdaa386f4df2037168 Mon Sep 17 00:00:00 2001 From: Jonathan Merritt Date: Tue, 3 Sep 2024 10:37:27 +1000 Subject: [PATCH 05/21] Remove unnecessary stuff from Path --- src/Techdraw/Internal/Svg/Path.elm | 29 +++++++---------------------- 1 file changed, 7 insertions(+), 22 deletions(-) diff --git a/src/Techdraw/Internal/Svg/Path.elm b/src/Techdraw/Internal/Svg/Path.elm index 58eacc4..19f34b8 100644 --- a/src/Techdraw/Internal/Svg/Path.elm +++ b/src/Techdraw/Internal/Svg/Path.elm @@ -1,16 +1,11 @@ module Techdraw.Internal.Svg.Path exposing - ( PathString - , svgStringPath, svgStringPathToString - , formatPath + ( formatPath , NFixDigits(..) , toFixed ) {-| String representation of SVG paths. -@docs PathString -@docs svgStringPath, svgStringPathToString - # Formatting a Path @@ -51,21 +46,10 @@ type PathString | PathStringEmpty -{-| Create an `SvgStringPath` from a `String`. --} -svgStringPath : String -> PathString -svgStringPath content = - if String.isEmpty content then - PathStringEmpty - - else - PathString content - - {-| Convert an `SvgStringPath` to a `String`. -} -svgStringPathToString : PathString -> String -svgStringPathToString ssp = +pathStringToString : PathString -> String +pathStringToString ssp = case ssp of PathString content -> content @@ -125,11 +109,12 @@ formatNonempty convert = ---- Path Conversion ---------------------------------------------------------- -{-| Format a `Path` into an `SvgStringPath`. +{-| Format a `Path` into a `String` suitable for a `d = "..."` attribute in +SVG. -} -formatPath : NFixDigits -> Path -> PathString +formatPath : NFixDigits -> Path -> String formatPath n (P.Path subPaths) = - formatList (formatSubPath n) subPaths + formatList (formatSubPath n) subPaths |> pathStringToString {-| Format a `SubPath` into an `SvgStringPath`. From 4a21b214d3942f3e688cf20cd76883ff13b45f7d Mon Sep 17 00:00:00 2001 From: Jonathan Merritt Date: Tue, 3 Sep 2024 10:40:32 +1000 Subject: [PATCH 06/21] Update Path --- src/Techdraw/Internal/Svg/Path.elm | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/src/Techdraw/Internal/Svg/Path.elm b/src/Techdraw/Internal/Svg/Path.elm index 19f34b8..af9c089 100644 --- a/src/Techdraw/Internal/Svg/Path.elm +++ b/src/Techdraw/Internal/Svg/Path.elm @@ -1,5 +1,5 @@ module Techdraw.Internal.Svg.Path exposing - ( formatPath + ( toString , NFixDigits(..) , toFixed ) @@ -7,9 +7,9 @@ module Techdraw.Internal.Svg.Path exposing {-| String representation of SVG paths. -# Formatting a Path +# Converting a Path to SVG -@docs formatPath +@docs toString # Number Formatting @@ -111,9 +111,13 @@ formatNonempty convert = {-| 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 -> String -formatPath n (P.Path subPaths) = +toString : NFixDigits -> Path -> String +toString n (P.Path subPaths) = formatList (formatSubPath n) subPaths |> pathStringToString From 9f4c3c4ab541aa8625d00dc3468c7788a1e448e9 Mon Sep 17 00:00:00 2001 From: Jonathan Merritt Date: Tue, 3 Sep 2024 10:41:47 +1000 Subject: [PATCH 07/21] Remove old Codec stuff --- elm.json | 1 - src/Techdraw/Internal/Codec.elm | 127 -------------------------------- 2 files changed, 128 deletions(-) delete mode 100644 src/Techdraw/Internal/Codec.elm diff --git a/elm.json b/elm.json index a2e903b..bb05ee4 100644 --- a/elm.json +++ b/elm.json @@ -15,7 +15,6 @@ "Techdraw.Style", "Techdraw.Shapes.Simple", "Techdraw.Shapes.Spring", - "Techdraw.Internal.Codec", "Techdraw.Internal.Hash", "Techdraw.Internal.Svg.Path" ], diff --git a/src/Techdraw/Internal/Codec.elm b/src/Techdraw/Internal/Codec.elm deleted file mode 100644 index 4a83d31..0000000 --- a/src/Techdraw/Internal/Codec.elm +++ /dev/null @@ -1,127 +0,0 @@ -module Techdraw.Internal.Codec exposing - ( endianness, encf32, decf32, encu32, decu32 - , encColor, decColor - , encList, decList - ) - -{-| Encoding and decoding from `Bytes`. - -This functionality currently exists for the purposes of hashing. - -@docs endianness, encf32, decf32, encu32, decu32 -@docs encColor, decColor -@docs encList, decList - --} - -import Bytes exposing (Endianness) -import Bytes.Decode as Decode exposing (Decoder) -import Bytes.Encode as Encode exposing (Encoder) -import Color exposing (Color) - - - ----- General ------------------------------------------------------------------ - - -{-| Default endianness. --} -endianness : Endianness -endianness = - Bytes.BE - - -{-| Encode a `Float32` value with default endianness. --} -encf32 : Float -> Encoder -encf32 = - Encode.float32 endianness - - -{-| Decode a `Float32` value with default endianness. --} -decf32 : Decoder Float -decf32 = - Decode.float32 endianness - - -{-| Encode a u32 with default endianness. --} -encu32 : Int -> Encoder -encu32 = - Encode.unsignedInt32 endianness - - -{-| Decode a u32 with default endianness. --} -decu32 : Decoder Int -decu32 = - Decode.unsignedInt32 endianness - - - ----- External Types ----------------------------------------------------------- - - -{-| Encode a `Color`. --} -encColor : Color -> Encoder -encColor color = - let - rgba = - Color.toRgba color - in - Encode.sequence - [ encf32 rgba.red - , encf32 rgba.green - , encf32 rgba.blue - , encf32 rgba.alpha - ] - - -{-| Decode a `Color`. --} -decColor : Decoder Color -decColor = - Decode.map4 - (\r g b a -> Color.fromRgba { red = r, green = g, blue = b, alpha = a }) - decf32 - decf32 - decf32 - decf32 - - - ----- List Encoders and Decoders ----------------------------------------------- - - -{-| Encode a list prefixed by its length. --} -encList : (a -> Encoder) -> List a -> Encoder -encList encElem lst = - let - n = - List.length lst - in - Encode.sequence <| encu32 n :: List.map encElem lst - - -{-| Decode a list prefixed by its length. --} -decList : Decoder a -> Decoder (List a) -decList decElem = - decu32 |> Decode.andThen (decListN decElem) - - -{-| Decode a list with a decoder for one element and an element count. --} -decListN : Decoder a -> Int -> Decoder (List a) -decListN decElem nElem = - Decode.loop ( nElem, [] ) - (\( nLeft, accum ) -> - if nLeft == 0 then - Decode.succeed <| Decode.Done <| List.reverse accum - - else - Decode.map (\x -> Decode.Loop ( nLeft - 1, x :: accum )) decElem - ) From 878eddaab2abfb9bb29f0d63c4e3775c0feabaa7 Mon Sep 17 00:00:00 2001 From: Jonathan Merritt Date: Tue, 3 Sep 2024 10:53:39 +1000 Subject: [PATCH 08/21] Better docs for Hash --- src/Techdraw/Internal/Hash.elm | 38 +++++++++++++++++++++++++++++++++- 1 file changed, 37 insertions(+), 1 deletion(-) diff --git a/src/Techdraw/Internal/Hash.elm b/src/Techdraw/Internal/Hash.elm index a7f6fb4..c0d265e 100644 --- a/src/Techdraw/Internal/Hash.elm +++ b/src/Techdraw/Internal/Hash.elm @@ -1,5 +1,6 @@ module Techdraw.Internal.Hash exposing ( Hash, Hasher, Manifest, Encoder + , toHex , fromEncoder , f32, u32 , encHash @@ -12,10 +13,39 @@ module Techdraw.Internal.Hash exposing {-| 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 @@ -66,6 +96,13 @@ 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 @@ -145,7 +182,6 @@ attachTag tag encFn = ] - {-| Apply 2 encoders in sequence. -} enc2 : From 8049b1749ab52bc1cc2e6d3d065f804ac6c80642 Mon Sep 17 00:00:00 2001 From: Jonathan Merritt Date: Tue, 3 Sep 2024 11:01:24 +1000 Subject: [PATCH 09/21] Access to gradient internals --- src/Techdraw/Style.elm | 55 ++++++++++++++++++++++++++++++++++++------ 1 file changed, 48 insertions(+), 7 deletions(-) diff --git a/src/Techdraw/Style.elm b/src/Techdraw/Style.elm index 3bb2a84..28dc731 100644 --- a/src/Techdraw/Style.elm +++ b/src/Techdraw/Style.elm @@ -10,6 +10,8 @@ module Techdraw.Style exposing , RadialGradientParams, RadialGradient , linearGradient, radialGradient , GradientParams, Gradient, Stop(..), gradient + , hashGradient, hashLinearGradient, hashRadialGradient + , gradientParams, linearGradientParams, radialGradientParams , combineStyle , inheritAll , fill, fillRule @@ -55,6 +57,8 @@ module Techdraw.Style exposing @docs RadialGradientParams, RadialGradient @docs linearGradient, radialGradient @docs GradientParams, Gradient, Stop, gradient +@docs hashGradient, hashLinearGradient, hashRadialGradient +@docs gradientParams, linearGradientParams, radialGradientParams # Operations @@ -305,13 +309,6 @@ type Gradient = Gradient Hash GradientParams -{-| Hasher for a gradient just extracts its pre-computed parameters hash. --} -hashGradient : Hasher Gradient -hashGradient (Gradient hash _) = - hash - - {-| Parameters for a `Gradient` : a list of `Stop`s. -} type alias GradientParams = @@ -365,6 +362,50 @@ 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 --------------------------------------------------------- From ae46e46b964cb66c07a88a6e6097c5c4698dfb41 Mon Sep 17 00:00:00 2001 From: Jonathan Merritt Date: Wed, 4 Sep 2024 15:24:42 +1000 Subject: [PATCH 10/21] Drawing API WIP --- elm.json | 14 +- examples/hello-spring/src/Main.elm | 96 --- .../{hello-spring => hello-world}/elm.json | 8 +- examples/hello-world/src/Main.elm | 69 ++ examples/spring-carts/elm.json | 29 - examples/spring-carts/src/Main.elm | 629 ------------------ src/Techdraw.elm | 153 +++++ src/Techdraw/CSys.elm | 13 - src/Techdraw/Datum.elm | 49 -- src/Techdraw/Decorator.elm | 25 - src/Techdraw/Event.elm | 2 +- src/Techdraw/Internal/Dwg.elm | 18 + src/Techdraw/Internal/Hash.elm | 3 + src/Techdraw/Internal/StyleAtom.elm | 55 ++ src/Techdraw/Internal/Svg/Defs.elm | 190 ++++++ src/Techdraw/Internal/Svg/Env.elm | 169 +++++ src/Techdraw/Internal/Svg/Extras.elm | 41 ++ src/Techdraw/Internal/Svg/Machine.elm | 304 +++++++++ src/Techdraw/Internal/Svg/Style.elm | 280 ++++++++ src/Techdraw/Style.elm | 52 +- src/Techdraw/Types.elm | 183 +++++ 21 files changed, 1528 insertions(+), 854 deletions(-) delete mode 100644 examples/hello-spring/src/Main.elm rename examples/{hello-spring => hello-world}/elm.json (77%) create mode 100644 examples/hello-world/src/Main.elm delete mode 100644 examples/spring-carts/elm.json delete mode 100644 examples/spring-carts/src/Main.elm create mode 100644 src/Techdraw.elm delete mode 100644 src/Techdraw/CSys.elm delete mode 100644 src/Techdraw/Datum.elm delete mode 100644 src/Techdraw/Decorator.elm create mode 100644 src/Techdraw/Internal/Dwg.elm create mode 100644 src/Techdraw/Internal/StyleAtom.elm create mode 100644 src/Techdraw/Internal/Svg/Defs.elm create mode 100644 src/Techdraw/Internal/Svg/Env.elm create mode 100644 src/Techdraw/Internal/Svg/Extras.elm create mode 100644 src/Techdraw/Internal/Svg/Machine.elm create mode 100644 src/Techdraw/Internal/Svg/Style.elm create mode 100644 src/Techdraw/Types.elm diff --git a/elm.json b/elm.json index bb05ee4..fa8d82e 100644 --- a/elm.json +++ b/elm.json @@ -5,18 +5,24 @@ "license": "BSD-3-Clause", "version": "1.0.0", "exposed-modules": [ - "Techdraw.CSys", - "Techdraw.Datum", - "Techdraw.Decorator", + "Techdraw", "Techdraw.Event", "Techdraw.Math", "Techdraw.Path", "Techdraw.PathBuilder", "Techdraw.Style", + "Techdraw.Types", "Techdraw.Shapes.Simple", "Techdraw.Shapes.Spring", + "Techdraw.Internal.Dwg", "Techdraw.Internal.Hash", - "Techdraw.Internal.Svg.Path" + "Techdraw.Internal.StyleAtom", + "Techdraw.Internal.Svg.Defs", + "Techdraw.Internal.Svg.Env", + "Techdraw.Internal.Svg.Extras", + "Techdraw.Internal.Svg.Machine", + "Techdraw.Internal.Svg.Path", + "Techdraw.Internal.Svg.Style" ], "source-directories": ["src"], "elm-version": "0.19.1 <= v < 0.20.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..4481b26 --- /dev/null +++ b/examples/hello-world/src/Main.elm @@ -0,0 +1,69 @@ +module Main exposing (main) + +import Browser +import Color +import Html exposing (Html) +import Techdraw as TD exposing (Drawing) +import Techdraw.Math as Math exposing (p2) +import Techdraw.Shapes.Simple exposing (circle) +import Techdraw.Style as Style exposing (LinearGradient, Stop(..)) +import Techdraw.Types as TT + + +type Model + = Model () + + +type Msg + = Msg () + + +init : Model +init = + Model () + + +lg : LinearGradient +lg = + Style.linearGradient + { start = p2 (300 - 180) (200 - 180) + , end = p2 (300 + 180) (200 + 180) + , transform = Math.affIdentity + , gradient = + Style.gradient + [ Stop 0 Color.green + , Stop 1 Color.yellow + ] + } + + +drawing : Model -> Drawing msg +drawing _ = + TD.path + (circle + { r = 180 + , cx = 300 + , cy = 200 + } + ) + |> TD.fill (Style.PaintLinearGradient lg) + |> TD.stroke (Style.Paint Color.black) + |> TD.strokeWidth 5 + + +view : Model -> Html msg +view model = + Html.div [] [ drawing model |> TD.toSvg (TT.sizingWH 600 400) ] + + +update : Msg -> Model -> Model +update _ model = + model + + +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/Techdraw.elm b/src/Techdraw.elm new file mode 100644 index 0000000..1a7d838 --- /dev/null +++ b/src/Techdraw.elm @@ -0,0 +1,153 @@ +module Techdraw exposing + ( Drawing + , empty, path + , fill, fillRule, stroke, strokeWidth, lineCap, lineJoin + , dashArray, dashOffset + , toSvg, toSvgWithWarnings + ) + +{-| Techdraw: Interactive Technical Drawing in Elm + + +# Creating Drawings + +@docs Drawing +@docs empty, path + + +# Styling Drawings + +@docs fill, fillRule, stroke, strokeWidth, lineCap, lineJoin +@docs dashArray, dashOffset + + +# Converting Drawings to SVG + +@docs toSvg, toSvgWithWarnings + +-} + +import Html exposing (Html) +import Techdraw.Internal.Dwg exposing (Dwg(..)) +import Techdraw.Internal.StyleAtom as StyleAtom exposing (StyleAtom) +import Techdraw.Internal.Svg.Machine as DwgMachine +import Techdraw.Path exposing (Path) +import Techdraw.Style as Style +import Techdraw.Types exposing (Sizing) + + + +---- 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 + + + +---- 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 + + + +---- 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/Techdraw/CSys.elm b/src/Techdraw/CSys.elm deleted file mode 100644 index 2885615..0000000 --- a/src/Techdraw/CSys.elm +++ /dev/null @@ -1,13 +0,0 @@ -module Techdraw.CSys exposing (CSysName(..)) - -{-| Named coordinate systems. - -@docs CSysName - --} - - -{-| Name of a coordinate system. --} -type CSysName - = CSysName String diff --git a/src/Techdraw/Datum.elm b/src/Techdraw/Datum.elm deleted file mode 100644 index fde86fc..0000000 --- a/src/Techdraw/Datum.elm +++ /dev/null @@ -1,49 +0,0 @@ -module Techdraw.Datum exposing - ( DatumName(..), DatumPrefix(..) - , datumNameToString - , createStringName - ) - -{-| Named datum points in a drawing. - -@docs DatumName, DatumPrefix -@docs datumNameToString -@docs createStringName - --} - - -{-| Name of a datum. --} -type DatumName - = DatumName String - - -{-| Prefix to provide namespacing for datum names. --} -type DatumPrefix - = DatumPrefix String - - -{-| Convert a `DatumName` to a `String`. --} -datumNameToString : DatumName -> String -datumNameToString (DatumName name) = - name - - -{-| Convert a `DatumPrefix` to a `String`. --} -datumPrefixToString : DatumPrefix -> String -datumPrefixToString (DatumPrefix str) = - str - - -{-| Create the string name of a final datum point from its list of -prefixes and its datum name. --} -createStringName : List DatumPrefix -> DatumName -> String -createStringName dps n = - List.map datumPrefixToString dps - |> String.concat - |> (\prefix -> prefix ++ datumNameToString n) diff --git a/src/Techdraw/Decorator.elm b/src/Techdraw/Decorator.elm deleted file mode 100644 index 807635b..0000000 --- a/src/Techdraw/Decorator.elm +++ /dev/null @@ -1,25 +0,0 @@ -module Techdraw.Decorator exposing (Decorator) - -{-| Path decorators (arrow-heads, length shortening, etc. - -@docs Decorator - --} - -import Techdraw.Math exposing (AffineTransform) -import Techdraw.Path exposing (Path) -import Techdraw.Style exposing (Style) - - -{-| Decorator for a path. --} -type Decorator - = Decorator (RenderPath -> List RenderPath) - - -type RenderPath - = RenderPath - { style : Style - , localToWorld : AffineTransform - , localPath : Path - } diff --git a/src/Techdraw/Event.elm b/src/Techdraw/Event.elm index 0d64946..3b21959 100644 --- a/src/Techdraw/Event.elm +++ b/src/Techdraw/Event.elm @@ -14,8 +14,8 @@ module Techdraw.Event exposing -} -import Techdraw.CSys exposing (CSysName) import Techdraw.Math exposing (P2) +import Techdraw.Types exposing (CSysName) {-| All event handler types. diff --git a/src/Techdraw/Internal/Dwg.elm b/src/Techdraw/Internal/Dwg.elm new file mode 100644 index 0000000..5d4668b --- /dev/null +++ b/src/Techdraw/Internal/Dwg.elm @@ -0,0 +1,18 @@ +module Techdraw.Internal.Dwg exposing (Dwg(..)) + +{-| Internal sum type representing drawings. + +@docs Dwg + +-} + +import Techdraw.Internal.StyleAtom exposing (StyleAtom) +import Techdraw.Path exposing (Path) + + +{-| Internal drawing type. +-} +type Dwg msg + = DwgEmpty + | DwgPath Path + | DwgStyled StyleAtom (Dwg msg) diff --git a/src/Techdraw/Internal/Hash.elm b/src/Techdraw/Internal/Hash.elm index c0d265e..c6da47d 100644 --- a/src/Techdraw/Internal/Hash.elm +++ b/src/Techdraw/Internal/Hash.elm @@ -73,6 +73,9 @@ import Techdraw.Math as Math exposing (AffineTransform, M22, P2, V2) {-| A hash digest. + +Use [`toHex`](#toHex) to convert a `Hash` to a `String`. + -} type Hash = Hash SHA1.Digest diff --git a/src/Techdraw/Internal/StyleAtom.elm b/src/Techdraw/Internal/StyleAtom.elm new file mode 100644 index 0000000..763d0d9 --- /dev/null +++ b/src/Techdraw/Internal/StyleAtom.elm @@ -0,0 +1,55 @@ +module Techdraw.Internal.StyleAtom exposing (StyleAtom(..), apply) + +{-| Individual components of a Style. + +[`StyleAtom`](#StyleAtom) is used so that style settings in a drawing tree +take up as little room as possible. + +@docs StyleAtom, apply + +-} + +import Techdraw.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/Techdraw/Internal/Svg/Defs.elm b/src/Techdraw/Internal/Svg/Defs.elm new file mode 100644 index 0000000..1dfbf39 --- /dev/null +++ b/src/Techdraw/Internal/Svg/Defs.elm @@ -0,0 +1,190 @@ +module Techdraw.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 Dict exposing (Dict) +import Techdraw.Internal.Hash as Hash exposing (Hasher) +import Techdraw.Internal.Svg.Extras as Extras +import Techdraw.Internal.Svg.Path as SvgPath +import Techdraw.Math as Math +import Techdraw.Style as Style + exposing + ( LinearGradient + , RadialGradient + , radialGradient + ) +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/Techdraw/Internal/Svg/Env.elm b/src/Techdraw/Internal/Svg/Env.elm new file mode 100644 index 0000000..b60ae5e --- /dev/null +++ b/src/Techdraw/Internal/Svg/Env.elm @@ -0,0 +1,169 @@ +module Techdraw.Internal.Svg.Env exposing + ( Env + , Warning + , unWarning + , getLocalToWorld, getWarnings, getNFixDigits, getStyle + , modStyle, applyStyleAtom + , getDefs, modDefs + , init + , thread + ) + +{-| Environment for SVG drawing machine. + +@docs Env +@docs Warning +@docs unWarning +@docs getLocalToWorld, getWarnings, getNFixDigits, getStyle +@docs modStyle, applyStyleAtom +@docs getDefs, modDefs +@docs init +@docs thread + +-} + +import Techdraw.Internal.StyleAtom as StyleAtom exposing (StyleAtom) +import Techdraw.Internal.Svg.Defs as Defs exposing (Defs) +import Techdraw.Internal.Svg.Path exposing (NFixDigits(..)) +import Techdraw.Math as Math exposing (AffineTransform) +import Techdraw.Style as Style exposing (Style) +import Techdraw.Types as T exposing (Sizing(..)) + + +{-| Environment. +-} +type Env msg + = Env + { localToWorld : AffineTransform + , warnings : List Warning + , nFixDigits : NFixDigits + , style : Style + , defs : Defs + } + + +{-| 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 } + + +{-| 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 = + Env + { localToWorld = initLocalToWorld sizing + , warnings = [] + , nFixDigits = NFixDigits 2 + , style = Style.inheritAll + , defs = Defs.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 + { localToWorld = ancestor.localToWorld + , warnings = next.warnings + , nFixDigits = ancestor.nFixDigits + , style = ancestor.style + , defs = next.defs + } diff --git a/src/Techdraw/Internal/Svg/Extras.elm b/src/Techdraw/Internal/Svg/Extras.elm new file mode 100644 index 0000000..cdd63ef --- /dev/null +++ b/src/Techdraw/Internal/Svg/Extras.elm @@ -0,0 +1,41 @@ +module Techdraw.Internal.Svg.Extras exposing (convertAffineTransformToSvg) + +{-| Extra SVG conversions that don't belong somewhere more specific. + +@docs convertAffineTransformToSvg + +-} + +import Techdraw.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/Techdraw/Internal/Svg/Machine.elm b/src/Techdraw/Internal/Svg/Machine.elm new file mode 100644 index 0000000..2e7215d --- /dev/null +++ b/src/Techdraw/Internal/Svg/Machine.elm @@ -0,0 +1,304 @@ +module Techdraw.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 Html exposing (Attribute, Html) +import Html.Attributes as HtmlA +import Techdraw.Internal.Dwg exposing (Dwg(..)) +import Techdraw.Internal.StyleAtom as StyleAtom +import Techdraw.Internal.Svg.Defs as Defs +import Techdraw.Internal.Svg.Env as Env exposing (Env, Warning) +import Techdraw.Internal.Svg.Path as SvgPath +import Techdraw.Internal.Svg.Style as SvgStyle +import Techdraw.Path as Path exposing (Path) +import Techdraw.Types as T exposing (ContainerSize, Sizing, ViewBox) +import TypedSvg +import TypedSvg.Attributes as SvgA +import TypedSvg.Core exposing (Svg) + + + +---- 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 svgs warnings) = + ToSvgResult (TypedSvg.svg (sizingToSvg sizing) svgs) warnings + + +{-| 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 (List (Svg msg)) (List Warning) + + +{-| 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 + = KontNothing + + +{-| State in the state machine. +-} +type alias State msg = + { expr : Expr msg + , envr : Env msg + , kont : List (Kont msg) + } + + +{-| Final SVG value, with an empty list of SVGs. +-} +emptyFine : Expr msg +emptyFine = + Fine [] + + +{-| 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 <| + prependDefs state <| + StateMachineResult svgs (Env.getWarnings state.envr) + + _ -> + Nothing + + +{-| Convert `Defs` from the environment into a `` SVG element and +prepend it onto the `StateMachineResult`. +-} +prependDefs : State msg -> StateMachineResult msg -> StateMachineResult msg +prependDefs state (StateMachineResult svgs warnings) = + StateMachineResult + (Defs.toSvg (Env.getDefs state.envr) :: svgs) + warnings + + +{-| Step the state machine. +-} +step : State msg -> State msg +step state = + case ( state.expr, state.kont ) of + {- ----------------------------------------------------------------- -} + {- Terminal state -} + {- ----------------------------------------------------------------- -} + ( Fine _, [] ) -> + state + + {- ----------------------------------------------------------------- -} + {- Initial states -} + {- ----------------------------------------------------------------- -} + {- Empty drawing. -} + ( Init DwgEmpty, _ ) -> + state |> setExpr (Fine []) + + {- Draw a Path. -} + ( Init (DwgPath path), _ ) -> + let + ( sAttrs, state1 ) = + styleAttrs state + in + state1 |> setExpr (Fine (pathToSvg state.envr sAttrs path)) + + {- Update the style in the environment. -} + ( Init (DwgStyled atom drawing), _ ) -> + state + |> setExpr (Init drawing) + |> modEnvr (Env.applyStyleAtom atom) + + {- ----------------------------------------------------------------- -} + {- Continuation states -} + {- ----------------------------------------------------------------- -} + ( Fine _, KontNothing :: ks ) -> + { state | kont = ks } + + +{-| 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 } + + +{-| Get the style attributes for the current state's style. +-} +styleAttrs : State msg -> ( List (Attribute msg), State msg ) +styleAttrs 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. + +TODO: Styling + +-} +pathToSvg : Env msg -> List (Attribute msg) -> Path -> List (Svg msg) +pathToSvg env sAttrs path = + let + l2w = + Env.getLocalToWorld env + + nfd = + Env.getNFixDigits env + + str = + Path.pathApplyAffineTransform l2w path |> SvgPath.toString nfd + + attrs = + SvgA.d str :: sAttrs + in + [ TypedSvg.path attrs [] ] diff --git a/src/Techdraw/Internal/Svg/Style.elm b/src/Techdraw/Internal/Svg/Style.elm new file mode 100644 index 0000000..267353b --- /dev/null +++ b/src/Techdraw/Internal/Svg/Style.elm @@ -0,0 +1,280 @@ +module Techdraw.Internal.Svg.Style exposing (envStyleToSvg) + +{-| Styling in SVG. + +@docs envStyleToSvg + +-} + +import Techdraw.Internal.Hash as Hash +import Techdraw.Internal.Svg.Defs as Defs +import Techdraw.Internal.Svg.Env as Env exposing (Env) +import Techdraw.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/Style.elm b/src/Techdraw/Style.elm index 28dc731..c5d94b7 100644 --- a/src/Techdraw/Style.elm +++ b/src/Techdraw/Style.elm @@ -9,9 +9,11 @@ module Techdraw.Style exposing , LinearGradientParams, LinearGradient , RadialGradientParams, RadialGradient , linearGradient, radialGradient + , linearGradientApplyAffineTransform, radialGradientApplyAffineTransform , GradientParams, Gradient, Stop(..), gradient , hashGradient, hashLinearGradient, hashRadialGradient , gradientParams, linearGradientParams, radialGradientParams + , stopLocation, stopColor , combineStyle , inheritAll , fill, fillRule @@ -56,9 +58,11 @@ module Techdraw.Style exposing @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 @@ -76,7 +80,7 @@ module Techdraw.Style exposing import Color exposing (Color) import Techdraw.Internal.Hash as Hash exposing (Hash, Hasher) -import Techdraw.Math exposing (AffineTransform, P2) +import Techdraw.Math as Math exposing (AffineTransform, P2) @@ -235,6 +239,24 @@ 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". @@ -296,6 +318,24 @@ 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 @@ -337,21 +377,21 @@ type Stop -} encStop : Hash.Encoder Stop encStop = - Hash.enc2 Hash.f32 Hash.color getStopLocation getStopColor + Hash.enc2 Hash.f32 Hash.color stopLocation stopColor |> Hash.attachTag "Style.Stop" {-| Return the location of a gradient stop. -} -getStopLocation : Stop -> Float -getStopLocation (Stop location _) = +stopLocation : Stop -> Float +stopLocation (Stop location _) = location {-| Return the color of a gradient stop. -} -getStopColor : Stop -> Color -getStopColor (Stop _ color) = +stopColor : Stop -> Color +stopColor (Stop _ color) = color diff --git a/src/Techdraw/Types.elm b/src/Techdraw/Types.elm new file mode 100644 index 0000000..5ef035b --- /dev/null +++ b/src/Techdraw/Types.elm @@ -0,0 +1,183 @@ +module Techdraw.Types exposing + ( Sizing(..), ViewBox(..), ContainerSize(..) + , sizingScaled, sizingWH + , sizingGetViewBox, sizingGetContainerSize + , containerSizeGetWidth, containerSizeGetHeight + , viewBoxGetXMin, viewBoxGetYMin, viewBoxGetWidth, viewBoxGetHeight + , CSysName(..) + ) + +{-| Additional types. + + +# Sizes + +@docs Sizing, ViewBox, ContainerSize +@docs sizingScaled, sizingWH +@docs sizingGetViewBox, sizingGetContainerSize +@docs containerSizeGetWidth, containerSizeGetHeight +@docs viewBoxGetXMin, viewBoxGetYMin, viewBoxGetWidth, viewBoxGetHeight + + +# Names + +@docs CSysName + +-} + +---- 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 + + + +---- Names -------------------------------------------------------------------- + + +{-| Name of a coordinate system. +-} +type CSysName + = CSysName String From a3380343fa119e9f9e9f50f483258ea4087efbf8 Mon Sep 17 00:00:00 2001 From: Jonathan Merritt Date: Wed, 4 Sep 2024 16:58:51 +1000 Subject: [PATCH 11/21] Drawing transformations --- examples/hello-world/src/Main.elm | 193 +++++++++++++++++++++++--- src/Techdraw.elm | 72 ++++++++++ src/Techdraw/Internal/Dwg.elm | 2 + src/Techdraw/Internal/Svg/Env.elm | 15 ++ src/Techdraw/Internal/Svg/Machine.elm | 6 + src/Techdraw/Internal/Svg/Path.elm | 2 +- src/Techdraw/Math.elm | 18 ++- 7 files changed, 289 insertions(+), 19 deletions(-) diff --git a/examples/hello-world/src/Main.elm b/examples/hello-world/src/Main.elm index 4481b26..d72ceb4 100644 --- a/examples/hello-world/src/Main.elm +++ b/examples/hello-world/src/Main.elm @@ -3,31 +3,74 @@ module Main exposing (main) import Browser import Color import Html exposing (Html) +import Html.Attributes as HA +import Html.Events as HE import Techdraw as TD exposing (Drawing) import Techdraw.Math as Math exposing (p2) -import Techdraw.Shapes.Simple exposing (circle) +import Techdraw.Shapes.Simple exposing (circle, rectRounded) import Techdraw.Style as Style exposing (LinearGradient, Stop(..)) import Techdraw.Types as TT +import TypedSvg.Attributes exposing (rotate) type Model - = Model () + = Model + { translateX : Float + , translateY : Float + , rotate : Float + , scaleX : Float + , scaleY : Float + , skewX : Float + } type Msg - = Msg () + = MsgReset + | MsgTranslateXChanged Float + | MsgTranslateYChanged Float + | MsgRotateChanged Float + | MsgScaleXChanged Float + | MsgScaleYChanged Float + | MsgSkewXChanged Float init : Model init = - Model () + Model + { translateX = 0 + , translateY = 0 + , rotate = 0 + , scaleX = 1 + , scaleY = 1 + , skewX = 0 + } + + +drawingWidth = + 600 + + +drawingHeight = + 400 + + +halfWidth = + drawingWidth / 2 + + +halfHeight = + drawingHeight / 2 + + +circleRadius = + 0.2 * min drawingWidth drawingHeight lg : LinearGradient lg = Style.linearGradient - { start = p2 (300 - 180) (200 - 180) - , end = p2 (300 + 180) (200 + 180) + { start = p2 (halfWidth - circleRadius) (halfHeight - circleRadius) + , end = p2 (halfWidth + circleRadius) (halfHeight + circleRadius) , transform = Math.affIdentity , gradient = Style.gradient @@ -38,27 +81,145 @@ lg = drawing : Model -> Drawing msg -drawing _ = +drawing (Model model) = TD.path (circle - { r = 180 - , cx = 300 - , cy = 200 + { r = circleRadius + , cx = drawingWidth / 2 + , cy = drawingHeight / 2 } ) + {- + (rectRounded + { x = halfWidth - circleRadius + , y = halfHeight - circleRadius + , width = 2 * circleRadius + , height = 2 * circleRadius + , rx = 0.2 * circleRadius + , ry = 0.2 * circleRadius + } + ) + -} |> TD.fill (Style.PaintLinearGradient lg) |> TD.stroke (Style.Paint Color.black) |> TD.strokeWidth 5 + |> (-- Scale and Skew about the middle of the drawing + 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) + + +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 -view : Model -> Html msg -view model = - Html.div [] [ drawing model |> TD.toSvg (TT.sizingWH 600 400) ] + MsgTranslateXChanged tx -> + Model { model | translateX = tx } + MsgTranslateYChanged ty -> + Model { model | translateY = ty } -update : Msg -> Model -> Model -update _ model = - model + MsgRotateChanged angleDeg -> + Model { model | rotate = angleDeg } + + MsgScaleXChanged scaleX -> + Model { model | scaleX = scaleX } + + MsgScaleYChanged scaleY -> + Model { model | scaleY = scaleY } + + MsgSkewXChanged angleDeg -> + Model { model | skewX = angleDeg } main = diff --git a/src/Techdraw.elm b/src/Techdraw.elm index 1a7d838..6edec22 100644 --- a/src/Techdraw.elm +++ b/src/Techdraw.elm @@ -3,6 +3,8 @@ module Techdraw exposing , empty, path , fill, fillRule, stroke, strokeWidth, lineCap, lineJoin , dashArray, dashOffset + , transform, translate, rotateDegrees, rotateDegreesAbout + , skewXDegrees, scale , toSvg, toSvgWithWarnings ) @@ -21,6 +23,12 @@ module Techdraw exposing @docs dashArray, dashOffset +# Transforming Drawings + +@docs transform, translate, rotateDegrees, rotateDegreesAbout +@docs skewXDegrees, scale + + # Converting Drawings to SVG @docs toSvg, toSvgWithWarnings @@ -31,6 +39,7 @@ import Html exposing (Html) import Techdraw.Internal.Dwg exposing (Dwg(..)) import Techdraw.Internal.StyleAtom as StyleAtom exposing (StyleAtom) import Techdraw.Internal.Svg.Machine as DwgMachine +import Techdraw.Math as Math exposing (AffineTransform, P2, V2) import Techdraw.Path exposing (Path) import Techdraw.Style as Style import Techdraw.Types exposing (Sizing) @@ -135,6 +144,69 @@ 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 + + + ---- Converting Drawings To SVG ----------------------------------------------- diff --git a/src/Techdraw/Internal/Dwg.elm b/src/Techdraw/Internal/Dwg.elm index 5d4668b..18bd34e 100644 --- a/src/Techdraw/Internal/Dwg.elm +++ b/src/Techdraw/Internal/Dwg.elm @@ -7,6 +7,7 @@ module Techdraw.Internal.Dwg exposing (Dwg(..)) -} import Techdraw.Internal.StyleAtom exposing (StyleAtom) +import Techdraw.Math exposing (AffineTransform) import Techdraw.Path exposing (Path) @@ -16,3 +17,4 @@ type Dwg msg = DwgEmpty | DwgPath Path | DwgStyled StyleAtom (Dwg msg) + | DwgTransformed AffineTransform (Dwg msg) diff --git a/src/Techdraw/Internal/Svg/Env.elm b/src/Techdraw/Internal/Svg/Env.elm index b60ae5e..4ec4c28 100644 --- a/src/Techdraw/Internal/Svg/Env.elm +++ b/src/Techdraw/Internal/Svg/Env.elm @@ -5,6 +5,7 @@ module Techdraw.Internal.Svg.Env exposing , getLocalToWorld, getWarnings, getNFixDigits, getStyle , modStyle, applyStyleAtom , getDefs, modDefs + , concatTransform , init , thread ) @@ -17,6 +18,7 @@ module Techdraw.Internal.Svg.Env exposing @docs getLocalToWorld, getWarnings, getNFixDigits, getStyle @docs modStyle, applyStyleAtom @docs getDefs, modDefs +@docs concatTransform @docs init @docs thread @@ -98,6 +100,19 @@ modDefs modFn (Env oldEnv) = Env { oldEnv | defs = modFn oldEnv.defs } +{-| 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 + } + + {-| Warning string. -} type Warning diff --git a/src/Techdraw/Internal/Svg/Machine.elm b/src/Techdraw/Internal/Svg/Machine.elm index 2e7215d..b027510 100644 --- a/src/Techdraw/Internal/Svg/Machine.elm +++ b/src/Techdraw/Internal/Svg/Machine.elm @@ -249,6 +249,12 @@ step 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) + {- ----------------------------------------------------------------- -} {- Continuation states -} {- ----------------------------------------------------------------- -} diff --git a/src/Techdraw/Internal/Svg/Path.elm b/src/Techdraw/Internal/Svg/Path.elm index af9c089..4c6439f 100644 --- a/src/Techdraw/Internal/Svg/Path.elm +++ b/src/Techdraw/Internal/Svg/Path.elm @@ -246,7 +246,7 @@ formatFloat n = -} formatOrientationPi : NFixDigits -> OrientationPi -> PathString formatOrientationPi n = - formatFloat n << M.getOrientationPi + formatFloat n << M.toDegrees << M.getOrientationPi {-| Format a `Bool` into an `SvgStringPath`. diff --git a/src/Techdraw/Math.elm b/src/Techdraw/Math.elm index 4d7e055..4712c69 100644 --- a/src/Techdraw/Math.elm +++ b/src/Techdraw/Math.elm @@ -1,5 +1,5 @@ module Techdraw.Math exposing - ( sq + ( sq, toRadians, toDegrees , Tol(..), closeFloat , Angle2Pi, AnglePi, OrientationPi , angle2Pi, anglePi, orientationPi @@ -53,7 +53,7 @@ module Techdraw.Math exposing # Floating Point Functions -@docs sq +@docs sq, toRadians, toDegrees # Comparison of Floating-Point Values @@ -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 -------------------------------------- From f0c8b6345dd82bbdb9485bb6eb1f54901174f1c5 Mon Sep 17 00:00:00 2001 From: Jonathan Merritt Date: Wed, 4 Sep 2024 17:41:00 +1000 Subject: [PATCH 12/21] Add atop --- examples/hello-world/src/Main.elm | 51 ++++++++++++------- src/Techdraw.elm | 14 ++++- src/Techdraw/Internal/Dwg.elm | 1 + src/Techdraw/Internal/Svg/Machine.elm | 73 +++++++++++++++++++++++++-- 4 files changed, 117 insertions(+), 22 deletions(-) diff --git a/examples/hello-world/src/Main.elm b/examples/hello-world/src/Main.elm index d72ceb4..bb63941 100644 --- a/examples/hello-world/src/Main.elm +++ b/examples/hello-world/src/Main.elm @@ -80,26 +80,43 @@ lg = } +lg2 : LinearGradient +lg2 = + Style.linearGradient + { start = p2 (halfWidth - circleRadius) (halfHeight + circleRadius) + , end = p2 (halfWidth + circleRadius) (halfHeight - circleRadius) + , transform = Math.affIdentity + , gradient = + Style.gradient + [ Stop 0 Color.purple + , Stop 1 Color.green + ] + } + + drawing : Model -> Drawing msg drawing (Model model) = - TD.path - (circle - { r = circleRadius - , cx = drawingWidth / 2 - , cy = drawingHeight / 2 - } + TD.atop + (TD.path + (circle + { r = circleRadius + , cx = drawingWidth / 2 + , cy = drawingHeight / 2 + } + ) + ) + (TD.path + (rectRounded + { x = halfWidth - circleRadius + , y = halfHeight - circleRadius + , width = 2 * circleRadius + , height = 2 * circleRadius + , rx = 0.2 * circleRadius + , ry = 0.2 * circleRadius + } + ) + |> TD.fill (Style.PaintLinearGradient lg2) ) - {- - (rectRounded - { x = halfWidth - circleRadius - , y = halfHeight - circleRadius - , width = 2 * circleRadius - , height = 2 * circleRadius - , rx = 0.2 * circleRadius - , ry = 0.2 * circleRadius - } - ) - -} |> TD.fill (Style.PaintLinearGradient lg) |> TD.stroke (Style.Paint Color.black) |> TD.strokeWidth 5 diff --git a/src/Techdraw.elm b/src/Techdraw.elm index 6edec22..752690e 100644 --- a/src/Techdraw.elm +++ b/src/Techdraw.elm @@ -1,6 +1,6 @@ module Techdraw exposing ( Drawing - , empty, path + , empty, path, atop , fill, fillRule, stroke, strokeWidth, lineCap, lineJoin , dashArray, dashOffset , transform, translate, rotateDegrees, rotateDegreesAbout @@ -14,7 +14,7 @@ module Techdraw exposing # Creating Drawings @docs Drawing -@docs empty, path +@docs empty, path, atop # Styling Drawings @@ -76,6 +76,16 @@ path = DwgPath >> Drawing +{-| Draw one drawing on top of another drawing. + +The top drawing is processed first. + +-} +atop : Drawing msg -> Drawing msg -> Drawing msg +atop top bottom = + Drawing (DwgAtop (unDrawing top) (unDrawing bottom)) + + ---- Styling Drawings --------------------------------------------------------- diff --git a/src/Techdraw/Internal/Dwg.elm b/src/Techdraw/Internal/Dwg.elm index 18bd34e..594837a 100644 --- a/src/Techdraw/Internal/Dwg.elm +++ b/src/Techdraw/Internal/Dwg.elm @@ -18,3 +18,4 @@ type Dwg msg | DwgPath Path | DwgStyled StyleAtom (Dwg msg) | DwgTransformed AffineTransform (Dwg msg) + | DwgAtop (Dwg msg) (Dwg msg) diff --git a/src/Techdraw/Internal/Svg/Machine.elm b/src/Techdraw/Internal/Svg/Machine.elm index b027510..3acfcff 100644 --- a/src/Techdraw/Internal/Svg/Machine.elm +++ b/src/Techdraw/Internal/Svg/Machine.elm @@ -164,7 +164,8 @@ type Expr msg {-| Continuation for the state machine. -} type Kont msg - = KontNothing + = KontAtop1 (Dwg msg) (Env msg) + | KontAtop2 (List (Svg msg)) (Env msg) {-| State in the state machine. @@ -255,11 +256,39 @@ step state = |> setExpr (Init drawing) |> modEnvr (Env.concatTransform childToParent) + {- Draw the first drawing on top of the second. -} + ( Init (DwgAtop topDrawing bottomDrawing), _ ) -> + state + |> setExpr (Init topDrawing) + |> suspendKont (KontAtop1 bottomDrawing) + {- ----------------------------------------------------------------- -} {- Continuation states -} {- ----------------------------------------------------------------- -} - ( Fine _, KontNothing :: ks ) -> - { state | kont = ks } + {- 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 + |> threadEnvr susEnv + |> setExpr (Init bottomDrawing) + |> popKont + |> suspendKont (KontAtop2 topSvgs) + + {- Process the second `DwgAtop` continuation. + + At this continuation, we have evaluated both arguments of a + `DwgAtop` value, and have to package them together. + + TODO: Handle discharging events into an SVG Group + -} + ( Fine bottomSvgs, (KontAtop2 topSvgs susEnv) :: _ ) -> + state + |> threadEnvr susEnv + |> setExpr (Fine <| combineDrawings susEnv topSvgs bottomSvgs) + |> popKont {-| Set the expression in the state. @@ -276,6 +305,34 @@ 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. -} styleAttrs : State msg -> ( List (Attribute msg), State msg ) @@ -308,3 +365,13 @@ pathToSvg env sAttrs path = SvgA.d str :: sAttrs in [ TypedSvg.path attrs [] ] + + +{-| Combine drawings in the specified order. + +TODO: Handle discharging events. + +-} +combineDrawings : Env msg -> List (Svg msg) -> List (Svg msg) -> List (Svg msg) +combineDrawings _ topSvgs bottomSvgs = + bottomSvgs ++ topSvgs From e7633b421315f6a2ffbb4a1f4a87a9502cef0988 Mon Sep 17 00:00:00 2001 From: Jonathan Merritt Date: Wed, 4 Sep 2024 17:59:45 +1000 Subject: [PATCH 13/21] Add below --- examples/hello-world/src/Main.elm | 25 +++++++++++----- src/Techdraw.elm | 18 +++++++++--- src/Techdraw/Internal/Dwg.elm | 1 + src/Techdraw/Internal/Svg/Machine.elm | 41 ++++++++++++++++++++------- src/Techdraw/Internal/Svg/Path.elm | 9 +----- 5 files changed, 65 insertions(+), 29 deletions(-) diff --git a/examples/hello-world/src/Main.elm b/examples/hello-world/src/Main.elm index bb63941..5478a70 100644 --- a/examples/hello-world/src/Main.elm +++ b/examples/hello-world/src/Main.elm @@ -97,12 +97,23 @@ lg2 = drawing : Model -> Drawing msg drawing (Model model) = TD.atop - (TD.path - (circle - { r = circleRadius - , cx = drawingWidth / 2 - , cy = drawingHeight / 2 - } + (TD.below + (TD.path + (circle + { r = circleRadius + , cx = drawingWidth / 2 + , cy = drawingHeight / 2 + } + ) + ) + (TD.path + (circle + { r = circleRadius / 3 + , cx = drawingWidth / 2 + , cy = drawingHeight / 2 + } + ) + |> TD.fill (Style.Paint Color.darkRed) ) ) (TD.path @@ -119,7 +130,7 @@ drawing (Model model) = ) |> TD.fill (Style.PaintLinearGradient lg) |> TD.stroke (Style.Paint Color.black) - |> TD.strokeWidth 5 + |> TD.strokeWidth 0.2 |> (-- Scale and Skew about the middle of the drawing TD.translate (Math.v2 -halfWidth -halfHeight) >> TD.scale model.scaleX model.scaleY diff --git a/src/Techdraw.elm b/src/Techdraw.elm index 752690e..d00ba5d 100644 --- a/src/Techdraw.elm +++ b/src/Techdraw.elm @@ -1,6 +1,6 @@ module Techdraw exposing ( Drawing - , empty, path, atop + , empty, path, atop, below , fill, fillRule, stroke, strokeWidth, lineCap, lineJoin , dashArray, dashOffset , transform, translate, rotateDegrees, rotateDegreesAbout @@ -14,7 +14,7 @@ module Techdraw exposing # Creating Drawings @docs Drawing -@docs empty, path, atop +@docs empty, path, atop, below # Styling Drawings @@ -76,9 +76,9 @@ path = DwgPath >> Drawing -{-| Draw one drawing on top of another drawing. +{-| Draw the first drawing on top of the second drawing. -The top drawing is processed first. +The first/top drawing is processed first. -} atop : Drawing msg -> Drawing msg -> Drawing msg @@ -86,6 +86,16 @@ atop top bottom = Drawing (DwgAtop (unDrawing top) (unDrawing bottom)) +{-| Draw the first drawing below the second drawing. + +The first/bottom drawing is processed first. + +-} +below : Drawing msg -> Drawing msg -> Drawing msg +below bottom top = + Drawing (DwgBelow (unDrawing bottom) (unDrawing top)) + + ---- Styling Drawings --------------------------------------------------------- diff --git a/src/Techdraw/Internal/Dwg.elm b/src/Techdraw/Internal/Dwg.elm index 594837a..e8b0ba0 100644 --- a/src/Techdraw/Internal/Dwg.elm +++ b/src/Techdraw/Internal/Dwg.elm @@ -19,3 +19,4 @@ type Dwg msg | DwgStyled StyleAtom (Dwg msg) | DwgTransformed AffineTransform (Dwg msg) | DwgAtop (Dwg msg) (Dwg msg) + | DwgBelow (Dwg msg) (Dwg msg) diff --git a/src/Techdraw/Internal/Svg/Machine.elm b/src/Techdraw/Internal/Svg/Machine.elm index 3acfcff..f9a95a0 100644 --- a/src/Techdraw/Internal/Svg/Machine.elm +++ b/src/Techdraw/Internal/Svg/Machine.elm @@ -25,7 +25,6 @@ This module implements a largely non-recursive state machine to evaluate a import Html exposing (Attribute, Html) import Html.Attributes as HtmlA import Techdraw.Internal.Dwg exposing (Dwg(..)) -import Techdraw.Internal.StyleAtom as StyleAtom import Techdraw.Internal.Svg.Defs as Defs import Techdraw.Internal.Svg.Env as Env exposing (Env, Warning) import Techdraw.Internal.Svg.Path as SvgPath @@ -166,6 +165,8 @@ type Expr msg type Kont msg = KontAtop1 (Dwg msg) (Env msg) | KontAtop2 (List (Svg msg)) (Env msg) + | KontBelow1 (Dwg msg) (Env msg) + | KontBelow2 (List (Svg msg)) (Env msg) {-| State in the state machine. @@ -177,13 +178,6 @@ type alias State msg = } -{-| Final SVG value, with an empty list of SVGs. --} -emptyFine : Expr msg -emptyFine = - Fine [] - - {-| Inject an initial size and drawing into the machine state. -} inject : Sizing -> Dwg msg -> State msg @@ -262,6 +256,12 @@ step state = |> setExpr (Init topDrawing) |> suspendKont (KontAtop1 bottomDrawing) + {- Draw the first drawing below the second. -} + ( Init (DwgBelow bottomDrawing topDrawing), _ ) -> + state + |> setExpr (Init bottomDrawing) + |> suspendKont (KontBelow1 topDrawing) + {- ----------------------------------------------------------------- -} {- Continuation states -} {- ----------------------------------------------------------------- -} @@ -281,8 +281,6 @@ step state = At this continuation, we have evaluated both arguments of a `DwgAtop` value, and have to package them together. - - TODO: Handle discharging events into an SVG Group -} ( Fine bottomSvgs, (KontAtop2 topSvgs susEnv) :: _ ) -> state @@ -290,6 +288,29 @@ step state = |> setExpr (Fine <| combineDrawings susEnv topSvgs bottomSvgs) |> popKont + {- Process the first `DwgBelow` continuation. + + At this continuation, we have evaluated the first argument of a + `DwgBelow` value, and have to evaluate the second argument. + -} + ( Fine bottomSvgs, (KontBelow1 topDrawing susEnv) :: _ ) -> + state + |> threadEnvr susEnv + |> setExpr (Init topDrawing) + |> popKont + |> suspendKont (KontBelow2 bottomSvgs) + + {- Process the second `DwgBelow` continuation. + + At this continuation, we have evaluated both arguments of a + `DwgBelow` value, and have to package them together. + -} + ( Fine topSvgs, (KontBelow2 bottomSvgs susEnv) :: _ ) -> + state + |> threadEnvr susEnv + |> setExpr (Fine <| combineDrawings susEnv topSvgs bottomSvgs) + |> popKont + {-| Set the expression in the state. -} diff --git a/src/Techdraw/Internal/Svg/Path.elm b/src/Techdraw/Internal/Svg/Path.elm index 4c6439f..0c17984 100644 --- a/src/Techdraw/Internal/Svg/Path.elm +++ b/src/Techdraw/Internal/Svg/Path.elm @@ -210,18 +210,11 @@ figures on top of the value in `NFixDigits`. -} formatArcTo : NFixDigits -> ArcTo -> PathString formatArcTo n (P.ArcTo arcTo) = - let - (NFixDigits linDigits) = - n - - nAngDigits = - NFixDigits (linDigits + 2) - in joinListWithSpace [ 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 From df3387c738d27f365e5504b7eff77bcac86f7b03 Mon Sep 17 00:00:00 2001 From: Jonathan Merritt Date: Wed, 4 Sep 2024 22:08:31 +1000 Subject: [PATCH 14/21] Event-handling WIP --- README.md | 13 +-- elm.json | 1 + src/Techdraw.elm | 18 ++++ src/Techdraw/Internal/Dwg.elm | 2 + src/Techdraw/Internal/Svg/Env.elm | 23 +++++ src/Techdraw/Internal/Svg/Event.elm | 138 ++++++++++++++++++++++++++ src/Techdraw/Internal/Svg/Machine.elm | 33 ++++-- 7 files changed, 211 insertions(+), 17 deletions(-) create mode 100644 src/Techdraw/Internal/Svg/Event.elm 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 fa8d82e..58bbb09 100644 --- a/elm.json +++ b/elm.json @@ -19,6 +19,7 @@ "Techdraw.Internal.StyleAtom", "Techdraw.Internal.Svg.Defs", "Techdraw.Internal.Svg.Env", + "Techdraw.Internal.Svg.Event", "Techdraw.Internal.Svg.Extras", "Techdraw.Internal.Svg.Machine", "Techdraw.Internal.Svg.Path", diff --git a/src/Techdraw.elm b/src/Techdraw.elm index d00ba5d..46c45b7 100644 --- a/src/Techdraw.elm +++ b/src/Techdraw.elm @@ -5,6 +5,7 @@ module Techdraw exposing , dashArray, dashOffset , transform, translate, rotateDegrees, rotateDegreesAbout , skewXDegrees, scale + , onEvent , toSvg, toSvgWithWarnings ) @@ -29,6 +30,11 @@ module Techdraw exposing @docs skewXDegrees, scale +# Adding Handlers for Events + +@docs onEvent + + # Converting Drawings to SVG @docs toSvg, toSvgWithWarnings @@ -36,6 +42,7 @@ module Techdraw exposing -} import Html exposing (Html) +import Techdraw.Event exposing (EventHandler) import Techdraw.Internal.Dwg exposing (Dwg(..)) import Techdraw.Internal.StyleAtom as StyleAtom exposing (StyleAtom) import Techdraw.Internal.Svg.Machine as DwgMachine @@ -227,6 +234,17 @@ scale scaleX scaleY = +---- 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 + + + ---- Converting Drawings To SVG ----------------------------------------------- diff --git a/src/Techdraw/Internal/Dwg.elm b/src/Techdraw/Internal/Dwg.elm index e8b0ba0..b6b9cdb 100644 --- a/src/Techdraw/Internal/Dwg.elm +++ b/src/Techdraw/Internal/Dwg.elm @@ -6,6 +6,7 @@ module Techdraw.Internal.Dwg exposing (Dwg(..)) -} +import Techdraw.Event exposing (EventHandler) import Techdraw.Internal.StyleAtom exposing (StyleAtom) import Techdraw.Math exposing (AffineTransform) import Techdraw.Path exposing (Path) @@ -20,3 +21,4 @@ type Dwg msg | DwgTransformed AffineTransform (Dwg msg) | DwgAtop (Dwg msg) (Dwg msg) | DwgBelow (Dwg msg) (Dwg msg) + | DwgEventHandler (EventHandler msg) (Dwg msg) diff --git a/src/Techdraw/Internal/Svg/Env.elm b/src/Techdraw/Internal/Svg/Env.elm index 4ec4c28..52098a0 100644 --- a/src/Techdraw/Internal/Svg/Env.elm +++ b/src/Techdraw/Internal/Svg/Env.elm @@ -6,6 +6,7 @@ module Techdraw.Internal.Svg.Env exposing , modStyle, applyStyleAtom , getDefs, modDefs , concatTransform + , getEventHandlers, addEventHandler , init , thread ) @@ -19,11 +20,13 @@ module Techdraw.Internal.Svg.Env exposing @docs modStyle, applyStyleAtom @docs getDefs, modDefs @docs concatTransform +@docs getEventHandlers, addEventHandler @docs init @docs thread -} +import Techdraw.Event exposing (EventHandler) import Techdraw.Internal.StyleAtom as StyleAtom exposing (StyleAtom) import Techdraw.Internal.Svg.Defs as Defs exposing (Defs) import Techdraw.Internal.Svg.Path exposing (NFixDigits(..)) @@ -41,6 +44,7 @@ type Env msg , nFixDigits : NFixDigits , style : Style , defs : Defs + , eventHandlers : List (EventHandler msg) } @@ -113,6 +117,23 @@ concatTransform childToParent (Env oldEnv) = } +{-| Return the list of event handlers from the environment. +-} +getEventHandlers : Env msg -> List (EventHandler msg) +getEventHandlers (Env env) = + env.eventHandlers + + +{-| Prepend an event handler to the environment +-} +addEventHandler : EventHandler msg -> Env msg -> Env msg +addEventHandler eventHandler (Env oldEnv) = + Env + { oldEnv + | eventHandlers = eventHandler :: oldEnv.eventHandlers + } + + {-| Warning string. -} type Warning @@ -136,6 +157,7 @@ init sizing = , nFixDigits = NFixDigits 2 , style = Style.inheritAll , defs = Defs.empty + , eventHandlers = [] } @@ -181,4 +203,5 @@ thread (Env ancestor) (Env next) = , nFixDigits = ancestor.nFixDigits , style = ancestor.style , defs = next.defs + , eventHandlers = ancestor.eventHandlers } diff --git a/src/Techdraw/Internal/Svg/Event.elm b/src/Techdraw/Internal/Svg/Event.elm new file mode 100644 index 0000000..1e87a26 --- /dev/null +++ b/src/Techdraw/Internal/Svg/Event.elm @@ -0,0 +1,138 @@ +module Techdraw.Internal.Svg.Event exposing (eventHandlersToSvgAttrs) + +{-| Conversion of events to SVG. + +@docs eventHandlersToSvgAttrs + +-} + +import Bitwise exposing (and, shiftLeftBy) +import Json.Decode as D exposing (Decoder) +import Techdraw.Event + exposing + ( BState(..) + , Buttons + , EventHandler(..) + , KState(..) + , Modifiers + , MouseInfo(..) + ) +import Techdraw.Math as Math exposing (AffineTransform, P2) +import TypedSvg.Core exposing (Attribute) + + +{-| Convert a list of event handlers to a list of SVG attributes. +-} +eventHandlersToSvgAttrs : List (EventHandler msg) -> List (Attribute msg) +eventHandlersToSvgAttrs = + Debug.todo "TODO" + + + +---- JSON Decoders ------------------------------------------------------------ + + +{-| Decode mouse information for an event handler. + +TODO: This function will require information about the coordinate systems to +create the pointIn function. + +-} +decodeMouseInfo : AffineTransform -> Decoder MouseInfo +decodeMouseInfo localToWorld = + D.map3 + (\offsetP2 buttons modifiers -> + MouseInfo + { offset = offsetP2 + , local = + Math.p2ApplyAffineTransform + (Math.affInvert localToWorld) + offsetP2 + , buttons = buttons + , modifiers = modifiers + , pointIn = \_ -> Math.p2 0 0 -- TODO: Use CSys lookup + } + ) + 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/Techdraw/Internal/Svg/Machine.elm b/src/Techdraw/Internal/Svg/Machine.elm index f9a95a0..3b589a4 100644 --- a/src/Techdraw/Internal/Svg/Machine.elm +++ b/src/Techdraw/Internal/Svg/Machine.elm @@ -24,9 +24,11 @@ This module implements a largely non-recursive state machine to evaluate a import Html exposing (Attribute, Html) import Html.Attributes as HtmlA +import Techdraw.Event exposing (EventHandler) import Techdraw.Internal.Dwg exposing (Dwg(..)) import Techdraw.Internal.Svg.Defs as Defs import Techdraw.Internal.Svg.Env as Env exposing (Env, Warning) +import Techdraw.Internal.Svg.Event exposing (eventHandlersToSvgAttrs) import Techdraw.Internal.Svg.Path as SvgPath import Techdraw.Internal.Svg.Style as SvgStyle import Techdraw.Path as Path exposing (Path) @@ -262,6 +264,12 @@ step state = |> setExpr (Init bottomDrawing) |> suspendKont (KontBelow1 topDrawing) + {- Add a pending event handler to the environment. -} + ( Init (DwgEventHandler eventHandler drawing), _ ) -> + state + |> setExpr (Init drawing) + |> modEnvr (Env.addEventHandler eventHandler) + {- ----------------------------------------------------------------- -} {- Continuation states -} {- ----------------------------------------------------------------- -} @@ -366,9 +374,6 @@ styleAttrs state = {-| Convert a `Path` to SVG in the current environment. - -TODO: Styling - -} pathToSvg : Env msg -> List (Attribute msg) -> Path -> List (Svg msg) pathToSvg env sAttrs path = @@ -385,14 +390,26 @@ pathToSvg env sAttrs path = attrs = SvgA.d str :: sAttrs in - [ TypedSvg.path attrs [] ] + attachPendingEvents env [ TypedSvg.path attrs [] ] {-| 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 -TODO: Handle discharging events. +{-| Attach any pending events from the environment to produced SVG. -} -combineDrawings : Env msg -> List (Svg msg) -> List (Svg msg) -> List (Svg msg) -combineDrawings _ topSvgs bottomSvgs = - bottomSvgs ++ topSvgs +attachPendingEvents : Env msg -> List (Svg msg) -> List (Svg msg) +attachPendingEvents env svgs = + let + handlers = + Env.getEventHandlers env + in + if List.isEmpty handlers then + svgs + + else + [ TypedSvg.g (eventHandlersToSvgAttrs handlers) svgs ] From 26314dbdfc41a6867f4c5b93b2f270f6e22b2fc9 Mon Sep 17 00:00:00 2001 From: Jonathan Merritt Date: Thu, 5 Sep 2024 13:27:10 +1000 Subject: [PATCH 15/21] Initial event handling --- examples/hello-world/src/Main.elm | 22 ++++++- src/Techdraw.elm | 89 ++++++++++++++++++++++++++- src/Techdraw/Event.elm | 2 +- src/Techdraw/Internal/Svg/Event.elm | 81 +++++++++++++++++++++++- src/Techdraw/Internal/Svg/Machine.elm | 2 +- 5 files changed, 188 insertions(+), 8 deletions(-) diff --git a/examples/hello-world/src/Main.elm b/examples/hello-world/src/Main.elm index 5478a70..3e9699a 100644 --- a/examples/hello-world/src/Main.elm +++ b/examples/hello-world/src/Main.elm @@ -21,6 +21,7 @@ type Model , scaleX : Float , scaleY : Float , skewX : Float + , mouseOverInnerCircle : Bool } @@ -32,6 +33,8 @@ type Msg | MsgScaleXChanged Float | MsgScaleYChanged Float | MsgSkewXChanged Float + | MsgMouseEnter + | MsgMouseLeave init : Model @@ -43,6 +46,7 @@ init = , scaleX = 1 , scaleY = 1 , skewX = 0 + , mouseOverInnerCircle = False } @@ -94,7 +98,7 @@ lg2 = } -drawing : Model -> Drawing msg +drawing : Model -> Drawing Msg drawing (Model model) = TD.atop (TD.below @@ -113,7 +117,15 @@ drawing (Model model) = , cy = drawingHeight / 2 } ) - |> TD.fill (Style.Paint Color.darkRed) + |> TD.fill + (if model.mouseOverInnerCircle then + Style.Paint Color.darkOrange + + else + Style.Paint Color.darkRed + ) + |> TD.onMouseEnter (\_ -> MsgMouseEnter) + |> TD.onMouseLeave (\_ -> MsgMouseLeave) ) ) (TD.path @@ -249,6 +261,12 @@ update message (Model model) = MsgSkewXChanged angleDeg -> Model { model | skewX = angleDeg } + MsgMouseEnter -> + Model { model | mouseOverInnerCircle = True } + + MsgMouseLeave -> + Model { model | mouseOverInnerCircle = False } + main = Browser.sandbox diff --git a/src/Techdraw.elm b/src/Techdraw.elm index 46c45b7..b332ff3 100644 --- a/src/Techdraw.elm +++ b/src/Techdraw.elm @@ -6,6 +6,9 @@ module Techdraw exposing , transform, translate, rotateDegrees, rotateDegreesAbout , skewXDegrees, scale , onEvent + , onMouseClick, onMouseContextMenu, onMouseDblClick, onMouseDown + , onMouseEnter, onMouseLeave, onMouseMove, onMouseOut, onMouseOver + , onMouseUp , toSvg, toSvgWithWarnings ) @@ -33,6 +36,9 @@ module Techdraw exposing # Adding Handlers for Events @docs onEvent +@docs onMouseClick, onMouseContextMenu, onMouseDblClick, onMouseDown +@docs onMouseEnter, onMouseLeave, onMouseMove, onMouseOut, onMouseOver +@docs onMouseUp # Converting Drawings to SVG @@ -42,7 +48,7 @@ module Techdraw exposing -} import Html exposing (Html) -import Techdraw.Event exposing (EventHandler) +import Techdraw.Event as Event exposing (EventHandler, MouseInfo) import Techdraw.Internal.Dwg exposing (Dwg(..)) import Techdraw.Internal.StyleAtom as StyleAtom exposing (StyleAtom) import Techdraw.Internal.Svg.Machine as DwgMachine @@ -244,6 +250,87 @@ 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 + + ---- Converting Drawings To SVG ----------------------------------------------- diff --git a/src/Techdraw/Event.elm b/src/Techdraw/Event.elm index 3b21959..b9f8230 100644 --- a/src/Techdraw/Event.elm +++ b/src/Techdraw/Event.elm @@ -33,7 +33,7 @@ type EventHandler msg | MouseUp (MouseHandler msg) -{-| Mouse event handler. - +{-| Mouse event handler. -} type MouseHandler msg = MouseHandler (MouseInfo -> msg) diff --git a/src/Techdraw/Internal/Svg/Event.elm b/src/Techdraw/Internal/Svg/Event.elm index 1e87a26..6bb6c52 100644 --- a/src/Techdraw/Internal/Svg/Event.elm +++ b/src/Techdraw/Internal/Svg/Event.elm @@ -7,6 +7,7 @@ module Techdraw.Internal.Svg.Event exposing (eventHandlersToSvgAttrs) -} import Bitwise exposing (and, shiftLeftBy) +import Html.Events as HtmlEvents import Json.Decode as D exposing (Decoder) import Techdraw.Event exposing @@ -15,23 +16,97 @@ import Techdraw.Event , EventHandler(..) , KState(..) , Modifiers + , MouseHandler(..) , MouseInfo(..) ) +import Techdraw.Internal.Svg.Env as Env exposing (Env) import Techdraw.Math as Math exposing (AffineTransform, P2) import TypedSvg.Core exposing (Attribute) {-| Convert a list of event handlers to a list of SVG attributes. -} -eventHandlersToSvgAttrs : List (EventHandler msg) -> List (Attribute msg) -eventHandlersToSvgAttrs = - Debug.todo "TODO" +eventHandlersToSvgAttrs : + Env msg + -> List (EventHandler msg) + -> List (Attribute msg) +eventHandlersToSvgAttrs env = + List.map (eventHandlerToSvgAttr (Env.getLocalToWorld env)) + + +{-| Convert an `EventHandler msg` to an `Attribute msg` using appropriate +environmental information. +-} +eventHandlerToSvgAttr : + AffineTransform + -> EventHandler msg + -> Attribute msg +eventHandlerToSvgAttr localToWorld eventHandler = + case eventHandler of + MouseClick mouseHandler -> + mouseHandlerToSvgAttr "click" localToWorld mouseHandler + + MouseContextMenu mouseHandler -> + mouseHandlerToSvgAttr "contextmenu" localToWorld mouseHandler + + MouseDblClick mouseHandler -> + mouseHandlerToSvgAttr "dblclick" localToWorld mouseHandler + + MouseDown mouseHandler -> + mouseHandlerToSvgAttr "mousedown" localToWorld mouseHandler + + MouseEnter mouseHandler -> + mouseHandlerToSvgAttr "mouseenter" localToWorld mouseHandler + + MouseLeave mouseHandler -> + mouseHandlerToSvgAttr "mouseleave" localToWorld mouseHandler + + MouseMove mouseHandler -> + mouseHandlerToSvgAttr "mousemove" localToWorld mouseHandler + + MouseOut mouseHandler -> + mouseHandlerToSvgAttr "mouseout" localToWorld mouseHandler + + MouseOver mouseHandler -> + mouseHandlerToSvgAttr "mouseover" localToWorld mouseHandler + + MouseUp mouseHandler -> + mouseHandlerToSvgAttr "mouseup" localToWorld mouseHandler + + +{-| Convert a `MouseHandler msg` to an `Attribute msg` using appropriate +environmental information. +-} +mouseHandlerToSvgAttr : + String + -> AffineTransform + -> MouseHandler msg + -> Attribute msg +mouseHandlerToSvgAttr eventName localToWorld mouseHandler = + HtmlEvents.on + eventName + (mouseHandlerToMessageDecoder localToWorld 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 + -> MouseHandler msg + -> Decoder msg +mouseHandlerToMessageDecoder localToWorld (MouseHandler mouseInfoToMsg) = + decodeMouseInfo localToWorld |> D.map mouseInfoToMsg + + {-| Decode mouse information for an event handler. TODO: This function will require information about the coordinate systems to diff --git a/src/Techdraw/Internal/Svg/Machine.elm b/src/Techdraw/Internal/Svg/Machine.elm index 3b589a4..c345b3f 100644 --- a/src/Techdraw/Internal/Svg/Machine.elm +++ b/src/Techdraw/Internal/Svg/Machine.elm @@ -412,4 +412,4 @@ attachPendingEvents env svgs = svgs else - [ TypedSvg.g (eventHandlersToSvgAttrs handlers) svgs ] + [ TypedSvg.g (eventHandlersToSvgAttrs env handlers) svgs ] From cc6fa5c6105d89cb1455a5d05c7f7aeaad4c0828 Mon Sep 17 00:00:00 2001 From: Jonathan Merritt Date: Thu, 5 Sep 2024 13:31:13 +1000 Subject: [PATCH 16/21] Rename below -> beneath --- examples/hello-world/src/Main.elm | 2 +- src/Techdraw.elm | 10 +++++----- src/Techdraw/Internal/Dwg.elm | 2 +- src/Techdraw/Internal/Svg/Machine.elm | 24 ++++++++++++------------ 4 files changed, 19 insertions(+), 19 deletions(-) diff --git a/examples/hello-world/src/Main.elm b/examples/hello-world/src/Main.elm index 3e9699a..880558a 100644 --- a/examples/hello-world/src/Main.elm +++ b/examples/hello-world/src/Main.elm @@ -101,7 +101,7 @@ lg2 = drawing : Model -> Drawing Msg drawing (Model model) = TD.atop - (TD.below + (TD.beneath (TD.path (circle { r = circleRadius diff --git a/src/Techdraw.elm b/src/Techdraw.elm index b332ff3..0be23ed 100644 --- a/src/Techdraw.elm +++ b/src/Techdraw.elm @@ -1,6 +1,6 @@ module Techdraw exposing ( Drawing - , empty, path, atop, below + , empty, path, atop, beneath , fill, fillRule, stroke, strokeWidth, lineCap, lineJoin , dashArray, dashOffset , transform, translate, rotateDegrees, rotateDegreesAbout @@ -18,7 +18,7 @@ module Techdraw exposing # Creating Drawings @docs Drawing -@docs empty, path, atop, below +@docs empty, path, atop, beneath # Styling Drawings @@ -104,9 +104,9 @@ atop top bottom = The first/bottom drawing is processed first. -} -below : Drawing msg -> Drawing msg -> Drawing msg -below bottom top = - Drawing (DwgBelow (unDrawing bottom) (unDrawing top)) +beneath : Drawing msg -> Drawing msg -> Drawing msg +beneath bottom top = + Drawing (DwgBeneath (unDrawing bottom) (unDrawing top)) diff --git a/src/Techdraw/Internal/Dwg.elm b/src/Techdraw/Internal/Dwg.elm index b6b9cdb..1932e33 100644 --- a/src/Techdraw/Internal/Dwg.elm +++ b/src/Techdraw/Internal/Dwg.elm @@ -20,5 +20,5 @@ type Dwg msg | DwgStyled StyleAtom (Dwg msg) | DwgTransformed AffineTransform (Dwg msg) | DwgAtop (Dwg msg) (Dwg msg) - | DwgBelow (Dwg msg) (Dwg msg) + | DwgBeneath (Dwg msg) (Dwg msg) | DwgEventHandler (EventHandler msg) (Dwg msg) diff --git a/src/Techdraw/Internal/Svg/Machine.elm b/src/Techdraw/Internal/Svg/Machine.elm index c345b3f..12cfa9d 100644 --- a/src/Techdraw/Internal/Svg/Machine.elm +++ b/src/Techdraw/Internal/Svg/Machine.elm @@ -167,8 +167,8 @@ type Expr msg type Kont msg = KontAtop1 (Dwg msg) (Env msg) | KontAtop2 (List (Svg msg)) (Env msg) - | KontBelow1 (Dwg msg) (Env msg) - | KontBelow2 (List (Svg msg)) (Env msg) + | KontBeneath1 (Dwg msg) (Env msg) + | KontBeneath2 (List (Svg msg)) (Env msg) {-| State in the state machine. @@ -258,11 +258,11 @@ step state = |> setExpr (Init topDrawing) |> suspendKont (KontAtop1 bottomDrawing) - {- Draw the first drawing below the second. -} - ( Init (DwgBelow bottomDrawing topDrawing), _ ) -> + {- Draw the first drawing beneath the second. -} + ( Init (DwgBeneath bottomDrawing topDrawing), _ ) -> state |> setExpr (Init bottomDrawing) - |> suspendKont (KontBelow1 topDrawing) + |> suspendKont (KontBeneath1 topDrawing) {- Add a pending event handler to the environment. -} ( Init (DwgEventHandler eventHandler drawing), _ ) -> @@ -296,24 +296,24 @@ step state = |> setExpr (Fine <| combineDrawings susEnv topSvgs bottomSvgs) |> popKont - {- Process the first `DwgBelow` continuation. + {- Process the first `DwgBeneath` continuation. At this continuation, we have evaluated the first argument of a - `DwgBelow` value, and have to evaluate the second argument. + `DwgBeneath` value, and have to evaluate the second argument. -} - ( Fine bottomSvgs, (KontBelow1 topDrawing susEnv) :: _ ) -> + ( Fine bottomSvgs, (KontBeneath1 topDrawing susEnv) :: _ ) -> state |> threadEnvr susEnv |> setExpr (Init topDrawing) |> popKont - |> suspendKont (KontBelow2 bottomSvgs) + |> suspendKont (KontBeneath2 bottomSvgs) - {- Process the second `DwgBelow` continuation. + {- Process the second `DwgBeneath` continuation. At this continuation, we have evaluated both arguments of a - `DwgBelow` value, and have to package them together. + `DwgBeneath` value, and have to package them together. -} - ( Fine topSvgs, (KontBelow2 bottomSvgs susEnv) :: _ ) -> + ( Fine topSvgs, (KontBeneath2 bottomSvgs susEnv) :: _ ) -> state |> threadEnvr susEnv |> setExpr (Fine <| combineDrawings susEnv topSvgs bottomSvgs) From 519403a61a55f19ee4cbdf89c2f039a6bcfbd398 Mon Sep 17 00:00:00 2001 From: Jonathan Merritt Date: Thu, 5 Sep 2024 16:35:25 +1000 Subject: [PATCH 17/21] Working CSys events --- elm.json | 1 + examples/hello-world/src/Main.elm | 118 +++++++++++++------------- src/Techdraw.elm | 36 +++++++- src/Techdraw/Internal/CSysDict.elm | 66 ++++++++++++++ src/Techdraw/Internal/Dwg.elm | 2 + src/Techdraw/Internal/Svg/Env.elm | 78 +++++++++++++++-- src/Techdraw/Internal/Svg/Event.elm | 67 ++++++++------- src/Techdraw/Internal/Svg/Machine.elm | 53 ++++++++---- src/Techdraw/Types.elm | 18 ++++ 9 files changed, 323 insertions(+), 116 deletions(-) create mode 100644 src/Techdraw/Internal/CSysDict.elm diff --git a/elm.json b/elm.json index 58bbb09..d3e14cd 100644 --- a/elm.json +++ b/elm.json @@ -14,6 +14,7 @@ "Techdraw.Types", "Techdraw.Shapes.Simple", "Techdraw.Shapes.Spring", + "Techdraw.Internal.CSysDict", "Techdraw.Internal.Dwg", "Techdraw.Internal.Hash", "Techdraw.Internal.StyleAtom", diff --git a/examples/hello-world/src/Main.elm b/examples/hello-world/src/Main.elm index 880558a..4750f6a 100644 --- a/examples/hello-world/src/Main.elm +++ b/examples/hello-world/src/Main.elm @@ -6,11 +6,11 @@ import Html exposing (Html) import Html.Attributes as HA import Html.Events as HE import Techdraw as TD exposing (Drawing) -import Techdraw.Math as Math exposing (p2) +import Techdraw.Event exposing (MouseInfo(..)) +import Techdraw.Math as Math exposing (P2, p2) import Techdraw.Shapes.Simple exposing (circle, rectRounded) import Techdraw.Style as Style exposing (LinearGradient, Stop(..)) import Techdraw.Types as TT -import TypedSvg.Attributes exposing (rotate) type Model @@ -22,6 +22,7 @@ type Model , scaleY : Float , skewX : Float , mouseOverInnerCircle : Bool + , coords : Maybe P2 } @@ -33,8 +34,9 @@ type Msg | MsgScaleXChanged Float | MsgScaleYChanged Float | MsgSkewXChanged Float - | MsgMouseEnter - | MsgMouseLeave + | MsgMouseEnterInner + | MsgMouseLeaveInner + | MsgMouseMove P2 init : Model @@ -47,6 +49,7 @@ init = , scaleY = 1 , skewX = 0 , mouseOverInnerCircle = False + , coords = Nothing } @@ -84,51 +87,34 @@ lg = } -lg2 : LinearGradient -lg2 = - Style.linearGradient - { start = p2 (halfWidth - circleRadius) (halfHeight + circleRadius) - , end = p2 (halfWidth + circleRadius) (halfHeight - circleRadius) - , transform = Math.affIdentity - , gradient = - Style.gradient - [ Stop 0 Color.purple - , Stop 1 Color.green - ] - } +rectStyle : Model -> Drawing msg -> Drawing msg +rectStyle (Model model) = + if model.mouseOverInnerCircle then + TD.fill (Style.Paint Color.darkOrange) + >> TD.stroke (Style.Paint Color.black) + >> TD.strokeWidth 1.2 + + else + TD.fill (Style.PaintLinearGradient lg) + >> TD.stroke (Style.Paint Color.black) + >> TD.strokeWidth 0.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.atop - (TD.beneath - (TD.path - (circle - { r = circleRadius - , cx = drawingWidth / 2 - , cy = drawingHeight / 2 - } - ) - ) - (TD.path - (circle - { r = circleRadius / 3 - , cx = drawingWidth / 2 - , cy = drawingHeight / 2 - } - ) - |> TD.fill - (if model.mouseOverInnerCircle then - Style.Paint Color.darkOrange - - else - Style.Paint Color.darkRed - ) - |> TD.onMouseEnter (\_ -> MsgMouseEnter) - |> TD.onMouseLeave (\_ -> MsgMouseLeave) - ) - ) - (TD.path + TD.stack TT.BottomToTop + [ TD.path (rectRounded { x = halfWidth - circleRadius , y = halfHeight - circleRadius @@ -138,19 +124,28 @@ drawing (Model model) = , ry = 0.2 * circleRadius } ) - |> TD.fill (Style.PaintLinearGradient lg2) - ) - |> TD.fill (Style.PaintLinearGradient lg) - |> TD.stroke (Style.Paint Color.black) - |> TD.strokeWidth 0.2 - |> (-- Scale and Skew about the middle of the drawing - 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) + |> TD.onMouseEnter (\_ -> MsgMouseEnterInner) + |> TD.onMouseLeave (\_ -> MsgMouseLeaveInner) + , 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.tagCSys (TT.CSysName "original") + |> rectStyle (Model model) + |> rectTransform (Model model) + |> TD.onMouseMove + (\(MouseInfo mouseInfo) -> + mouseInfo.pointIn (TT.CSysName "original") |> MsgMouseMove + ) view : Model -> Html Msg @@ -261,12 +256,15 @@ update message (Model model) = MsgSkewXChanged angleDeg -> Model { model | skewX = angleDeg } - MsgMouseEnter -> + MsgMouseEnterInner -> Model { model | mouseOverInnerCircle = True } - MsgMouseLeave -> + MsgMouseLeaveInner -> Model { model | mouseOverInnerCircle = False } + MsgMouseMove p -> + Model { model | coords = Just p } + main = Browser.sandbox diff --git a/src/Techdraw.elm b/src/Techdraw.elm index 0be23ed..0f84c7f 100644 --- a/src/Techdraw.elm +++ b/src/Techdraw.elm @@ -1,6 +1,6 @@ module Techdraw exposing ( Drawing - , empty, path, atop, beneath + , empty, path, atop, beneath, stack , fill, fillRule, stroke, strokeWidth, lineCap, lineJoin , dashArray, dashOffset , transform, translate, rotateDegrees, rotateDegreesAbout @@ -9,6 +9,7 @@ module Techdraw exposing , onMouseClick, onMouseContextMenu, onMouseDblClick, onMouseDown , onMouseEnter, onMouseLeave, onMouseMove, onMouseOut, onMouseOver , onMouseUp + , tagCSys , toSvg, toSvgWithWarnings ) @@ -18,7 +19,7 @@ module Techdraw exposing # Creating Drawings @docs Drawing -@docs empty, path, atop, beneath +@docs empty, path, atop, beneath, stack # Styling Drawings @@ -41,6 +42,11 @@ module Techdraw exposing @docs onMouseUp +# Tagging Coordinate Systems + +@docs tagCSys + + # Converting Drawings to SVG @docs toSvg, toSvgWithWarnings @@ -55,7 +61,7 @@ import Techdraw.Internal.Svg.Machine as DwgMachine import Techdraw.Math as Math exposing (AffineTransform, P2, V2) import Techdraw.Path exposing (Path) import Techdraw.Style as Style -import Techdraw.Types exposing (Sizing) +import Techdraw.Types exposing (CSysName, Order(..), Sizing) @@ -109,6 +115,18 @@ 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 --------------------------------------------------------- @@ -332,6 +350,18 @@ onMouseUp = +---- Tagging Coordinate Systems ----------------------------------------------- + + +{-| Tag the current local-to-world transformation with the supplied +coordinate system name. +-} +tagCSys : CSysName -> Drawing msg -> Drawing msg +tagCSys cSysName = + unDrawing >> DwgTagCSys cSysName >> Drawing + + + ---- Converting Drawings To SVG ----------------------------------------------- diff --git a/src/Techdraw/Internal/CSysDict.elm b/src/Techdraw/Internal/CSysDict.elm new file mode 100644 index 0000000..66851c7 --- /dev/null +++ b/src/Techdraw/Internal/CSysDict.elm @@ -0,0 +1,66 @@ +module Techdraw.Internal.CSysDict exposing + ( CSysDict + , empty, insertLocalToWorld, getLocalToWorld, getWorldToLocal + , inCSys + ) + +{-| Dictionary (map) containing coordinate systems. + +@docs CSysDict +@docs empty, insertLocalToWorld, getLocalToWorld, getWorldToLocal +@docs inCSys + +-} + +import Dict exposing (Dict) +import Techdraw.Math as Math exposing (AffineTransform, P2) +import Techdraw.Types exposing (CSysName(..)) + + +{-| 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/Techdraw/Internal/Dwg.elm b/src/Techdraw/Internal/Dwg.elm index 1932e33..a1c0d61 100644 --- a/src/Techdraw/Internal/Dwg.elm +++ b/src/Techdraw/Internal/Dwg.elm @@ -10,6 +10,7 @@ import Techdraw.Event exposing (EventHandler) import Techdraw.Internal.StyleAtom exposing (StyleAtom) import Techdraw.Math exposing (AffineTransform) import Techdraw.Path exposing (Path) +import Techdraw.Types exposing (CSysName) {-| Internal drawing type. @@ -22,3 +23,4 @@ type Dwg msg | DwgAtop (Dwg msg) (Dwg msg) | DwgBeneath (Dwg msg) (Dwg msg) | DwgEventHandler (EventHandler msg) (Dwg msg) + | DwgTagCSys CSysName (Dwg msg) diff --git a/src/Techdraw/Internal/Svg/Env.elm b/src/Techdraw/Internal/Svg/Env.elm index 52098a0..06f686b 100644 --- a/src/Techdraw/Internal/Svg/Env.elm +++ b/src/Techdraw/Internal/Svg/Env.elm @@ -1,12 +1,15 @@ module Techdraw.Internal.Svg.Env exposing ( Env , Warning + , EventHandlerCapturedEnv(..) , unWarning , getLocalToWorld, getWarnings, getNFixDigits, getStyle , modStyle, applyStyleAtom , getDefs, modDefs , concatTransform - , getEventHandlers, addEventHandler + , getEventHandlers, hasPendingEventHandlers, addEventHandler + , removeEventHandlers + , tagCSys, getCSysDict , init , thread ) @@ -15,24 +18,28 @@ module Techdraw.Internal.Svg.Env exposing @docs Env @docs Warning +@docs EventHandlerCapturedEnv @docs unWarning @docs getLocalToWorld, getWarnings, getNFixDigits, getStyle @docs modStyle, applyStyleAtom @docs getDefs, modDefs @docs concatTransform -@docs getEventHandlers, addEventHandler +@docs getEventHandlers, hasPendingEventHandlers, addEventHandler +@docs removeEventHandlers +@docs tagCSys, getCSysDict @docs init @docs thread -} import Techdraw.Event exposing (EventHandler) +import Techdraw.Internal.CSysDict as CSysDict exposing (CSysDict) import Techdraw.Internal.StyleAtom as StyleAtom exposing (StyleAtom) import Techdraw.Internal.Svg.Defs as Defs exposing (Defs) import Techdraw.Internal.Svg.Path exposing (NFixDigits(..)) import Techdraw.Math as Math exposing (AffineTransform) import Techdraw.Style as Style exposing (Style) -import Techdraw.Types as T exposing (Sizing(..)) +import Techdraw.Types as T exposing (CSysName, Sizing(..)) {-| Environment. @@ -44,7 +51,8 @@ type Env msg , nFixDigits : NFixDigits , style : Style , defs : Defs - , eventHandlers : List (EventHandler msg) + , eventHandlers : List (EventHandlerCapturedEnv msg) + , cSysDict : CSysDict } @@ -117,9 +125,16 @@ concatTransform childToParent (Env oldEnv) = } +{-| 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 (EventHandler msg) +getEventHandlers : Env msg -> List (EventHandlerCapturedEnv msg) getEventHandlers (Env env) = env.eventHandlers @@ -128,12 +143,51 @@ getEventHandlers (Env env) = -} 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 = [] + } + + +{-| 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 - | eventHandlers = eventHandler :: oldEnv.eventHandlers + | 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 @@ -158,6 +212,7 @@ init sizing = , style = Style.inheritAll , defs = Defs.empty , eventHandlers = [] + , cSysDict = CSysDict.empty } @@ -204,4 +259,15 @@ thread (Env ancestor) (Env next) = , style = ancestor.style , defs = next.defs , eventHandlers = ancestor.eventHandlers + , 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/Techdraw/Internal/Svg/Event.elm b/src/Techdraw/Internal/Svg/Event.elm index 6bb6c52..204392e 100644 --- a/src/Techdraw/Internal/Svg/Event.elm +++ b/src/Techdraw/Internal/Svg/Event.elm @@ -19,7 +19,8 @@ import Techdraw.Event , MouseHandler(..) , MouseInfo(..) ) -import Techdraw.Internal.Svg.Env as Env exposing (Env) +import Techdraw.Internal.CSysDict as CSysDict exposing (CSysDict) +import Techdraw.Internal.Svg.Env exposing (EventHandlerCapturedEnv(..)) import Techdraw.Math as Math exposing (AffineTransform, P2) import TypedSvg.Core exposing (Attribute) @@ -27,51 +28,59 @@ import TypedSvg.Core exposing (Attribute) {-| Convert a list of event handlers to a list of SVG attributes. -} eventHandlersToSvgAttrs : - Env msg - -> List (EventHandler msg) + CSysDict + -> List (EventHandlerCapturedEnv msg) -> List (Attribute msg) -eventHandlersToSvgAttrs env = - List.map (eventHandlerToSvgAttr (Env.getLocalToWorld env)) +eventHandlersToSvgAttrs cSysDict = + List.map (eventHandlerToSvgAttr cSysDict) {-| Convert an `EventHandler msg` to an `Attribute msg` using appropriate environmental information. -} eventHandlerToSvgAttr : - AffineTransform - -> EventHandler msg + CSysDict + -> EventHandlerCapturedEnv msg -> Attribute msg -eventHandlerToSvgAttr localToWorld eventHandler = - case eventHandler of +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 -> - mouseHandlerToSvgAttr "click" localToWorld mouseHandler + processMouseHandler "click" mouseHandler MouseContextMenu mouseHandler -> - mouseHandlerToSvgAttr "contextmenu" localToWorld mouseHandler + processMouseHandler "contextmenu" mouseHandler MouseDblClick mouseHandler -> - mouseHandlerToSvgAttr "dblclick" localToWorld mouseHandler + processMouseHandler "dblclick" mouseHandler MouseDown mouseHandler -> - mouseHandlerToSvgAttr "mousedown" localToWorld mouseHandler + processMouseHandler "mousedown" mouseHandler MouseEnter mouseHandler -> - mouseHandlerToSvgAttr "mouseenter" localToWorld mouseHandler + processMouseHandler "mouseenter" mouseHandler MouseLeave mouseHandler -> - mouseHandlerToSvgAttr "mouseleave" localToWorld mouseHandler + processMouseHandler "mouseleave" mouseHandler MouseMove mouseHandler -> - mouseHandlerToSvgAttr "mousemove" localToWorld mouseHandler + processMouseHandler "mousemove" mouseHandler MouseOut mouseHandler -> - mouseHandlerToSvgAttr "mouseout" localToWorld mouseHandler + processMouseHandler "mouseout" mouseHandler MouseOver mouseHandler -> - mouseHandlerToSvgAttr "mouseover" localToWorld mouseHandler + processMouseHandler "mouseover" mouseHandler MouseUp mouseHandler -> - mouseHandlerToSvgAttr "mouseup" localToWorld mouseHandler + processMouseHandler "mouseup" mouseHandler {-| Convert a `MouseHandler msg` to an `Attribute msg` using appropriate @@ -80,12 +89,13 @@ environmental information. mouseHandlerToSvgAttr : String -> AffineTransform + -> CSysDict -> MouseHandler msg -> Attribute msg -mouseHandlerToSvgAttr eventName localToWorld mouseHandler = +mouseHandlerToSvgAttr eventName localToWorld cSysDict mouseHandler = HtmlEvents.on eventName - (mouseHandlerToMessageDecoder localToWorld mouseHandler) + (mouseHandlerToMessageDecoder localToWorld cSysDict mouseHandler) @@ -101,20 +111,17 @@ create the pointIn function. -} mouseHandlerToMessageDecoder : AffineTransform + -> CSysDict -> MouseHandler msg -> Decoder msg -mouseHandlerToMessageDecoder localToWorld (MouseHandler mouseInfoToMsg) = - decodeMouseInfo localToWorld |> D.map mouseInfoToMsg +mouseHandlerToMessageDecoder localToWorld cSysDict (MouseHandler toMsg) = + decodeMouseInfo localToWorld cSysDict |> D.map toMsg {-| Decode mouse information for an event handler. - -TODO: This function will require information about the coordinate systems to -create the pointIn function. - -} -decodeMouseInfo : AffineTransform -> Decoder MouseInfo -decodeMouseInfo localToWorld = +decodeMouseInfo : AffineTransform -> CSysDict -> Decoder MouseInfo +decodeMouseInfo localToWorld cSysDict = D.map3 (\offsetP2 buttons modifiers -> MouseInfo @@ -125,7 +132,7 @@ decodeMouseInfo localToWorld = offsetP2 , buttons = buttons , modifiers = modifiers - , pointIn = \_ -> Math.p2 0 0 -- TODO: Use CSys lookup + , pointIn = \name -> CSysDict.inCSys cSysDict name offsetP2 } ) decodeOffsetP2 diff --git a/src/Techdraw/Internal/Svg/Machine.elm b/src/Techdraw/Internal/Svg/Machine.elm index 12cfa9d..ec8450f 100644 --- a/src/Techdraw/Internal/Svg/Machine.elm +++ b/src/Techdraw/Internal/Svg/Machine.elm @@ -24,7 +24,6 @@ This module implements a largely non-recursive state machine to evaluate a import Html exposing (Attribute, Html) import Html.Attributes as HtmlA -import Techdraw.Event exposing (EventHandler) import Techdraw.Internal.Dwg exposing (Dwg(..)) import Techdraw.Internal.Svg.Defs as Defs import Techdraw.Internal.Svg.Env as Env exposing (Env, Warning) @@ -238,7 +237,9 @@ step state = ( sAttrs, state1 ) = styleAttrs state in - state1 |> setExpr (Fine (pathToSvg state.envr sAttrs path)) + state1 + |> setExpr (Fine (pathToSvg state.envr sAttrs path)) + |> modEnvr Env.removeEventHandlers {- Update the style in the environment. -} ( Init (DwgStyled atom drawing), _ ) -> @@ -255,14 +256,22 @@ step state = {- Draw the first drawing on top of the second. -} ( Init (DwgAtop topDrawing bottomDrawing), _ ) -> state - |> setExpr (Init topDrawing) + -- 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 - |> setExpr (Init bottomDrawing) + -- 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), _ ) -> @@ -270,6 +279,12 @@ step state = |> setExpr (Init drawing) |> modEnvr (Env.addEventHandler eventHandler) + {- Tag the current local-to-world coordinate system. -} + ( Init (DwgTagCSys cSysName drawing), _ ) -> + state + |> setExpr (Init drawing) + |> modEnvr (Env.tagCSys cSysName) + {- ----------------------------------------------------------------- -} {- Continuation states -} {- ----------------------------------------------------------------- -} @@ -280,10 +295,11 @@ step state = -} ( Fine topSvgs, (KontAtop1 bottomDrawing susEnv) :: _ ) -> state - |> threadEnvr susEnv - |> setExpr (Init bottomDrawing) |> popKont + |> threadEnvr susEnv |> suspendKont (KontAtop2 topSvgs) + |> modEnvr Env.removeEventHandlers + |> setExpr (Init bottomDrawing) {- Process the second `DwgAtop` continuation. @@ -292,9 +308,9 @@ step state = -} ( Fine bottomSvgs, (KontAtop2 topSvgs susEnv) :: _ ) -> state + |> popKont |> threadEnvr susEnv |> setExpr (Fine <| combineDrawings susEnv topSvgs bottomSvgs) - |> popKont {- Process the first `DwgBeneath` continuation. @@ -303,10 +319,11 @@ step state = -} ( Fine bottomSvgs, (KontBeneath1 topDrawing susEnv) :: _ ) -> state - |> threadEnvr susEnv - |> setExpr (Init topDrawing) |> popKont + |> threadEnvr susEnv |> suspendKont (KontBeneath2 bottomSvgs) + |> modEnvr Env.removeEventHandlers + |> setExpr (Init topDrawing) {- Process the second `DwgBeneath` continuation. @@ -315,9 +332,9 @@ step state = -} ( Fine topSvgs, (KontBeneath2 bottomSvgs susEnv) :: _ ) -> state + |> popKont |> threadEnvr susEnv |> setExpr (Fine <| combineDrawings susEnv topSvgs bottomSvgs) - |> popKont {-| Set the expression in the state. @@ -404,12 +421,14 @@ combineDrawings env topSvgs bottomSvgs = -} attachPendingEvents : Env msg -> List (Svg msg) -> List (Svg msg) attachPendingEvents env svgs = - let - handlers = - Env.getEventHandlers env - in - if List.isEmpty handlers then - svgs + if Env.hasPendingEventHandlers env then + [ TypedSvg.g + (eventHandlersToSvgAttrs + (Env.getCSysDict env) + (Env.getEventHandlers env) + ) + svgs + ] else - [ TypedSvg.g (eventHandlersToSvgAttrs env handlers) svgs ] + svgs diff --git a/src/Techdraw/Types.elm b/src/Techdraw/Types.elm index 5ef035b..8e1ca58 100644 --- a/src/Techdraw/Types.elm +++ b/src/Techdraw/Types.elm @@ -4,6 +4,7 @@ module Techdraw.Types exposing , sizingGetViewBox, sizingGetContainerSize , containerSizeGetWidth, containerSizeGetHeight , viewBoxGetXMin, viewBoxGetYMin, viewBoxGetWidth, viewBoxGetHeight + , Order(..) , CSysName(..) ) @@ -19,6 +20,11 @@ module Techdraw.Types exposing @docs viewBoxGetXMin, viewBoxGetYMin, viewBoxGetWidth, viewBoxGetHeight +# Drawing Order + +@docs Order + + # Names @docs CSysName @@ -174,6 +180,18 @@ viewBoxGetHeight (ViewBox vb) = +---- 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 + + + ---- Names -------------------------------------------------------------------- From 2f229352e67945e82aff257f62df51bb4470bc4b Mon Sep 17 00:00:00 2001 From: Jonathan Merritt Date: Thu, 5 Sep 2024 17:01:15 +1000 Subject: [PATCH 18/21] Add host events --- examples/hello-world/src/Main.elm | 32 ++------- src/Techdraw.elm | 98 +++++++++++++++++++++++++++ src/Techdraw/Internal/Dwg.elm | 1 + src/Techdraw/Internal/Svg/Env.elm | 30 ++++++++ src/Techdraw/Internal/Svg/Machine.elm | 46 +++++++++---- 5 files changed, 167 insertions(+), 40 deletions(-) diff --git a/examples/hello-world/src/Main.elm b/examples/hello-world/src/Main.elm index 4750f6a..a4ca5dd 100644 --- a/examples/hello-world/src/Main.elm +++ b/examples/hello-world/src/Main.elm @@ -21,7 +21,6 @@ type Model , scaleX : Float , scaleY : Float , skewX : Float - , mouseOverInnerCircle : Bool , coords : Maybe P2 } @@ -34,8 +33,6 @@ type Msg | MsgScaleXChanged Float | MsgScaleYChanged Float | MsgSkewXChanged Float - | MsgMouseEnterInner - | MsgMouseLeaveInner | MsgMouseMove P2 @@ -48,7 +45,6 @@ init = , scaleX = 1 , scaleY = 1 , skewX = 0 - , mouseOverInnerCircle = False , coords = Nothing } @@ -87,17 +83,11 @@ lg = } -rectStyle : Model -> Drawing msg -> Drawing msg -rectStyle (Model model) = - if model.mouseOverInnerCircle then - TD.fill (Style.Paint Color.darkOrange) - >> TD.stroke (Style.Paint Color.black) - >> TD.strokeWidth 1.2 - - else - TD.fill (Style.PaintLinearGradient lg) - >> TD.stroke (Style.Paint Color.black) - >> TD.strokeWidth 0.8 +rectStyle : Drawing msg -> Drawing msg +rectStyle = + TD.fill (Style.PaintLinearGradient lg) + >> TD.stroke (Style.Paint Color.black) + >> TD.strokeWidth 0.8 rectTransform : Model -> Drawing msg -> Drawing msg @@ -124,8 +114,6 @@ drawing (Model model) = , ry = 0.2 * circleRadius } ) - |> TD.onMouseEnter (\_ -> MsgMouseEnterInner) - |> TD.onMouseLeave (\_ -> MsgMouseLeaveInner) , case model.coords of Nothing -> TD.empty @@ -140,9 +128,9 @@ drawing (Model model) = ) ] |> TD.tagCSys (TT.CSysName "original") - |> rectStyle (Model model) + |> rectStyle |> rectTransform (Model model) - |> TD.onMouseMove + |> TD.onHostMouseMove (\(MouseInfo mouseInfo) -> mouseInfo.pointIn (TT.CSysName "original") |> MsgMouseMove ) @@ -256,12 +244,6 @@ update message (Model model) = MsgSkewXChanged angleDeg -> Model { model | skewX = angleDeg } - MsgMouseEnterInner -> - Model { model | mouseOverInnerCircle = True } - - MsgMouseLeaveInner -> - Model { model | mouseOverInnerCircle = False } - MsgMouseMove p -> Model { model | coords = Just p } diff --git a/src/Techdraw.elm b/src/Techdraw.elm index 0f84c7f..9cfd400 100644 --- a/src/Techdraw.elm +++ b/src/Techdraw.elm @@ -9,6 +9,9 @@ module Techdraw exposing , onMouseClick, onMouseContextMenu, onMouseDblClick, onMouseDown , onMouseEnter, onMouseLeave, onMouseMove, onMouseOut, onMouseOver , onMouseUp + , onHostMouseClick, onHostMouseContextMenu, onHostMouseDblClick + , onHostMouseDown, onHostMouseEnter, onHostMouseLeave, onHostMouseMove + , onHostMouseOut, onHostMouseOver, onHostMouseUp , tagCSys , toSvg, toSvgWithWarnings ) @@ -40,6 +43,9 @@ module Techdraw exposing @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 @@ -349,12 +355,104 @@ 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 = diff --git a/src/Techdraw/Internal/Dwg.elm b/src/Techdraw/Internal/Dwg.elm index a1c0d61..63be038 100644 --- a/src/Techdraw/Internal/Dwg.elm +++ b/src/Techdraw/Internal/Dwg.elm @@ -23,4 +23,5 @@ type 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) diff --git a/src/Techdraw/Internal/Svg/Env.elm b/src/Techdraw/Internal/Svg/Env.elm index 06f686b..2baa578 100644 --- a/src/Techdraw/Internal/Svg/Env.elm +++ b/src/Techdraw/Internal/Svg/Env.elm @@ -9,6 +9,7 @@ module Techdraw.Internal.Svg.Env exposing , concatTransform , getEventHandlers, hasPendingEventHandlers, addEventHandler , removeEventHandlers + , addHostEventHandler, getHostEventHandlers , tagCSys, getCSysDict , init , thread @@ -26,6 +27,7 @@ module Techdraw.Internal.Svg.Env exposing @docs concatTransform @docs getEventHandlers, hasPendingEventHandlers, addEventHandler @docs removeEventHandlers +@docs addHostEventHandler, getHostEventHandlers @docs tagCSys, getCSysDict @docs init @docs thread @@ -52,6 +54,7 @@ type Env msg , style : Style , defs : Defs , eventHandlers : List (EventHandlerCapturedEnv msg) + , hostEventHandlers : List (EventHandlerCapturedEnv msg) , cSysDict : CSysDict } @@ -166,6 +169,31 @@ removeEventHandlers (Env oldEnv) = } +{-| 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. -} @@ -212,6 +240,7 @@ init sizing = , style = Style.inheritAll , defs = Defs.empty , eventHandlers = [] + , hostEventHandlers = [] , cSysDict = CSysDict.empty } @@ -259,6 +288,7 @@ thread (Env ancestor) (Env next) = , style = ancestor.style , defs = next.defs , eventHandlers = ancestor.eventHandlers + , hostEventHandlers = next.hostEventHandlers , cSysDict = next.cSysDict } diff --git a/src/Techdraw/Internal/Svg/Machine.elm b/src/Techdraw/Internal/Svg/Machine.elm index ec8450f..12dbe7c 100644 --- a/src/Techdraw/Internal/Svg/Machine.elm +++ b/src/Techdraw/Internal/Svg/Machine.elm @@ -88,8 +88,22 @@ toSvg sizing = {-| Produce final HTML after running the state machine to completion. -} produceHtml : Sizing -> StateMachineResult msg -> ToSvgResult msg -produceHtml sizing (StateMachineResult svgs warnings) = - ToSvgResult (TypedSvg.svg (sizingToSvg sizing) svgs) warnings +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. @@ -145,7 +159,10 @@ loopTailRecursive state = {-| Final result of running the state machine. -} type StateMachineResult msg - = StateMachineResult (List (Svg msg)) (List Warning) + = StateMachineResult + { childSvgs : List (Svg msg) + , envr : Env msg + } {-| Expression in the state machine. @@ -196,23 +213,16 @@ extractIfDone state = case ( state.expr, state.kont ) of ( Fine svgs, [] ) -> Just <| - prependDefs state <| - StateMachineResult svgs (Env.getWarnings state.envr) + StateMachineResult + { childSvgs = + (Env.getDefs state.envr |> Defs.toSvg) :: svgs + , envr = state.envr + } _ -> Nothing -{-| Convert `Defs` from the environment into a `` SVG element and -prepend it onto the `StateMachineResult`. --} -prependDefs : State msg -> StateMachineResult msg -> StateMachineResult msg -prependDefs state (StateMachineResult svgs warnings) = - StateMachineResult - (Defs.toSvg (Env.getDefs state.envr) :: svgs) - warnings - - {-| Step the state machine. -} step : State msg -> State msg @@ -279,6 +289,12 @@ step 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 From a14b763ac15547e6bc015edf5765ea8a7c2079fa Mon Sep 17 00:00:00 2001 From: Jonathan Merritt Date: Sat, 7 Sep 2024 16:04:33 +1000 Subject: [PATCH 19/21] Freeze and use frozen drawings --- examples/hello-world/src/Main.elm | 43 +++++++++++-- src/Techdraw.elm | 26 +++++++- src/Techdraw/Internal/Dwg.elm | 4 +- src/Techdraw/Internal/StyleAtom.elm | 7 ++- src/Techdraw/Internal/Svg/Env.elm | 57 +++++++++++++++-- src/Techdraw/Internal/Svg/Machine.elm | 89 ++++++++++++++++++++++++++- src/Techdraw/Types.elm | 11 ++++ 7 files changed, 222 insertions(+), 15 deletions(-) diff --git a/examples/hello-world/src/Main.elm b/examples/hello-world/src/Main.elm index a4ca5dd..cc4601c 100644 --- a/examples/hello-world/src/Main.elm +++ b/examples/hello-world/src/Main.elm @@ -69,6 +69,11 @@ circleRadius = 0.2 * min drawingWidth drawingHeight + +-- Bottom-left: Red +-- Top-right: Green + + lg : LinearGradient lg = Style.linearGradient @@ -77,8 +82,8 @@ lg = , transform = Math.affIdentity , gradient = Style.gradient - [ Stop 0 Color.green - , Stop 1 Color.yellow + [ Stop 0 Color.red + , Stop 1 Color.green ] } @@ -87,7 +92,7 @@ rectStyle : Drawing msg -> Drawing msg rectStyle = TD.fill (Style.PaintLinearGradient lg) >> TD.stroke (Style.Paint Color.black) - >> TD.strokeWidth 0.8 + >> TD.strokeWidth 8 rectTransform : Model -> Drawing msg -> Drawing msg @@ -114,6 +119,35 @@ drawing (Model model) = , ry = 0.2 * circleRadius } ) + |> rectStyle + |> TD.freeze (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 (Just (TT.FrozenName "rect_pair")) + , TD.stack TT.TopToBottom + [ TD.use (TT.FrozenName "rect_pair") + , TD.use (TT.FrozenName "frozen_rect") + ] + |> TD.freeze (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 @@ -126,10 +160,11 @@ drawing (Model model) = , r = 0.1 * circleRadius } ) + |> TD.fill (Style.Paint Color.red) ] |> TD.tagCSys (TT.CSysName "original") - |> rectStyle |> rectTransform (Model model) + |> TD.freeze Nothing |> TD.onHostMouseMove (\(MouseInfo mouseInfo) -> mouseInfo.pointIn (TT.CSysName "original") |> MsgMouseMove diff --git a/src/Techdraw.elm b/src/Techdraw.elm index 9cfd400..f7f65dc 100644 --- a/src/Techdraw.elm +++ b/src/Techdraw.elm @@ -5,6 +5,7 @@ module Techdraw exposing , dashArray, dashOffset , transform, translate, rotateDegrees, rotateDegreesAbout , skewXDegrees, scale + , freeze, use , onEvent , onMouseClick, onMouseContextMenu, onMouseDblClick, onMouseDown , onMouseEnter, onMouseLeave, onMouseMove, onMouseOut, onMouseOver @@ -37,6 +38,11 @@ module Techdraw exposing @docs skewXDegrees, scale +# Freezing Drawings + +@docs freeze, use + + # Adding Handlers for Events @docs onEvent @@ -67,7 +73,7 @@ import Techdraw.Internal.Svg.Machine as DwgMachine import Techdraw.Math as Math exposing (AffineTransform, P2, V2) import Techdraw.Path exposing (Path) import Techdraw.Style as Style -import Techdraw.Types exposing (CSysName, Order(..), Sizing) +import Techdraw.Types exposing (CSysName, FrozenName, Order(..), Sizing) @@ -264,6 +270,24 @@ scale scaleX scaleY = +---- Freezing Drawings -------------------------------------------------------- + + +{-| Freeze a drawing, adding an optional name to it. +-} +freeze : Maybe FrozenName -> Drawing msg -> Drawing msg +freeze optName = + unDrawing >> DwgFrozen optName >> Drawing + + +{-| Re-use a frozen drawing, summoning it by name. +-} +use : FrozenName -> Drawing msg +use = + DwgUse >> Drawing + + + ---- Adding Handlers for Events ----------------------------------------------- diff --git a/src/Techdraw/Internal/Dwg.elm b/src/Techdraw/Internal/Dwg.elm index 63be038..fe9f85c 100644 --- a/src/Techdraw/Internal/Dwg.elm +++ b/src/Techdraw/Internal/Dwg.elm @@ -10,7 +10,7 @@ import Techdraw.Event exposing (EventHandler) import Techdraw.Internal.StyleAtom exposing (StyleAtom) import Techdraw.Math exposing (AffineTransform) import Techdraw.Path exposing (Path) -import Techdraw.Types exposing (CSysName) +import Techdraw.Types exposing (CSysName, FrozenName) {-| Internal drawing type. @@ -25,3 +25,5 @@ type Dwg msg | DwgEventHandler (EventHandler msg) (Dwg msg) | DwgHostEventHandler (EventHandler msg) (Dwg msg) | DwgTagCSys CSysName (Dwg msg) + | DwgFrozen (Maybe FrozenName) (Dwg msg) + | DwgUse FrozenName diff --git a/src/Techdraw/Internal/StyleAtom.elm b/src/Techdraw/Internal/StyleAtom.elm index 763d0d9..d7ae138 100644 --- a/src/Techdraw/Internal/StyleAtom.elm +++ b/src/Techdraw/Internal/StyleAtom.elm @@ -1,9 +1,10 @@ module Techdraw.Internal.StyleAtom exposing (StyleAtom(..), apply) -{-| Individual components of a Style. +{-| Individual component of a Style. -[`StyleAtom`](#StyleAtom) is used so that style settings in a drawing tree -take up as little room as possible. +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 diff --git a/src/Techdraw/Internal/Svg/Env.elm b/src/Techdraw/Internal/Svg/Env.elm index 2baa578..5fcdee3 100644 --- a/src/Techdraw/Internal/Svg/Env.elm +++ b/src/Techdraw/Internal/Svg/Env.elm @@ -6,7 +6,8 @@ module Techdraw.Internal.Svg.Env exposing , getLocalToWorld, getWarnings, getNFixDigits, getStyle , modStyle, applyStyleAtom , getDefs, modDefs - , concatTransform + , getInitLocalToWorld, getInitWorldToLocal + , setLocalToWorldTransform, setLocalToWorldTransformAsInit, concatTransform , getEventHandlers, hasPendingEventHandlers, addEventHandler , removeEventHandlers , addHostEventHandler, getHostEventHandlers @@ -24,7 +25,8 @@ module Techdraw.Internal.Svg.Env exposing @docs getLocalToWorld, getWarnings, getNFixDigits, getStyle @docs modStyle, applyStyleAtom @docs getDefs, modDefs -@docs concatTransform +@docs getInitLocalToWorld, getInitWorldToLocal +@docs setLocalToWorldTransform, setLocalToWorldTransformAsInit, concatTransform @docs getEventHandlers, hasPendingEventHandlers, addEventHandler @docs removeEventHandlers @docs addHostEventHandler, getHostEventHandlers @@ -48,7 +50,9 @@ import Techdraw.Types as T exposing (CSysName, Sizing(..)) -} type Env msg = Env - { localToWorld : AffineTransform + { sizing : Sizing + , initTransform : AffineTransform + , localToWorld : AffineTransform , warnings : List Warning , nFixDigits : NFixDigits , style : Style @@ -115,6 +119,41 @@ 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. @@ -233,8 +272,14 @@ unWarning (Warning str) = -} init : Sizing -> Env msg init sizing = + let + initTransform = + initLocalToWorld sizing + in Env - { localToWorld = initLocalToWorld sizing + { sizing = sizing + , initTransform = initTransform + , localToWorld = initTransform , warnings = [] , nFixDigits = NFixDigits 2 , style = Style.inheritAll @@ -282,7 +327,9 @@ which are threaded through the depthwise traversal of the tree. thread : Env msg -> Env msg -> Env msg thread (Env ancestor) (Env next) = Env - { localToWorld = ancestor.localToWorld + { sizing = ancestor.sizing + , initTransform = ancestor.initTransform + , localToWorld = ancestor.localToWorld , warnings = next.warnings , nFixDigits = ancestor.nFixDigits , style = ancestor.style diff --git a/src/Techdraw/Internal/Svg/Machine.elm b/src/Techdraw/Internal/Svg/Machine.elm index 12dbe7c..c406b54 100644 --- a/src/Techdraw/Internal/Svg/Machine.elm +++ b/src/Techdraw/Internal/Svg/Machine.elm @@ -28,10 +28,18 @@ import Techdraw.Internal.Dwg exposing (Dwg(..)) import Techdraw.Internal.Svg.Defs as Defs import Techdraw.Internal.Svg.Env as Env exposing (Env, Warning) import Techdraw.Internal.Svg.Event exposing (eventHandlersToSvgAttrs) +import Techdraw.Internal.Svg.Extras as Extras import Techdraw.Internal.Svg.Path as SvgPath import Techdraw.Internal.Svg.Style as SvgStyle +import Techdraw.Math as Math import Techdraw.Path as Path exposing (Path) -import Techdraw.Types as T exposing (ContainerSize, Sizing, ViewBox) +import Techdraw.Types as T + exposing + ( ContainerSize + , FrozenName(..) + , Sizing + , ViewBox + ) import TypedSvg import TypedSvg.Attributes as SvgA import TypedSvg.Core exposing (Svg) @@ -185,6 +193,7 @@ type Kont msg | KontAtop2 (List (Svg msg)) (Env msg) | KontBeneath1 (Dwg msg) (Env msg) | KontBeneath2 (List (Svg msg)) (Env msg) + | KontFrozen (Maybe FrozenName) (Env msg) {-| State in the state machine. @@ -301,6 +310,22 @@ step state = |> setExpr (Init drawing) |> modEnvr (Env.tagCSys cSysName) + {- Freeze a drawing: convert it to SVG at this point. -} + ( Init (DwgFrozen optName drawing), _ ) -> + state + |> suspendKont (KontFrozen optName) + |> modEnvr Env.setLocalToWorldTransformAsInit + |> setExpr (Init drawing) + + ( Init (DwgUse frozenName), _ ) -> + let + ( sAttrs, state1 ) = + styleAttrs state + in + state1 + |> setExpr (Fine <| useToSvg state.envr sAttrs frozenName) + |> modEnvr Env.removeEventHandlers + {- ----------------------------------------------------------------- -} {- Continuation states -} {- ----------------------------------------------------------------- -} @@ -352,6 +377,15 @@ step state = |> threadEnvr susEnv |> setExpr (Fine <| combineDrawings susEnv topSvgs bottomSvgs) + {- Process the "freeze" continuation. This attaches an optional ID + to the frozen drawing. + -} + ( Fine svgs, (KontFrozen optName susEnv) :: _ ) -> + state + |> popKont + |> threadEnvr susEnv + |> setExpr (Fine <| freezeWithOptionalId susEnv optName svgs) + {-| Set the expression in the state. -} @@ -426,6 +460,25 @@ pathToSvg env sAttrs path = attachPendingEvents env [ TypedSvg.path attrs [] ] +{-| Convert a "use" to SVG. +-} +useToSvg : Env msg -> List (Attribute msg) -> FrozenName -> List (Svg msg) +useToSvg env sAttrs (FrozenName name) = + attachPendingEvents env + [ TypedSvg.g + [ SvgA.transform + [ Extras.convertAffineTransformToSvg + (Math.affMatMul + (Env.getLocalToWorld env) + (Env.getInitWorldToLocal env) + ) + ] + ] + [ TypedSvg.use (SvgA.href ("#" ++ name) :: sAttrs) [] + ] + ] + + {-| Combine drawings in the specified order. -} combineDrawings : Env msg -> List (Svg msg) -> List (Svg msg) -> List (Svg msg) @@ -448,3 +501,37 @@ attachPendingEvents 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 + -> Maybe FrozenName + -> List (Svg msg) + -> List (Svg msg) +freezeWithOptionalId env optName svgs = + case optName of + Nothing -> + svgs + + Just (FrozenName name) -> + [ TypedSvg.g + [ SvgA.transform + -- Post-multiplying by inverse of initial transform. + [ Extras.convertAffineTransformToSvg + (Math.affMatMul + (Env.getLocalToWorld env) + (Env.getInitWorldToLocal env) + ) + ] + ] + [ TypedSvg.g + [ SvgA.id name ] + svgs + ] + ] diff --git a/src/Techdraw/Types.elm b/src/Techdraw/Types.elm index 8e1ca58..585e2b7 100644 --- a/src/Techdraw/Types.elm +++ b/src/Techdraw/Types.elm @@ -6,6 +6,7 @@ module Techdraw.Types exposing , viewBoxGetXMin, viewBoxGetYMin, viewBoxGetWidth, viewBoxGetHeight , Order(..) , CSysName(..) + , FrozenName(..) ) {-| Additional types. @@ -28,6 +29,7 @@ module Techdraw.Types exposing # Names @docs CSysName +@docs FrozenName -} @@ -199,3 +201,12 @@ type Order -} type CSysName = CSysName String + + +{-| Name of a frozen drawing. + +Let it go. + +-} +type FrozenName + = FrozenName String From b4caeb01f4a0670036ca6ca64e1a9afa989835f2 Mon Sep 17 00:00:00 2001 From: Jonathan Merritt Date: Sat, 7 Sep 2024 20:47:23 +1000 Subject: [PATCH 20/21] Allow frozen drawings to be hidden --- examples/hello-world/src/Main.elm | 8 +-- src/Techdraw.elm | 26 ++++++-- src/Techdraw/Internal/Dwg.elm | 4 +- src/Techdraw/Internal/Svg/Machine.elm | 85 +++++++++++++++++---------- src/Techdraw/Types.elm | 15 ++++- 5 files changed, 95 insertions(+), 43 deletions(-) diff --git a/examples/hello-world/src/Main.elm b/examples/hello-world/src/Main.elm index cc4601c..747b1c7 100644 --- a/examples/hello-world/src/Main.elm +++ b/examples/hello-world/src/Main.elm @@ -120,7 +120,7 @@ drawing (Model model) = } ) |> rectStyle - |> TD.freeze (Just (TT.FrozenName "frozen_rect")) + |> TD.freeze TT.Hidden (Just (TT.FrozenName "frozen_rect")) , TD.path (rectRounded { x = halfWidth - (1 - 0.2) * circleRadius @@ -139,12 +139,12 @@ drawing (Model model) = , TD.use (TT.FrozenName "frozen_rect") |> TD.translate (Math.v2 -(2 * circleRadius + 10) 0) ] - |> TD.freeze (Just (TT.FrozenName "rect_pair")) + |> 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 (Just (TT.FrozenName "triple")) + |> 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)) @@ -164,7 +164,7 @@ drawing (Model model) = ] |> TD.tagCSys (TT.CSysName "original") |> rectTransform (Model model) - |> TD.freeze Nothing + |> TD.freeze TT.Visible Nothing |> TD.onHostMouseMove (\(MouseInfo mouseInfo) -> mouseInfo.pointIn (TT.CSysName "original") |> MsgMouseMove diff --git a/src/Techdraw.elm b/src/Techdraw.elm index f7f65dc..db04e00 100644 --- a/src/Techdraw.elm +++ b/src/Techdraw.elm @@ -73,7 +73,14 @@ import Techdraw.Internal.Svg.Machine as DwgMachine import Techdraw.Math as Math exposing (AffineTransform, P2, V2) import Techdraw.Path exposing (Path) import Techdraw.Style as Style -import Techdraw.Types exposing (CSysName, FrozenName, Order(..), Sizing) +import Techdraw.Types + exposing + ( CSysName + , FrozenName + , Order(..) + , Sizing + , Visibility + ) @@ -274,10 +281,21 @@ scale scaleX scaleY = {-| 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 : Maybe FrozenName -> Drawing msg -> Drawing msg -freeze optName = - unDrawing >> DwgFrozen optName >> Drawing +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. diff --git a/src/Techdraw/Internal/Dwg.elm b/src/Techdraw/Internal/Dwg.elm index fe9f85c..28715e8 100644 --- a/src/Techdraw/Internal/Dwg.elm +++ b/src/Techdraw/Internal/Dwg.elm @@ -10,7 +10,7 @@ import Techdraw.Event exposing (EventHandler) import Techdraw.Internal.StyleAtom exposing (StyleAtom) import Techdraw.Math exposing (AffineTransform) import Techdraw.Path exposing (Path) -import Techdraw.Types exposing (CSysName, FrozenName) +import Techdraw.Types exposing (CSysName, FrozenName, Visibility) {-| Internal drawing type. @@ -25,5 +25,5 @@ type Dwg msg | DwgEventHandler (EventHandler msg) (Dwg msg) | DwgHostEventHandler (EventHandler msg) (Dwg msg) | DwgTagCSys CSysName (Dwg msg) - | DwgFrozen (Maybe FrozenName) (Dwg msg) + | DwgFrozen Visibility (Maybe FrozenName) (Dwg msg) | DwgUse FrozenName diff --git a/src/Techdraw/Internal/Svg/Machine.elm b/src/Techdraw/Internal/Svg/Machine.elm index c406b54..8d1b77b 100644 --- a/src/Techdraw/Internal/Svg/Machine.elm +++ b/src/Techdraw/Internal/Svg/Machine.elm @@ -39,10 +39,12 @@ import Techdraw.Types as T , FrozenName(..) , Sizing , ViewBox + , Visibility(..) ) import TypedSvg import TypedSvg.Attributes as SvgA import TypedSvg.Core exposing (Svg) +import TypedSvg.Types as SvgTypes @@ -193,7 +195,7 @@ type Kont msg | KontAtop2 (List (Svg msg)) (Env msg) | KontBeneath1 (Dwg msg) (Env msg) | KontBeneath2 (List (Svg msg)) (Env msg) - | KontFrozen (Maybe FrozenName) (Env msg) + | KontFrozen Visibility (Maybe FrozenName) (Env msg) {-| State in the state machine. @@ -238,7 +240,12 @@ step : State msg -> State msg step state = case ( state.expr, state.kont ) of {- ----------------------------------------------------------------- -} - {- Terminal state -} + {- 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 @@ -253,11 +260,11 @@ step state = {- Draw a Path. -} ( Init (DwgPath path), _ ) -> let - ( sAttrs, state1 ) = - styleAttrs state + ( styleAttrs, state1 ) = + stateToStyleAttrs state in state1 - |> setExpr (Fine (pathToSvg state.envr sAttrs path)) + |> setExpr (Fine (pathToSvg state.envr styleAttrs path)) |> modEnvr Env.removeEventHandlers {- Update the style in the environment. -} @@ -311,19 +318,19 @@ step state = |> modEnvr (Env.tagCSys cSysName) {- Freeze a drawing: convert it to SVG at this point. -} - ( Init (DwgFrozen optName drawing), _ ) -> + ( Init (DwgFrozen visibility optName drawing), _ ) -> state - |> suspendKont (KontFrozen optName) + |> suspendKont (KontFrozen visibility optName) |> modEnvr Env.setLocalToWorldTransformAsInit |> setExpr (Init drawing) ( Init (DwgUse frozenName), _ ) -> let - ( sAttrs, state1 ) = - styleAttrs state + ( styleAttrs, state1 ) = + stateToStyleAttrs state in state1 - |> setExpr (Fine <| useToSvg state.envr sAttrs frozenName) + |> setExpr (Fine <| useToSvg state.envr styleAttrs frozenName) |> modEnvr Env.removeEventHandlers {- ----------------------------------------------------------------- -} @@ -380,11 +387,14 @@ step state = {- Process the "freeze" continuation. This attaches an optional ID to the frozen drawing. -} - ( Fine svgs, (KontFrozen optName susEnv) :: _ ) -> + ( Fine svgs, (KontFrozen visibility optName susEnv) :: _ ) -> state |> popKont |> threadEnvr susEnv - |> setExpr (Fine <| freezeWithOptionalId susEnv optName svgs) + |> setExpr + (Fine <| + freezeWithOptionalId susEnv visibility optName svgs + ) {-| Set the expression in the state. @@ -431,8 +441,8 @@ popKont oldState = {-| Get the style attributes for the current state's style. -} -styleAttrs : State msg -> ( List (Attribute msg), State msg ) -styleAttrs state = +stateToStyleAttrs : State msg -> ( List (Attribute msg), State msg ) +stateToStyleAttrs state = let ( attrs, childEnv ) = SvgStyle.envStyleToSvg state.envr @@ -443,19 +453,20 @@ styleAttrs state = {-| Convert a `Path` to SVG in the current environment. -} pathToSvg : Env msg -> List (Attribute msg) -> Path -> List (Svg msg) -pathToSvg env sAttrs path = +pathToSvg env styleAttrs path = let - l2w = + localToWorld = Env.getLocalToWorld env - nfd = + numFixedDigits = Env.getNFixDigits env str = - Path.pathApplyAffineTransform l2w path |> SvgPath.toString nfd + Path.pathApplyAffineTransform localToWorld path + |> SvgPath.toString numFixedDigits attrs = - SvgA.d str :: sAttrs + SvgA.d str :: styleAttrs in attachPendingEvents env [ TypedSvg.path attrs [] ] @@ -463,10 +474,11 @@ pathToSvg env sAttrs path = {-| Convert a "use" to SVG. -} useToSvg : Env msg -> List (Attribute msg) -> FrozenName -> List (Svg msg) -useToSvg env sAttrs (FrozenName name) = +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) @@ -474,7 +486,7 @@ useToSvg env sAttrs (FrozenName name) = ) ] ] - [ TypedSvg.use (SvgA.href ("#" ++ name) :: sAttrs) [] + [ TypedSvg.use (SvgA.href ("#" ++ name) :: styleAttrs) [] ] ] @@ -511,25 +523,36 @@ attachPendingEvents env svgs = -} freezeWithOptionalId : Env msg + -> Visibility -> Maybe FrozenName -> List (Svg msg) -> List (Svg msg) -freezeWithOptionalId env optName svgs = +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 - [ SvgA.transform - -- Post-multiplying by inverse of initial transform. - [ Extras.convertAffineTransformToSvg - (Math.affMatMul - (Env.getLocalToWorld env) - (Env.getInitWorldToLocal env) - ) - ] - ] + attrs [ TypedSvg.g [ SvgA.id name ] svgs diff --git a/src/Techdraw/Types.elm b/src/Techdraw/Types.elm index 585e2b7..b2d1b8c 100644 --- a/src/Techdraw/Types.elm +++ b/src/Techdraw/Types.elm @@ -4,7 +4,7 @@ module Techdraw.Types exposing , sizingGetViewBox, sizingGetContainerSize , containerSizeGetWidth, containerSizeGetHeight , viewBoxGetXMin, viewBoxGetYMin, viewBoxGetWidth, viewBoxGetHeight - , Order(..) + , Order(..), Visibility(..) , CSysName(..) , FrozenName(..) ) @@ -23,7 +23,7 @@ module Techdraw.Types exposing # Drawing Order -@docs Order +@docs Order, Visibility # Names @@ -194,6 +194,17 @@ type Order +---- Visibility --------------------------------------------------------------- + + +{-| Visibility of an item. +-} +type Visibility + = Visible + | Hidden + + + ---- Names -------------------------------------------------------------------- From 4e59f821a97657fa77066ceafeb130f15fffcc9e Mon Sep 17 00:00:00 2001 From: Jonathan Merritt Date: Sat, 7 Sep 2024 20:59:26 +1000 Subject: [PATCH 21/21] Rename Techdraw -> Depict --- elm.json | 40 +++++++++---------- examples/hello-world/src/Main.elm | 12 +++--- src/{Techdraw.elm => Depict.elm} | 20 +++++----- src/{Techdraw => Depict}/Event.elm | 6 +-- .../Internal/CSysDict.elm | 6 +-- src/{Techdraw => Depict}/Internal/Dwg.elm | 12 +++--- src/{Techdraw => Depict}/Internal/Hash.elm | 4 +- .../Internal/StyleAtom.elm | 4 +- .../Internal/Svg/Defs.elm | 14 +++---- src/{Techdraw => Depict}/Internal/Svg/Env.elm | 18 ++++----- .../Internal/Svg/Event.elm | 14 +++---- .../Internal/Svg/Extras.elm | 4 +- .../Internal/Svg/Machine.elm | 26 ++++++------ .../Internal/Svg/Path.elm | 8 ++-- .../Internal/Svg/Style.elm | 10 ++--- src/{Techdraw => Depict}/Math.elm | 4 +- src/{Techdraw => Depict}/Path.elm | 4 +- src/{Techdraw => Depict}/PathBuilder.elm | 8 ++-- src/{Techdraw => Depict}/Shapes/Simple.elm | 6 +-- src/{Techdraw => Depict}/Shapes/Spring.elm | 8 ++-- src/{Techdraw => Depict}/Style.elm | 6 +-- src/{Techdraw => Depict}/Types.elm | 2 +- tests/{Techdraw => Depict}/Anticipate.elm | 2 +- tests/{Techdraw => Depict}/Math/Compare.elm | 6 +-- tests/{Techdraw => Depict}/Math/Fuzzer.elm | 4 +- tests/{Techdraw => Depict}/Path/Compare.elm | 10 ++--- tests/{Techdraw => Depict}/Path/Fuzzer.elm | 10 ++--- tests/{Techdraw => Depict}/TestMath.elm | 10 ++--- tests/{Techdraw => Depict}/TestPath.elm | 14 +++---- tests/{Techdraw => Depict}/Util.elm | 2 +- tests/Suite.elm | 8 ++-- 31 files changed, 151 insertions(+), 151 deletions(-) rename src/{Techdraw.elm => Depict.elm} (96%) rename src/{Techdraw => Depict}/Event.elm (95%) rename src/{Techdraw => Depict}/Internal/CSysDict.elm (91%) rename src/{Techdraw => Depict}/Internal/Dwg.elm (63%) rename src/{Techdraw => Depict}/Internal/Hash.elm (98%) rename src/{Techdraw => Depict}/Internal/StyleAtom.elm (91%) rename src/{Techdraw => Depict}/Internal/Svg/Defs.elm (94%) rename src/{Techdraw => Depict}/Internal/Svg/Env.elm (94%) rename src/{Techdraw => Depict}/Internal/Svg/Event.elm (94%) rename src/{Techdraw => Depict}/Internal/Svg/Extras.elm (89%) rename src/{Techdraw => Depict}/Internal/Svg/Machine.elm (96%) rename src/{Techdraw => Depict}/Internal/Svg/Path.elm (98%) rename src/{Techdraw => Depict}/Internal/Svg/Style.elm (96%) rename src/{Techdraw => Depict}/Math.elm (99%) rename src/{Techdraw => Depict}/Path.elm (99%) rename src/{Techdraw => Depict}/PathBuilder.elm (98%) rename src/{Techdraw => Depict}/Shapes/Simple.elm (97%) rename src/{Techdraw => Depict}/Shapes/Spring.elm (97%) rename src/{Techdraw => Depict}/Style.elm (98%) rename src/{Techdraw => Depict}/Types.elm (99%) rename tests/{Techdraw => Depict}/Anticipate.elm (99%) rename tests/{Techdraw => Depict}/Math/Compare.elm (97%) rename tests/{Techdraw => Depict}/Math/Fuzzer.elm (98%) rename tests/{Techdraw => Depict}/Path/Compare.elm (76%) rename tests/{Techdraw => Depict}/Path/Fuzzer.elm (97%) rename tests/{Techdraw => Depict}/TestMath.elm (98%) rename tests/{Techdraw => Depict}/TestPath.elm (72%) rename tests/{Techdraw => Depict}/Util.elm (91%) diff --git a/elm.json b/elm.json index d3e14cd..b4591b9 100644 --- a/elm.json +++ b/elm.json @@ -5,26 +5,26 @@ "license": "BSD-3-Clause", "version": "1.0.0", "exposed-modules": [ - "Techdraw", - "Techdraw.Event", - "Techdraw.Math", - "Techdraw.Path", - "Techdraw.PathBuilder", - "Techdraw.Style", - "Techdraw.Types", - "Techdraw.Shapes.Simple", - "Techdraw.Shapes.Spring", - "Techdraw.Internal.CSysDict", - "Techdraw.Internal.Dwg", - "Techdraw.Internal.Hash", - "Techdraw.Internal.StyleAtom", - "Techdraw.Internal.Svg.Defs", - "Techdraw.Internal.Svg.Env", - "Techdraw.Internal.Svg.Event", - "Techdraw.Internal.Svg.Extras", - "Techdraw.Internal.Svg.Machine", - "Techdraw.Internal.Svg.Path", - "Techdraw.Internal.Svg.Style" + "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", diff --git a/examples/hello-world/src/Main.elm b/examples/hello-world/src/Main.elm index 747b1c7..cf7950b 100644 --- a/examples/hello-world/src/Main.elm +++ b/examples/hello-world/src/Main.elm @@ -2,15 +2,15 @@ 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 -import Techdraw as TD exposing (Drawing) -import Techdraw.Event exposing (MouseInfo(..)) -import Techdraw.Math as Math exposing (P2, p2) -import Techdraw.Shapes.Simple exposing (circle, rectRounded) -import Techdraw.Style as Style exposing (LinearGradient, Stop(..)) -import Techdraw.Types as TT type Model diff --git a/src/Techdraw.elm b/src/Depict.elm similarity index 96% rename from src/Techdraw.elm rename to src/Depict.elm index db04e00..8dd1abe 100644 --- a/src/Techdraw.elm +++ b/src/Depict.elm @@ -1,4 +1,4 @@ -module Techdraw exposing +module Depict exposing ( Drawing , empty, path, atop, beneath, stack , fill, fillRule, stroke, strokeWidth, lineCap, lineJoin @@ -65,15 +65,14 @@ module Techdraw exposing -} -import Html exposing (Html) -import Techdraw.Event as Event exposing (EventHandler, MouseInfo) -import Techdraw.Internal.Dwg exposing (Dwg(..)) -import Techdraw.Internal.StyleAtom as StyleAtom exposing (StyleAtom) -import Techdraw.Internal.Svg.Machine as DwgMachine -import Techdraw.Math as Math exposing (AffineTransform, P2, V2) -import Techdraw.Path exposing (Path) -import Techdraw.Style as Style -import Techdraw.Types +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 @@ -81,6 +80,7 @@ import Techdraw.Types , Sizing , Visibility ) +import Html exposing (Html) diff --git a/src/Techdraw/Event.elm b/src/Depict/Event.elm similarity index 95% rename from src/Techdraw/Event.elm rename to src/Depict/Event.elm index b9f8230..1a4993d 100644 --- a/src/Techdraw/Event.elm +++ b/src/Depict/Event.elm @@ -1,4 +1,4 @@ -module Techdraw.Event exposing +module Depict.Event exposing ( EventHandler(..) , MouseHandler(..), MouseInfo(..) , Buttons, BState(..), Modifiers, KState(..) @@ -14,8 +14,8 @@ module Techdraw.Event exposing -} -import Techdraw.Math exposing (P2) -import Techdraw.Types exposing (CSysName) +import Depict.Math exposing (P2) +import Depict.Types exposing (CSysName) {-| All event handler types. diff --git a/src/Techdraw/Internal/CSysDict.elm b/src/Depict/Internal/CSysDict.elm similarity index 91% rename from src/Techdraw/Internal/CSysDict.elm rename to src/Depict/Internal/CSysDict.elm index 66851c7..384e569 100644 --- a/src/Techdraw/Internal/CSysDict.elm +++ b/src/Depict/Internal/CSysDict.elm @@ -1,4 +1,4 @@ -module Techdraw.Internal.CSysDict exposing +module Depict.Internal.CSysDict exposing ( CSysDict , empty, insertLocalToWorld, getLocalToWorld, getWorldToLocal , inCSys @@ -12,9 +12,9 @@ module Techdraw.Internal.CSysDict exposing -} +import Depict.Math as Math exposing (AffineTransform, P2) +import Depict.Types exposing (CSysName(..)) import Dict exposing (Dict) -import Techdraw.Math as Math exposing (AffineTransform, P2) -import Techdraw.Types exposing (CSysName(..)) {-| Map from the names of coordinate systems to their local-to-world diff --git a/src/Techdraw/Internal/Dwg.elm b/src/Depict/Internal/Dwg.elm similarity index 63% rename from src/Techdraw/Internal/Dwg.elm rename to src/Depict/Internal/Dwg.elm index 28715e8..faa5283 100644 --- a/src/Techdraw/Internal/Dwg.elm +++ b/src/Depict/Internal/Dwg.elm @@ -1,4 +1,4 @@ -module Techdraw.Internal.Dwg exposing (Dwg(..)) +module Depict.Internal.Dwg exposing (Dwg(..)) {-| Internal sum type representing drawings. @@ -6,11 +6,11 @@ module Techdraw.Internal.Dwg exposing (Dwg(..)) -} -import Techdraw.Event exposing (EventHandler) -import Techdraw.Internal.StyleAtom exposing (StyleAtom) -import Techdraw.Math exposing (AffineTransform) -import Techdraw.Path exposing (Path) -import Techdraw.Types exposing (CSysName, FrozenName, Visibility) +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. diff --git a/src/Techdraw/Internal/Hash.elm b/src/Depict/Internal/Hash.elm similarity index 98% rename from src/Techdraw/Internal/Hash.elm rename to src/Depict/Internal/Hash.elm index c6da47d..3159983 100644 --- a/src/Techdraw/Internal/Hash.elm +++ b/src/Depict/Internal/Hash.elm @@ -1,4 +1,4 @@ -module Techdraw.Internal.Hash exposing +module Depict.Internal.Hash exposing ( Hash, Hasher, Manifest, Encoder , toHex , fromEncoder @@ -64,8 +64,8 @@ running a SHA1 algorithm over the blob to produce a hash. 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 -import Techdraw.Math as Math exposing (AffineTransform, M22, P2, V2) diff --git a/src/Techdraw/Internal/StyleAtom.elm b/src/Depict/Internal/StyleAtom.elm similarity index 91% rename from src/Techdraw/Internal/StyleAtom.elm rename to src/Depict/Internal/StyleAtom.elm index d7ae138..38770d7 100644 --- a/src/Techdraw/Internal/StyleAtom.elm +++ b/src/Depict/Internal/StyleAtom.elm @@ -1,4 +1,4 @@ -module Techdraw.Internal.StyleAtom exposing (StyleAtom(..), apply) +module Depict.Internal.StyleAtom exposing (StyleAtom(..), apply) {-| Individual component of a Style. @@ -10,7 +10,7 @@ little memory as possible. -} -import Techdraw.Style as Style exposing (Style) +import Depict.Style as Style exposing (Style) {-| Individual component of a `Style`. diff --git a/src/Techdraw/Internal/Svg/Defs.elm b/src/Depict/Internal/Svg/Defs.elm similarity index 94% rename from src/Techdraw/Internal/Svg/Defs.elm rename to src/Depict/Internal/Svg/Defs.elm index 1dfbf39..6b8f497 100644 --- a/src/Techdraw/Internal/Svg/Defs.elm +++ b/src/Depict/Internal/Svg/Defs.elm @@ -1,4 +1,4 @@ -module Techdraw.Internal.Svg.Defs exposing +module Depict.Internal.Svg.Defs exposing ( Defs , empty , ensureLinearGradient, ensureRadialGradient @@ -16,17 +16,17 @@ document. -} import Color -import Dict exposing (Dict) -import Techdraw.Internal.Hash as Hash exposing (Hasher) -import Techdraw.Internal.Svg.Extras as Extras -import Techdraw.Internal.Svg.Path as SvgPath -import Techdraw.Math as Math -import Techdraw.Style as Style +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) diff --git a/src/Techdraw/Internal/Svg/Env.elm b/src/Depict/Internal/Svg/Env.elm similarity index 94% rename from src/Techdraw/Internal/Svg/Env.elm rename to src/Depict/Internal/Svg/Env.elm index 5fcdee3..5a13a77 100644 --- a/src/Techdraw/Internal/Svg/Env.elm +++ b/src/Depict/Internal/Svg/Env.elm @@ -1,4 +1,4 @@ -module Techdraw.Internal.Svg.Env exposing +module Depict.Internal.Svg.Env exposing ( Env , Warning , EventHandlerCapturedEnv(..) @@ -36,14 +36,14 @@ module Techdraw.Internal.Svg.Env exposing -} -import Techdraw.Event exposing (EventHandler) -import Techdraw.Internal.CSysDict as CSysDict exposing (CSysDict) -import Techdraw.Internal.StyleAtom as StyleAtom exposing (StyleAtom) -import Techdraw.Internal.Svg.Defs as Defs exposing (Defs) -import Techdraw.Internal.Svg.Path exposing (NFixDigits(..)) -import Techdraw.Math as Math exposing (AffineTransform) -import Techdraw.Style as Style exposing (Style) -import Techdraw.Types as T exposing (CSysName, Sizing(..)) +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. diff --git a/src/Techdraw/Internal/Svg/Event.elm b/src/Depict/Internal/Svg/Event.elm similarity index 94% rename from src/Techdraw/Internal/Svg/Event.elm rename to src/Depict/Internal/Svg/Event.elm index 204392e..02287bf 100644 --- a/src/Techdraw/Internal/Svg/Event.elm +++ b/src/Depict/Internal/Svg/Event.elm @@ -1,4 +1,4 @@ -module Techdraw.Internal.Svg.Event exposing (eventHandlersToSvgAttrs) +module Depict.Internal.Svg.Event exposing (eventHandlersToSvgAttrs) {-| Conversion of events to SVG. @@ -7,9 +7,7 @@ module Techdraw.Internal.Svg.Event exposing (eventHandlersToSvgAttrs) -} import Bitwise exposing (and, shiftLeftBy) -import Html.Events as HtmlEvents -import Json.Decode as D exposing (Decoder) -import Techdraw.Event +import Depict.Event exposing ( BState(..) , Buttons @@ -19,9 +17,11 @@ import Techdraw.Event , MouseHandler(..) , MouseInfo(..) ) -import Techdraw.Internal.CSysDict as CSysDict exposing (CSysDict) -import Techdraw.Internal.Svg.Env exposing (EventHandlerCapturedEnv(..)) -import Techdraw.Math as Math exposing (AffineTransform, P2) +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) diff --git a/src/Techdraw/Internal/Svg/Extras.elm b/src/Depict/Internal/Svg/Extras.elm similarity index 89% rename from src/Techdraw/Internal/Svg/Extras.elm rename to src/Depict/Internal/Svg/Extras.elm index cdd63ef..f88734c 100644 --- a/src/Techdraw/Internal/Svg/Extras.elm +++ b/src/Depict/Internal/Svg/Extras.elm @@ -1,4 +1,4 @@ -module Techdraw.Internal.Svg.Extras exposing (convertAffineTransformToSvg) +module Depict.Internal.Svg.Extras exposing (convertAffineTransformToSvg) {-| Extra SVG conversions that don't belong somewhere more specific. @@ -6,7 +6,7 @@ module Techdraw.Internal.Svg.Extras exposing (convertAffineTransformToSvg) -} -import Techdraw.Math +import Depict.Math exposing ( AffineTransform , affGetLinear diff --git a/src/Techdraw/Internal/Svg/Machine.elm b/src/Depict/Internal/Svg/Machine.elm similarity index 96% rename from src/Techdraw/Internal/Svg/Machine.elm rename to src/Depict/Internal/Svg/Machine.elm index 8d1b77b..b8a5576 100644 --- a/src/Techdraw/Internal/Svg/Machine.elm +++ b/src/Depict/Internal/Svg/Machine.elm @@ -1,4 +1,4 @@ -module Techdraw.Internal.Svg.Machine exposing +module Depict.Internal.Svg.Machine exposing ( ToSvgResult , svgResultGetHtml, svgResultGetWarnings, svgResultTuple , toSvg @@ -22,18 +22,16 @@ This module implements a largely non-recursive state machine to evaluate a -} -import Html exposing (Attribute, Html) -import Html.Attributes as HtmlA -import Techdraw.Internal.Dwg exposing (Dwg(..)) -import Techdraw.Internal.Svg.Defs as Defs -import Techdraw.Internal.Svg.Env as Env exposing (Env, Warning) -import Techdraw.Internal.Svg.Event exposing (eventHandlersToSvgAttrs) -import Techdraw.Internal.Svg.Extras as Extras -import Techdraw.Internal.Svg.Path as SvgPath -import Techdraw.Internal.Svg.Style as SvgStyle -import Techdraw.Math as Math -import Techdraw.Path as Path exposing (Path) -import Techdraw.Types as T +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(..) @@ -41,6 +39,8 @@ import Techdraw.Types as T , ViewBox , Visibility(..) ) +import Html exposing (Attribute, Html) +import Html.Attributes as HtmlA import TypedSvg import TypedSvg.Attributes as SvgA import TypedSvg.Core exposing (Svg) diff --git a/src/Techdraw/Internal/Svg/Path.elm b/src/Depict/Internal/Svg/Path.elm similarity index 98% rename from src/Techdraw/Internal/Svg/Path.elm rename to src/Depict/Internal/Svg/Path.elm index 0c17984..1f177da 100644 --- a/src/Techdraw/Internal/Svg/Path.elm +++ b/src/Depict/Internal/Svg/Path.elm @@ -1,4 +1,4 @@ -module Techdraw.Internal.Svg.Path exposing +module Depict.Internal.Svg.Path exposing ( toString , NFixDigits(..) , toFixed @@ -19,9 +19,8 @@ module Techdraw.Internal.Svg.Path 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 @@ -33,6 +32,7 @@ import Techdraw.Path as P , Start , SubPath ) +import List.Nonempty as Nonempty exposing (Nonempty) {-| String representation of an SVG path. diff --git a/src/Techdraw/Internal/Svg/Style.elm b/src/Depict/Internal/Svg/Style.elm similarity index 96% rename from src/Techdraw/Internal/Svg/Style.elm rename to src/Depict/Internal/Svg/Style.elm index 267353b..7f297c8 100644 --- a/src/Techdraw/Internal/Svg/Style.elm +++ b/src/Depict/Internal/Svg/Style.elm @@ -1,4 +1,4 @@ -module Techdraw.Internal.Svg.Style exposing (envStyleToSvg) +module Depict.Internal.Svg.Style exposing (envStyleToSvg) {-| Styling in SVG. @@ -6,10 +6,10 @@ module Techdraw.Internal.Svg.Style exposing (envStyleToSvg) -} -import Techdraw.Internal.Hash as Hash -import Techdraw.Internal.Svg.Defs as Defs -import Techdraw.Internal.Svg.Env as Env exposing (Env) -import Techdraw.Style as Style +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 diff --git a/src/Techdraw/Math.elm b/src/Depict/Math.elm similarity index 99% rename from src/Techdraw/Math.elm rename to src/Depict/Math.elm index 4712c69..02472e5 100644 --- a/src/Techdraw/Math.elm +++ b/src/Depict/Math.elm @@ -1,4 +1,4 @@ -module Techdraw.Math exposing +module Depict.Math exposing ( sq, toRadians, toDegrees , Tol(..), closeFloat , Angle2Pi, AnglePi, OrientationPi @@ -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) 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/Techdraw/Style.elm b/src/Depict/Style.elm similarity index 98% rename from src/Techdraw/Style.elm rename to src/Depict/Style.elm index c5d94b7..28ccebe 100644 --- a/src/Techdraw/Style.elm +++ b/src/Depict/Style.elm @@ -1,4 +1,4 @@ -module Techdraw.Style exposing +module Depict.Style exposing ( Style(..) , Option(..) , Fill(..) @@ -79,8 +79,8 @@ module Techdraw.Style exposing -} import Color exposing (Color) -import Techdraw.Internal.Hash as Hash exposing (Hash, Hasher) -import Techdraw.Math as Math exposing (AffineTransform, P2) +import Depict.Internal.Hash as Hash exposing (Hash, Hasher) +import Depict.Math as Math exposing (AffineTransform, P2) diff --git a/src/Techdraw/Types.elm b/src/Depict/Types.elm similarity index 99% rename from src/Techdraw/Types.elm rename to src/Depict/Types.elm index b2d1b8c..f7a2278 100644 --- a/src/Techdraw/Types.elm +++ b/src/Depict/Types.elm @@ -1,4 +1,4 @@ -module Techdraw.Types exposing +module Depict.Types exposing ( Sizing(..), ViewBox(..), ContainerSize(..) , sizingScaled, sizingWH , sizingGetViewBox, sizingGetContainerSize 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 ]