diff --git a/docs/sketch.png b/docs/sketch.png new file mode 100644 index 0000000..046dce3 Binary files /dev/null and b/docs/sketch.png differ diff --git a/examples/sketch.bjo b/examples/sketch.bjo new file mode 100644 index 0000000..3054b14 --- /dev/null +++ b/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)) diff --git a/src/app.bjo b/src/app.bjo index 79e4918..e89ebb8 100644 --- a/src/app.bjo +++ b/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.))) diff --git a/src/view.bjo b/src/view.bjo index 5b63129..903046b 100644 --- a/src/view.bjo +++ b/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) diff --git a/tests/canvas.bjo b/tests/canvas.bjo new file mode 100644 index 0000000..4215c35 --- /dev/null +++ b/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"))