bjogui/tests/canvas.bjo

;; 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) (left-of* (cast AvaloniaObject c)))
  (defun (top-of c) (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"))