diff --git a/NEXT.md b/NEXT.md index 540ec54..76083c8 100644 --- a/NEXT.md +++ b/NEXT.md @@ -5,7 +5,14 @@ that is what makes it checkable against the header — and the layer is where a already exist by hand in `vendor/raylib/raylib.flan` and are the shape to copy: `collision-point-poly?` takes a slice and `collision-lines` answers with an `Option`, each wrapping a `-raw` binding of the same name. -## Queued: a restart is not a transaction, and the docs must say so +## ~~Queued: a restart is not a transaction, and the docs must say so~~ — **landed** + +See [`BUILT.md`](BUILT.md), "A restart is not a transaction". **This entry was stale** — all three places already +carried the note when it was re-read: `conditions.org` under *Gotchas*, `spec-conditions.md` §5, and +`web/index.html`'s restart gotcha list, which was rewritten in place rather than gaining a second bullet beside the +existing one. Nothing was left to write. + +What follows is the original entry, kept for the reasoning. Raised by the author, and it is a real sharp edge rather than a gap. **If a frame mutates a global and then signals, taking a `retry` re-runs the mutation.** Nothing rolls back. Common Lisp has exactly this property and offers no help @@ -17,8 +24,7 @@ either put the restart before anything mutates, make the retried section idempot re-applied. This matters more here than in most Lisps because the intended use is a **game loop**, where the author's plan is to -skip a frame and carry on rather than die — exactly the case where a non-idempotent mutation bites. Write it into -`conditions.org` and `spec-conditions.md`'s prose, and into `web/index.html` beside the restart documentation. +skip a frame and carry on rather than die — exactly the case where a non-idempotent mutation bites. ## ~~Queued: a dev-build allocation registry~~ — **landed, in part; three of the six remain** ## Queued: a dev-build allocation registry — address to type diff --git a/sand.flan b/sand.flan index b5a215f..deea0c2 100644 --- a/sand.flan +++ b/sand.flan @@ -1,23 +1,21 @@ ;;;; Falling sand — Flan port of the Odin/Janet/Lisp/jank versions in ~/Development/fnm. ;;;; -;;;; THE SECOND ACCEPTANCE PROGRAM — build sequence milestone 4. calc-me.flan -;;;; comes first: sand cannot run at all until raylib FFI, keyword->enum -;;;; coercion and a window exist, and none of those should be on the critical -;;;; path to "the language runs something". +;;;; Kept at parity with lisp/sand.lisp, clojure/src/fnm/sand.clj and +;;;; src/fnm/sand.jank: the same constants, the same eight functions, and +;;;; nothing else. Anything a reference version does not have does not belong +;;;; here — this file is the acceptance program for the language, not a +;;;; showcase for raylib bindings. ;;;; ;;;; It is tested twice: headless (N frames, hash the grid — the version CI runs ;;;; on native and wasm32) and interactive at 120 fps. Both halves are one file -;;;; now. The simulation lived in a package of its own for a while, not because -;;;; it wanted to but because importing raylib linked libraylib whatever main -;;;; did, and on wasm32 that link cannot succeed. The link follows what the -;;;; program reaches now, so test/programs/sand-headless.flan imports *this -;;;; file* as a package, calls the simulation directly, and pulls in neither a -;;;; window nor libraylib. The main below is not exported: an entry point is -;;;; not something a package offers. +;;;; now. The link follows what the program reaches, so +;;;; test/programs/sand-headless.flan imports *this file* as a package, calls +;;;; the simulation directly, and pulls in neither a window nor libraylib. The +;;;; main below is not exported: an entry point is not something a package +;;;; offers. ;;;; -;;;; Note what it still deliberately does not use: no Vec, no Map, no generics, -;;;; no user-written macros, no conditions, no allocator other than the stack -;;;; and static storage. +;;;; Note what it deliberately does not use: no Vec, no Map, no generics, no +;;;; user-written macros, no allocator other than the stack and static storage. ;;;; ;;;; Notation reminders (see plan.org and spec-memory.md): ;;;; [n T] fixed array, length n, element T — a VALUE, copies @@ -25,8 +23,6 @@ ;;;; (Ptr T) pointer (Handle T) generational handle ;;;; types are inline name/type pairs, as in `let` and `defstruct` ;;;; a return type of () means the function returns nothing -;;;; lowercase in a TYPE position is a type variable; in a LENGTH position -;;;; it is an ordinary compile-time value, so [rows [cols u32]] is unambiguous (import rl "vendor:raylib") ; directory = package; declaration optional (import agent "vendor:agent") ; the dev agent: redefinitions, installed below @@ -63,9 +59,6 @@ (set grid (zeroed)) (set velocity (zeroed))) -(defn empty-at? [row i32 col i32] bool - (= 0 (at grid row col))) - (defn next-color [] () (set current-color (% (+ current-color 1) (len colors)))) @@ -80,19 +73,11 @@ c (+ x (- col half))] (when (and (>= r 0) (< r (- rows 1)) (>= c 0) (< c (- cols 1)) - (empty-at? r c) + (= 0 (at grid r c)) (< (rand-f32) 0.5)) (set (at grid r c) (at colors current-color)) (set (at velocity r c) 1.0))))))) -(defn move-grain [from-row i32 from-col i32 - to-row i32 to-col i32 - vel f32] () - (set (at grid to-row to-col) (at grid from-row from-col)) - (set (at grid from-row from-col) 0) - (set (at velocity to-row to-col) vel) - (set (at velocity from-row from-col) 0.0)) - ;; Move the grain at [row col] as far down as it can, sliding to a free ;; diagonal neighbour when the cell below is taken. ;; @@ -101,21 +86,25 @@ ;; over a mutable scan position, which is what a while loop is. (defn settle [row i32 col i32] () (let [vel (+ gravity (at velocity row col)) - some-point (rl/Vector2 {.x 15.0 .y 12}) y (min (- rows 1) (+ row (i32 vel)))] (while (> y row) - (when (empty-at? y col) - (move-grain row col y col vel) + (when (= 0 (at grid y col)) + (set (at grid y col) (at grid row col)) + (set (at grid row col) 0) + (set (at velocity y col) vel) + (set (at velocity row col) 0.0) (return)) - (let [left? (and (> col 0) (empty-at? y (- col 1))) - right? (and (< col (- cols 1)) (empty-at? y (+ col 1)))] + (let [left? (and (> col 0) (= 0 (at grid y (- col 1)))) + right? (and (< col (- cols 1)) (= 0 (at grid y (+ col 1))))] (when (or left? right?) - (pause) (let [side (cond (not left?) 1 (not right?) -1 :else (if (< (rand-f32) 0.5) 1 -1))] - (move-grain row col y (+ col side) vel) + (set (at grid y (+ col side)) (at grid row col)) + (set (at grid row col) 0) + (set (at velocity y (+ col side)) vel) + (set (at velocity row col) 0.0) (return)))) (set y (- y 1))) ;; Nowhere to fall: reset the accumulated velocity and stay put. @@ -126,7 +115,7 @@ (let [row (- rows 2)] (while (>= row 0) (dotimes [col cols] - (unless (empty-at? row col) + (unless (= 0 (at grid row col)) (settle row col))) (set row (- row 1))))) @@ -153,273 +142,6 @@ ;;;; Everything from here on needs a window, and nothing headless reaches any ;;;; of it — which is why importing this file costs a headless build nothing. -;; The brush sprite: a 16x8 sheet of two 8x8 frames, the ring drawn while the -;; mouse is idle and the blob while it is painting. It is here because the -;; texture calls cannot be in the acceptance table at all — loading one needs a -;; GL context — so the only way they are exercised is by running this. -(defvar brush rl/Texture2D) -(defvar brush-ok bool) - -;; The same sheet a second time, mirrored on the CPU before the GPU ever sees -;; it. That is what the Image family is for, and this is its only call site: -;; nothing headless can make a texture, so load-texture-from-image would -;; otherwise be bound and never called, which is the same as not bound. -(defvar brush-mirrored rl/Texture2D) -(defvar brush-mirrored-ok bool) - -;; The sheet itself, baked into the binary at compile time. This used to be -;; (rl/load-texture "brush.png") against a bare relative path, and that is the -;; one line that kept this program off the browser: a relative path has no -;; meaning on a target with no filesystem, so raylib would have opened nothing -;; and the cursor would have been missing with no way to say why. -;; -;; The path is resolved relative to *this file*, not to wherever flan was -;; invoked from, which is what lets test/programs/sand-headless.flan import -;; this file as a package from _build and still find the PNG. Nothing is read -;; at run time on either target, so there is one code path and not two. -(defconst brush-png (embed "brush.png")) - -;; A brush that does not load is not a crash and not silence: an Image that -;; failed to decode has a null buffer, LoadTextureFromImage hands back a -;; texture with an id of 0, every draw with it is a no-op, and the program -;; looks like it has a drawing bug. So it is asked and said once, here. -;; -;; Note what this can no longer mean: the file is missing. A missing -;; brush.png is a compile error now, at the embed, which is the whole point of -;; embedding it. What is left is a decode that failed or an upload with no GL -;; context behind it. -;; -;; One decode serves both textures. The unflipped upload happens first, -;; because ImageFlipHorizontal rewrites the buffer in place and the second -;; upload has to see the changed pixels — if the two badges look the same, -;; either the flip did nothing or the order here was swapped. -(defn load-brush [] () - (let [sheet (rl/load-image-from-memory ".png" brush-png)] - (when (rl/image-valid? sheet) - (set brush (rl/load-texture-from-image sheet)) - (rl/image-flip-horizontal (addr sheet)) - (set brush-mirrored (rl/load-texture-from-image sheet))) - ;; An Image that failed to decode has a null buffer and unloading it is - ;; still safe, so there is one unload and not two. - (rl/unload-image sheet)) - (set brush-ok (rl/texture-valid? brush)) - (unless brush-ok - (println "sand: brush.png would not decode — drawing the cursor is off")) - (set brush-mirrored-ok (rl/texture-valid? brush-mirrored))) - -;; Four draws, one per shape the call comes in, because none of them can be in -;; the acceptance table. The cursor picks one frame out of the sheet and so -;; needs a source rectangle; the three badges in the corner are the whole -;; sheet, at integer coordinates, at a Vector2 tinted with the current sand -;; colour, and scaled up — draw-texture, draw-texture-v and draw-texture-ex. -(defn draw-brush [] () - (when brush-ok - (let [m (rl/get-mouse-position) - frame (f32 (if (rl/mouse-button-down? :left) 8.0 0.0))] - (rl/draw-texture-rec brush - (rl/Rectangle {.x frame .y 0.0 .width 8.0 .height 8.0}) - (rl/Vector2 {.x (- (.x m) 4.0) .y (- (.y m) 4.0)}) - rl/white) - (rl/draw-texture brush 20 50 rl/white) - (rl/draw-texture-v brush (rl/Vector2 {.x 44.0 .y 50.0}) - (rl/get-color (at colors current-color))) - (rl/draw-texture-ex brush (rl/Vector2 {.x 72.0 .y 46.0}) 0.0 2.0 rl/white))) - ;; The mirrored one beside them, scaled up so the flip is visible rather - ;; than eight pixels wide. If the two badges look the same, either the flip - ;; did nothing or the upload took the unedited buffer. - (when brush-mirrored-ok - (rl/draw-texture-ex brush-mirrored (rl/Vector2 {.x 110.0 .y 46.0}) - 0.0 2.0 rl/white))) - -;; ── Sound ────────────────────────────────────────────────────────── -;; -;; Nothing in this section can be in the acceptance table and the reason is -;; sharper than "it needs a GL context": a Sound is a buffer the miniaudio -;; mixer owns, so it does not exist until init-audio-device has found a -;; device, and a machine with no sound server gets a zeroed struct and a -;; warning. What CAN be asserted headlessly is the Wave the sound is made -;; from — test/programs/raylib-audio.flan does exactly that — so the split -;; here is real and not an excuse: the samples are checked, the playing is -;; only listened to. -;; -;; The tone is generated rather than loaded because a .wav in the repository -;; would be an asset to maintain for one plink, and because generating it is -;; what gives load-sound-from-wave and export-wave a call site that is not a -;; test. - -(defconst tone-rate 22050) -(defconst tone-frames 4410) ; 0.2 s -(defconst tone-path "/tmp/flan-sand-tone.wav") - -;; Little-endian signed 16-bit PCM, two bytes per frame, written as bytes -;; because that is what a Wave's `data` is: the element width is `sample-size`, -;; a run-time number, and no Flan type says what the buffer holds. -(defvar tone-pcm [8820 u8]) - -(defn write-sample [i i32 v i32] () - (set (at tone-pcm (* i 2)) (u8 (bit-and v 255))) - (set (at tone-pcm (+ (* i 2) 1)) (u8 (bit-and (>> v 8) 255)))) - -;; A square wave that decays to nothing over its length, which is the -;; cheapest thing that sounds like a plink rather than a click. `period` is -;; the half-period in frames, so a smaller one is a higher note. -(defn build-tone [period i32] () - (dotimes [i tone-frames] - (let [amp (/ (* 9000 (- tone-frames i)) tone-frames)] - (write-sample i (if (= 0 (% (/ i period) 2)) amp (- 0 amp)))))) - -(defvar audio-ok bool) -(defvar tone rl/Sound) -(defvar tone-ok bool) -(defvar music rl/Music) -(defvar music-ok bool) -(defvar music-on bool) - -(defn start-audio [] () - (rl/init-audio-device) - (set audio-ok (rl/audio-device-ready?)) - (unless audio-ok - (println "sand: no audio device — the grains are silent")) - (build-tone 40) - (let [w (rl/Wave {.frame-count (u32 tone-frames) .sample-rate (u32 tone-rate) - .sample-size 16 .channels 1 - .data (addr (at tone-pcm 0))})] - (when audio-ok - (set tone (rl/load-sound-from-wave w)) - (set tone-ok (rl/sound-valid? tone)) - (rl/set-sound-volume tone 0.25) - (rl/set-sound-pan tone 0.5) - ;; The same samples out to a file and straight back in as a stream, so - ;; the Music side has a call site without an asset in the repository. - ;; A Sound is resident and a Music is decoded as it plays, which is the - ;; whole difference, and update-music-stream in the loop below is the - ;; visible consequence of it. - (when (rl/export-wave w tone-path) - (set music (rl/load-music-stream tone-path)) - (set music-ok (rl/music-valid? music)) - (when music-ok - (set (.looping music) true) - (rl/set-music-volume music 0.15) - (rl/set-music-pitch music 0.5))))) - (rl/set-master-volume 0.6)) - -(defn stop-audio [] () - (when music-ok (rl/unload-music-stream music)) - (when tone-ok (rl/unload-sound tone)) - (rl/close-audio-device)) - -;; Every plink goes through here, so a silent build — no device, or a wave -;; that would not load — is one branch and not a guard at every call site. -(defn plink [pitch f32] () - (when tone-ok - (rl/set-sound-pitch tone pitch) - (rl/play-sound tone))) - -(defn toggle-music [] () - (when music-ok - (set music-on (not music-on)) - (if music-on - (rl/play-music-stream music) - (rl/pause-music-stream music)))) - -;; ── The scene, off-screen ─────────────────────────────────────────── -;; -;; The world is drawn into a render texture and the render texture is drawn to -;; the screen, which is what a post-process pass or a pixel-perfect upscale -;; would hang off. There is nothing to assert here either — LoadRenderTexture -;; makes a GL framebuffer object and answers an id of 0 with no context — so -;; the fallback below is not defensive padding, it is what keeps the program -;; honest when the framebuffer is not there. -;; -;; The source rectangle's height is NEGATIVE on purpose. raylib renders into a -;; framebuffer bottom-up, so drawing the result the right way up needs the -;; flip, and getting it wrong is a world that is upside down rather than an -;; error. - -(defvar scene rl/RenderTexture2D) -(defvar scene-ok bool) - -(defn load-scene [] () - (set scene (rl/load-render-texture screen-width screen-height)) - (set scene-ok (rl/render-texture-valid? scene)) - (unless scene-ok - (println "sand: no render texture — drawing straight to the screen"))) - -;; ── The font ──────────────────────────────────────────────────────── -;; -;; get-font-default needs a window: the default font is loaded as part of -;; init-window and LoadFontDefault is not exported, which is the same fact -;; that makes the plain measure-text answer 0 headless. The Font family IS -;; assertable — test/programs/raylib-font.flan builds one by hand and has -;; raylib measure with it — so what is left here is the drawing, and the -;; drawing is looked at. - -(defvar hud-font rl/Font) -(defvar hud-font-ok bool) - -(defn load-hud-font [] () - (set hud-font (rl/get-font-default)) - (set hud-font-ok (rl/font-valid? hud-font))) - -;; ── The view ──────────────────────────────────────────────────────── -;; -;; begin-mode-2d and end-mode-2d were bound along with Camera2D and then -;; called by nothing at all, which is the same as not having bound them. They -;; are load-bearing here now: the grid is drawn through this camera, the arrow -;; keys pan it, comma and period zoom, and `paint` has to undo the transform -;; with get-screen-to-world-2d or the sand lands somewhere other than the -;; cursor. That last part is what makes this a check rather than decoration — -;; a camera plumbed in wrongly shows up as grains appearing in the wrong -;; place, at once, while zoomed. -(defvar view rl/Camera2D) - -;; A fresh (Camera2D {}) has a zoom of 0, which is singular: both conversions -;; hand back NaN and nothing draws. 1.0 is the identity. -(defn reset-view [] () - (set view (rl/Camera2D {.offset (rl/Vector2 {.x 0.0 .y 0.0}) - .target (rl/Vector2 {.x 0.0 .y 0.0}) - .rotation 0.0 - .zoom 1.0}))) - -(defn set-view [target-x f32 target-y f32 zoom f32] () - (set view (rl/Camera2D {.offset (.offset view) - .target (rl/Vector2 {.x target-x .y target-y}) - .rotation (.rotation view) - .zoom zoom}))) - -;; Panning is world units per second and zooming is a factor per second, so -;; neither changes with the frame rate. That is the whole of what -;; get-frame-time is for, and a loop that assumed it hit its target fps would -;; be a loop that moves differently on a slower machine. -(defn move-view [] () - (let [dt (rl/get-frame-time) - pan (* (f32 600.0) dt) - tx (.x (.target view)) - ty (.y (.target view)) - zoom (.zoom view)] - (when (rl/key-down? :left) (set tx (- tx pan))) - (when (rl/key-down? :right) (set tx (+ tx pan))) - (when (rl/key-down? :up) (set ty (- ty pan))) - (when (rl/key-down? :down) (set ty (+ ty pan))) - (when (rl/key-down? :comma) (set zoom (- zoom (* zoom dt)))) - (when (rl/key-down? :period) (set zoom (+ zoom (* zoom dt)))) - ;; Clamped away from 0 for the reason above, and away from the far end - ;; because a cell is 5 pixels and there is no point past a screenful of - ;; one of them. - (set-view tx ty (min (f32 8.0) (max (f32 0.125) zoom))) - (when (rl/key-pressed? :zero) (reset-view)))) - -;; Locals are assignable places (spec-memory.md); parameters are not. -;; -;; The mouse is in screen pixels and the grid is in world cells, and with a -;; camera in the way those stopped being the same thing — so this is the one -;; place get-screen-to-world-2d is not a test case but a requirement. -(defn paint [] () - (let [m (rl/get-screen-to-world-2d (rl/get-mouse-position) view) - row (/ (i32 (.y m)) cell-size) - col (/ (i32 (.x m)) cell-size)] - (paint-at row col))) - ;; Every cross-function call in a dev build routes through an indirection cell, ;; so redefining this from the REPL reaches the running loop on the next frame. ;; No `varfn` (Janet), no `let update = ref` (OCaml), no var-routing (jank). @@ -427,37 +149,20 @@ ;; ;; A cell holds an (Fn ...) — a plain function pointer, no captured environment; ;; this one is (Fn [] ()), `settle`'s is (Fn [i32 i32] ()). Redefining -;; `settle` while `game-update` is mid-frame is safe -;; because old code is never unloaded; changing its SIGNATURE is not, and the -;; reload rejects it. See plan.org "What redefinition cannot do". +;; `settle` while `game-update` is mid-frame is safe because old code is never +;; unloaded; changing its SIGNATURE is not, and the reload rejects it. See +;; plan.org "What redefinition cannot do". (defn game-update [] () - (when (rl/key-pressed? :r) (clear-grid)) - (move-view) - ;; key-released? and mouse-button-pressed? were bound and called by nothing - ;; at all, which is the same as not having bound them. They are the two - ;; halves nothing else here uses: space cycles the colour when it comes back - ;; UP, and the right button resets the view the instant it goes DOWN, so the - ;; two edges are told apart by eye rather than only in the source. - (when (rl/key-released? :space) (next-color) (plink 1.4)) - (when (rl/mouse-button-pressed? :right) (reset-view) (plink 0.6)) - (when (rl/mouse-button-pressed? :left) (plink 1.0)) - (when (rl/key-pressed? :m) (toggle-music)) - ;; The pad, when there is one. Pressed and released are separate events here - ;; too, for the same reason. - (when (rl/gamepad-available? 0) - (when (rl/gamepad-button-pressed? 0 :right-face-down) (plink 1.2)) - (when (rl/gamepad-button-released? 0 :right-face-down) (next-color)) - (when (rl/gamepad-button-down? 0 :middle-right) (clear-grid))) - (when (rl/mouse-button-down? :left) (paint)) + (when (rl/key-pressed? :r) (clear-grid)) + (when (rl/mouse-button-down? :left) + (let [m (rl/get-mouse-position)] + (paint-at (/ (i32 (.y m)) cell-size) + (/ (i32 (.x m)) cell-size)))) (when (rl/mouse-button-released? :left) (next-color)) - ;; Once a frame, every frame, or the stream runs dry and the music stops - ;; without saying anything. This is the whole difference between a Music and - ;; a Sound. - (when music-on (rl/update-music-stream music)) (step)) - -(defn draw-grid [] () +(defn game-draw [] () + (rl/clear-background rl/black) (dotimes [row rows] (dotimes [col cols] (let [c (at grid row col)] @@ -465,257 +170,7 @@ (rl/draw-rectangle (i32 (* col cell-size)) (i32 (* row cell-size)) cell-size cell-size - (rl/get-color c))))))) - -;; Drawn inside the camera, in world units, so every one of these moves and -;; scales with the grid. That is the point: a shape binding that is subtly -;; wrong is easiest to see when it is supposed to sit exactly on the cursor -;; and does not. -(defn draw-world-cursor [] () - (let [p (rl/get-screen-to-world-2d (rl/get-mouse-position) view) - tint (rl/get-color (at colors current-color)) - x (.x p) - y (.y p) - r (f32 (* brush-size cell-size))] - ;; The brush's actual reach, as a ring, plus a thinner circle outside it. - (rl/draw-ring p (* r (f32 0.9)) r (f32 0.0) (f32 360.0) 48 tint) - (rl/draw-circle-lines-v p (+ r (f32 6.0)) tint) - ;; A crosshair: two thin lines and one thick one, which is three separate - ;; raylib calls with three different shapes of argument. - (rl/draw-line-v (rl/Vector2 {.x (- x r) .y y}) - (rl/Vector2 {.x (+ x r) .y y}) tint) - (rl/draw-line-v (rl/Vector2 {.x x .y (- y r)}) - (rl/Vector2 {.x x .y (+ y r)}) tint) - (rl/draw-line-ex (rl/Vector2 {.x (- x (f32 4.0)) .y y}) - (rl/Vector2 {.x (+ x (f32 4.0)) .y y}) (f32 3.0) rl/white) - ;; The exact world point: a filled dot, and one pixel of white on top of - ;; it. Both are the Vector2 forms, so they land where the ring's centre - ;; is and not somewhere an integer cast put them. - (rl/draw-circle-v p (f32 5.0) tint) - (rl/draw-pixel-v p rl/white) - ;; A pointer above the cursor. Counter-clockwise, because raylib culls the - ;; other winding and draws nothing — which looks exactly like a broken - ;; binding and is why the outline is drawn over it as a control. - (let [tip (rl/Vector2 {.x x .y (- y (+ r (f32 26.0)))}) - left (rl/Vector2 {.x (- x (f32 12.0)) .y (- y (+ r (f32 6.0)))}) - rght (rl/Vector2 {.x (+ x (f32 12.0)) .y (- y (+ r (f32 6.0)))})] - (rl/draw-triangle tip left rght tint) - (rl/draw-triangle-lines tip left rght rl/white)) - ;; And the world's own edge, so panning has something to pan against. - (rl/draw-rectangle-lines-ex - (rl/Rectangle {.x 0.0 .y 0.0 - .width (f32 screen-width) - .height (f32 screen-height)}) - (f32 2.0) (rl/get-color 0x303030FF)))) - -;; Drawn outside the camera, in screen pixels, so it stays put while the world -;; moves underneath it. Nothing here can be asserted — it needs a GL context — -;; so it is built to be *looked* at: every shape binding appears once, and each -;; one is asymmetric enough that a wrapper with its arguments crossed is -;; visible rather than merely different. -(defn draw-hud [] () - (let [title "SAND" - keys "arrows pan , . zoom 0 reset r clear space colour m music" - ;; measure-text is what sizes the panel, so the box fits the string - ;; rather than a number somebody guessed. Headless it answers 0 for - ;; everything, which is why it is not in the acceptance table. - ;; - ;; The title is measured with the Font form instead, which takes a - ;; float size and a spacing the integer form has no way to express — - ;; and then drawn with the matching draw-text-ex, so the box and the - ;; letters agree. That agreement is the check: measure with one and - ;; draw with the other and the panel is visibly the wrong width. - title-w (if hud-font-ok - (i32 (.x (rl/measure-text-ex hud-font title 30.0 4.0))) - (rl/measure-text title 30)) - w (max title-w (rl/measure-text keys 20)) - h 72 - x 24 - y (- (rl/get-screen-height) (+ h 24)) - panel (rl/Rectangle {.x (f32 (- x 12)) .y (f32 (- y 12)) - .width (f32 (+ w 24)) .height (f32 (+ h 24))})] - (rl/draw-rectangle-rounded panel (f32 0.2) 8 (rl/get-color 0x101018E0)) - ;; Both outline forms, one inside the other: the plain one has no - ;; thickness in raylib 5.5 and the -ex one is where thickness went. - (rl/draw-rectangle-rounded-lines panel (f32 0.2) 8 (rl/get-color 0x404060FF)) - (rl/draw-rectangle-rounded-lines-ex panel (f32 0.2) 8 (f32 2.0) - (rl/get-color 0x6060A0FF)) - (if hud-font-ok - (rl/draw-text-ex hud-font title (rl/Vector2 {.x (f32 x) .y (f32 y)}) - 30.0 4.0 rl/white) - (rl/draw-text title x y 30 rl/white)) - (rl/draw-text keys x (+ y 40) 20 (rl/get-color 0xA0A0B0FF)) - - ;; The palette, along the bottom right. The selected colour is the one - ;; with a ring round it, so `current-color` is readable off the screen. - (let [sw (- (rl/get-screen-width) 40) - sh (- (rl/get-screen-height) 40)] - (dotimes [i (len colors)] - (let [cx (- sw (* (- (len colors) (+ i 1)) 46)) - c (rl/get-color (at colors i))] - (rl/draw-circle cx sh (f32 16.0) c) - (when (= i current-color) - (rl/draw-circle-lines cx sh (f32 22.0) rl/white)))) - - ;; The selected index as a digit, drawn one codepoint at a time. There - ;; is no string formatting in the language yet, so this is the only way - ;; a number reaches the screen at all — and get-glyph-index is what says - ;; whether the default font has the digit before it is asked for. - (when hud-font-ok - (let [cp (+ 48 current-color)] - (when (> (rl/get-glyph-index hud-font cp) 0) - (rl/draw-text-codepoint hud-font cp - (rl/Vector2 {.x (f32 (- sw 24)) - .y (f32 (- sh 96))}) - 30.0 rl/white)))) - - ;; A zoom read-out with no number in it, because there is no string - ;; formatting yet: the bar's length is the zoom. draw-rectangle-rec, - ;; draw-rectangle-v and draw-rectangle-lines are the three remaining - ;; rectangle shapes, so all three are here rather than invented - ;; elsewhere. - (let [bx (f32 (- sw 220)) - by (f32 (- sh 60)) - fill (* (f32 200.0) (min (f32 1.0) (/ (.zoom view) (f32 8.0))))] - (rl/draw-rectangle-rec (rl/Rectangle {.x bx .y by .width (f32 200.0) - .height (f32 10.0)}) - (rl/get-color 0x202028FF)) - (rl/draw-rectangle-v (rl/Vector2 {.x bx .y by}) - (rl/Vector2 {.x fill .y (f32 10.0)}) - (rl/get-color 0x6060A0FF)) - (rl/draw-rectangle-lines (- sw 220) (- sh 60) 200 10 - (rl/get-color 0x8080C0FF)) - ;; The tick at the identity zoom, and a single pixel marking its left - ;; end — the integer forms of the line and pixel calls. - (rl/draw-line (+ (- sw 220) 25) (- sh 66) (+ (- sw 220) 25) (- sh 46) - rl/white) - (rl/draw-pixel (- sw 220) (- sh 66) rl/white)) - - ;; An ellipse, deliberately wider than it is tall so that exchanging its - ;; two radii would be obvious, and a ring whose sweep is driven by - ;; get-time so that something on screen proves the clock is running. - (let [ex (- sw 320) - ey (- sh 20) - spin (f32 (* 60.0 (rl/get-time)))] - (rl/draw-ellipse ex ey (f32 26.0) (f32 12.0) (rl/get-color 0x303040FF)) - (rl/draw-ellipse-lines ex ey (f32 26.0) (f32 12.0) - (rl/get-color 0x8080C0FF)) - (rl/draw-ring-lines (rl/Vector2 {.x (f32 ex) .y (f32 ey)}) - (f32 30.0) (f32 34.0) spin (+ spin (f32 270.0)) 32 - rl/white))))) - - -;; ── Gamepads, touch and gestures ──────────────────────────────────── -;; -;; None of this can be asserted anywhere, and the reason is worth stating -;; rather than assuming. With no pad attached, gamepad-available? is false, -;; every button predicate is false and every axis reads 0.0 — which is exactly -;; what a wrapper with its two int arguments exchanged would report. Touch and -;; gestures are the same: they are fed by raylib's own event polling inside a -;; frame loop, so they answer nothing at all headless. A test would be -;; asserting that two zeroes are equal. -;; -;; So they are drawn, and the only check they get is that moving a stick moves -;; the marker. Every read-out below is asymmetric on purpose — the stick dot -;; is offset by x and y separately, and the trigger bars are different lengths -;; — so a crossed wrapper is visible rather than merely different. -(defn draw-input-state [] () - (let [ox (f32 200.0) - oy (f32 90.0) - r (f32 34.0)] - (when (rl/gamepad-available? 0) - ;; The ring only appears when raylib says a pad is there, which is what - ;; separates "centred stick" from "no pad" — both of which are a dot in - ;; the middle otherwise. - (rl/draw-circle-lines (i32 ox) (i32 oy) r (rl/get-color 0x6060A0FF)) - (let [p (rl/Vector2 {.x (+ ox (* (rl/get-gamepad-axis-movement 0 :left-x) r)) - .y (+ oy (* (rl/get-gamepad-axis-movement 0 :left-y) r))})] - (rl/draw-circle-v p (f32 5.0) rl/white)) - ;; The two triggers as bars of different lengths, so exchanging them is - ;; visible. They rest at -1 and not at 0, which raylib does not - ;; normalise and neither does this — hence the +1. - (let [lt (+ (f32 1.0) (rl/get-gamepad-axis-movement 0 :left-trigger)) - rt (+ (f32 1.0) (rl/get-gamepad-axis-movement 0 :right-trigger))] - (rl/draw-rectangle-v (rl/Vector2 {.x (+ ox (f32 46.0)) .y (- oy (f32 12.0))}) - (rl/Vector2 {.x (* lt (f32 30.0)) .y (f32 8.0)}) - (rl/get-color 0x8080C0FF)) - (rl/draw-rectangle-v (rl/Vector2 {.x (+ ox (f32 46.0)) .y (+ oy (f32 4.0))}) - (rl/Vector2 {.x (* rt (f32 50.0)) .y (f32 8.0)}) - (rl/get-color 0x8080C0FF))) - ;; One pip per axis the pad reports, and one per face button that is - ;; NOT up — gamepad-button-up? rather than -down? so the negative form - ;; has a call site of its own. - (dotimes [i (rl/get-gamepad-axis-count 0)] - (rl/draw-pixel (+ (i32 ox) (* i 4)) (+ (i32 oy) 44) rl/white)) - (unless (rl/gamepad-button-up? 0 :right-face-down) - (rl/draw-circle (+ (i32 ox) 110) (i32 oy) (f32 6.0) rl/white)) - ;; -1 when nothing is pressed, which is why this is an i32 and not a - ;; GamepadButton: the answer is outside the enum. - (when (>= (rl/get-gamepad-button-pressed) 0) - (rl/draw-circle (+ (i32 ox) 130) (i32 oy) (f32 6.0) - (rl/get-color 0xFFC000FF)))) - - ;; Touch. On a desktop the count is 0 but point 0 still follows the - ;; mouse, so the ring below is what says a real touchscreen is there. - (dotimes [i (rl/get-touch-point-count)] - (rl/draw-circle-lines-v (rl/get-touch-position i) (f32 18.0) - (rl/get-color 0xA0A0FFFF)) - (rl/draw-pixel (rl/get-touch-x) (rl/get-touch-y) rl/white) - (rl/draw-pixel-v (rl/Vector2 {.x (f32 (rl/get-touch-point-id i)) - .y (f32 4.0)}) - rl/white)) - - ;; And the gesture, if any: a bar as long as the hold has lasted, and the - ;; drag vector drawn from the centre of the ring. - (unless (= (rl/get-gesture-detected) :none) - (rl/draw-rectangle (i32 ox) (+ (i32 oy) 54) - (i32 (* (f32 60.0) (rl/get-gesture-hold-duration))) - 8 rl/white) - (when (rl/gesture-detected? :drag) - (let [d (rl/get-gesture-drag-vector)] - (rl/draw-line-v (rl/Vector2 {.x ox .y oy}) - (rl/Vector2 {.x (+ ox (* (.x d) (f32 200.0))) - .y (+ oy (* (.y d) (f32 200.0)))}) - (rl/get-color 0xFFC000FF)))) - (when (rl/gesture-detected? :pinch-in) - (let [q (rl/get-gesture-pinch-vector)] - (rl/draw-circle-v (rl/Vector2 {.x (+ ox (* (.x q) (f32 200.0))) - .y (+ oy (* (.y q) (f32 200.0)))}) - (f32 4.0) rl/white)))))) - -(defn draw-world [] () - ;; Everything between these two is in world space and moves with the camera. - (rl/begin-mode-2d view) - (draw-grid) - (draw-world-cursor) - (rl/end-mode-2d)) - -(defn game-draw [] () - ;; The world goes into the render texture first, if there is one. Note the - ;; clear inside the texture mode: the framebuffer keeps last frame's pixels - ;; otherwise, which looks like a trail and not like a bug. - (when scene-ok - (rl/begin-texture-mode scene) - (rl/clear-background rl/black) - (draw-world) - (rl/end-texture-mode)) - (rl/clear-background rl/black) - ;; Then the texture, upside down on purpose: raylib renders into a - ;; framebuffer bottom-up, so a negative source height is the correction and - ;; not a trick. Without a framebuffer the world is drawn straight to the - ;; screen and nothing else changes. - (if scene-ok - (rl/draw-texture-rec (.texture scene) - (rl/Rectangle {.x 0.0 .y 0.0 - .width (f32 screen-width) - .height (f32 (- 0 screen-height))}) - (rl/Vector2 {.x 0.0 .y 0.0}) - rl/white) - (draw-world)) - ;; And everything after it is in screen pixels again. - (draw-brush) - (draw-hud) - (draw-input-state) + (rl/get-color c)))))) (rl/draw-fps 20 20)) (defn main [] () @@ -723,25 +178,6 @@ (rl/init-window screen-width screen-height "SAND") (defer (rl/close-window)) (rl/set-target-fps 120) - ;; Before anything draws: a zero zoom is singular and nothing would appear. - (reset-view) - ;; After the window, never before: LoadTexture uploads to the GPU and there - ;; is no GPU to upload to until InitWindow has made a context. - (load-brush) - (defer (rl/unload-texture brush)) - (defer (rl/unload-texture brush-mirrored)) - ;; The same rule for the framebuffer and the default font, and a third one - ;; for the mixer: the audio device is its own subsystem and does not come - ;; with the window, so it is opened and closed on its own. - (load-scene) - (defer (rl/unload-render-texture scene)) - (load-hud-font) - (start-audio) - (defer (stop-audio)) - ;; Gestures are off until something asks for them. Everything, because the - ;; read-out draws whichever one arrives, and because the parameter is a set - ;; of flags rather than one member — see the note on the Gesture enum. - (rl/set-gestures-enabled rl/gesture-all) ;; The dev agent listens on a socket for redefinitions and hands them over; ;; (agent/poll) below is where they are installed. Building without --dev is ;; fine — nothing has cells to install into, so a module is refused on the diff --git a/test/dune b/test/dune index d895143..d6efd95 100644 --- a/test/dune +++ b/test/dune @@ -12,11 +12,11 @@ (deps (file %{workspace_root}/calc-me.flan) (file %{workspace_root}/sand.flan) - ; The brush sheet, which sand.flan now (embed ...)s rather than opening by - ; path. An embed is read by the *checker*, relative to the file the form is - ; written in, so it is a dependency of every build of sand.flan including the - ; headless one — which reaches sand.flan through ../../ from programs/ and - ; would otherwise find nothing at _build/default/brush.png. + ; The brush sheet. sand.flan no longer embeds it — the front-end was cut back + ; to what lisp/sand.lisp and sand.jank have — so nothing in the corpus reads + ; it today. Kept as a dependency because it is still in the workspace and an + ; embed is read by the *checker*, relative to the file the form is written + ; in, which is the rule any program picking it up again would meet. (file %{workspace_root}/brush.png) ; The raylib bindings, because sand.flan and the FFI case import them and an ; import reads the directory at build time. sand.flan itself is above: the diff --git a/test/test_session.ml b/test/test_session.ml index 8506b63..2bce7b3 100644 --- a/test/test_session.ml +++ b/test/test_session.ml @@ -182,12 +182,12 @@ let () = let t, _ = Session.create ~file:"../sand.flan" () in let src = In_channel.with_open_bin "../sand.flan" In_channel.input_all in (* [~origin] is the buffer's own path and both editor paths send it - (flan-dev.el's `:file (or buffer-file-name "")`). It became - load-bearing here when sand.flan started embedding brush.png: an embedded - path is resolved relative to the file the form is written in, so the - default origin of "" would look for ./brush.png beside the test's - working directory and find nothing. Omitting it here was testing a request - the editor never sends. *) + (flan-dev.el's `:file (or buffer-file-name "")`). Omitting it here + was testing a request the editor never sends. It used to matter to this + case for a second reason — sand.flan embedded brush.png, and an embedded + path resolves relative to the file the form is written in, so the default + origin of "" found nothing. sand.flan has no embed any more; the + first reason is the one that stands. *) (match Session.eval ~origin:"../sand.flan" t src with | c -> if not (List.mem "game-draw" c.Session.fns) then diff --git a/test/test_web.ml b/test/test_web.ml index 73e3e67..de51d96 100644 --- a/test/test_web.ml +++ b/test/test_web.ml @@ -255,12 +255,6 @@ let () = "no asyncify in sand's module — its `until` loop would block the browser"; if not (contains bytes "glViewport") then fail "no GL imports in sand's module — raylib did not link"; - let png = read "../brush.png" in - if String.length png = 0 then - fail "brush.png is empty, so the embed assertion below proves nothing" - else if not (contains bytes png) then - fail - "brush.png's bytes are not in sand's module — the embed did not reach the browser"; cleanup out))); (* ── Refused by name ───────────────────────────────────────────────