Joseph Ferano
df73f87b2f
The slot after a defn's parameters is unconditionally a type. Parse.decl no
longer takes a set of type names, and is_type_form, qualified_type, types_in,
declared_types and prelude_types are gone with the pre-pass that fed them.
What they were for: (Option f64) and (Some 1) are the same s-expression, so the
parser decided which it had by looking the head up in a set of the file's own
type names. Sound -- one top-level namespace means a name cannot be both a type
and a value -- and brittle, because the set had to be complete. It was wrong
twice in one day, the second time parsing (defn f [] (Rune {.code 65}) (bar))
as a function returning a Rune with a one-form body, silently, in every file in
the language.
Two things fall out. A type the parser could not have known -- a struct
declared further down the file, rl/Vector2 behind an unresolved alias, a
prelude type -- never needed recognising, only placing. And a mistyped type is
a mistyped type: (defn f [] f65 0.0) reaches the resolver's near-miss check and
says did you mean f64, where it used to be read as the first form of the body
and reported as an unknown name.
Unit is written (). The old spelling is refused with a message naming the new
one, the rule the colon-to-dot change followed. Internally it is still
Tname "Unit" and Types.Unit, so the resolver, the shim and the emitter did not
change; Cimport still builds Tname "Unit" for C's void without going through
the parser. Types.to_string prints () though -- that printer prints what a
person would write for every other type it knows, [i32], {K V}, (Ptr T), and
Unit was the odd one out once the source spelling moved.
Dropping prelude_types removes one of the two reasons Macro.reduce may only
drop defns: the memoised set a bootstrap build could have poisoned is gone, so
the remaining reason is the plain one.
766 lines
37 KiB
Plaintext
766 lines
37 KiB
Plaintext
;;;; 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".
|
|
;;;;
|
|
;;;; 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.
|
|
;;;;
|
|
;;;; 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.
|
|
;;;;
|
|
;;;; Notation reminders (see plan.org and spec-memory.md):
|
|
;;;; [n T] fixed array, length n, element T — a VALUE, copies
|
|
;;;; [T] slice, ptr+len, non-owning (Vec T) owning, move-only
|
|
;;;; (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
|
|
|
|
;;;; ── The simulation ───────────────────────────────────────────
|
|
;;;;
|
|
;;;; No raylib between here and the next banner, which is what the headless
|
|
;;;; driver imports this file for. The hash is over exactly this.
|
|
|
|
(defconst screen-width 900)
|
|
(defconst screen-height 600)
|
|
(defconst cell-size 5)
|
|
;; f32: velocity is [f32], and there is no implicit widening.
|
|
(defconst gravity f32 0.05)
|
|
(defconst rows (/ screen-height cell-size))
|
|
(defconst cols (/ screen-width cell-size))
|
|
(defconst brush-size 10)
|
|
|
|
;; Packed 0xRRGGBBAA. A cell of 0 means empty, so no Option and no tag word.
|
|
(defconst colors [4 u32] [0xFFF00FFF 0x3B6E8CFF 0xA83232FF 0xCC6B1FFF])
|
|
|
|
;; Flat, unboxed, statically sized. No headers, so these are exactly
|
|
;; rows*cols*4 bytes each — the same memory the Odin port has. Fixed arrays are
|
|
;; values, so `(set grid (zeroed))` overwrites in place rather than reallocating.
|
|
;; No initialiser means all-bytes-zero (plan.org, zero values), so these are
|
|
;; BSS and cost nothing to start. `(zeroed)` below is the explicit spelling for
|
|
;; re-zeroing later — a memset, not an allocation.
|
|
(defvar grid [rows [cols u32]])
|
|
(defvar velocity [rows [cols f32]])
|
|
;; An index into colors, not a colour.
|
|
(defvar current-color i32)
|
|
|
|
(defn clear-grid [] ()
|
|
(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))))
|
|
|
|
;; Drop a brush-sized cloud of grains centred on [row col]. This is what the
|
|
;; mouse drives interactively and what the headless run calls directly — the
|
|
;; only difference between the two is where the centre comes from.
|
|
(defn paint-at [row i32 col i32] ()
|
|
(let [half (/ brush-size 2)]
|
|
(dotimes [x brush-size]
|
|
(dotimes [y brush-size]
|
|
(let [r (+ y (- row half))
|
|
c (+ x (- col half))]
|
|
(when (and (>= r 0) (< r (- rows 1))
|
|
(>= c 0) (< c (- cols 1))
|
|
(empty-at? 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.
|
|
;;
|
|
;; Imperative `while` with early `return`, not loop/recur — see plan.org
|
|
;; "Loop story". The recur version read as a tail call but was a countdown
|
|
;; 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)
|
|
(return))
|
|
(let [left? (and (> col 0) (empty-at? y (- col 1)))
|
|
right? (and (< col (- cols 1)) (empty-at? 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)
|
|
(return))))
|
|
(set y (- y 1)))
|
|
;; Nowhere to fall: reset the accumulated velocity and stay put.
|
|
(set (at velocity row col) 0.0)))
|
|
|
|
;; One frame of physics. Bottom-up, so a grain settles at most once per frame.
|
|
(defn step [] ()
|
|
(let [row (- rows 2)]
|
|
(while (>= row 0)
|
|
(dotimes [col cols]
|
|
(unless (empty-at? row col)
|
|
(settle row col)))
|
|
(set row (- row 1)))))
|
|
|
|
;; FNV-1a over the grid, so the headless run has one number to compare. It has
|
|
;; to be identical on native and wasm32, which is the whole reason rand-f32 is
|
|
;; a seeded PRNG written in Flan rather than libc's (plan.org, RNG is ours).
|
|
;; Named because a let binding takes no type annotation, and 0xcbf29ce484222325
|
|
;; does not fit the i32 an unannotated integer literal would default to.
|
|
(defconst fnv-offset u64 0xcbf29ce484222325)
|
|
(defconst fnv-prime u64 1099511628211)
|
|
|
|
(defn hash-grid [] u64
|
|
(let [h fnv-offset]
|
|
(dotimes [row rows]
|
|
(dotimes [col cols]
|
|
(let [c (at grid row col)]
|
|
(dotimes [b 4]
|
|
(set h (bit-xor h (u64 (bit-and (>> c (u32 (* b 8))) 255))))
|
|
(set h (* h fnv-prime))))))
|
|
h))
|
|
|
|
;;;; ── The raylib front-end ──────────────────────────────────
|
|
;;;;
|
|
;;;; 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).
|
|
;; Release builds compile the same source to direct calls.
|
|
;;
|
|
;; 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".
|
|
(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/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 [] ()
|
|
(dotimes [row rows]
|
|
(dotimes [col cols]
|
|
(let [c (at grid row col)]
|
|
(unless (= 0 c)
|
|
(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/draw-fps 20 20))
|
|
|
|
(defn main [] ()
|
|
(rl/set-trace-log-level :warning)
|
|
(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
|
|
;; listener thread and the loop never notices.
|
|
(agent/start "/tmp/flan-sand.sock")
|
|
;; Bare (defn main []) — argv and the i32 status are both optional.
|
|
;; Nothing in this loop allocates, so context/temp is never even touched.
|
|
(until (rl/window-should-close?)
|
|
;; The frame boundary, and the only place a redefinition becomes visible.
|
|
;; An error while installing/evaluating a dev form, or during the update,
|
|
;; leaves one CL-style escape hatch: choose `continue' in the editor to
|
|
;; abandon this frame and return to the next one with the game still live.
|
|
;; Keep drawing outside it. Skipping between BeginDrawing and EndDrawing
|
|
;; would leave raylib's frame unbalanced.
|
|
(restart-case
|
|
(do (agent/poll)
|
|
(game-update))
|
|
(continue [] (do)))
|
|
(rl/begin-drawing)
|
|
(game-draw)
|
|
(rl/end-drawing)))
|