Controls of the program's own, drawn with a pen
A component draws itself with (bjogui draw), a pen over Avalonia's DrawingContext, and hears the pointer, the wheel, the keys and the focus. It keeps a state of its own between inputs, and sends outputs that drawn makes the app's messages. It is drawn again only when its value, its state or its size changes, and no Avalonia class is subclassed: the picture is a DrawingImage on a canvas. start-headless! sets Avalonia up with no screen, drawing with Skia, so tests/components.bjo draws components and reads their pixels. The mixer example has knobs and a timeline. 🤖 Generated with [ECA](https://eca.dev) (anthropic/claude-opus-4-8) Co-Authored-By: eca-agent <git@eca.dev>
This commit is contained in:
parent
5379269f43
commit
5237bf3273
9 changed files with 1482 additions and 33 deletions
88
Readme.org
88
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.
|
||||
|
|
|
|||
BIN
docs/mixer.png
Normal file
BIN
docs/mixer.png
Normal file
Binary file not shown.
|
After Width: | Height: | Size: 36 KiB |
208
examples/mixer.bjo
Normal file
208
examples/mixer.bjo
Normal file
|
|
@ -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))
|
||||
|
|
@ -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"))))
|
||||
|
|
|
|||
|
|
@ -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",
|
||||
|
|
|
|||
316
src/app.bjo
316
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))))
|
||||
|
|
|
|||
437
src/draw.bjo
Normal file
437
src/draw.bjo
Normal file
|
|
@ -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))))))
|
||||
144
src/view.bjo
144
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)]))
|
||||
|
|
|
|||
278
tests/components.bjo
Normal file
278
tests/components.bjo
Normal file
|
|
@ -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"))
|
||||
Loading…
Add table
Add a link
Reference in a new issue