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>
This commit is contained in:
parent
f53877e7a1
commit
ff9db1cc5b
5 changed files with 533 additions and 3 deletions
176
tests/canvas.bjo
Normal file
176
tests/canvas.bjo
Normal 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"))
|
||||
Loading…
Add table
Add a link
Reference in a new issue