bjogui/tests/components.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/components.bjo — components: state, outputs, drawing.
;;
;;     bjo run tests/components.bjo
;;
;; No window is opened. Avalonia runs with no screen and draws with Skia, so
;; a component's picture is drawn for real and its pixels can be read.

(import (std prelude))
(import (std simpletest))
(import (std mutable vec))
(import (bjogui draw))
(import (bjogui view))
(import (bjogui app))

(import/class
  (Object          (: System.Object))
  (IntPtr          (: System.IntPtr))
  (Control         (: Avalonia.Controls.Control))
  (Layoutable      (: Avalonia.Layout.Layoutable))
  (Visual          (: Avalonia.Visual))
  (Interactive     (: Avalonia.Interactivity.Interactive))
  (RoutedEvent     (: Avalonia.Interactivity.RoutedEvent))
  (RoutedEventArgs (: Avalonia.Interactivity.RoutedEventArgs))
  (Size            (: Avalonia.Size (-> double double Size)))
  (Rect            (: Avalonia.Rect (-> double double double double Rect)))
  (Point           (: Avalonia.Point (-> double double Point)))
  (PixelSize       (: Avalonia.PixelSize (-> int int PixelSize)))
  (PixelRect       (: Avalonia.PixelRect (-> int int int int PixelRect)))
  (Vector          (: Avalonia.Vector (-> double double Vector)))
  (RenderBitmap    (: Avalonia.Media.Imaging.RenderTargetBitmap (-> PixelSize Vector RenderBitmap)))
  (Bitmap          (: Avalonia.Media.Imaging.Bitmap))
  (AvPointer       (: Avalonia.Input.Pointer (-> int PointerType bool AvPointer)))
  (PointerType     (: Avalonia.Input.PointerType))
  (IPointer        (: Avalonia.Input.IPointer))
  (PointProps      (: Avalonia.Input.PointerPointProperties (-> PointProps)))
  (KeyModifiers    (: Avalonia.Input.KeyModifiers))
  (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))))

