742 lines
36 KiB
Plaintext
742 lines
36 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`
|
|
;;;; an omitted return type means Unit
|
|
;;;; 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) (nth 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))
|
|
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?)
|
|
(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)
|
|
|
|
;; A missing file is not a crash and not silence: LoadTexture 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.
|
|
(defn load-brush []
|
|
(set brush (rl/load-texture "brush.png"))
|
|
(set brush-ok (rl/texture-valid? brush))
|
|
(unless brush-ok
|
|
(print-line "sand: cannot load brush.png — drawing the cursor is off"))
|
|
;; The other route to a texture: the file into RAM, changed there, and only
|
|
;; then uploaded. An Image that failed to load has a null buffer and
|
|
;; unloading it is still safe, so there is one unload and not two.
|
|
(let [sheet (rl/load-image "brush.png")]
|
|
(when (rl/image-valid? sheet)
|
|
(rl/image-flip-horizontal (addr sheet))
|
|
(set brush-mirrored (rl/load-texture-from-image sheet)))
|
|
(rl/unload-image sheet))
|
|
(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 (nth 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
|
|
(print-line "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
|
|
(print-line "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 [] Unit), `settle`'s is (Fn [i32 i32] Unit). 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 (nth 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 (nth 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)))
|