diff --git a/Readme.org b/Readme.org index 3be094b..f2a602c 100644 --- a/Readme.org +++ b/Readme.org @@ -177,6 +177,84 @@ Shapes are views like any other, so keyed ones are kept as their list changes. [[file:examples/sketch.bjo][examples/sketch.bjo]] is the picture above, and uses two components of its own. +* Controls of your own: component and (bjogui draw) + +[[file:docs/mixer.png]] + +~(component state draw #:input #:cursor #:focusable)~ makes a control that +draws itself and hears the pointer and the keys. It keeps a state of its own, +such as where a drag started or where the pointer hovers, which the model +never sees. ~(drawn c value on-output)~ puts it in a view: it shows ~value~, +and each output it sends is made a message with ~on-output~, as a slider's +value is. + +#+BEGIN_SRC scheme +(import (bjogui draw)) + +;; Where a drag started, and the value then. +(type (: Drag (Union Idle (: Dragging double double)))) + +(: knob (Component double Drag double)) +(def knob + (component Idle + (fun (pen w h s v) + (fill-circle pen (/ w 2.0) (/ h 2.0) (/ w 2.0) "#2c3e50") + (stroke-arc pen (/ w 2.0) (/ h 2.0) (- (/ w 2.0) 6.0) 2.4 (* v 4.7) "orange" + #:width 5.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 (max 0.0 (min 1.0 (+ v0 (/ (- y0 (.y p)) 150.0))))))) + ((Tuple (PointerUp _) _) (Tuple Idle None)) + (_ (Tuple s None)))) + #:cursor (fun (s v) "Hand"))) + +;; In a view: +(drawn knob (.volume model) Volume #:width 80.0 #:height 80.0) +#+END_SRC + +- ~(draw pen width height state value)~ draws the component at its size. It + is called again when the value, the state or the size changes, and not + otherwise. +- ~(input in width height state value)~ gives the next state, and maybe an + output. ~in~ is an ~Input~: ~(PointerDown p)~, ~(PointerMove p)~, + ~(PointerUp p)~, ~PointerEnter~, ~PointerLeave~, ~(Wheel p dx dy)~, + ~(KeyDown "Ctrl+Z")~, ~FocusIn~ and ~FocusOut~. A ~Pointer~ has ~x~ and ~y~ + from the component's corner, ~button~ (~"left"~, ~"right"~, ~"middle"~), + ~clicks~ (2 for a double click) and ~mods~ (~"Ctrl+Shift"~). +- A press takes the pointer, so a drag that leaves the component still + reaches it. A ~#:focusable~ component takes the keys when it is pressed. +- An input that changes the state or sends an output is the component's, and + goes no further. Any other goes on to the parents, so a key the component + does not use still works as a shortcut. +- With no ~#:width~ or ~#:height~, a component fills the space it is given, + and is drawn again when that changes. +- Make a component once, at the top of a module. A view in the place of + another component is a new control, whose state starts again. +- A component that sends nothing needs its type written, because its output + type is not known: ~(: lamp (Component bool Unit Unit))~. + +(bjogui draw) is the pen. Its coordinates start at the component's top left +corner, its colours are strings, and its angles are radians, clockwise from +the right, as ~sin~ and ~cos~ take them. + +- Shapes: ~fill-rect~, ~stroke-rect~ (~#:radius~), ~fill-circle~, + ~stroke-circle~, ~fill-ellipse~, ~stroke-ellipse~, ~stroke-line~, + ~stroke-polyline~, ~fill-polygon~, ~stroke-arc~, and ~fill-path~ and + ~stroke-path~ with SVG path data. Lines take ~#:width~, ~#:cap~ and + ~#:dash~. +- Text and pictures: ~draw-text~ (~#:size~, ~#:bold~, ~#:font~, ~#:align~, + ~#:max-width~), ~text-size~ to lay text out, and ~draw-image~. +- ~translated~, ~scaled~, ~rotated~, ~clipped~ and ~faded~ change what a + function given to them draws. + +The drawing is vectors, so it is sharp at any scale. +[[file:examples/mixer.bjo][examples/mixer.bjo]] has knobs and a timeline with +a playhead, marks and a hover line. ~start-headless!~ sets Avalonia up with no +screen, so that a test can draw components and read their pixels; see +~tests/components.bjo~. + * Styles and themes [[file:docs/styles.png]] @@ -304,6 +382,8 @@ answered. Avalonia's does. - ~app-stop!~ cancels the subscriptions and drops later messages. - ~app-press!~ presses keys, such as ~"Ctrl+S"~, as the window does. + - ~app-input!~ gives an ~Input~ to the component at a path, as its control + does. - ~app-model~ reads the model, and ~app-control-at~ finds a control by its path of child indices. @@ -329,11 +409,13 @@ bjo run tests/menus.bjo # prints "bjogui menus ok" bjo run tests/dialogs.bjo # prints "bjogui dialogs ok" bjo run tests/tree.bjo # prints "bjogui tree ok" bjo run tests/canvas.bjo # prints "bjogui canvas ok" +bjo run tests/components.bjo # prints "bjogui components ok" bjo run examples/counter.bjo bjo run examples/stopwatch.bjo bjo run examples/todo.bjo bjo run examples/styles.bjo bjo run examples/sketch.bjo +bjo run examples/mixer.bjo #+END_SRC * Not yet @@ -342,7 +424,9 @@ bjo run examples/sketch.bjo - Dialogs of one's own, with a view and a state. - The macOS menu bar. - Pointer-over and pressed colours for kinds other than buttons. -- Controls of Avalonia's or another package's that bjogui does not wrap, and - controls that draw themselves, which would need a subclass. +- Controls of Avalonia's or another package's that bjogui does not wrap. +- A component asks for no size of its own: it is given one, or fills the + space it gets. Measuring itself, an accessibility tree, and text input + inside a component would need a subclass. - A moved control is taken out of the panel and put back, so it may lose the keyboard focus. diff --git a/docs/mixer.png b/docs/mixer.png new file mode 100644 index 0000000..b4988ba Binary files /dev/null and b/docs/mixer.png differ diff --git a/examples/mixer.bjo b/examples/mixer.bjo new file mode 100644 index 0000000..0f238c7 --- /dev/null +++ b/examples/mixer.bjo @@ -0,0 +1,208 @@ +;; 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/mixer.bjo — controls of the program's own: knobs and a +;; timeline, drawn with (bjogui draw). +;; +;; bjo run examples/mixer.bjo +;; +;; Drag a knob up or down, or click it and press the arrow keys. Click or +;; drag on the timeline to move the playhead, double-click to put a mark +;; there, and press Left or Right to step by a second. "Play" moves the +;; playhead with a subscription. +;; +;; Each component keeps what only it needs, such as where a drag started or +;; where the pointer hovers, in a state of its own. The model holds only the +;; values, and the components send outputs that are made messages of. +;; +;; The picture in the Readme is this program, taken with +;; +;; BJOGUI_SCREENSHOT=docs/mixer.png bjo run examples/mixer.bjo + +(import (std prelude)) +(import (std maths)) +(import (bjogui draw)) +(import (bjogui view)) +(import (bjogui app)) + +(def pi 3.141592653589793) + +;; --------------------------------------------------------------------------- +;; A knob, for a value from 0 to 1 +;; --------------------------------------------------------------------------- + +;; Where a drag started, and the value then; and whether it has the keys. +(type (: KnobState (Record (: drag (Option (Tuple double double))) (: focused bool)))) + +(: (-> double double)) +(defun (within-one v) (max 0.0 (min 1.0 v))) + +;; The arc runs from the bottom left, through the top, to the bottom right. +(def knob-start (* 0.75 pi)) +(def knob-sweep (* 1.5 pi)) + +(: knob (Component double KnobState double)) +(def knob + (component (KnobState (drag None) (focused #f)) + (fun (pen w h s v) + (def cx (/ w 2.0)) + (def cy (/ h 2.0)) + (def r (- (min cx cy) 6.0)) + (fill-circle pen cx cy r (if (.focused s) "#3d4a5c" "#2c3e50")) + (stroke-arc pen cx cy (- r 6.0) knob-start knob-sweep "#55606e" #:width 5.0 #:cap "round") + (stroke-arc pen cx cy (- r 6.0) knob-start (* v knob-sweep) "#f39c12" #:width 5.0 #:cap "round") + ;; The pointer, at the end of the value's arc. + (def a (+ knob-start (* v knob-sweep))) + (stroke-line pen (+ cx (* 0.25 r (cos a))) (+ cy (* 0.25 r (sin a))) + (+ cx (* 0.6 r (cos a))) (+ cy (* 0.6 r (sin a))) + "white" #:width 3.0 #:cap "round") + (draw-text pen #"${(exact-round (* v 100.0))}%" cx (+ cy (* 0.55 r)) "white" + #:size 11.0 #:align "centre")) + #:input (fun (in w h s v) + (match in + ((PointerDown p) (Tuple (record-set s (drag (Some (Tuple (.y p) v)))) None)) + ((PointerMove p) + (match (.drag s) + ((Some (Tuple y0 v0)) (Tuple s (Some (within-one (+ v0 (/ (- y0 (.y p)) 150.0)))))) + (None (Tuple s None)))) + ((PointerUp _) (Tuple (record-set s (drag None)) None)) + ((Wheel _ _ dy) (Tuple s (Some (within-one (+ v (* dy 0.05)))))) + ((KeyDown "Up") (Tuple s (Some (within-one (+ v 0.05))))) + ((KeyDown "Down") (Tuple s (Some (within-one (- v 0.05))))) + (FocusIn (Tuple (record-set s (focused #t)) None)) + (FocusOut (Tuple (record-set s (focused #f)) None)) + (_ (Tuple s None)))) + #:cursor (fun (s v) (match (.drag s) ((Some _) "SizeNorthSouth") (None "Hand"))) + #:focusable #t)) + +;; --------------------------------------------------------------------------- +;; A timeline, with a playhead and marks +;; --------------------------------------------------------------------------- + +(type (: Timeline (Record (: length double) (: position double) (: marks (Vec double))))) + +;; Where the pointer hovers, and whether the playhead is being dragged. +(type (: TimelineState (Record (: hover (Option double)) (: dragging bool)))) + +(type (: TimelineOut (Union (: Seek double) (: AddMark double)))) + +(def margin 12.0) + +(: (-> double string)) +(defun (clock seconds) + (def s (exact-floor seconds)) + (def secs (string-pad-left (number->string (remainder s 60)) 2 #:with #\0)) + #"${(quotient s 60)}:${secs}") + +;; The timeline at `w` by `h`. +(: (-> Pen double double TimelineState Timeline void)) +(defun (draw-timeline pen w h s t) + (def span (- w (* 2.0 margin))) + (defun (x-of time) (+ margin (* span (/ time (.length t))))) + (fill-rect pen 0.0 0.0 w h "#1e2730" #:radius 6.0) + (fill-rect pen margin 30.0 span 8.0 "#33404d" #:radius 4.0) + (fill-rect pen margin 30.0 (- (x-of (.position t)) margin) 8.0 "#2e86de" #:radius 4.0) + ;; A tick each five seconds, with the time under every second one. + (loop (:for i (range 0 (+ 1 (exact-floor (/ (.length t) 5.0))))) + (:do (def x (x-of (* 5.0 (cast double i)))) + (stroke-line pen x 44.0 x (if (even? i) 52.0 48.0) "#7f8c8d") + (when (even? i) + (draw-text pen (clock (* 5.0 (cast double i))) x 53.0 "#95a5a6" #:size 10.0 #:align "centre")))) + (loop (:for m (.marks t)) + (:do (def x (x-of m)) + (fill-polygon pen [(Tuple (- x 5.0) 14.0) (Tuple (+ x 5.0) 14.0) (Tuple x 22.0)] "#f1c40f"))) + (match (.hover s) + ((Some time) + (def x (x-of time)) + (stroke-line pen x 8.0 x 44.0 "#ffffff60" #:dash [2.0 2.0]) + (draw-text pen (clock time) x 0.0 "#bdc3c7" #:size 10.0 #:align "centre")) + (None unit)) + (def px (x-of (.position t))) + (stroke-line pen px 10.0 px 44.0 "#e74c3c" #:width 2.0) + (fill-circle pen px 34.0 (if (.dragging s) 8.0 6.0) "#e74c3c")) + +;; The next state for `in`, and the place to move the playhead to or to mark. +(: (-> Input double double TimelineState Timeline (Tuple TimelineState (Option TimelineOut)))) +(defun (timeline-input in w h s t) + (defun (time-at x) + (max 0.0 (min (.length t) (* (.length t) (/ (- x margin) (- w (* 2.0 margin))))))) + (match in + ((PointerDown p) + (if (= (.clicks p) 2) + (Tuple s (Some (AddMark (time-at (.x p))))) + (Tuple (record-set s (dragging #t)) (Some (Seek (time-at (.x p))))))) + ((PointerMove p) + (def hovered (record-set s (hover (Some (time-at (.x p)))))) + (Tuple hovered (if (.dragging s) (Some (Seek (time-at (.x p)))) None))) + ((PointerUp _) (Tuple (record-set s (dragging #f)) None)) + (PointerLeave (Tuple (record-set s (hover None)) None)) + ((KeyDown "Right") (Tuple s (Some (Seek (min (.length t) (+ (.position t) 1.0)))))) + ((KeyDown "Left") (Tuple s (Some (Seek (max 0.0 (- (.position t) 1.0)))))) + (_ (Tuple s None)))) + +(: (-> TimelineState Timeline string)) +(defun (timeline-cursor s t) (if (.dragging s) "SizeWestEast" "Hand")) + +(: timeline (Component Timeline TimelineState TimelineOut)) +(def timeline + (component (TimelineState (hover None) (dragging #f)) draw-timeline + #:input timeline-input + #:cursor timeline-cursor + #:focusable #t)) + +;; --------------------------------------------------------------------------- +;; The mixer +;; --------------------------------------------------------------------------- + +(type (: Msg (Union (: Volume double) (: Bass double) (: Treble double) + (: Track TimelineOut) Play Tick))) + +(type (: Model (Record (: volume double) (: bass double) (: treble double) + (: track Timeline) (: playing bool)))) + +(: gui-update (-> Msg Model (Tuple Model (List (Event Msg))))) +(defun (gui-update msg m) + (def t (.track m)) + (next (match msg + ((Volume v) (record-set m (volume v))) + ((Bass v) (record-set m (bass v))) + ((Treble v) (record-set m (treble v))) + ((Track (Seek time)) (record-set m (track (record-set t (position time))))) + ((Track (AddMark time)) (record-set m (track (record-set t (marks (vec-add (.marks t) time)))))) + (Play (record-set m (playing (not (.playing m))))) + (Tick + (def time (+ (.position t) 0.1)) + (if (>= time (.length t)) + (record-set m (playing #f) (track (record-set t (position (.length t))))) + (record-set m (track (record-set t (position time))))))))) + +(: subscriptions (-> Model (List (Sub Msg)))) +(defun (subscriptions m) + (if (.playing m) (list (every (milliseconds 100) Tick)) '())) + +(: (-> string double (-> double Msg) (View Msg))) +(defun (labelled-knob label v msg) + (column #:spacing 4.0 + (drawn knob v msg #:width 84.0 #:height 84.0) + (text label #:margin 2.0))) + +(: view (-> Model (View Msg))) +(defun (view m) + (column #:spacing 12.0 #:margin 16.0 + (row #:spacing 16.0 + (labelled-knob "Volume" (.volume m) Volume) + (labelled-knob "Bass" (.bass m) Bass) + (labelled-knob "Treble" (.treble m) Treble)) + (drawn timeline (.track m) Track #:height 68.0) + (row #:spacing 8.0 + (button (if (.playing m) "Pause" "Play") Play #:width 80.0) + (text #"${(clock (.position (.track m)))} of ${(clock (.length (.track m)))}")))) + +(defun (main) + (run-app (Model (volume 0.7) (bass 0.4) (treble 0.55) + (track (Timeline (length 60.0) (position 21.5) (marks [8.0 33.0 47.5]))) + (playing #f)) + gui-update view + #:subscriptions subscriptions + #:title "Mixer" #:width 460.0 #:height 300.0)) diff --git a/manifest.bjodat b/manifest.bjodat index 33285c1..a62c1a2 100644 --- a/manifest.bjodat +++ b/manifest.bjodat @@ -9,4 +9,8 @@ (packages (nuget (id "Avalonia") (version "11.3.2")) (nuget (id "Avalonia.Desktop") (version "11.3.2")) - (nuget (id "Avalonia.Themes.Fluent") (version "11.3.2")))) + (nuget (id "Avalonia.Themes.Fluent") (version "11.3.2")) + ;; A platform with no screen, and the drawing it uses, for tests: see + ;; `start-headless!`. + (nuget (id "Avalonia.Headless") (version "11.3.2")) + (nuget (id "Avalonia.Skia") (version "11.3.2")))) diff --git a/packages.lock.json b/packages.lock.json index ac60a16..a633c82 100644 --- a/packages.lock.json +++ b/packages.lock.json @@ -26,6 +26,30 @@ "Avalonia.X11": "11.3.2" } }, + "Avalonia.Headless": { + "type": "Direct", + "requested": "[11.3.2, )", + "resolved": "11.3.2", + "contentHash": "IE5UuoXZ10qhaJ9hzyZL6jlvDhNBdxvrSPoaB2WPRCEYf1N27i5bSCu0jDsjgscqmYQ3XB40GUinI0v32ZNTtA==", + "dependencies": { + "Avalonia": "11.3.2" + } + }, + "Avalonia.Skia": { + "type": "Direct", + "requested": "[11.3.2, )", + "resolved": "11.3.2", + "contentHash": "PJIPSqkWbQpKyWPMEIDAWYQaJ8xpJASg2H75sGWCkthLj+mCG/DZxdHI6UsDAcxKu/ppSRkX88RGo117bRYfFg==", + "dependencies": { + "Avalonia": "11.3.2", + "HarfBuzzSharp": "8.3.1.1", + "HarfBuzzSharp.NativeAssets.Linux": "8.3.1.1", + "HarfBuzzSharp.NativeAssets.WebAssembly": "8.3.1.1", + "SkiaSharp": "2.88.9", + "SkiaSharp.NativeAssets.Linux": "2.88.9", + "SkiaSharp.NativeAssets.WebAssembly": "2.88.9" + } + }, "Avalonia.Themes.Fluent": { "type": "Direct", "requested": "[11.3.2, )", @@ -67,20 +91,6 @@ "resolved": "11.3.2", "contentHash": "my6aXePR+N7tl3xDKdYNH2ZFZWUSNmyeU37HIgYJX2fQ4IOBv7SeaWBEd1F/qVsIbOlYxaqE7qOPfeFFtdYq/A==" }, - "Avalonia.Skia": { - "type": "Transitive", - "resolved": "11.3.2", - "contentHash": "PJIPSqkWbQpKyWPMEIDAWYQaJ8xpJASg2H75sGWCkthLj+mCG/DZxdHI6UsDAcxKu/ppSRkX88RGo117bRYfFg==", - "dependencies": { - "Avalonia": "11.3.2", - "HarfBuzzSharp": "8.3.1.1", - "HarfBuzzSharp.NativeAssets.Linux": "8.3.1.1", - "HarfBuzzSharp.NativeAssets.WebAssembly": "8.3.1.1", - "SkiaSharp": "2.88.9", - "SkiaSharp.NativeAssets.Linux": "2.88.9", - "SkiaSharp.NativeAssets.WebAssembly": "2.88.9" - } - }, "Avalonia.Win32": { "type": "Transitive", "resolved": "11.3.2", diff --git a/src/app.bjo b/src/app.bjo index e89ebb8..440f396 100644 --- a/src/app.bjo +++ b/src/app.bjo @@ -30,13 +30,14 @@ ;; Subscriptions. every subscription ;; For tests and for hosts of their own: an app with no window. - start-app app-dispatch! app-send! app-stop! app-run-pending! app-press! - app-model app-control app-control-at) + start-app app-dispatch! app-send! app-stop! app-run-pending! app-press! app-input! + app-model app-control app-control-at start-headless!) (import (std prelude)) (import (std interop)) (import (std mutable vec)) (import (std mutable map)) +(import (bjogui draw)) (import (bjogui view)) ;; --------------------------------------------------------------------------- @@ -154,7 +155,20 @@ (-> Lifetime))) (Dispatcher (: Avalonia.Threading.Dispatcher)) (UiPriority (: Avalonia.Threading.DispatcherPriority)) - ((DispatcherOp %a) (: Avalonia.Threading.DispatcherOperation))) + ((DispatcherOp %a) (: Avalonia.Threading.DispatcherOperation)) + ;; Components. + (Rect (: Avalonia.Rect)) + (Stretch (: Avalonia.Media.Stretch)) + (CursorObject (: Avalonia.Input.Cursor (-> CursorType CursorObject))) + (CursorType (: Avalonia.Input.StandardCursorType)) + (PointerPoint (: Avalonia.Input.PointerPoint)) + (PointProps (: Avalonia.Input.PointerPointProperties)) + (UpdateKind (: Avalonia.Input.PointerUpdateKind)) + (PressedArgs (: Avalonia.Input.PointerPressedEventArgs)) + (WheelArgs (: Avalonia.Input.PointerWheelEventArgs)) + (InputElement (: Avalonia.Input.InputElement)) + (NavigationMethod (: Avalonia.Input.NavigationMethod)) + (HeadlessOptions (: Avalonia.Headless.AvaloniaHeadlessPlatformOptions (-> HeadlessOptions)))) (import/extern ;; Properties, as the objects `SetValue` takes. @@ -355,7 +369,42 @@ (timer-stop! (: Avalonia.Threading.DispatcherTimer.Stop (-> Timer void))) (render-into! (: Avalonia.Media.Imaging.RenderTargetBitmap.Render (-> RenderBitmap Visual void))) (save-png! (: Avalonia.Media.Imaging.Bitmap.Save (-> Bitmap string (Nullable int) void))) - (window-content! (: Avalonia.Controls.ContentControl.Content (-> ContentControl Object void) #:set))) + (window-content! (: Avalonia.Controls.ContentControl.Content (-> ContentControl Object void) #:set)) + + ;; Components. + (image-stretch-property (: Avalonia.Controls.Image.StretchProperty #:get)) + (focusable-property (: Avalonia.Input.InputElement.FocusableProperty #:get)) + (hit-test-property (: Avalonia.Input.InputElement.IsHitTestVisibleProperty #:get)) + (clip-property (: Avalonia.Visual.ClipToBoundsProperty #:get)) + (cursor-property (: Avalonia.Input.InputElement.CursorProperty #:get)) + (bounds-property (: Avalonia.Visual.BoundsProperty #:get)) + (bounds-of (: Avalonia.Visual.Bounds (-> Visual Rect) #:get)) + (rect-width (: Avalonia.Rect.Width (-> Rect double) #:get)) + (rect-height (: Avalonia.Rect.Height (-> Rect double) #:get)) + (pointer-entered-event (: Avalonia.Input.InputElement.PointerEnteredEvent #:get)) + (pointer-exited-event (: Avalonia.Input.InputElement.PointerExitedEvent #:get)) + (wheel-event (: Avalonia.Input.InputElement.PointerWheelChangedEvent #:get)) + (got-focus-event (: Avalonia.Input.InputElement.GotFocusEvent #:get)) + (lost-focus-event (: Avalonia.Input.InputElement.LostFocusEvent #:get)) + (current-point (: Avalonia.Input.PointerEventArgs.GetCurrentPoint (-> PointerEventArgs Visual PointerPoint))) + (point-props (: Avalonia.Input.PointerPoint.Properties (-> PointerPoint PointProps) #:get)) + (update-kind (: Avalonia.Input.PointerPointProperties.PointerUpdateKind (-> PointProps UpdateKind) #:get)) + (pointer-mods (: Avalonia.Input.PointerEventArgs.KeyModifiers (-> PointerEventArgs KeyModifiers) #:get)) + (click-count (: Avalonia.Input.PointerPressedEventArgs.ClickCount (-> PressedArgs int) #:get)) + (wheel-delta (: Avalonia.Input.PointerWheelEventArgs.Delta (-> WheelArgs Vector) #:get)) + (vector-x (: Avalonia.Vector.X (-> Vector double) #:get)) + (vector-y (: Avalonia.Vector.Y (-> Vector double) #:get)) + (focus! (: Avalonia.Input.InputElement.Focus (-> InputElement NavigationMethod KeyModifiers bool))) + (parse-enum (: System.Enum.Parse (-> ClrType string bool Object))) + (gesture-text (: Avalonia.Input.KeyGesture.ToString (-> KeyGesture string))) + + ;; No screen, for tests. + (use-skia (: Avalonia.SkiaApplicationExtensions.UseSkia (-> AppBuilder AppBuilder))) + (use-headless (: Avalonia.Headless.AvaloniaHeadlessPlatformExtensions.UseHeadless + (-> AppBuilder HeadlessOptions AppBuilder))) + (headless-drawing! (: Avalonia.Headless.AvaloniaHeadlessPlatformOptions.UseHeadlessDrawing + (-> HeadlessOptions bool void) #:set)) + (setup-without-starting (: Avalonia.AppBuilder.SetupWithoutStarting (-> AppBuilder AppBuilder)))) ;; --------------------------------------------------------------------------- ;; Properties @@ -399,6 +448,7 @@ (EllipseKind #f) (LineKind #f) (PathKind #f) + (CustomKind #f) (_ #t))) ;; A kind that Avalonia draws as a shape, with a fill and a stroke. @@ -762,10 +812,19 @@ ;; The app ;; --------------------------------------------------------------------------- +;; What a component was drawn with: its value, its state, and its size. +(type (: Painted (Record (: drawn-value Object) (: drawn-state Object) + (: drawn-width double) (: drawn-height double)))) + ;; A control, the view it was last given, and the live children it holds. +;; A component's control holds its state too, what it was last drawn with, +;; and the name of its cursor; other controls hold null, None and "". (type (: (Live %m) #:opaque (Record (: control Control) (: view (View %m) #:mutable) - (: children (MutableVec (Live %m)))))) + (: children (MutableVec (Live %m))) + (: local Object #:mutable) + (: painted (Option Painted) #:mutable) + (: cursor-name string #:mutable)))) ;; --------------------------------------------------------------------------- ;; Commands and subscriptions @@ -842,18 +901,30 @@ ((Some live) (.control live)) (None (raise (cast Exception (InvalidOperation. "the app has no view")))))) -;; The control at `path`, a child index for each level below the root. -(: (-> (App %model %m) (List int) Control)) -(defun (app-control-at app path) - (: (-> (Live %m) (List int) Control)) +;; The live control at `path`, a child index for each level below the root. +(: (-> (App %model %m) (List int) (Live %m))) +(defun (live-at app path) + (: (-> (Live %m) (List int) (Live %m))) (defun (walk live path) (match path - (() (.control live)) + (() live) ((List i rest ...) (walk (mutablevec-ref (.children live) i) rest)))) (match (.root app) ((Some live) (walk live path)) (None (raise (cast Exception (InvalidOperation. "the app has no view")))))) +;; The control at `path`, a child index for each level below the root. +(: (-> (App %model %m) (List int) Control)) +(defun (app-control-at app path) + (.control (live-at app path))) + +;; Gives `in` to the component at `path`, as the control gives it what the +;; user does. True when the component's state changed or it sent an output. +;; For tests. +(: (-> (App %model %m) (List int) Input bool)) +(defun (app-input! app path in) + (custom-input! app (live-at app path) in)) + ;; Makes the next model from `msg`, shows its view, starts its commands, and ;; starts and stops subscriptions. Only on the UI thread; from anywhere else, ;; use `app-send!`. A stopped app drops the message. @@ -1127,6 +1198,7 @@ (fun () (def i (selected-index (cast SelectingItemsControl control))) (fun (on) (match on ((OnSelect f) (Some (f i))) (_ None)))))) + (CustomKind (listen-custom! app live)) (_ unit))) (: (-> Kind Control)) @@ -1192,7 +1264,21 @@ (AutoCompleteKind (cast Control (AutoCompleteBox.))) (ExpanderKind (cast Control (Expander.))) (WrapKind (cast Control (WrapPanel.))) - (DockKind (cast Control (DockPanel.))))) + (DockKind (cast Control (DockPanel.))) + (CustomKind + ;; A canvas, because a canvas asks for no size of its own: the + ;; component takes the size it is given, and its picture does not make + ;; it grow. The picture is an Image on it that takes no pointer, so the + ;; pointer's events come from the canvas. It is transparent and not + ;; empty, so that it takes the pointer where nothing is drawn. + (def c (cast Control (Canvas.))) + (put! c (cast AvaloniaProperty panel-background) (cast Object (parse-brush "Transparent"))) + (put! c (cast AvaloniaProperty clip-property) (cast Object #t)) + (def image (cast Control (Image.))) + (put! image (cast AvaloniaProperty image-stretch-property) (cast Object Stretch.None)) + (put! image (cast AvaloniaProperty hit-test-property) (cast Object #f)) + (ignore (list-add! (cast IList (panel-children (cast Panel c))) (cast Object image))) + c))) ;; Where the controls of a panel's children, or of a list's items, are. (: (-> Kind Control IList)) @@ -1236,7 +1322,8 @@ (defun (mount app v) (def kind (view-kind v)) (def control (make-control kind)) - (def live (Live (control control) (view v) (children (mutablevec)))) + (def live (Live (control control) (view v) (children (mutablevec)) + (local (: (clr-default) Object)) (painted None) (cursor-name ""))) (loop (:for p (view-props v)) (:do (set-prop! control kind p))) (listen! app live kind) (loop (:for child (view-children v)) @@ -1245,6 +1332,7 @@ (adopt! kind control (- (mutablevec-length (.children live)) 1) (.control c)))) (sync-selection! control kind (view-props v)) (sync-tree-choice! live) + (when (= kind CustomKind) (start-custom! live)) live) ;; Changes the controls of `live` to show `next`. Gives `live` itself, or new @@ -1253,11 +1341,12 @@ (defun (patch! app live next) (def old (.view live)) (def kind (view-kind next)) - (if (not (= (view-kind old) kind)) + (if (or (not (= (view-kind old) kind)) (not (same-component? old next))) (mount app next) (begin (patch-props! (.control live) kind (view-props old) (view-props next)) (record-set! live (view next)) + (when (= kind CustomKind) (sync-custom! live)) (cond ((single? kind) (patch-single! app live kind (view-children next))) ((or (panel? kind) (items? kind)) (patch-children! app live kind (view-children next))) (else unit)) @@ -1593,3 +1682,204 @@ (ignore (start-lifetime lifetime (: (make-array 0) (Array ClrString)))) (app-stop! app) (cancel (Requested "the window is closed")))) + +;; --------------------------------------------------------------------------- +;; Components +;; --------------------------------------------------------------------------- + +(: (-> (View %m) (Option (Custom %m)))) +(defun (custom-of v) + (loop (:for on (view-events v)) + (:when-let (OnCustom c) on) + (:finish #t (Some c)) + => None)) + +;; Whether two views are of one component, or neither is a component. A view +;; of another component in the same place is another control. +(: (-> (View %m) (View %m) bool)) +(defun (same-component? a b) + (match (Tuple (custom-of a) (custom-of b)) + ((Tuple (Some x) (Some y)) (eq? (.identity x) (.identity y))) + (_ #t))) + +;; The size a component is drawn at: the size it was laid out at, or before +;; it is laid out, the size its view gives it, or 0. +(: (-> (Live %m) (Tuple double double))) +(defun (custom-size live) + (def b (bounds-of (cast Visual (.control live)))) + (defun (given pick) + (loop (:for p (view-props (.view live))) + (:when-let (Some d) (pick p)) + (:finish #t d) + => 0.0)) + (Tuple (if (> (rect-width b) 0.0) + (rect-width b) + (given (fun (p) (match p ((PropWidth d) (Some d)) (_ None))))) + (if (> (rect-height b) 0.0) + (rect-height b) + (given (fun (p) (match p ((PropHeight d) (Some d)) (_ None))))))) + +(: cursors (MutableMap string (Option CursorObject))) +(def cursors (mutablemap)) + +;; The cursor of Avalonia's StandardCursorType `name`. None for a name that +;; is not one, and when the platform has no cursors, as with no screen. +(: (-> string (Option CursorObject))) +(defun (cursor-named name) + (match (mutablemap-try-ref cursors name) + ((Some c) c) + (None + (def c (match (try (CursorObject. + (cast CursorType + (parse-enum (type-named "Avalonia.Input.StandardCursorType, Avalonia.Base") + name #t))) + #:catch (System.Exception)) + ((Ok c) (Some c)) + ((Err _) None))) + (mutablemap-set! cursors name c) + c))) + +;; Draws the component again if its value, its state or its size is another +;; than it was drawn with, and sets its cursor if that is another. +(: (-> (Live %m) void)) +(defun (repaint! live) + (match (custom-of (.view live)) + ((Some c) + (def (Tuple w h) (custom-size live)) + (def state (.local live)) + (def fresh? + (match (.painted live) + ((Some p) (and (= (.drawn-width p) w) (= (.drawn-height p) h) + ((.same-value? c) (.drawn-value p)) + ((.same-state? c) (.drawn-state p) state))) + (None #f))) + (unless fresh? + (def image (cast Control (list-ref (cast IList (panel-children (cast Panel (.control live)))) 0))) + (def draw (.draw c)) + (match (drawing-image (fun (pen) (draw pen w h state)) w h) + ((Some (Tuple picture x y)) + (put! image (cast AvaloniaProperty image-source-property) picture) + (put! image (cast AvaloniaProperty canvas-left-property) (cast Object x)) + (put! image (cast AvaloniaProperty canvas-top-property) (cast Object y))) + (None (clear-value (cast AvaloniaObject image) (cast AvaloniaProperty image-source-property)))) + (record-set! live (painted (Some (Painted (drawn-value (.value c)) (drawn-state state) + (drawn-width w) (drawn-height h)))))) + (def name ((.cursor c) state)) + (unless (= name (.cursor-name live)) + (record-set! live (cursor-name name)) + (match (cursor-named name) + ((Some k) (put! (.control live) (cast AvaloniaProperty cursor-property) (cast Object k))) + (None (clear-value (cast AvaloniaObject (.control live)) (cast AvaloniaProperty cursor-property)))))) + (None unit))) + +;; A new component's control: its first state, and its first picture. +(: (-> (Live %m) void)) +(defun (start-custom! live) + (match (custom-of (.view live)) + ((Some c) (record-set! live (local (.initial c)))) + (None unit)) + (sync-custom! live)) + +;; A component's control, given a view of the same component. +(: (-> (Live %m) void)) +(defun (sync-custom! live) + (match (custom-of (.view live)) + ((Some c) (put! (.control live) (cast AvaloniaProperty focusable-property) (cast Object (.focusable c)))) + (None unit)) + (repaint! live)) + +;; Gives `in` to the component: its next state, and its output to `gui-update`. +;; True when the state changed or there was an output, and so the input is +;; the component's and not its parents'. Input while the controls are being +;; changed is not the user's, and is dropped. +(: (-> (App %model %m) (Live %m) Input bool)) +(defun (custom-input! app live in) + (match (if (.patching app) None (custom-of (.view live))) + ((Some c) + (def (Tuple w h) (custom-size live)) + (def before (.local live)) + (def (Tuple after out) ((.input c) in w h before)) + (record-set! live (local after)) + (match out + ((Some msg) (app-dispatch! app msg)) + (None unit)) + (repaint! live) + (or (not ((.same-state? c) before after)) + (match out ((Some _) #t) (None #f)))) + (None #f))) + +;; Keys held, as "Ctrl+Shift", in the order that keys are written in. +(: (-> KeyModifiers string)) +(defun (mods-text m) + (def s (.ToString (cast Object m))) + (string-join (vecing-of (fun (name text) (if (string-contains? s name) (Some text) None))) + "+")) + +(: (-> (-> string string (Option string)) (Vec string))) +(defun (vecing-of pick) + (loop (:for (Tuple name text) [(Tuple "Control" "Ctrl") (Tuple "Shift" "Shift") (Tuple "Alt" "Alt") + (Tuple "Meta" "Meta")]) + (:when-let (Some t) (pick name text)) + (:acc out (vecing t)) + => out)) + +;; Hears what the user does to a component's control, and gives it to the +;; component as Input. The size the control is laid out at is heard too: the +;; component is drawn again at it. +(: (-> (App %model %m) (Live %m) void)) +(defun (listen-custom! app live) + (def control (.control live)) + (def visual (cast Visual control)) + (defun (pointer (: e PointerEventArgs) button clicks) + (def at (position-in e visual)) + (Pointer (x (point-x at)) (y (point-y at)) (button button) (clicks clicks) + (mods (mods-text (pointer-mods e))))) + (defun (button-of (: e PointerEventArgs)) + (def k (.ToString (cast Object (update-kind (point-props (current-point e visual)))))) + (cond ((string-contains? k "Left") "left") + ((string-contains? k "Right") "right") + ((string-contains? k "Middle") "middle") + (else ""))) + (defun (hear (: event RoutedEvent) make) + (on! control event + (fun (sender e) + (when (custom-input! app live (make e)) (handled! e #t))))) + (hear (cast RoutedEvent pointer-pressed-event) + (fun (e) + (def p (cast PointerEventArgs e)) + ;; The pointer is the component's until the button is let go, and + ;; a focusable component takes the keys. + (capture! (pointer-of p) (cast IInputElement control)) + (when (match (custom-of (.view live)) ((Some c) (.focusable c)) (None #f)) + (ignore (focus! (cast InputElement control) NavigationMethod.Pointer KeyModifiers.None))) + (PointerDown (pointer p (button-of p) (click-count (cast PressedArgs e)))))) + (hear (cast RoutedEvent pointer-moved-event) + (fun (e) (PointerMove (pointer (cast PointerEventArgs e) "" 0)))) + (hear (cast RoutedEvent pointer-released-event) + (fun (e) (def p (cast PointerEventArgs e)) (PointerUp (pointer p (button-of p) 1)))) + (hear (cast RoutedEvent pointer-entered-event) (fun (e) PointerEnter)) + (hear (cast RoutedEvent pointer-exited-event) (fun (e) PointerLeave)) + (hear (cast RoutedEvent wheel-event) + (fun (e) + (def d (wheel-delta (cast WheelArgs e))) + (Wheel (pointer (cast PointerEventArgs e) "" 0) (vector-x d) (vector-y d)))) + (hear (cast RoutedEvent key-down-event) + (fun (e) + (def k (cast KeyEventArgs e)) + (KeyDown (gesture-text (KeyGesture. (key-of k) (modifiers-of k)))))) + (hear (cast RoutedEvent got-focus-event) (fun (e) FocusIn)) + (hear (cast RoutedEvent lost-focus-event) (fun (e) FocusOut)) + (ignore (add-event-handler! control "PropertyChanged" + (: (fun (sender e) + (when (eq? (changed-property (cast PropertyChange e)) (cast AvaloniaProperty bounds-property)) + (repaint! live))) + (-> Object Object void))))) + +;; Sets Avalonia up with no screen, drawing with Skia, so that components can +;; be drawn and their pictures read in a test. Call it once, before +;; `start-app`. +(: (-> void)) +(defun (start-headless!) + (def options (HeadlessOptions.)) + (headless-drawing! options #f) + (ignore (setup-without-starting (use-headless (use-skia (configure (fun () (Application.)))) options)))) diff --git a/src/draw.bjo b/src/draw.bjo new file mode 100644 index 0000000..80927c3 --- /dev/null +++ b/src/draw.bjo @@ -0,0 +1,437 @@ +;; 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/src/draw.bjo — the module (bjogui draw). +;; +;; Drawing with a pen: what a component made by `component` in (bjogui view) +;; draws itself with. Each function draws at once, on top of what is drawn +;; before it, in the component's own coordinates: 0, 0 is its top left +;; corner, x grows to the right and y down, in pixels. +;; +;; A colour is a string, as everywhere in bjogui: a name such as "red", or +;; "#rgb", "#rrggbb" or "#aarrggbb". The empty string, and a colour that +;; cannot be read, draw nothing. An angle is in radians, as `sin` and `cos` +;; of (std maths) take it, and grows clockwise from the right, because y +;; grows down. +;; +;; The pen is Avalonia's DrawingContext, so a drawing is vectors: it is sharp +;; at any scale of the screen. + +(export + Pen + ;; Shapes. + fill-rect stroke-rect fill-circle stroke-circle fill-ellipse stroke-ellipse + stroke-line stroke-polyline fill-polygon stroke-arc fill-path stroke-path + ;; Text and pictures. + draw-text text-size draw-image + ;; What is drawn inside a function, moved, turned, cut or faded. + translated scaled rotated clipped faded + ;; For (bjogui app): a drawing, as the picture an Image shows. + drawing-image) + +(import (std prelude)) +(import (std maths)) +(import (std interop)) +(import (std mutable map)) + +(import/class + (Object (: System.Object)) + (Disposable (: System.IDisposable)) + (Culture (: System.Globalization.CultureInfo)) + (IBrush (: Avalonia.Media.IBrush)) + (IPen (: Avalonia.Media.IPen)) + (AvPen (: Avalonia.Media.Pen (-> IBrush double IDashStyle LineCap LineJoin double AvPen))) + (IDashStyle (: Avalonia.Media.IDashStyle)) + (DashStyle (: Avalonia.Media.DashStyle (-> (Seq double) double DashStyle))) + (LineCap (: Avalonia.Media.PenLineCap)) + (LineJoin (: Avalonia.Media.PenLineJoin)) + (BoxShadows (: Avalonia.Media.BoxShadows)) + (Rect (: Avalonia.Rect (-> double double double double Rect))) + (Point (: Avalonia.Point (-> double double Point))) + (Size (: Avalonia.Size (-> double double Size))) + (Matrix (: Avalonia.Matrix)) + (Geometry (: Avalonia.Media.Geometry)) + (RectGeometry (: Avalonia.Media.RectangleGeometry (-> Rect double double RectGeometry))) + (StreamGeometry (: Avalonia.Media.StreamGeometry (-> StreamGeometry))) + (GeometryContext (: Avalonia.Media.StreamGeometryContext)) + (Sweep (: Avalonia.Media.SweepDirection)) + (DrawingGroup (: Avalonia.Media.DrawingGroup (-> DrawingGroup))) + (DrawingImage (: Avalonia.Media.DrawingImage (-> Drawing DrawingImage))) + (Drawing (: Avalonia.Media.Drawing)) + (DrawingContext (: Avalonia.Media.DrawingContext)) + (PushedState (: Avalonia.Media.DrawingContext.PushedState)) + (IImage (: Avalonia.Media.IImage)) + (Bitmap (: Avalonia.Media.Imaging.Bitmap (-> string Bitmap))) + (FontFamily (: Avalonia.Media.FontFamily (-> string FontFamily))) + (FontStyle (: Avalonia.Media.FontStyle)) + (FontWeight (: Avalonia.Media.FontWeight)) + (FontStretch (: Avalonia.Media.FontStretch)) + (Typeface (: Avalonia.Media.Typeface (-> FontFamily FontStyle FontWeight FontStretch Typeface))) + (FlowDirection (: Avalonia.Media.FlowDirection)) + (FormattedText (: Avalonia.Media.FormattedText + (-> string Culture FlowDirection Typeface double IBrush FormattedText)))) + +(import/extern + (parse-brush (: Avalonia.Media.Brush.Parse (-> string IBrush))) + (parse-geometry (: Avalonia.Media.Geometry.Parse (-> string Geometry))) + (open-group (: Avalonia.Media.DrawingGroup.Open (-> DrawingGroup DrawingContext))) + (bounds-of (: Avalonia.Media.Drawing.GetBounds (-> Drawing Rect))) + (rect-x (: Avalonia.Rect.X (-> Rect double) #:get)) + (rect-y (: Avalonia.Rect.Y (-> Rect double) #:get)) + (open-geometry (: Avalonia.Media.StreamGeometry.Open (-> StreamGeometry GeometryContext))) + (begin-figure! (: Avalonia.Media.StreamGeometryContext.BeginFigure (-> GeometryContext Point bool void))) + (line-to! (: Avalonia.Media.StreamGeometryContext.LineTo (-> GeometryContext Point void))) + (arc-to! (: Avalonia.Media.StreamGeometryContext.ArcTo + (-> GeometryContext Point Size double bool Sweep void))) + (end-figure! (: Avalonia.Media.StreamGeometryContext.EndFigure (-> GeometryContext bool void))) + (dc-rect (: Avalonia.Media.DrawingContext.DrawRectangle + (-> DrawingContext IBrush IPen Rect double double BoxShadows void))) + (dc-ellipse (: Avalonia.Media.DrawingContext.DrawEllipse + (-> DrawingContext IBrush IPen Point double double void))) + (dc-line (: Avalonia.Media.DrawingContext.DrawLine (-> DrawingContext IPen Point Point void))) + (dc-geometry (: Avalonia.Media.DrawingContext.DrawGeometry + (-> DrawingContext IBrush IPen Geometry void))) + (dc-text (: Avalonia.Media.DrawingContext.DrawText (-> DrawingContext FormattedText Point void))) + (dc-image (: Avalonia.Media.DrawingContext.DrawImage (-> DrawingContext IImage Rect void))) + (push-transform (: Avalonia.Media.DrawingContext.PushTransform (-> DrawingContext Matrix PushedState))) + (push-clip (: Avalonia.Media.DrawingContext.PushClip (-> DrawingContext Rect PushedState))) + (push-opacity (: Avalonia.Media.DrawingContext.PushOpacity (-> DrawingContext double PushedState))) + (pop! (: Avalonia.Media.DrawingContext.PushedState.Dispose (-> PushedState void))) + (translation (: Avalonia.Matrix.CreateTranslation (-> double double Matrix))) + (scaling (: Avalonia.Matrix.CreateScale (-> double double Matrix))) + (rotation (: Avalonia.Matrix.CreateRotation (-> double Point Matrix))) + (text-width (: Avalonia.Media.FormattedText.Width (-> FormattedText double) #:get)) + (text-height (: Avalonia.Media.FormattedText.Height (-> FormattedText double) #:get)) + (max-text-width! (: Avalonia.Media.FormattedText.MaxTextWidth (-> FormattedText double void) #:set)) + (default-family (: Avalonia.Media.FontFamily.Default #:get)) + (invariant (: System.Globalization.CultureInfo.InvariantCulture #:get)) + (dispose! (: System.IDisposable.Dispose (-> Disposable void)))) + +;; --------------------------------------------------------------------------- +;; The pen +;; --------------------------------------------------------------------------- + +;; What a component draws with, for as long as its `#:draw` function runs. +(type (: Pen #:opaque (Record (: dc DrawingContext)))) + +;; --------------------------------------------------------------------------- +;; What is read once +;; --------------------------------------------------------------------------- + +;; Colours, paths, pictures and fonts are read once each and kept, because a +;; component draws them again on each change. A table that grows past its +;; limit is emptied, so a program that makes new paths all the time does not +;; keep them all. +(def cache-limit 2000) + +(: brushes (MutableMap string (Option IBrush))) +(def brushes (mutablemap)) + +(: geometries (MutableMap string (Option Geometry))) +(def geometries (mutablemap)) + +(: bitmaps (MutableMap string (Option Bitmap))) +(def bitmaps (mutablemap)) + +(: typefaces (MutableMap string Typeface)) +(def typefaces (mutablemap)) + +(: (-> (MutableMap string %a) string (-> %a) %a)) +(defun (cached table key make) + (match (mutablemap-try-ref table key) + ((Some v) v) + (None + (when (>= (mutablemap-length table) cache-limit) (mutablemap-clear! table)) + (def v (make)) + (mutablemap-set! table key v) + v))) + +(: (-> string (Option IBrush))) +(defun (brush colour) + (if (string-empty? colour) + None + (cached brushes colour + (fun () + (match (try (parse-brush colour) #:catch (System.Exception)) + ((Ok b) (Some b)) + ((Err _) None)))))) + +(: (-> string (Option Geometry))) +(defun (geometry data) + (cached geometries data + (fun () + (match (try (parse-geometry data) #:catch (System.Exception)) + ((Ok g) (Some g)) + ((Err _) None))))) + +(: (-> string (Option Bitmap))) +(defun (bitmap path) + (cached bitmaps path + (fun () + (match (try (Bitmap. path) #:catch (System.Exception)) + ((Ok b) (Some b)) + ((Err _) None))))) + +(: (-> string bool Typeface)) +(defun (typeface font bold?) + (cached typefaces #"${font}/${bold?}" + (fun () + (Typeface. (if (string-empty? font) default-family (FontFamily. font)) + FontStyle.Normal (if bold? FontWeight.Bold FontWeight.Normal) FontStretch.Normal)))) + +;; A line of `width`, in the brush. `cap` is "flat", "round" or "square". +;; `dash` is the lengths of the dashes and the gaps between them, in widths +;; of the line, in turn; empty for a solid line. +(: (-> IBrush double string (Vec double) IPen)) +(defun (line-pen b width cap dash) + (def c (match cap ("round" LineCap.Round) ("square" LineCap.Square) (_ LineCap.Flat))) + (def d (if (vec-empty? dash) + (: (clr-default) IDashStyle) + (cast IDashStyle (DashStyle. (cast (Seq double) (: (vec->array dash) (Array double))) 0.0)))) + (cast IPen (AvPen. b width d c LineJoin.Round 10.0))) + +(: (-> double double Point)) +(defun (pt x y) (Point. x y)) + +(def no-brush (: (clr-default) IBrush)) +(def no-pen (: (clr-default) IPen)) + +;; --------------------------------------------------------------------------- +;; Shapes +;; --------------------------------------------------------------------------- + +;; The rectangle at `x`, `y`, `w` by `h`, filled, with corners as round as +;; `#:radius`. +;; A rectangle with round corners is drawn as a geometry, because a drawing +;; that is kept, as a component's is, drops the corners of DrawRectangle. +(: (-> Pen IBrush IPen double double double double double void)) +(defun (rect! pen b p x y w h radius) + (if (> radius 0.0) + (dc-geometry (.dc pen) b p (cast Geometry (RectGeometry. (Rect. x y w h) radius radius))) + (dc-rect (.dc pen) b p (Rect. x y w h) 0.0 0.0 (clr-default)))) + +(: fill-rect (-> Pen double double double double string (#:radius double) void)) +(defun (fill-rect pen x y w h colour #:radius 0.0) + (match (brush colour) + ((Some b) (rect! pen b no-pen x y w h radius)) + (None unit))) + +;; The line around a rectangle. The line is centred on the rectangle's edge. +(: stroke-rect (-> Pen double double double double string (#:width double) (#:radius double) + (#:dash (Vec double)) + void)) +(defun (stroke-rect pen x y w h colour #:width 1.0 #:radius 0.0 #:dash []) + (match (brush colour) + ((Some b) (rect! pen no-brush (line-pen b width "flat" dash) x y w h radius)) + (None unit))) + +;; The circle around `cx`, `cy`, of radius `r`, filled. +(: fill-circle (-> Pen double double double string void)) +(defun (fill-circle pen cx cy r colour) + (fill-ellipse pen (- cx r) (- cy r) (* 2.0 r) (* 2.0 r) colour)) + +;; The line around a circle. +(: stroke-circle (-> Pen double double double string (#:width double) (#:dash (Vec double)) void)) +(defun (stroke-circle pen cx cy r colour #:width 1.0 #:dash []) + (stroke-ellipse pen (- cx r) (- cy r) (* 2.0 r) (* 2.0 r) colour #:width width #:dash dash)) + +;; The ellipse in the rectangle at `x`, `y`, `w` by `h`, filled. +(: fill-ellipse (-> Pen double double double double string void)) +(defun (fill-ellipse pen x y w h colour) + (match (brush colour) + ((Some b) (dc-ellipse (.dc pen) b no-pen (pt (+ x (/ w 2.0)) (+ y (/ h 2.0))) (/ w 2.0) (/ h 2.0))) + (None unit))) + +;; The line around an ellipse. +(: stroke-ellipse (-> Pen double double double double string (#:width double) (#:dash (Vec double)) + void)) +(defun (stroke-ellipse pen x y w h colour #:width 1.0 #:dash []) + (match (brush colour) + ((Some b) (dc-ellipse (.dc pen) no-brush (line-pen b width "flat" dash) + (pt (+ x (/ w 2.0)) (+ y (/ h 2.0))) (/ w 2.0) (/ h 2.0))) + (None unit))) + +;; A line from `x1`, `y1` to `x2`, `y2`. `#:cap` is how its ends look: +;; "flat", "round" or "square". +(: stroke-line (-> Pen double double double double string (#:width double) (#:cap string) + (#:dash (Vec double)) + void)) +(defun (stroke-line pen x1 y1 x2 y2 colour #:width 1.0 #:cap "flat" #:dash []) + (match (brush colour) + ((Some b) (dc-line (.dc pen) (line-pen b width cap dash) (pt x1 y1) (pt x2 y2))) + (None unit))) + +;; The geometry through `points`, closed when `closed?`. +(: (-> (Vec (Tuple double double)) bool bool (Option Geometry))) +(defun (through points filled? closed?) + (if (< (vec-length points) 2) + None + (begin + (def g (StreamGeometry.)) + (def ctx (open-geometry g)) + (def (Tuple x0 y0) (vec-ref points 0)) + (begin-figure! ctx (pt x0 y0) filled?) + (loop (:for (Tuple x y) (vec-drop points 1)) (:do (line-to! ctx (pt x y)))) + (end-figure! ctx closed?) + (dispose! (cast Disposable ctx)) + (Some (cast Geometry g))))) + +;; Lines from each of `points` to the next. +(: stroke-polyline (-> Pen (Vec (Tuple double double)) string (#:width double) (#:cap string) + (#:dash (Vec double)) + void)) +(defun (stroke-polyline pen points colour #:width 1.0 #:cap "flat" #:dash []) + (match (Tuple (brush colour) (through points #f #f)) + ((Tuple (Some b) (Some g)) (dc-geometry (.dc pen) no-brush (line-pen b width cap dash) g)) + (_ unit))) + +;; The polygon with `points` at its corners, filled. +(: fill-polygon (-> Pen (Vec (Tuple double double)) string void)) +(defun (fill-polygon pen points colour) + (match (Tuple (brush colour) (through points #t #t)) + ((Tuple (Some b) (Some g)) (dc-geometry (.dc pen) b no-pen g)) + (_ unit))) + +;; A piece of the circle around `cx`, `cy` of radius `r`: from the angle +;; `from`, `sweep` radians on, clockwise when `sweep` is more than 0. A sweep +;; of a whole turn or more is the whole circle. +(: stroke-arc (-> Pen double double double double double string (#:width double) (#:cap string) + (#:dash (Vec double)) + void)) +(defun (stroke-arc pen cx cy r from sweep colour #:width 1.0 #:cap "flat" #:dash []) + (def turn (* 2.0 3.141592653589793)) + (defun (at a) (pt (+ cx (* r (cos a))) (+ cy (* r (sin a))))) + (match (brush colour) + ((Some b) + (cond ((>= (abs sweep) (- turn 1e-9)) + (stroke-circle pen cx cy r colour #:width width #:dash dash)) + ((= sweep 0.0) unit) + (else + (def g (StreamGeometry.)) + (def ctx (open-geometry g)) + (begin-figure! ctx (at from) #f) + (arc-to! ctx (at (+ from sweep)) (Size. r r) 0.0 (> (abs sweep) (/ turn 2.0)) + (if (> sweep 0.0) Sweep.Clockwise Sweep.CounterClockwise)) + (end-figure! ctx #f) + (dispose! (cast Disposable ctx)) + (dc-geometry (.dc pen) no-brush (line-pen b width cap dash) (cast Geometry g))))) + (None unit))) + +;; The path `data`, written as SVG writes one: "M 10 10 L 50 10 L 30 40 Z" +;; is a triangle. Filled. A path that cannot be read draws nothing. +(: fill-path (-> Pen string string void)) +(defun (fill-path pen data colour) + (match (Tuple (brush colour) (geometry data)) + ((Tuple (Some b) (Some g)) (dc-geometry (.dc pen) b no-pen g)) + (_ unit))) + +;; The line along the path `data`. +(: stroke-path (-> Pen string string (#:width double) (#:cap string) (#:dash (Vec double)) void)) +(defun (stroke-path pen data colour #:width 1.0 #:cap "flat" #:dash []) + (match (Tuple (brush colour) (geometry data)) + ((Tuple (Some b) (Some g)) (dc-geometry (.dc pen) no-brush (line-pen b width cap dash) g)) + (_ unit))) + +;; --------------------------------------------------------------------------- +;; Text and pictures +;; --------------------------------------------------------------------------- + +(: (-> string IBrush double bool string double FormattedText)) +(defun (formatted s b size bold? font max-width) + (def t (FormattedText. s invariant FlowDirection.LeftToRight (typeface font bold?) size b)) + (when (> max-width 0.0) (max-text-width! t max-width)) + t) + +;; The text `s` with its top at `y`. `#:align` says where `x` is on it: +;; "left", "centre" or "right". `#:font` is the name of a font, "" for the +;; theme's. With `#:max-width`, the text breaks its lines at that width. +(: draw-text (-> Pen string double double string (#:size double) (#:bold bool) (#:font string) + (#:align string) (#:max-width double) + void)) +(defun (draw-text pen s x y colour #:size 14.0 #:bold #f #:font "" #:align "left" #:max-width 0.0) + (match (brush colour) + ((Some b) + (def t (formatted s b size bold font max-width)) + (def left (match align + ("centre" (- x (/ (text-width t) 2.0))) + ("right" (- x (text-width t))) + (_ x))) + (dc-text (.dc pen) t (pt left y))) + (None unit))) + +;; The width and the height that `draw-text` gives `s`, with the same +;; options. For a component to lay out its text. +(: text-size (-> string (#:size double) (#:bold bool) (#:font string) (#:max-width double) + (Tuple double double))) +(defun (text-size s #:size 14.0 #:bold #f #:font "" #:max-width 0.0) + (def t (formatted s (parse-brush "black") size bold font max-width)) + (Tuple (text-width t) (text-height t))) + +;; The picture in the file at `path`, in the rectangle at `x`, `y`, `w` by +;; `h`. A file that cannot be read draws nothing. +(: draw-image (-> Pen string double double double double void)) +(defun (draw-image pen path x y w h) + (match (bitmap path) + ((Some b) (dc-image (.dc pen) (cast IImage b) (Rect. x y w h))) + (None unit))) + +;; --------------------------------------------------------------------------- +;; Moved, turned, cut and faded +;; --------------------------------------------------------------------------- + +(: (-> PushedState (-> void) void)) +(defun (inside state body) + (body) + (pop! state)) + +;; What `body` draws, moved by `dx`, `dy`. +(: translated (-> Pen double double (-> void) void)) +(defun (translated pen dx dy body) + (inside (push-transform (.dc pen) (translation dx dy)) body)) + +;; What `body` draws, `sx` times as wide and `sy` times as tall, from 0, 0. +(: scaled (-> Pen double double (-> void) void)) +(defun (scaled pen sx sy body) + (inside (push-transform (.dc pen) (scaling sx sy)) body)) + +;; What `body` draws, turned by `angle` around `cx`, `cy`. +(: rotated (-> Pen double double double (-> void) void)) +(defun (rotated pen angle cx cy body) + (inside (push-transform (.dc pen) (rotation angle (pt cx cy))) body)) + +;; What `body` draws, only inside the rectangle at `x`, `y`, `w` by `h`. +(: clipped (-> Pen double double double double (-> void) void)) +(defun (clipped pen x y w h body) + (inside (push-clip (.dc pen) (Rect. x y w h)) body)) + +;; What `body` draws, at `opacity`: 0 is not seen, 1 is as drawn. +(: faded (-> Pen double (-> void) void)) +(defun (faded pen opacity body) + (inside (push-opacity (.dc pen) opacity) body)) + +;; --------------------------------------------------------------------------- +;; For the app +;; --------------------------------------------------------------------------- + +;; What `draw` draws on `w` by `h`, as a picture that an Image shows, and +;; where the Image goes for 0, 0 to be the top left corner. None when there +;; is no room. +;; +;; A DrawingImage moves the top left corner of what is drawn to its own 0, 0, +;; so a drawing that starts at 10, 10, or at -5, 0, would move. The place of +;; the bounds' corner is given back, and the Image is put there, which moves +;; the drawing back. What is drawn is cut to `w` by `h`, so what is outside +;; costs nothing to show. +(: drawing-image (-> (-> Pen void) double double (Option (Tuple Object double double)))) +(defun (drawing-image draw w h) + (if (or (<= w 0.0) (<= h 0.0)) + None + (begin + (def group (DrawingGroup.)) + (def dc (open-group group)) + (def pen (Pen (dc dc))) + (clipped pen 0.0 0.0 w h (fun () (draw pen))) + (dispose! (cast Disposable dc)) + (def b (bounds-of (cast Drawing group))) + (Some (Tuple (cast Object (DrawingImage. (cast Drawing group))) (rect-x b) (rect-y b)))))) diff --git a/src/view.bjo b/src/view.bjo index 903046b..eac61a2 100644 --- a/src/view.bjo +++ b/src/view.bjo @@ -12,6 +12,10 @@ ;; ;; An event is a message, or a function that makes one from what the control ;; holds. The app gives the message to `update`. +;; +;; A component, made by `component`, is a control of the program's own: it +;; draws itself with (bjogui draw), hears the pointer and the keys, and keeps +;; a state of its own between them. `drawn` puts one in a view. (export ;; Types. @@ -32,6 +36,9 @@ ;; Views of another message type. view-map + ;; Components. + Component Input Pointer Custom component drawn + ;; Keyboard shortcuts. Key key key-gesture key-message @@ -39,6 +46,10 @@ view-kind view-props view-events view-children view-key) (import (std prelude)) +(import (bjogui draw)) + +;; The type of a component's value and state while the app holds them. +(import/class (Object (: System.Object))) ;; --------------------------------------------------------------------------- ;; The types @@ -52,7 +63,7 @@ ToggleSwitchKind RadioKind NumberKind DateKind AutoCompleteKind ExpanderKind WrapKind DockKind TreeKind TreeNodeKind CanvasKind RectKind EllipseKind LineKind PathKind - ColumnKind RowKind GridKind ScrollKind BorderKind))) + ColumnKind RowKind GridKind ScrollKind BorderKind CustomKind))) ;; A property of a control. A kind takes only some of them; the app ignores ;; the others. @@ -102,6 +113,46 @@ (: PropEnd double double) (: PropData string)))) ; a path, as "M 0 0 L 10 10 Z" +;; Where the pointer is on a component, from its top left corner, and how. +;; `button` is "left", "right" or "middle" for a press and a release, and "" +;; for a move. `clicks` is 2 for the second press of a double click, 1 for a +;; press alone and a release, and 0 for a move and the wheel. `mods` is the +;; keys held, as "Ctrl+Shift", or "". +(type (: Pointer (Record (: x double) (: y double) (: button string) (: clicks int) + (: mods string)))) + +;; What a component hears. +;; +;; A press takes the pointer: the moves and the release after it come to the +;; component that was pressed, also outside it. A focusable component takes +;; the keys after a press, and hears them as `KeyDown`, written as keys are +;; written for `key`: "Up", "Ctrl+Z", "Shift+Tab". +(type (: Input (Union (: PointerDown Pointer) + (: PointerMove Pointer) + (: PointerUp Pointer) + PointerEnter + PointerLeave + (: Wheel Pointer double double) ; and how far: across, and down + (: KeyDown string) + FocusIn + FocusOut))) + +;; A component, as the app holds one: its value and its state are objects, +;; so that components of any types are views of one type. Made by `drawn`, +;; which knows the types, and read by (bjogui app). +;; +;; `identity` is the component itself. A view in the place of one with +;; another identity is another control, with a state of its own. +(type (: (Custom %m) (Record (: identity Object) + (: value Object) + (: same-value? (-> Object bool)) + (: initial Object) + (: same-state? (-> Object Object bool)) + (: draw (-> Pen double double Object void)) + (: input (-> Input double double Object (Tuple Object (Option %m)))) + (: cursor (-> Object string)) + (: focusable bool)))) + ;; An event, and the message it sends. (type (: (On %m) (Union (: OnClick %m) (: OnInput (-> string %m)) @@ -111,7 +162,8 @@ (: OnPick (-> string %m)) (: OnPress (-> double double %m)) (: OnMove (-> double double %m)) - (: OnRelease (-> double double %m))))) + (: OnRelease (-> double double %m)) + (: OnCustom (Custom %m))))) ;; One control and what is in it. ;; @@ -216,7 +268,8 @@ ((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))))))) + ((OnRelease g) (OnRelease (fun (x y) (f (g x y))))) + ((OnCustom c) (OnCustom (custom-map f c))))) (View (kind (.kind v)) (props (.props v)) (events (vec-map map-on (.events v))) @@ -629,3 +682,88 @@ (: key-message (-> (Key %m) %m)) (defun (key-message k) (.msg k)) + +;; --------------------------------------------------------------------------- +;; Components +;; --------------------------------------------------------------------------- + +;; A control of the program's own, for values of type %v. It keeps a state +;; of type %s, which only it sees, such as where a drag started, and sends +;; outputs of type %o, which `drawn` makes messages of. +(type (: (Component %v %s %o) #:opaque + (Record (: state %s) + (: same-state? (-> %s %s bool)) + (: draw (-> Pen double double %s %v void)) + (: input (-> Input double double %s %v (Tuple %s (Option %o)))) + (: cursor (-> %s %v string)) + (: focusable bool)))) + +(: (-> (-> %a %b) (Custom %a) (Custom %b))) +(defun (custom-map f c) + (def input (.input c)) + (Custom (identity (.identity c)) (value (.value c)) (same-value? (.same-value? c)) + (initial (.initial c)) (same-state? (.same-state? c)) (draw (.draw c)) + (input (fun (in w h s) + (def (Tuple s2 out) (input in w h s)) + (Tuple s2 (match out ((Some o) (Some (f o))) (None None))))) + (cursor (.cursor c)) (focusable (.focusable c)))) + +;; A component that starts in `state`, and draws itself with `draw`. +;; +;; `(draw pen width height state value)` draws the component at its size, +;; with the functions of (bjogui draw). It is called again when the value, +;; the state or the size changes, and not otherwise. +;; +;; `(#:input input width height state value)` gives the next state for an +;; input, and maybe an output to send. With none, the component hears +;; nothing. +;; +;; `#:cursor` gives the pointer's look over the component: "Arrow", "Hand", +;; "Cross", "Ibeam", "SizeAll", "SizeWestEast", "SizeNorthSouth", or any +;; other of Avalonia's StandardCursorType. `#:focusable` makes a press give +;; the component the keys. +;; +;; Make a component once, at the top of a module, and not in a view: a view +;; is made anew for each model, and a component made anew is another one, +;; whose state starts again. +(: component (-> %s (-> Pen double double %s %v void) + (#:input (-> Input double double %s %v (Tuple %s (Option %o)))) + (#:cursor (-> %s %v string)) + (#:focusable bool) + (Component %v %s %o)) + (where (Eq %s))) +(defun (component state draw #:input (fun (in w h s v) (Tuple s None)) + #:cursor (fun (s v) "Arrow") #:focusable #f) + (Component (state state) (same-state? (fun (a b) (= a b))) (draw draw) (input input) + (cursor cursor) (focusable focusable))) + +;; The component `c`, showing `value`. Each output it sends is given to +;; `on-output`, and the message that makes is the app's. +;; +;; With no `#:width` or `#:height`, the component fills the space its +;; parent gives it, and is drawn at that size once it is laid out. In a row +;; or a column, which give as little as is asked for, give it a size. +(: drawn (-> (Component %v %s %o) %v (-> %o %m) (#:width double) (#:height double) + (#:margin double) + (View %m)) + (where (Eq %v))) +(defun (drawn c value on-output #:width 0.0 #:height 0.0 #:margin 0.0) + (def same-state? (.same-state? c)) + (def draw (.draw c)) + (def input (.input c)) + (def cursor (.cursor c)) + (: (-> Object %s)) + (defun (state-of o) (cast %s o)) + (def custom + (Custom (identity (cast Object c)) + (value (cast Object value)) + (same-value? (fun (o) (= value (cast %v o)))) + (initial (cast Object (.state c))) + (same-state? (fun (a b) (same-state? (state-of a) (state-of b)))) + (draw (fun (pen w h s) (draw pen w h (state-of s) value))) + (input (fun (in w h s) + (def (Tuple s2 out) (input in w h (state-of s) value)) + (Tuple (cast Object s2) (match out ((Some o) (Some (on-output o))) (None None))))) + (cursor (fun (s) (cursor (state-of s) value))) + (focusable (.focusable c)))) + (leaf CustomKind (with-layout [] width height margin 0.0) [(OnCustom custom)])) diff --git a/tests/components.bjo b/tests/components.bjo new file mode 100644 index 0000000..1e06b93 --- /dev/null +++ b/tests/components.bjo @@ -0,0 +1,278 @@ +;; 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"))