bjoli/bjogui
SHA256
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
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>
This commit is contained in:
Linus Björnstam 2026-10-25 19:26:37 +01:00
parent f53877e7a1
commit ff9db1cc5b
5 changed files with 533 additions and 3 deletions
Download patch file Download diff file Expand all files Collapse all files

BIN
docs/sketch.png Normal file
View file

Binary file not shown.
Side by side

After

Width:  |  Height:  |  Size: 42 KiB

132
examples/sketch.bjo Normal file
View file

@ -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))

103
src/app.bjo
View file

@ -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.)))

125
src/view.bjo
View file

@ -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)

176
tests/canvas.bjo Normal file
View file

@ -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"))