JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

sand.flan is the game the other ports are, and nothing else

Browse Source 
765 lines to 201, at parity with lisp/sand.lisp, clojure/src/fnm/sand.clj
and src/fnm/sand.jank. Gone: audio and tone synthesis, the brush textures
and the embedded PNG, the render-texture scene, the HUD font, the camera,
the world cursor, the HUD and the input-state read-out. None of it is in
any reference version, and none of it was the language being exercised.

Inlined the single-use helpers -- empty-at?, move-grain, draw-grid, paint.
settle also carried an unused (rl/Vector2 ...) binding, which put raylib
inside the section whose banner says there is none, and a stray (pause).

The physics is untouched on purpose: the references disagree there, so
parity does not name a target, and settle is what the pinned hash covers.
It still prints 15595743031174623232 at -O2, -O0 and as a dev build.

test_web.ml asserted brush.png's bytes reached the wasm module, proving an
embed survives the web build. web-files.flan is web-built and *run* under
node and asserts the embedded bytes print, which is the same property
checked harder, so the sand assertion goes rather than the embed staying.
This commit is contained in:
Joseph Ferano 2026-09-13 12:19:13 +07:00
parent 344e571c8c
commit aa6087af91
5 changed files with 56 additions and 620 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
NEXT.md
View File

@ -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

636
sand.flan
View File

@ -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

10
test/dune
View File

@ -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

12
test/test_session.ml
View File

@ -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 "<buffer>")`). 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 "<eval>" 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 "<buffer>")`). 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 "<eval>" 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

6
test/test_web.ml
View File

@ -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 ───────────────────────────────────────────────