Components with view-map, and canvases with shapes and the pointer

view-map gives a view's every message to a function first, so a part with a
message type, an update and a view of its own goes in a larger view with
the case of the larger message that carries its own.

canvas is a surface for rect, ellipse, line and path, placed by their own
numbers, and other views by at-point. on-press, on-move and on-release send
the place on the canvas. They come from whatever is drawn on it too, so
they are taken from any source, and a press takes the pointer for the drag.
examples/sketch.bjo draws with it, and docs/sketch.png is its picture.

🤖 Generated with [ECA](https://eca.dev) (anthropic/claude-opus-4-8)

Co-Authored-By: eca-agent <git@eca.dev>

examples/sketch.bjo

@@ -0,0 +1,132 @@
+;; 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/examples/sketch.bjo — drawing with the pointer, and two components.
+;;
+;;     bjo run examples/sketch.bjo
+;;
+;; Press and drag on the canvas to draw a stroke. The colour and the width
+;; are chosen by two pickers, each a component of its own: a message type, an
+;; update and a view, which know nothing of the sketch. The sketch puts them
+;; in its view with `view-map`, and hands their messages back to them.
+;;
+;; The picture in the Readme is this program, taken with
+;;
+;;     BJOGUI_SCREENSHOT=docs/sketch.png bjo run examples/sketch.bjo
+
+(import (std prelude))
+(import (std maths))
+(import (bjogui view))
+(import (bjogui app))
+
+;; ---------------------------------------------------------------------------
+;; A picker: one of some choices, shown as buttons
+;; ---------------------------------------------------------------------------
+
+(type (: PickerMsg (Union (: Picked int))))
+(type (: Picker (Record (: label string) (: choices (Vec string)) (: chosen int))))
+
+(: (-> PickerMsg Picker Picker))
+(defun (picker-update msg p)
+  (match msg ((Picked i) (record-set p (chosen i)))))
+
+(: (-> Picker (View PickerMsg)))
+(defun (picker-view p)
+  (apply row #:spacing 4.0
+         (vec->array
+           (vec-add-first
+             (vec-map (fun (i)
+                        (def label (vec-ref (.choices p) i))
+                        (if (= i (.chosen p))
+                            (paint (button label (Picked i)) #:background "#2c3e50" #:colour "white")
+                            (button label (Picked i))))
+                      (->vec (range 0 (vec-length (.choices p)))))
+             (text (.label p) #:margin 4.0)))))
+
+(: (-> Picker string))
+(defun (picked p) (vec-ref (.choices p) (.chosen p)))
+
+;; ---------------------------------------------------------------------------
+;; The sketch
+;; ---------------------------------------------------------------------------
+
+(type (: Stroke (Record (: colour string) (: width double) (: points (List (Tuple double double))))))
+
+(type (: Msg (Union (: Colour PickerMsg) (: Width PickerMsg)
+                    (: Down double double) (: Drag double double) Up Clear)))
+
+(type (: Model (Record (: strokes (List Stroke)) (: drawing (Option Stroke))
+                       (: colour Picker) (: width Picker))))
+
+(: (-> Model double))
+(defun (width-of m) (string->double (picked (.width m))))
+
+(: (-> Msg Model (Tuple Model (List (Event Msg)))))
+(defun (gui-update msg m)
+  (next
+    (match msg
+      ((Colour pm) (record-set m (colour (picker-update pm (.colour m)))))
+      ((Width pm) (record-set m (width (picker-update pm (.width m)))))
+      ((Down x y)
+       (record-set m (drawing (Some (Stroke (colour (picked (.colour m))) (width (width-of m))
+                                            (points (list (Tuple x y))))))))
+      ((Drag x y)
+       (match (.drawing m)
+         ((Some s) (record-set m (drawing (Some (record-set s (points (cons (Tuple x y) (.points s))))))))
+         (None m)))
+      (Up
+       (match (.drawing m)
+         ((Some s) (record-set m (strokes (cons s (.strokes m))) (drawing None)))
+         (None m)))
+      (Clear (record-set m (strokes '()) (drawing None))))))
+
+;; A stroke as a path: a move to its first point and a line to each other.
+(: (-> Stroke (View Msg)))
+(defun (stroke-view s)
+  (def points (list-reverse (.points s)))
+  (def data
+    (loop (:for (Tuple i p) (enumerate points))
+          (:let (Tuple x y) p)
+          (:acc parts (vecing #"${(if (= i 0) "M" "L")} ${x} ${y}"))
+          => (string-join parts " ")))
+  (path data #:stroke (.colour s) #:stroke-width (.width s)))
+
+(: (-> Model (View Msg)))
+(defun (view m)
+  (def strokes (list-reverse (match (.drawing m)
+                               ((Some s) (cons s (.strokes m)))
+                               (None (.strokes m)))))
+  (column #:spacing 8.0 #:margin 12.0
+    (view-map Colour (picker-view (.colour m)))
+    (view-map Width (picker-view (.width m)))
+    (border
+      (on-release
+        (on-move
+          (on-press
+            (apply canvas 460.0 260.0 #:background "white"
+                   (vec->array (vec-map stroke-view (list->vec strokes))))
+            Down)
+          Drag)
+        (fun (x y) Up))
+      #:colour "#bdc3c7")
+    (row #:spacing 8.0
+      (button "Clear" Clear)
+      (text #"${(length (.strokes m))} strokes"))))
+
+;; Strokes to show in the picture: a wave, a loop and a line.
+(: (-> string double (-> double (Tuple double double)) Stroke))
+(defun (drawn colour width f)
+  (Stroke (colour colour) (width width)
+          (points (list-reverse (list-map (fun (i) (f (cast System.Double i))) (->list (range 0 61)))))))
+
+(defun (main)
+  (def wave (drawn "steelblue" 4.0 (fun (i) (Tuple (+ 20.0 (* i 7.0)) (+ 70.0 (* 35.0 (sin (/ i 6.0))))))))
+  (def loop-stroke (drawn "firebrick" 6.0 (fun (i) (Tuple (+ 330.0 (* 70.0 (cos (/ i 9.55))))
+                                                       (+ 160.0 (* 60.0 (sin (/ i 9.55))))))))
+  (def line-stroke (drawn "seagreen" 2.0 (fun (i) (Tuple (+ 30.0 (* i 4.0)) (+ 230.0 (* -1.5 i))))))
+  (run-app (Model (strokes (list line-stroke loop-stroke wave)) (drawing None)
+                  (colour (Picker (label "Colour") (choices ["steelblue" "firebrick" "seagreen" "black"]) (chosen 1)))
+                  (width (Picker (label "Width") (choices ["2" "4" "6" "10"]) (chosen 2))))
+           gui-update view
+           #:title "Sketch" #:width 500.0 #:height 420.0))

src/app.bjo

@@ -101,6 +101,16 @@
   (DockEdge          (: Avalonia.Controls.Dock))
   (TreeView          (: Avalonia.Controls.TreeView (-> TreeView)))
   (TreeViewItem      (: Avalonia.Controls.TreeViewItem (-> TreeViewItem)))
+  (Canvas            (: Avalonia.Controls.Canvas (-> Canvas)))
+  (RectShape         (: Avalonia.Controls.Shapes.Rectangle (-> RectShape)))
+  (EllipseShape      (: Avalonia.Controls.Shapes.Ellipse (-> EllipseShape)))
+  (LineShape         (: Avalonia.Controls.Shapes.Line (-> LineShape)))
+  (PathShape         (: Avalonia.Controls.Shapes.Path (-> PathShape)))
+  (Geometry          (: Avalonia.Media.Geometry))
+  (Point             (: Avalonia.Point (-> double double Point)))
+  (PointerEventArgs  (: Avalonia.Input.PointerEventArgs))
+  (IPointer          (: Avalonia.Input.IPointer))
+  (IInputElement     (: Avalonia.Input.IInputElement))
   (PropertyChange    (: Avalonia.AvaloniaPropertyChangedEventArgs))
   (Classes           (: Avalonia.Controls.Classes))
   (StyledElement     (: Avalonia.StyledElement))
@@ -226,6 +236,25 @@
   (tree-expanded-property (: Avalonia.Controls.TreeViewItem.IsExpandedProperty #:get))
   (tree-selected-property (: Avalonia.Controls.TreeView.SelectedItemProperty #:get))
   (tree-selected        (: Avalonia.Controls.TreeView.SelectedItem (-> TreeView Object) #:get))
+  (canvas-left-property (: Avalonia.Controls.Canvas.LeftProperty #:get))
+  (canvas-top-property  (: Avalonia.Controls.Canvas.TopProperty #:get))
+  (fill-property        (: Avalonia.Controls.Shapes.Shape.FillProperty #:get))
+  (stroke-property      (: Avalonia.Controls.Shapes.Shape.StrokeProperty #:get))
+  (stroke-width-property (: Avalonia.Controls.Shapes.Shape.StrokeThicknessProperty #:get))
+  (radius-x-property    (: Avalonia.Controls.Shapes.Rectangle.RadiusXProperty #:get))
+  (radius-y-property    (: Avalonia.Controls.Shapes.Rectangle.RadiusYProperty #:get))
+  (line-start-property  (: Avalonia.Controls.Shapes.Line.StartPointProperty #:get))
+  (line-end-property    (: Avalonia.Controls.Shapes.Line.EndPointProperty #:get))
+  (path-data-property   (: Avalonia.Controls.Shapes.Path.DataProperty #:get))
+  (parse-geometry       (: Avalonia.Media.Geometry.Parse (-> string Geometry)))
+  (pointer-pressed-event (: Avalonia.Input.InputElement.PointerPressedEvent #:get))
+  (pointer-moved-event  (: Avalonia.Input.InputElement.PointerMovedEvent #:get))
+  (pointer-released-event (: Avalonia.Input.InputElement.PointerReleasedEvent #:get))
+  (position-in          (: Avalonia.Input.PointerEventArgs.GetPosition (-> PointerEventArgs Visual Point)))
+  (pointer-of           (: Avalonia.Input.PointerEventArgs.Pointer (-> PointerEventArgs IPointer) #:get))
+  (capture!             (: Avalonia.Input.IPointer.Capture (-> IPointer IInputElement void)))
+  (point-x              (: Avalonia.Point.X (-> Point double) #:get))
+  (point-y              (: Avalonia.Point.Y (-> Point double) #:get))
   (classes-of           (: Avalonia.StyledElement.Classes (-> StyledElement Classes) #:get))
   (classes-clear!       (: Avalonia.Controls.Classes.Clear (-> Classes void)))
   (classes-add!         (: Avalonia.Controls.Classes.Add (-> Classes string void)))
@@ -341,6 +370,7 @@
     (GridKind #t)
     (WrapKind #t)
     (DockKind #t)
+    (CanvasKind #t)
     (_ #f)))
 
 (: (-> Kind bool))
@@ -364,8 +394,23 @@
     (ContextKind #f)
     (WrapKind #f)
     (DockKind #f)
+    (CanvasKind #f)
+    (RectKind #f)
+    (EllipseKind #f)
+    (LineKind #f)
+    (PathKind #f)
     (_ #t)))
 
+;; A kind that Avalonia draws as a shape, with a fill and a stroke.
+(: (-> Kind bool))
+(defun (shape? kind)
+  (match kind
+    (RectKind #t)
+    (EllipseKind #t)
+    (LineKind #t)
+    (PathKind #t)
+    (_ #f)))
+
 ;; A kind that is on or off, as a checkbox.
 (: (-> Kind bool))
 (defun (toggle? kind)
@@ -499,6 +544,14 @@
            (else None)))
     ;; Set after the children, by `sync-tree-choice!`.
     ((PropChosenKey _) None)
+    ((PropLeft _) (Some (cast AvaloniaProperty canvas-left-property)))
+    ((PropTop _) (Some (cast AvaloniaProperty canvas-top-property)))
+    ((PropFill _) (when-kind (shape? kind) (cast AvaloniaProperty fill-property)))
+    ((PropStroke _) (when-kind (shape? kind) (cast AvaloniaProperty stroke-property)))
+    ((PropStrokeWidth _) (when-kind (shape? kind) (cast AvaloniaProperty stroke-width-property)))
+    ((PropStart _ _) (when-kind (= kind LineKind) (cast AvaloniaProperty line-start-property)))
+    ((PropEnd _ _) (when-kind (= kind LineKind) (cast AvaloniaProperty line-end-property)))
+    ((PropData _) (when-kind (= kind PathKind) (cast AvaloniaProperty path-data-property)))
     ((PropDockSide _) (Some (cast AvaloniaProperty dock-property)))
     ((PropClasses _) None)
     ((PropDate _) (when-kind (= kind DateKind) (cast AvaloniaProperty date-property)))
@@ -530,6 +583,12 @@
     ((PropBackground s) (brush s))
     ((PropForeground s) (brush s))
     ((PropBorderColour s) (brush s))
+    ((PropFill s) (brush s))
+    ((PropStroke s) (brush s))
+    ((PropData s)
+     (match (try (parse-geometry s) #:catch (System.Exception))
+       ((Ok g) (Some (cast Object g)))
+       ((Err _) None)))
     ((PropShortcut s) (match (gesture s) ((Some g) (Some (cast Object g))) (None None)))
     ;; No date, or one that cannot be read, is none: the property is cleared.
     ((PropDate s)
@@ -588,6 +647,14 @@
     ((PropDate s) (text s))
     ((PropClasses _) (cast Object 0))
     ((PropChosenKey s) (text s))
+    ((PropLeft d) (cast Object d))
+    ((PropTop d) (cast Object d))
+    ((PropFill s) (text s))
+    ((PropStroke s) (text s))
+    ((PropStrokeWidth d) (cast Object d))
+    ((PropStart x y) (cast Object (Point. x y)))
+    ((PropEnd x y) (cast Object (Point. x y)))
+    ((PropData s) (text s))
     ((PropDockSide i)
      (cast Object (match i (0 DockEdge.Left) (1 DockEdge.Top) (2 DockEdge.Right) (_ DockEdge.Bottom))))))
 
@@ -604,7 +671,9 @@
     ((PropRows _) 20) ((PropRow _) 21) ((PropColumn _) 22) ((PropRowSpan _) 23) ((PropColumnSpan _) 24)
     ((PropBackground _) 25) ((PropForeground _) 26) ((PropBorderColour _) 27) ((PropBorderWidth _) 28)
     ((PropRadius _) 29) ((PropShortcut _) 30) ((PropTip _) 31) ((PropExpanded _) 32) ((PropDate _) 33)
-    ((PropDockSide _) 34) ((PropClasses _) 35) ((PropChosenKey _) 36)))
+    ((PropDockSide _) 34) ((PropClasses _) 35) ((PropChosenKey _) 36)
+    ((PropLeft _) 37) ((PropTop _) 38) ((PropFill _) 39) ((PropStroke _) 40)
+    ((PropStrokeWidth _) 41) ((PropStart _ _) 42) ((PropEnd _ _) 43) ((PropData _) 44)))
 
 (: (-> Control AvaloniaProperty Object void))
 (defun (put! control property value)
@@ -632,6 +701,9 @@
     ((Tuple WrapKind (PropSpacing d))
      (put! control (cast AvaloniaProperty wrap-item-spacing) (cast Object d))
      (put! control (cast AvaloniaProperty wrap-line-spacing) (cast Object d)))
+    ((Tuple RectKind (PropRadius d))
+     (put! control (cast AvaloniaProperty radius-x-property) (cast Object d))
+     (put! control (cast AvaloniaProperty radius-y-property) (cast Object d)))
     ((Tuple _ (PropClasses names))
      (def classes (classes-of (cast StyledElement control)))
      (classes-clear! classes)
@@ -667,6 +739,9 @@
      (clear (cast AvaloniaProperty wrap-item-spacing))
      (clear (cast AvaloniaProperty wrap-line-spacing)))
     ((Tuple _ (PropClasses _)) (classes-clear! (classes-of (cast StyledElement control))))
+    ((Tuple RectKind (PropRadius _))
+     (clear (cast AvaloniaProperty radius-x-property))
+     (clear (cast AvaloniaProperty radius-y-property)))
     (_
      (match (slot kind p)
        ((Some property) (clear property))
@@ -1024,6 +1099,22 @@
                (fun ()
                  (def d (range-value (cast RangeBase control)))
                  (fun (on) (match on ((OnSlide f) (Some (f d))) (_ None))))))
+;; A canvas's pointer events come from whatever is drawn on it as well,
+    ;; so they are taken from any source, at the place on the canvas.
+    (CanvasKind
+     (defun (on-pointer (: event RoutedEvent) pick (: press? bool))
+       (on! control event
+            (fun (sender e)
+              (def p (cast PointerEventArgs e))
+              (when press? (capture! (pointer-of p) (cast IInputElement control)))
+              (def at (position-in p (cast Visual control)))
+              (fire! app live (pick (point-x at) (point-y at))))))
+     (on-pointer (cast RoutedEvent pointer-pressed-event)
+                 (fun (x y) (fun (on) (match on ((OnPress f) (Some (f x y))) (_ None)))) #t)
+     (on-pointer (cast RoutedEvent pointer-moved-event)
+                 (fun (x y) (fun (on) (match on ((OnMove f) (Some (f x y))) (_ None)))) #f)
+     (on-pointer (cast RoutedEvent pointer-released-event)
+                 (fun (x y) (fun (on) (match on ((OnRelease f) (Some (f x y))) (_ None)))) #f))
     (TreeKind
      (on-event (cast RoutedEvent selection-changed-event)
                (fun ()
@@ -1083,6 +1174,16 @@
     (ContextKind (cast Control (Border.)))
     (ContextMenuKind (cast Control (ContextMenu.)))
     (TreeKind (cast Control (TreeView.)))
+    (CanvasKind
+     ;; Transparent and not empty: a panel with no background takes no
+     ;; pointer where nothing is drawn.
+     (def c (cast Control (Canvas.)))
+     (put! c (cast AvaloniaProperty panel-background) (cast Object (parse-brush "Transparent")))
+     c)
+    (RectKind (cast Control (RectShape.)))
+    (EllipseKind (cast Control (EllipseShape.)))
+    (LineKind (cast Control (LineShape.)))
+    (PathKind (cast Control (PathShape.)))
     (TreeNodeKind (cast Control (TreeViewItem.)))
     (ToggleSwitchKind (cast Control (ToggleSwitch.)))
     (RadioKind (cast Control (RadioButton.)))

src/view.bjo

@@ -23,9 +23,14 @@
   menu-bar submenu menu-item menu-separator
   toggle-switch radio number-input date-picker auto-complete expander
   tree-view tree-node
+  canvas rect ellipse line path
   column row grid scroll border flow dock
   ;; Wrappers.
   keyed at paint with-context-menu tooltip at-top at-bottom at-left at-right classed
+  at-point on-press on-move on-release
+
+  ;; Views of another message type.
+  view-map
 
   ;; Keyboard shortcuts.
   Key key key-gesture key-message
@@ -46,6 +51,7 @@
                      MenuBarKind MenuItemKind SeparatorKind ContextKind ContextMenuKind
                      ToggleSwitchKind RadioKind NumberKind DateKind AutoCompleteKind
                      ExpanderKind WrapKind DockKind TreeKind TreeNodeKind
+                     CanvasKind RectKind EllipseKind LineKind PathKind
                      ColumnKind RowKind GridKind ScrollKind BorderKind)))
 
 ;; A property of a control. A kind takes only some of them; the app ignores
@@ -86,7 +92,15 @@
                      (: PropDate string)            ; a date picker's date, as "2026-10-25"
                      (: PropDockSide int)           ; where a view is in its dock: 0 to 3
                      (: PropClasses (Vec string))   ; the classes that styles match
-                     (: PropChosenKey string))))    ; the key of a tree's chosen node
+                     (: PropChosenKey string)       ; the key of a tree's chosen node
+                     (: PropLeft double)            ; where a view is on its canvas
+                     (: PropTop double)
+                     (: PropFill string)            ; the colour inside a shape
+                     (: PropStroke string)          ; the colour of a shape's line
+                     (: PropStrokeWidth double)
+                     (: PropStart double double)    ; the ends of a line
+                     (: PropEnd double double)
+                     (: PropData string))))         ; a path, as "M 0 0 L 10 10 Z"
 
 ;; An event, and the message it sends.
 (type (: (On %m) (Union (: OnClick %m)
@@ -94,7 +108,10 @@
                         (: OnToggle (-> bool %m))
                         (: OnSlide (-> double %m))
                         (: OnSelect (-> int %m))
-                        (: OnPick (-> string %m)))))
+                        (: OnPick (-> string %m))
+                        (: OnPress (-> double double %m))
+                        (: OnMove (-> double double %m))
+                        (: OnRelease (-> double double %m)))))
 
 ;; One control and what is in it.
 ;;
@@ -153,6 +170,59 @@
 (defun (classed v #:rest names)
   (record-set v (props (vec-add (.props v) (PropClasses (array->vec names))))))
 
+;; The view, at `x`, `y` on its canvas, counted from the top left corner.
+(: at-point (-> double double (View %m) (View %m)))
+(defun (at-point x y v)
+  (record-set v (props (vec-add (vec-add (.props v) (PropLeft x)) (PropTop y)))))
+
+(: (-> (On %m) (View %m) (View %m)))
+(defun (with-event on v)
+  (record-set v (events (vec-add (.events v) on))))
+
+;; The canvas, sending `(f x y)` when a button is pressed on it, with the
+;; place on the canvas. The canvas takes the pointer until the button is let
+;; go, so a drag that leaves it still reaches it. Only a canvas has these.
+(: on-press (-> (View %m) (-> double double %m) (View %m)))
+(defun (on-press v f) (with-event (OnPress f) v))
+
+;; The canvas, sending `(f x y)` each time the pointer moves over it, or
+;; anywhere while a button pressed on it is held.
+(: on-move (-> (View %m) (-> double double %m) (View %m)))
+(defun (on-move v f) (with-event (OnMove f) v))
+
+;; The canvas, sending `(f x y)` when the button pressed on it is let go.
+(: on-release (-> (View %m) (-> double double %m) (View %m)))
+(defun (on-release v f) (with-event (OnRelease f) v))
+
+;; ---------------------------------------------------------------------------
+;; Views of another message type
+;; ---------------------------------------------------------------------------
+
+;; The view, sending `(f msg)` for each message it would send. This is how a
+;; part of a program with messages of its own is put in a larger view: its
+;; view is mapped with the case of the larger message that carries its own.
+;;
+;;     (view-map Picker (date-range-view (.range m)))
+(: view-map (-> (-> %a %b) (View %a) (View %b)))
+(defun (view-map f v)
+  (: (-> (On %a) (On %b)))
+  (defun (map-on on)
+    (match on
+      ((OnClick m) (OnClick (f m)))
+      ((OnInput g) (OnInput (fun (s) (f (g s)))))
+      ((OnToggle g) (OnToggle (fun (b) (f (g b)))))
+      ((OnSlide g) (OnSlide (fun (d) (f (g d)))))
+      ((OnSelect g) (OnSelect (fun (i) (f (g i)))))
+      ((OnPick g) (OnPick (fun (k) (f (g k)))))
+      ((OnPress g) (OnPress (fun (x y) (f (g x y)))))
+      ((OnMove g) (OnMove (fun (x y) (f (g x y)))))
+      ((OnRelease g) (OnRelease (fun (x y) (f (g x y)))))))
+  (View (kind (.kind v))
+        (props (.props v))
+        (events (vec-map map-on (.events v)))
+        (children (vec-map (fun (c) (view-map f c)) (.children v)))
+        (key (.key v))))
+
 ;; The view, with `text` shown when the pointer rests on it.
 (: tooltip (-> (View %m) string (View %m)))
 (defun (tooltip v text)
@@ -486,6 +556,57 @@
 (defun (dock #:margin 0.0 #:rest children)
   (stack DockKind 0.0 margin children))
 
+;; A surface to draw on, `width` by `height`, with shapes and other views at
+;; places of their own: a shape by its numbers, a view by `at-point`. Its
+;; pointer messages come from `on-press`, `on-move` and `on-release`.
+(: (-> double double (#:background string) (#:margin double) #:rest (View %m) (View %m)))
+(defun (canvas width height #:background "" #:margin 0.0 #:rest children)
+  (container CanvasKind
+             (with-layout (if (string-empty? background) [] [(PropBackground background)])
+                          width height margin 0.0)
+             (array->vec children)))
+
+(: (-> (Vec Prop) string string double (Vec Prop)))
+(defun (with-paint props fill stroke stroke-width)
+  (defun (with ps make c) (if (string-empty? c) ps (vec-add ps (make c))))
+  (with (with (if (> stroke-width 0.0) (vec-add props (PropStrokeWidth stroke-width)) props)
+              PropFill fill)
+        PropStroke stroke))
+
+;; A rectangle at `x`, `y`, `width` by `height`, with corners as round as
+;; `#:radius`.
+(: (-> double double double double (#:fill string) (#:stroke string) (#:stroke-width double)
+       (#:radius double)
+       (View %m)))
+(defun (rect x y width height #:fill "" #:stroke "" #:stroke-width 1.0 #:radius 0.0)
+  (leaf RectKind
+        (with-paint (with-size [(PropLeft x) (PropTop y) (PropWidth width) (PropHeight height)]
+                               PropRadius radius)
+                    fill stroke stroke-width)
+        []))
+
+;; An ellipse in the rectangle at `x`, `y`, `width` by `height`.
+(: (-> double double double double (#:fill string) (#:stroke string) (#:stroke-width double)
+       (View %m)))
+(defun (ellipse x y width height #:fill "" #:stroke "" #:stroke-width 1.0)
+  (leaf EllipseKind
+        (with-paint [(PropLeft x) (PropTop y) (PropWidth width) (PropHeight height)]
+                    fill stroke stroke-width)
+        []))
+
+;; A line from `x1`, `y1` to `x2`, `y2`.
+(: (-> double double double double (#:stroke string) (#:stroke-width double) (View %m)))
+(defun (line x1 y1 x2 y2 #:stroke "black" #:stroke-width 1.0)
+  (leaf LineKind
+        (with-paint [(PropStart x1 y1) (PropEnd x2 y2)] "" stroke stroke-width)
+        []))
+
+;; A path, written as SVG writes one: "M 10 10 L 50 10 L 30 40 Z" is a
+;; triangle. Its numbers are places on the canvas.
+(: (-> string (#:fill string) (#:stroke string) (#:stroke-width double) (View %m)))
+(defun (path data #:fill "" #:stroke "" #:stroke-width 1.0)
+  (leaf PathKind (with-paint [(PropData data)] fill stroke stroke-width) []))
+
 ;; A view that scrolls when it is taller than the space it has.
 (: (-> (View %m) (#:width double) (#:height double) (#:margin double) (View %m)))
 (defun (scroll child #:width 0.0 #:height 0.0 #:margin 0.0)

tests/canvas.bjo

@@ -0,0 +1,176 @@
+;; 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/tests/canvas.bjo — views of another message type, and canvases.
+;;
+;;     bjo run tests/canvas.bjo
+;;
+;; No window is opened. Pointer events are made as Avalonia makes them, and
+;; raised on the canvas and on a shape on it.
+
+(import (std prelude))
+(import (std simpletest))
+(import (bjogui view))
+(import (bjogui app))
+
+(import/class
+  (Object          (: System.Object))
+  (ClrString       (: System.String))
+  (Control         (: Avalonia.Controls.Control))
+  (AvaloniaObject  (: Avalonia.AvaloniaObject))
+  (Layoutable      (: Avalonia.Layout.Layoutable))
+  (Visual          (: Avalonia.Visual))
+  (Interactive     (: Avalonia.Interactivity.Interactive))
+  (RoutedEvent     (: Avalonia.Interactivity.RoutedEvent))
+  (RoutedEventArgs (: Avalonia.Interactivity.RoutedEventArgs (-> RoutedEvent RoutedEventArgs)))
+  (TextBox         (: Avalonia.Controls.TextBox))
+  (Shape           (: Avalonia.Controls.Shapes.Shape))
+  (LineShape       (: Avalonia.Controls.Shapes.Line))
+  (PathShape       (: Avalonia.Controls.Shapes.Path))
+  (IBrush          (: Avalonia.Media.IBrush))
+  (Geometry        (: Avalonia.Media.Geometry))
+  (Point           (: Avalonia.Point (-> double double Point)))
+  (Pointer         (: Avalonia.Input.Pointer (-> int PointerType bool Pointer)))
+  (PointerType     (: Avalonia.Input.PointerType))
+  (IPointer        (: Avalonia.Input.IPointer))
+  (PointProps      (: Avalonia.Input.PointerPointProperties (-> PointProps)))
+  (KeyModifiers    (: Avalonia.Input.KeyModifiers))
+  (MouseButton     (: Avalonia.Input.MouseButton))
+  (Pressed         (: Avalonia.Input.PointerPressedEventArgs
+                      (-> Object IPointer Visual Point ulong PointProps KeyModifiers int Pressed)))
+  (Moved           (: Avalonia.Input.PointerEventArgs
+                      (-> RoutedEvent Object IPointer Visual Point ulong PointProps KeyModifiers Moved)))
+  (Released        (: Avalonia.Input.PointerReleasedEventArgs
+                      (-> Object IPointer Visual Point ulong PointProps KeyModifiers MouseButton Released))))
+
+(import/extern
+  (click-event    (: Avalonia.Controls.Button.ClickEvent #:get))
+  (moved-event    (: Avalonia.Input.InputElement.PointerMovedEvent #:get))
+  (raise-event    (: Avalonia.Interactivity.Interactive.RaiseEvent (-> Interactive RoutedEventArgs void)))
+  (box-text!      (: Avalonia.Controls.TextBox.Text (-> TextBox string void) #:set))
+  (left-of*       (: Avalonia.Controls.Canvas.GetLeft (-> AvaloniaObject double)))
+  (top-of*        (: Avalonia.Controls.Canvas.GetTop (-> AvaloniaObject double)))
+  (fill-of        (: Avalonia.Controls.Shapes.Shape.Fill (-> Shape IBrush) #:get))
+  (stroke-width-of (: Avalonia.Controls.Shapes.Shape.StrokeThickness (-> Shape double) #:get))
+  (line-end       (: Avalonia.Controls.Shapes.Line.EndPoint (-> LineShape Point) #:get))
+  (path-data      (: Avalonia.Controls.Shapes.Path.Data (-> PathShape Geometry) #:get))
+  (point-x        (: Avalonia.Point.X (-> Point double) #:get))
+  (width-of       (: Avalonia.Layout.Layoutable.Width (-> Layoutable double) #:get)))
+
+;; ---------------------------------------------------------------------------
+;; A component: a counter with a name, which knows nothing of who uses it
+;; ---------------------------------------------------------------------------
+
+(type (: CounterMsg (Union Inc (: Named string))))
+(type (: Counter (Record (: count int) (: name string))))
+
+(: (-> CounterMsg Counter Counter))
+(defun (counter-update msg c)
+  (match msg
+    (Inc (record-set c (count (+ (.count c) 1))))
+    ((Named s) (record-set c (name s)))))
+
+(: (-> Counter (View CounterMsg)))
+(defun (counter-view c)
+  (row (button "+" Inc) (text-input (.name c) Named) (text #"${(.count c)}")))
+
+;; Two of them, each a case of the larger message.
+(type (: PairMsg (Union (: Left CounterMsg) (: Right CounterMsg))))
+(type (: Pair (Record (: left Counter) (: right Counter))))
+
+(: (-> PairMsg Pair Pair))
+(defun (pair-update msg p)
+  (match msg
+    ((Left m) (record-set p (left (counter-update m (.left p)))))
+    ((Right m) (record-set p (right (counter-update m (.right p)))))))
+
+(: (-> Pair (View PairMsg)))
+(defun (pair-view p)
+  (column (view-map Left (counter-view (.left p))) (view-map Right (counter-view (.right p)))))
+
+;; And the whole app: the pair, mapped once more, and a canvas.
+(type (: Msg (Union (: OfPair PairMsg) (: Down double double) (: Drag double double)
+                    (: Up double double))))
+(type (: Model (Record (: pair Pair) (: log (List string)))))
+
+(: (-> Msg Model (Tuple Model (List (Event Msg)))))
+(defun (gui-update msg m)
+  (defun (log s) (record-set m (log (cons s (.log m)))))
+  (next (match msg
+          ((OfPair pm) (record-set m (pair (pair-update pm (.pair m)))))
+          ((Down x y) (log #"down ${x} ${y}"))
+          ((Drag x y) (log #"drag ${x} ${y}"))
+          ((Up x y) (log #"up ${x} ${y}")))))
+
+(: (-> Model (View Msg)))
+(defun (view m)
+  (column
+    (view-map OfPair (pair-view (.pair m)))                                      ; 0
+    (on-release
+      (on-move
+        (on-press
+          (canvas 200.0 100.0 #:background "white"                              ; 1
+            (rect 10.0 20.0 30.0 40.0 #:fill "red" #:stroke "black" #:radius 4.0) ; 1 0
+            (ellipse 50.0 10.0 20.0 20.0 #:fill "blue")                          ; 1 1
+            (line 0.0 0.0 80.0 60.0 #:stroke "green" #:stroke-width 3.0)         ; 1 2
+            (path "M 100 10 L 140 10 L 120 40 Z" #:fill "orange")                ; 1 3
+            (at-point 150.0 60.0 (text "hi")))                                   ; 1 4
+          Down)
+        Drag)
+      Up)))
+
+(defun (main)
+  (def app (start-app (Model (pair (Pair (left (Counter (count 0) (name "")))
+                                         (right (Counter (count 0) (name "")))))
+                             (log '()))
+                      gui-update view (fun (c) unit)))
+  (defun (ctl path) (app-control-at app path))
+  (defun (click path)
+    (raise-event (cast Interactive (ctl path)) (RoutedEventArgs. (cast RoutedEvent click-event))))
+  (defun (both) (.pair (app-model app)))
+  (defun (left-of (: c Control)) (left-of* (cast AvaloniaObject c)))
+  (defun (top-of (: c Control)) (top-of* (cast AvaloniaObject c)))
+
+  ;; --- view-map ---------------------------------------------------------------------
+  (click '(0 1 0))
+  (expect "a click in a mapped view, mapped twice" (.count (.right (both))) 1)
+  (expect "and not the other one" (.count (.left (both))) 0)
+  (box-text! (cast TextBox (ctl '(0 0 1))) "Ada")
+  (expect "a mapped function message" (.name (.left (both))) "Ada")
+  (click '(0 0 0))
+  (click '(0 0 0))
+  (expect "the view shows the component's model" (.count (.left (both))) 2)
+
+  ;; --- shapes -----------------------------------------------------------------------
+  (def r (ctl '(1 0)))
+  (expect "a rectangle's place" (list (left-of r) (top-of r)) '(10.0 20.0))
+  (expect "its size" (width-of (cast Layoutable r)) 30.0)
+  (expect "its fill" (.ToString (cast Object (fill-of (cast Shape r)))) "Red")
+  (expect "a line's end" (point-x (line-end (cast LineShape (ctl '(1 2))))) 80.0)
+  (expect "its width" (stroke-width-of (cast Shape (ctl '(1 2)))) 3.0)
+  (expect "a path's geometry" (eq? (cast Object (path-data (cast PathShape (ctl '(1 3))))) (cast Object 0)) #f)
+  (expect "a view at a point" (left-of (ctl '(1 4))) 150.0)
+
+  ;; --- pointer ----------------------------------------------------------------------
+  (def canvas-control (ctl '(1)))
+  (def pointer (cast IPointer (Pointer. 1 PointerType.Mouse #t)))
+  (defun (at x y) (Point. x y))
+  (raise-event (cast Interactive canvas-control)
+               (cast RoutedEventArgs (Pressed. (cast Object canvas-control) pointer (cast Visual canvas-control)
+                                               (at 30.0 40.0) 0UL (PointProps.) KeyModifiers.None 1)))
+  (expect "a press on the canvas" (.log (app-model app)) '("down 30 40"))
+  ;; On a shape, the event comes from the shape, and the place is still the
+  ;; canvas's.
+  (raise-event (cast Interactive r)
+               (cast RoutedEventArgs (Moved. (cast RoutedEvent moved-event) (cast Object r) pointer
+                                             (cast Visual canvas-control) (at 35.0 45.0) 1UL (PointProps.)
+                                             KeyModifiers.None)))
+  (expect "a move over a shape" (list-ref (.log (app-model app)) 0) "drag 35 45")
+  (raise-event (cast Interactive canvas-control)
+               (cast RoutedEventArgs (Released. (cast Object canvas-control) pointer (cast Visual canvas-control)
+                                                (at 36.0 46.0) 2UL (PointProps.) KeyModifiers.None
+                                                MouseButton.Left)))
+  (expect "a release" (list-ref (.log (app-model app)) 0) "up 36 46")
+
+  (println "bjogui canvas ok"))