(import/extern
  (moved-event    (: Avalonia.Input.InputElement.PointerMovedEvent #:get))
  (handled?       (: Avalonia.Interactivity.RoutedEventArgs.Handled (-> RoutedEventArgs bool) #:get))
  (raise-event (: Avalonia.Interactivity.Interactive.RaiseEvent (-> Interactive RoutedEventArgs void)))
  (measure!    (: Avalonia.Layout.Layoutable.Measure (-> Layoutable Size void)))
  (arrange!    (: Avalonia.Layout.Layoutable.Arrange (-> Layoutable Rect void)))
  (render-into! (: Avalonia.Media.Imaging.RenderTargetBitmap.Render (-> RenderBitmap Visual void)))
  (copy-pixels! (: Avalonia.Media.Imaging.Bitmap.CopyPixels (-> Bitmap PixelRect IntPtr int int void)))
  (alloc       (: System.Runtime.InteropServices.Marshal.AllocHGlobal (-> int IntPtr)))
  (free!       (: System.Runtime.InteropServices.Marshal.FreeHGlobal (-> IntPtr void)))
  (read-int    (: System.Runtime.InteropServices.Marshal.ReadInt32 (-> IntPtr int int))))

;; What the components drew, in order, so that a test can see when they draw.
(: drawings (MutableVec string))
(def drawings (mutablevec))

(: (-> int (Vec string)))
(defun (drawn-since n)
  (vec-drop (mutablevec->vec drawings) n))

;; ---------------------------------------------------------------------------
;; A knob: drag up and down, or press the arrow keys
;; ---------------------------------------------------------------------------

;; Where a drag started, and the value then.
(type (: Knob (Union Idle (: Dragging double double))))

(: (-> double double))
(defun (within-one v) (max 0.0 (min 1.0 v)))

(def knob
  (component Idle
    (fun (pen w h s v)
      (mutablevec-add! drawings #"knob ${w}x${h} ${(written s)} ${v}")
      (fill-circle pen (/ w 2.0) (/ h 2.0) (/ w 2.0) "#333")
      (stroke-arc pen (/ w 2.0) (/ h 2.0) (- (/ w 2.0) 4.0) 2.0 (* v 5.0) "orange" #:width 3.0 #:cap "round"))
    #:input (fun (in w h s v)
              (match (Tuple in s)
                ((Tuple (PointerDown p) _) (Tuple (Dragging (.y p) v) None))
                ((Tuple (PointerMove p) (Dragging y0 v0)) (Tuple s (Some (within-one (+ v0 (/ (- y0 (.y p)) 100.0))))))
                ((Tuple (PointerUp _) _) (Tuple Idle None))
                ((Tuple (KeyDown "Up") _) (Tuple s (Some (within-one (+ v 0.125)))))
                (_ (Tuple s None))))
    #:cursor (fun (s v) (match s (Idle "Hand") (_ "SizeNorthSouth")))
    #:focusable #t))

;; A lamp: on or off, and it hears nothing.
(: lamp (Component bool Unit Unit))
(def lamp
  (component unit
    (fun (pen w h s on?)
      (mutablevec-add! drawings #"lamp ${on?}")
      (fill-circle pen (/ w 2.0) (/ h 2.0) (/ w 2.0) (if on? "yellow" "grey")))))

;; ---------------------------------------------------------------------------
;; The app
;; ---------------------------------------------------------------------------

(type (: Inner (Union (: Turned double))))
(type (: Msg (Union (: Volume double) (: Other double) (: Third double) (: Wrapped Inner) Swap Noop)))
(type (: Model (Record (: volume double) (: other double) (: third double) (: wrapped double)
                       (: swap bool) (: noops int))))

(: (-> Msg Model (Tuple Model (List (Event Msg)))))
(defun (gui-update msg m)
  (next (match msg
          ((Volume v) (record-set m (volume v)))
          ((Other v) (record-set m (other v)))
          ((Third v) (record-set m (third v)))
          ((Wrapped (Turned v)) (record-set m (wrapped v)))
          (Swap (record-set m (swap (not (.swap m)))))
          (Noop (record-set m (noops (+ (.noops m) 1)))))))

(: (-> double (View Inner)))
(defun (inner-view v) (drawn knob v Turned #:width 40.0 #:height 40.0))

(: (-> Model (View Msg)))
(defun (view m)
  (column
    (drawn knob (.volume m) Volume #:width 50.0 #:height 50.0)                     ; 0
    (drawn knob (.other m) Other #:width 50.0 #:height 50.0)                       ; 1
    (if (.swap m)                                                                  ; 2
        (drawn lamp #t (fun (o) Noop) #:width 20.0 #:height 20.0)
        (drawn knob (.third m) Third #:width 30.0 #:height 30.0))
    (view-map Wrapped (inner-view (.wrapped m)))))                                 ; 3

;; ---------------------------------------------------------------------------
;; Pictures
;; ---------------------------------------------------------------------------

;; Red on the left half, blue on the right, and a green dot at 30, 10.
(: halves (Component Unit Unit Unit))
(def halves
  (component unit
    (fun (pen w h s v)
      (fill-rect pen 0.0 0.0 (/ w 2.0) h "red")
      (fill-rect pen (/ w 2.0) 0.0 (/ w 2.0) h "blue")
      (fill-circle pen 30.0 10.0 3.0 "#00ff00"))))

;; Draws everything the pen can, so that each is seen to draw with no error.
(: everything (Component Unit Unit Unit))
(def everything
  (component unit
    (fun (pen w h s v)
      (stroke-rect pen 1.0 1.0 20.0 10.0 "black" #:width 2.0 #:radius 3.0 #:dash [2.0 1.0])
      (stroke-circle pen 10.0 10.0 5.0 "black")
      (fill-ellipse pen 0.0 0.0 8.0 4.0 "black")
      (stroke-ellipse pen 0.0 0.0 8.0 4.0 "black")
      (stroke-line pen 0.0 0.0 w h "black" #:cap "square")
      (stroke-polyline pen [(Tuple 0.0 0.0) (Tuple 5.0 9.0) (Tuple 9.0 3.0)] "black")
      (fill-polygon pen [(Tuple 0.0 0.0) (Tuple 5.0 9.0) (Tuple 9.0 3.0)] "black")
      (stroke-arc pen 10.0 10.0 5.0 0.0 7.0 "black")
      (fill-path pen "M 0 0 L 10 0 L 5 5 Z" "black")
      (stroke-path pen "M 0 0 L 10 0 L 5 5 Z" "black")
      (fill-path pen "not a path" "black")
      (fill-rect pen 0.0 0.0 5.0 5.0 "not a colour")
      (draw-text pen "text" (/ w 2.0) 0.0 "black" #:align "centre" #:bold #t #:max-width 50.0)
      (draw-image pen "no such file.png" 0.0 0.0 5.0 5.0)
      (translated pen 5.0 5.0
                  (fun () (scaled pen 2.0 2.0
                                  (fun () (rotated pen 1.0 3.0 3.0
                                                   (fun () (clipped pen 0.0 0.0 4.0 4.0
                                                                    (fun () (faded pen 0.5
                                                                                   (fun () (fill-rect pen 0.0 0.0 4.0 4.0 "black")))))))))))
      (mutablevec-add! drawings #"everything ${w}x${h}"))))

;; The colour at `x`, `y` of what `control` shows, laid out at `w` by `h`, as
;; "AARRGGBB".
(: (-> Control int int int int string))
(defun (pixel control w h x y)
  (measure! (cast Layoutable control) (Size. (cast double w) (cast double h)))
  (arrange! (cast Layoutable control) (Rect. 0.0 0.0 (cast double w) (cast double h)))
  (def bitmap (RenderBitmap. (PixelSize. w h) (Vector. 96.0 96.0)))
  (render-into! bitmap (cast Visual control))
  (def buffer (alloc (* 4 w h)))
  (copy-pixels! (cast Bitmap bitmap) (PixelRect. 0 0 w h) buffer (* 4 w h) (* 4 w))
  (def colour (read-int buffer (* 4 (+ x (* y w)))))
  (free! buffer)
  (.ToString (cast System.UInt32 colour) "X8"))

;; ---------------------------------------------------------------------------
;; The tests
;; ---------------------------------------------------------------------------

(defun (main)
  (start-headless!)
  (def app (start-app (Model (volume 0.5) (other 0.25) (third 0.0) (wrapped 0.0) (swap #f) (noops 0))
                      gui-update view (fun (c) unit)))
  (defun (input path in) (app-input! app path in))
  (defun (at y) (Pointer (x 10.0) (y y) (button "left") (clicks 1) (mods "")))

  ;; --- drawing --------------------------------------------------------------------
  (expect "each component is drawn once, at its size, in its first state"
          (mutablevec->vec drawings)
          ["knob 50x50 Idle 0.5" "knob 50x50 Idle 0.25" "knob 30x30 Idle 0" "knob 40x40 Idle 0"])

  ;; --- state and outputs ------------------------------------------------------------
  (def n (mutablevec-length drawings))
  (expect "a press changes the state" (input '(0) (PointerDown (at 40.0))) #t)
  (expect "and draws it, with no message" (drawn-since n) ["knob 50x50 (Dragging 40.0 0.5) 0.5"])
  (expect "the model is as it was" (.volume (app-model app)) 0.5)
  (def n (mutablevec-length drawings))
  (expect "a drag sends an output" (input '(0) (PointerMove (at 15.0))) #t)
  (expect "which is the app's message" (.volume (app-model app)) 0.75)
  (expect "and the new value is drawn" (drawn-since n) ["knob 50x50 (Dragging 40.0 0.5) 0.75"])
  (expect "the other knob kept its state" (input '(1) (PointerMove (at 15.0))) #f)
  (expect "and sent nothing" (.other (app-model app)) 0.25)
  (expect "a release" (input '(0) (PointerUp (at 15.0))) #t)
  (def n (mutablevec-length drawings))
  (expect "an input that changes nothing is not the component's" (input '(0) (PointerMove (at 1.0))) #f)
  (expect "and draws nothing" (drawn-since n) [])
  (expect "a key" (input '(0) (KeyDown "Up")) #t)
  (expect "sends its output" (.volume (app-model app)) 0.875)

  ;; --- an update that changes nothing of a component does not draw it -------------
  (def n (mutablevec-length drawings))
  (app-dispatch! app (Other 0.25))
  (expect "the same values draw nothing" (drawn-since n) [])

  ;; --- another component in the same place is another control ---------------------
  (expect "the third knob is pressed" (input '(2) (PointerDown (at 5.0))) #t)
  (def n (mutablevec-length drawings))
  (app-dispatch! app Swap)
  (expect "a lamp in its place" (drawn-since n) ["lamp #t"])
  (expect "which hears nothing" (input '(2) (PointerDown (at 5.0))) #f)
  (def n (mutablevec-length drawings))
  (app-dispatch! app Swap)
  (expect "the knob again, in its first state" (drawn-since n) ["knob 30x30 Idle 0"])

  ;; --- view-map ---------------------------------------------------------------------
  (ignore (input '(3) (PointerDown (at 20.0))))
  (ignore (input '(3) (PointerMove (at -5.0))))
  (expect "a mapped component's output is mapped" (.wrapped (app-model app)) 0.25)

  ;; --- the pointer, as Avalonia gives it ---------------------------------------------
  (def control (app-control-at app '(1)))
  (def pointer (cast IPointer (AvPointer. 1 PointerType.Mouse #t)))
  (def n (mutablevec-length drawings))
  (def press (cast RoutedEventArgs (Pressed. (cast Object control) pointer (cast Visual control)
                                             (Point. 10.0 20.0) 0UL (PointProps.) KeyModifiers.None 1)))
  (raise-event (cast Interactive control) press)
  (expect "a press on the control" (drawn-since n) ["knob 50x50 (Dragging 20.0 0.25) 0.25"])
  (expect "is the component's, and goes no further" (handled? press) #t)
  (defun (move y)
    (def e (cast RoutedEventArgs (Moved. (cast RoutedEvent moved-event) (cast Object control) pointer
                                         (cast Visual control) (Point. 10.0 y) 1UL (PointProps.)
                                         KeyModifiers.None)))
    (raise-event (cast Interactive control) e)
    (handled? e))
  (expect "a drag on the control" (move 5.0) #t)
  (expect "sends its output" (.other (app-model app)) 0.4)
  (ignore (input '(1) (PointerUp (at 5.0))))
  (expect "a move that changes nothing is left to the parents" (move 6.0) #f)

  ;; --- pictures ---------------------------------------------------------------------
  (def picture (start-app unit (fun (msg m) (next m))
                          (fun (m) (drawn halves unit (fun (o) o) #:width 60.0 #:height 20.0))
                          (fun (c) unit)))
  (def root (app-control picture))
  (expect "red at the left" (pixel root 60 20 5 15) "FFFF0000")
  (expect "blue at the right" (pixel root 60 20 55 15) "FF0000FF")
  (expect "a dot where it is drawn" (pixel root 60 20 30 10) "FF00FF00")

  ;; --- a component with no size takes the size it is laid out at --------------------
  (def filling (start-app unit (fun (msg m) (next m))
                          (fun (m) (grid (drawn everything unit (fun (o) o))))
                          (fun (c) unit)))
  (def n (mutablevec-length drawings))
  (ignore (pixel (app-control filling) 120 30 0 0))
  (expect "drawn at the size it is given" (drawn-since n) ["everything 120x30"])
  (expect "text has a size" (> (fst (text-size "text")) 0.0) #t)

  (println "bjogui components ok"))