Controls of the program's own, drawn with a pen
A component draws itself with (bjogui draw), a pen over Avalonia's DrawingContext, and hears the pointer, the wheel, the keys and the focus. It keeps a state of its own between inputs, and sends outputs that drawn makes the app's messages. It is drawn again only when its value, its state or its size changes, and no Avalonia class is subclassed: the picture is a DrawingImage on a canvas. start-headless! sets Avalonia up with no screen, drawing with Skia, so tests/components.bjo draws components and reads their pixels. The mixer example has knobs and a timeline. 🤖 Generated with [ECA](https://eca.dev) (anthropic/claude-opus-4-8) Co-Authored-By: eca-agent <git@eca.dev>
This commit is contained in:
parent
5379269f43
commit
5237bf3273
9 changed files with 1482 additions and 33 deletions
437
src/draw.bjo
Normal file
437
src/draw.bjo
Normal file
|
|
@ -0,0 +1,437 @@
|
|||
;; This Source Code Form is subject to the terms of the Mozilla Public
|
||||
;; License, v. 2.0. If a copy of the MPL was not distributed with this
|
||||
;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
|
||||
|
||||
;; bjogui/src/draw.bjo — the module (bjogui draw).
|
||||
;;
|
||||
;; Drawing with a pen: what a component made by `component` in (bjogui view)
|
||||
;; draws itself with. Each function draws at once, on top of what is drawn
|
||||
;; before it, in the component's own coordinates: 0, 0 is its top left
|
||||
;; corner, x grows to the right and y down, in pixels.
|
||||
;;
|
||||
;; A colour is a string, as everywhere in bjogui: a name such as "red", or
|
||||
;; "#rgb", "#rrggbb" or "#aarrggbb". The empty string, and a colour that
|
||||
;; cannot be read, draw nothing. An angle is in radians, as `sin` and `cos`
|
||||
;; of (std maths) take it, and grows clockwise from the right, because y
|
||||
;; grows down.
|
||||
;;
|
||||
;; The pen is Avalonia's DrawingContext, so a drawing is vectors: it is sharp
|
||||
;; at any scale of the screen.
|
||||
|
||||
(export
|
||||
Pen
|
||||
;; Shapes.
|
||||
fill-rect stroke-rect fill-circle stroke-circle fill-ellipse stroke-ellipse
|
||||
stroke-line stroke-polyline fill-polygon stroke-arc fill-path stroke-path
|
||||
;; Text and pictures.
|
||||
draw-text text-size draw-image
|
||||
;; What is drawn inside a function, moved, turned, cut or faded.
|
||||
translated scaled rotated clipped faded
|
||||
;; For (bjogui app): a drawing, as the picture an Image shows.
|
||||
drawing-image)
|
||||
|
||||
(import (std prelude))
|
||||
(import (std maths))
|
||||
(import (std interop))
|
||||
(import (std mutable map))
|
||||
|
||||
(import/class
|
||||
(Object (: System.Object))
|
||||
(Disposable (: System.IDisposable))
|
||||
(Culture (: System.Globalization.CultureInfo))
|
||||
(IBrush (: Avalonia.Media.IBrush))
|
||||
(IPen (: Avalonia.Media.IPen))
|
||||
(AvPen (: Avalonia.Media.Pen (-> IBrush double IDashStyle LineCap LineJoin double AvPen)))
|
||||
(IDashStyle (: Avalonia.Media.IDashStyle))
|
||||
(DashStyle (: Avalonia.Media.DashStyle (-> (Seq double) double DashStyle)))
|
||||
(LineCap (: Avalonia.Media.PenLineCap))
|
||||
(LineJoin (: Avalonia.Media.PenLineJoin))
|
||||
(BoxShadows (: Avalonia.Media.BoxShadows))
|
||||
(Rect (: Avalonia.Rect (-> double double double double Rect)))
|
||||
(Point (: Avalonia.Point (-> double double Point)))
|
||||
(Size (: Avalonia.Size (-> double double Size)))
|
||||
(Matrix (: Avalonia.Matrix))
|
||||
(Geometry (: Avalonia.Media.Geometry))
|
||||
(RectGeometry (: Avalonia.Media.RectangleGeometry (-> Rect double double RectGeometry)))
|
||||
(StreamGeometry (: Avalonia.Media.StreamGeometry (-> StreamGeometry)))
|
||||
(GeometryContext (: Avalonia.Media.StreamGeometryContext))
|
||||
(Sweep (: Avalonia.Media.SweepDirection))
|
||||
(DrawingGroup (: Avalonia.Media.DrawingGroup (-> DrawingGroup)))
|
||||
(DrawingImage (: Avalonia.Media.DrawingImage (-> Drawing DrawingImage)))
|
||||
(Drawing (: Avalonia.Media.Drawing))
|
||||
(DrawingContext (: Avalonia.Media.DrawingContext))
|
||||
(PushedState (: Avalonia.Media.DrawingContext.PushedState))
|
||||
(IImage (: Avalonia.Media.IImage))
|
||||
(Bitmap (: Avalonia.Media.Imaging.Bitmap (-> string Bitmap)))
|
||||
(FontFamily (: Avalonia.Media.FontFamily (-> string FontFamily)))
|
||||
(FontStyle (: Avalonia.Media.FontStyle))
|
||||
(FontWeight (: Avalonia.Media.FontWeight))
|
||||
(FontStretch (: Avalonia.Media.FontStretch))
|
||||
(Typeface (: Avalonia.Media.Typeface (-> FontFamily FontStyle FontWeight FontStretch Typeface)))
|
||||
(FlowDirection (: Avalonia.Media.FlowDirection))
|
||||
(FormattedText (: Avalonia.Media.FormattedText
|
||||
(-> string Culture FlowDirection Typeface double IBrush FormattedText))))
|
||||
|
||||
(import/extern
|
||||
(parse-brush (: Avalonia.Media.Brush.Parse (-> string IBrush)))
|
||||
(parse-geometry (: Avalonia.Media.Geometry.Parse (-> string Geometry)))
|
||||
(open-group (: Avalonia.Media.DrawingGroup.Open (-> DrawingGroup DrawingContext)))
|
||||
(bounds-of (: Avalonia.Media.Drawing.GetBounds (-> Drawing Rect)))
|
||||
(rect-x (: Avalonia.Rect.X (-> Rect double) #:get))
|
||||
(rect-y (: Avalonia.Rect.Y (-> Rect double) #:get))
|
||||
(open-geometry (: Avalonia.Media.StreamGeometry.Open (-> StreamGeometry GeometryContext)))
|
||||
(begin-figure! (: Avalonia.Media.StreamGeometryContext.BeginFigure (-> GeometryContext Point bool void)))
|
||||
(line-to! (: Avalonia.Media.StreamGeometryContext.LineTo (-> GeometryContext Point void)))
|
||||
(arc-to! (: Avalonia.Media.StreamGeometryContext.ArcTo
|
||||
(-> GeometryContext Point Size double bool Sweep void)))
|
||||
(end-figure! (: Avalonia.Media.StreamGeometryContext.EndFigure (-> GeometryContext bool void)))
|
||||
(dc-rect (: Avalonia.Media.DrawingContext.DrawRectangle
|
||||
(-> DrawingContext IBrush IPen Rect double double BoxShadows void)))
|
||||
(dc-ellipse (: Avalonia.Media.DrawingContext.DrawEllipse
|
||||
(-> DrawingContext IBrush IPen Point double double void)))
|
||||
(dc-line (: Avalonia.Media.DrawingContext.DrawLine (-> DrawingContext IPen Point Point void)))
|
||||
(dc-geometry (: Avalonia.Media.DrawingContext.DrawGeometry
|
||||
(-> DrawingContext IBrush IPen Geometry void)))
|
||||
(dc-text (: Avalonia.Media.DrawingContext.DrawText (-> DrawingContext FormattedText Point void)))
|
||||
(dc-image (: Avalonia.Media.DrawingContext.DrawImage (-> DrawingContext IImage Rect void)))
|
||||
(push-transform (: Avalonia.Media.DrawingContext.PushTransform (-> DrawingContext Matrix PushedState)))
|
||||
(push-clip (: Avalonia.Media.DrawingContext.PushClip (-> DrawingContext Rect PushedState)))
|
||||
(push-opacity (: Avalonia.Media.DrawingContext.PushOpacity (-> DrawingContext double PushedState)))
|
||||
(pop! (: Avalonia.Media.DrawingContext.PushedState.Dispose (-> PushedState void)))
|
||||
(translation (: Avalonia.Matrix.CreateTranslation (-> double double Matrix)))
|
||||
(scaling (: Avalonia.Matrix.CreateScale (-> double double Matrix)))
|
||||
(rotation (: Avalonia.Matrix.CreateRotation (-> double Point Matrix)))
|
||||
(text-width (: Avalonia.Media.FormattedText.Width (-> FormattedText double) #:get))
|
||||
(text-height (: Avalonia.Media.FormattedText.Height (-> FormattedText double) #:get))
|
||||
(max-text-width! (: Avalonia.Media.FormattedText.MaxTextWidth (-> FormattedText double void) #:set))
|
||||
(default-family (: Avalonia.Media.FontFamily.Default #:get))
|
||||
(invariant (: System.Globalization.CultureInfo.InvariantCulture #:get))
|
||||
(dispose! (: System.IDisposable.Dispose (-> Disposable void))))
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; The pen
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
;; What a component draws with, for as long as its `#:draw` function runs.
|
||||
(type (: Pen #:opaque (Record (: dc DrawingContext))))
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; What is read once
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
;; Colours, paths, pictures and fonts are read once each and kept, because a
|
||||
;; component draws them again on each change. A table that grows past its
|
||||
;; limit is emptied, so a program that makes new paths all the time does not
|
||||
;; keep them all.
|
||||
(def cache-limit 2000)
|
||||
|
||||
(: brushes (MutableMap string (Option IBrush)))
|
||||
(def brushes (mutablemap))
|
||||
|
||||
(: geometries (MutableMap string (Option Geometry)))
|
||||
(def geometries (mutablemap))
|
||||
|
||||
(: bitmaps (MutableMap string (Option Bitmap)))
|
||||
(def bitmaps (mutablemap))
|
||||
|
||||
(: typefaces (MutableMap string Typeface))
|
||||
(def typefaces (mutablemap))
|
||||
|
||||
(: (-> (MutableMap string %a) string (-> %a) %a))
|
||||
(defun (cached table key make)
|
||||
(match (mutablemap-try-ref table key)
|
||||
((Some v) v)
|
||||
(None
|
||||
(when (>= (mutablemap-length table) cache-limit) (mutablemap-clear! table))
|
||||
(def v (make))
|
||||
(mutablemap-set! table key v)
|
||||
v)))
|
||||
|
||||
(: (-> string (Option IBrush)))
|
||||
(defun (brush colour)
|
||||
(if (string-empty? colour)
|
||||
None
|
||||
(cached brushes colour
|
||||
(fun ()
|
||||
(match (try (parse-brush colour) #:catch (System.Exception))
|
||||
((Ok b) (Some b))
|
||||
((Err _) None))))))
|
||||
|
||||
(: (-> string (Option Geometry)))
|
||||
(defun (geometry data)
|
||||
(cached geometries data
|
||||
(fun ()
|
||||
(match (try (parse-geometry data) #:catch (System.Exception))
|
||||
((Ok g) (Some g))
|
||||
((Err _) None)))))
|
||||
|
||||
(: (-> string (Option Bitmap)))
|
||||
(defun (bitmap path)
|
||||
(cached bitmaps path
|
||||
(fun ()
|
||||
(match (try (Bitmap. path) #:catch (System.Exception))
|
||||
((Ok b) (Some b))
|
||||
((Err _) None)))))
|
||||
|
||||
(: (-> string bool Typeface))
|
||||
(defun (typeface font bold?)
|
||||
(cached typefaces #"${font}/${bold?}"
|
||||
(fun ()
|
||||
(Typeface. (if (string-empty? font) default-family (FontFamily. font))
|
||||
FontStyle.Normal (if bold? FontWeight.Bold FontWeight.Normal) FontStretch.Normal))))
|
||||
|
||||
;; A line of `width`, in the brush. `cap` is "flat", "round" or "square".
|
||||
;; `dash` is the lengths of the dashes and the gaps between them, in widths
|
||||
;; of the line, in turn; empty for a solid line.
|
||||
(: (-> IBrush double string (Vec double) IPen))
|
||||
(defun (line-pen b width cap dash)
|
||||
(def c (match cap ("round" LineCap.Round) ("square" LineCap.Square) (_ LineCap.Flat)))
|
||||
(def d (if (vec-empty? dash)
|
||||
(: (clr-default) IDashStyle)
|
||||
(cast IDashStyle (DashStyle. (cast (Seq double) (: (vec->array dash) (Array double))) 0.0))))
|
||||
(cast IPen (AvPen. b width d c LineJoin.Round 10.0)))
|
||||
|
||||
(: (-> double double Point))
|
||||
(defun (pt x y) (Point. x y))
|
||||
|
||||
(def no-brush (: (clr-default) IBrush))
|
||||
(def no-pen (: (clr-default) IPen))
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; Shapes
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
;; The rectangle at `x`, `y`, `w` by `h`, filled, with corners as round as
|
||||
;; `#:radius`.
|
||||
;; A rectangle with round corners is drawn as a geometry, because a drawing
|
||||
;; that is kept, as a component's is, drops the corners of DrawRectangle.
|
||||
(: (-> Pen IBrush IPen double double double double double void))
|
||||
(defun (rect! pen b p x y w h radius)
|
||||
(if (> radius 0.0)
|
||||
(dc-geometry (.dc pen) b p (cast Geometry (RectGeometry. (Rect. x y w h) radius radius)))
|
||||
(dc-rect (.dc pen) b p (Rect. x y w h) 0.0 0.0 (clr-default))))
|
||||
|
||||
(: fill-rect (-> Pen double double double double string (#:radius double) void))
|
||||
(defun (fill-rect pen x y w h colour #:radius 0.0)
|
||||
(match (brush colour)
|
||||
((Some b) (rect! pen b no-pen x y w h radius))
|
||||
(None unit)))
|
||||
|
||||
;; The line around a rectangle. The line is centred on the rectangle's edge.
|
||||
(: stroke-rect (-> Pen double double double double string (#:width double) (#:radius double)
|
||||
(#:dash (Vec double))
|
||||
void))
|
||||
(defun (stroke-rect pen x y w h colour #:width 1.0 #:radius 0.0 #:dash [])
|
||||
(match (brush colour)
|
||||
((Some b) (rect! pen no-brush (line-pen b width "flat" dash) x y w h radius))
|
||||
(None unit)))
|
||||
|
||||
;; The circle around `cx`, `cy`, of radius `r`, filled.
|
||||
(: fill-circle (-> Pen double double double string void))
|
||||
(defun (fill-circle pen cx cy r colour)
|
||||
(fill-ellipse pen (- cx r) (- cy r) (* 2.0 r) (* 2.0 r) colour))
|
||||
|
||||
;; The line around a circle.
|
||||
(: stroke-circle (-> Pen double double double string (#:width double) (#:dash (Vec double)) void))
|
||||
(defun (stroke-circle pen cx cy r colour #:width 1.0 #:dash [])
|
||||
(stroke-ellipse pen (- cx r) (- cy r) (* 2.0 r) (* 2.0 r) colour #:width width #:dash dash))
|
||||
|
||||
;; The ellipse in the rectangle at `x`, `y`, `w` by `h`, filled.
|
||||
(: fill-ellipse (-> Pen double double double double string void))
|
||||
(defun (fill-ellipse pen x y w h colour)
|
||||
(match (brush colour)
|
||||
((Some b) (dc-ellipse (.dc pen) b no-pen (pt (+ x (/ w 2.0)) (+ y (/ h 2.0))) (/ w 2.0) (/ h 2.0)))
|
||||
(None unit)))
|
||||
|
||||
;; The line around an ellipse.
|
||||
(: stroke-ellipse (-> Pen double double double double string (#:width double) (#:dash (Vec double))
|
||||
void))
|
||||
(defun (stroke-ellipse pen x y w h colour #:width 1.0 #:dash [])
|
||||
(match (brush colour)
|
||||
((Some b) (dc-ellipse (.dc pen) no-brush (line-pen b width "flat" dash)
|
||||
(pt (+ x (/ w 2.0)) (+ y (/ h 2.0))) (/ w 2.0) (/ h 2.0)))
|
||||
(None unit)))
|
||||
|
||||
;; A line from `x1`, `y1` to `x2`, `y2`. `#:cap` is how its ends look:
|
||||
;; "flat", "round" or "square".
|
||||
(: stroke-line (-> Pen double double double double string (#:width double) (#:cap string)
|
||||
(#:dash (Vec double))
|
||||
void))
|
||||
(defun (stroke-line pen x1 y1 x2 y2 colour #:width 1.0 #:cap "flat" #:dash [])
|
||||
(match (brush colour)
|
||||
((Some b) (dc-line (.dc pen) (line-pen b width cap dash) (pt x1 y1) (pt x2 y2)))
|
||||
(None unit)))
|
||||
|
||||
;; The geometry through `points`, closed when `closed?`.
|
||||
(: (-> (Vec (Tuple double double)) bool bool (Option Geometry)))
|
||||
(defun (through points filled? closed?)
|
||||
(if (< (vec-length points) 2)
|
||||
None
|
||||
(begin
|
||||
(def g (StreamGeometry.))
|
||||
(def ctx (open-geometry g))
|
||||
(def (Tuple x0 y0) (vec-ref points 0))
|
||||
(begin-figure! ctx (pt x0 y0) filled?)
|
||||
(loop (:for (Tuple x y) (vec-drop points 1)) (:do (line-to! ctx (pt x y))))
|
||||
(end-figure! ctx closed?)
|
||||
(dispose! (cast Disposable ctx))
|
||||
(Some (cast Geometry g)))))
|
||||
|
||||
;; Lines from each of `points` to the next.
|
||||
(: stroke-polyline (-> Pen (Vec (Tuple double double)) string (#:width double) (#:cap string)
|
||||
(#:dash (Vec double))
|
||||
void))
|
||||
(defun (stroke-polyline pen points colour #:width 1.0 #:cap "flat" #:dash [])
|
||||
(match (Tuple (brush colour) (through points #f #f))
|
||||
((Tuple (Some b) (Some g)) (dc-geometry (.dc pen) no-brush (line-pen b width cap dash) g))
|
||||
(_ unit)))
|
||||
|
||||
;; The polygon with `points` at its corners, filled.
|
||||
(: fill-polygon (-> Pen (Vec (Tuple double double)) string void))
|
||||
(defun (fill-polygon pen points colour)
|
||||
(match (Tuple (brush colour) (through points #t #t))
|
||||
((Tuple (Some b) (Some g)) (dc-geometry (.dc pen) b no-pen g))
|
||||
(_ unit)))
|
||||
|
||||
;; A piece of the circle around `cx`, `cy` of radius `r`: from the angle
|
||||
;; `from`, `sweep` radians on, clockwise when `sweep` is more than 0. A sweep
|
||||
;; of a whole turn or more is the whole circle.
|
||||
(: stroke-arc (-> Pen double double double double double string (#:width double) (#:cap string)
|
||||
(#:dash (Vec double))
|
||||
void))
|
||||
(defun (stroke-arc pen cx cy r from sweep colour #:width 1.0 #:cap "flat" #:dash [])
|
||||
(def turn (* 2.0 3.141592653589793))
|
||||
(defun (at a) (pt (+ cx (* r (cos a))) (+ cy (* r (sin a)))))
|
||||
(match (brush colour)
|
||||
((Some b)
|
||||
(cond ((>= (abs sweep) (- turn 1e-9))
|
||||
(stroke-circle pen cx cy r colour #:width width #:dash dash))
|
||||
((= sweep 0.0) unit)
|
||||
(else
|
||||
(def g (StreamGeometry.))
|
||||
(def ctx (open-geometry g))
|
||||
(begin-figure! ctx (at from) #f)
|
||||
(arc-to! ctx (at (+ from sweep)) (Size. r r) 0.0 (> (abs sweep) (/ turn 2.0))
|
||||
(if (> sweep 0.0) Sweep.Clockwise Sweep.CounterClockwise))
|
||||
(end-figure! ctx #f)
|
||||
(dispose! (cast Disposable ctx))
|
||||
(dc-geometry (.dc pen) no-brush (line-pen b width cap dash) (cast Geometry g)))))
|
||||
(None unit)))
|
||||
|
||||
;; The path `data`, written as SVG writes one: "M 10 10 L 50 10 L 30 40 Z"
|
||||
;; is a triangle. Filled. A path that cannot be read draws nothing.
|
||||
(: fill-path (-> Pen string string void))
|
||||
(defun (fill-path pen data colour)
|
||||
(match (Tuple (brush colour) (geometry data))
|
||||
((Tuple (Some b) (Some g)) (dc-geometry (.dc pen) b no-pen g))
|
||||
(_ unit)))
|
||||
|
||||
;; The line along the path `data`.
|
||||
(: stroke-path (-> Pen string string (#:width double) (#:cap string) (#:dash (Vec double)) void))
|
||||
(defun (stroke-path pen data colour #:width 1.0 #:cap "flat" #:dash [])
|
||||
(match (Tuple (brush colour) (geometry data))
|
||||
((Tuple (Some b) (Some g)) (dc-geometry (.dc pen) no-brush (line-pen b width cap dash) g))
|
||||
(_ unit)))
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; Text and pictures
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
(: (-> string IBrush double bool string double FormattedText))
|
||||
(defun (formatted s b size bold? font max-width)
|
||||
(def t (FormattedText. s invariant FlowDirection.LeftToRight (typeface font bold?) size b))
|
||||
(when (> max-width 0.0) (max-text-width! t max-width))
|
||||
t)
|
||||
|
||||
;; The text `s` with its top at `y`. `#:align` says where `x` is on it:
|
||||
;; "left", "centre" or "right". `#:font` is the name of a font, "" for the
|
||||
;; theme's. With `#:max-width`, the text breaks its lines at that width.
|
||||
(: draw-text (-> Pen string double double string (#:size double) (#:bold bool) (#:font string)
|
||||
(#:align string) (#:max-width double)
|
||||
void))
|
||||
(defun (draw-text pen s x y colour #:size 14.0 #:bold #f #:font "" #:align "left" #:max-width 0.0)
|
||||
(match (brush colour)
|
||||
((Some b)
|
||||
(def t (formatted s b size bold font max-width))
|
||||
(def left (match align
|
||||
("centre" (- x (/ (text-width t) 2.0)))
|
||||
("right" (- x (text-width t)))
|
||||
(_ x)))
|
||||
(dc-text (.dc pen) t (pt left y)))
|
||||
(None unit)))
|
||||
|
||||
;; The width and the height that `draw-text` gives `s`, with the same
|
||||
;; options. For a component to lay out its text.
|
||||
(: text-size (-> string (#:size double) (#:bold bool) (#:font string) (#:max-width double)
|
||||
(Tuple double double)))
|
||||
(defun (text-size s #:size 14.0 #:bold #f #:font "" #:max-width 0.0)
|
||||
(def t (formatted s (parse-brush "black") size bold font max-width))
|
||||
(Tuple (text-width t) (text-height t)))
|
||||
|
||||
;; The picture in the file at `path`, in the rectangle at `x`, `y`, `w` by
|
||||
;; `h`. A file that cannot be read draws nothing.
|
||||
(: draw-image (-> Pen string double double double double void))
|
||||
(defun (draw-image pen path x y w h)
|
||||
(match (bitmap path)
|
||||
((Some b) (dc-image (.dc pen) (cast IImage b) (Rect. x y w h)))
|
||||
(None unit)))
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; Moved, turned, cut and faded
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
(: (-> PushedState (-> void) void))
|
||||
(defun (inside state body)
|
||||
(body)
|
||||
(pop! state))
|
||||
|
||||
;; What `body` draws, moved by `dx`, `dy`.
|
||||
(: translated (-> Pen double double (-> void) void))
|
||||
(defun (translated pen dx dy body)
|
||||
(inside (push-transform (.dc pen) (translation dx dy)) body))
|
||||
|
||||
;; What `body` draws, `sx` times as wide and `sy` times as tall, from 0, 0.
|
||||
(: scaled (-> Pen double double (-> void) void))
|
||||
(defun (scaled pen sx sy body)
|
||||
(inside (push-transform (.dc pen) (scaling sx sy)) body))
|
||||
|
||||
;; What `body` draws, turned by `angle` around `cx`, `cy`.
|
||||
(: rotated (-> Pen double double double (-> void) void))
|
||||
(defun (rotated pen angle cx cy body)
|
||||
(inside (push-transform (.dc pen) (rotation angle (pt cx cy))) body))
|
||||
|
||||
;; What `body` draws, only inside the rectangle at `x`, `y`, `w` by `h`.
|
||||
(: clipped (-> Pen double double double double (-> void) void))
|
||||
(defun (clipped pen x y w h body)
|
||||
(inside (push-clip (.dc pen) (Rect. x y w h)) body))
|
||||
|
||||
;; What `body` draws, at `opacity`: 0 is not seen, 1 is as drawn.
|
||||
(: faded (-> Pen double (-> void) void))
|
||||
(defun (faded pen opacity body)
|
||||
(inside (push-opacity (.dc pen) opacity) body))
|
||||
|
||||
;; ---------------------------------------------------------------------------
|
||||
;; For the app
|
||||
;; ---------------------------------------------------------------------------
|
||||
|
||||
;; What `draw` draws on `w` by `h`, as a picture that an Image shows, and
|
||||
;; where the Image goes for 0, 0 to be the top left corner. None when there
|
||||
;; is no room.
|
||||
;;
|
||||
;; A DrawingImage moves the top left corner of what is drawn to its own 0, 0,
|
||||
;; so a drawing that starts at 10, 10, or at -5, 0, would move. The place of
|
||||
;; the bounds' corner is given back, and the Image is put there, which moves
|
||||
;; the drawing back. What is drawn is cut to `w` by `h`, so what is outside
|
||||
;; costs nothing to show.
|
||||
(: drawing-image (-> (-> Pen void) double double (Option (Tuple Object double double))))
|
||||
(defun (drawing-image draw w h)
|
||||
(if (or (<= w 0.0) (<= h 0.0))
|
||||
None
|
||||
(begin
|
||||
(def group (DrawingGroup.))
|
||||
(def dc (open-group group))
|
||||
(def pen (Pen (dc dc)))
|
||||
(clipped pen 0.0 0.0 w h (fun () (draw pen)))
|
||||
(dispose! (cast Disposable dc))
|
||||
(def b (bounds-of (cast Drawing group)))
|
||||
(Some (Tuple (cast Object (DrawingImage. (cast Drawing group))) (rect-x b) (rect-y b))))))
|
||||
Loading…
Add table
Add a link
Reference in a new issue