aesthetic.computer
Monorepo for Aesthetic.Computer
aesthetic.computer
1;;; Notepat — AC Native OS musical keyboard instrument (Common Lisp)
2;;; Port of fedac/native/pieces/notepat.mjs
3
4(in-package :ac-native)
5
6(defvar *running* t "Main loop flag.")
7
8;;; ── Pixel scale ──
9
10(defun compute-pixel-scale (display-w)
11 "Compute pixel scale targeting ~200px wide (bigger pixels)."
12 (let ((target (max 1 (min 16 (floor display-w 200)))))
13 (loop for delta from 0 to 3 do
14 (let ((s (+ target delta)))
15 (when (and (>= s 1) (<= s 16) (zerop (mod display-w s)))
16 (return-from compute-pixel-scale s)))
17 (let ((s (- target delta)))
18 (when (and (>= s 1) (zerop (mod display-w s)))
19 (return-from compute-pixel-scale s))))
20 target))
21
22;;; ── Music theory ──
23
24(defvar *chromatic* #("c" "c#" "d" "d#" "e" "f" "f#" "g" "g#" "a" "a#" "b"))
25
26(defun note-to-freq (note-name octave)
27 "Convert note name and octave to frequency in Hz. A4 = 440Hz."
28 (let ((idx (position note-name *chromatic* :test #'string=)))
29 (if idx
30 (* 440.0d0 (expt 2.0d0 (+ (- octave 4) (/ (- idx 9) 12.0d0))))
31 440.0d0)))
32
33(defun note-is-sharp-p (note-name)
34 (search "#" note-name))
35
36;;; ── Note colors (chromatic rainbow) ──
37
38(defvar *note-colors*
39 '(("c" 255 30 30) ; red
40 ("c#" 255 80 0) ; red-orange
41 ("d" 255 150 0) ; orange
42 ("d#" 200 200 0) ; yellow-green
43 ("e" 230 220 0) ; yellow
44 ("f" 30 200 30) ; green
45 ("f#" 0 200 180) ; teal
46 ("g" 30 100 255) ; blue
47 ("g#" 80 50 255) ; indigo
48 ("a" 140 30 220) ; purple
49 ("a#" 200 30 150) ; magenta
50 ("b" 200 50 255))) ; violet
51
52(defun note-color-rgb (note-name)
53 "Return (r g b) list for a note name."
54 (let ((entry (assoc note-name *note-colors* :test #'string=)))
55 (if entry (cdr entry) '(80 80 80))))
56
57;;; ── Keyboard mapping: evdev keycode → (note-name . octave-offset) ──
58
59(defvar *key-note-map* (make-hash-table :test 'eql))
60
61(defun init-key-note-map ()
62 "Populate keycode → note mapping (QWERTY layout matching JS notepat)."
63 (clrhash *key-note-map*)
64 (flet ((m (key note off) (setf (gethash key *key-note-map*) (cons note off))))
65 ;; Lower octave naturals
66 (m ac-native.input:+key-c+ "c" 0) (m ac-native.input:+key-d+ "d" 0)
67 (m ac-native.input:+key-e+ "e" 0) (m ac-native.input:+key-f+ "f" 0)
68 (m ac-native.input:+key-g+ "g" 0) (m ac-native.input:+key-a+ "a" 0)
69 (m ac-native.input:+key-b+ "b" 0)
70 ;; Lower octave sharps
71 (m ac-native.input:+key-v+ "c#" 0) (m ac-native.input:+key-s+ "d#" 0)
72 (m ac-native.input:+key-w+ "f#" 0) (m ac-native.input:+key-r+ "g#" 0)
73 (m ac-native.input:+key-q+ "a#" 0)
74 ;; Upper octave naturals
75 (m ac-native.input:+key-h+ "c" 1) (m ac-native.input:+key-i+ "d" 1)
76 (m ac-native.input:+key-j+ "e" 1) (m ac-native.input:+key-k+ "f" 1)
77 (m ac-native.input:+key-l+ "g" 1) (m ac-native.input:+key-m+ "a" 1)
78 (m ac-native.input:+key-n+ "b" 1)
79 ;; Upper octave sharps
80 (m ac-native.input:+key-t+ "c#" 1) (m ac-native.input:+key-y+ "d#" 1)
81 (m ac-native.input:+key-u+ "f#" 1) (m ac-native.input:+key-o+ "g#" 1)
82 (m ac-native.input:+key-p+ "a#" 1)
83 ;; Extension +2
84 (m ac-native.input:+key-semicolon+ "c" 2)
85 (m ac-native.input:+key-apostrophe+ "c#" 2)
86 (m ac-native.input:+key-rightbrace+ "d" 2)
87 ;; Sub-octave
88 (m ac-native.input:+key-z+ "a#" -1) (m ac-native.input:+key-x+ "b" -1)))
89
90;;; ── State ──
91
92(defvar *wave-names* #("sine" "triangle" "sawtooth" "square" "noise"))
93(defvar *wave-index* 0)
94(defvar *octave* 4)
95(defvar *quick-mode* nil "Short attack/release for staccato play.")
96
97;; Active voices and trails
98(defvar *active-voices* (make-hash-table :test 'eql))
99(defvar *active-notes* (make-hash-table :test 'eql))
100(defvar *trails* (make-hash-table :test 'equal))
101
102;; Background color
103(defvar *bg-r* 20) (defvar *bg-g* 20) (defvar *bg-b* 25)
104
105;; FPS
106(defvar *fps-display* 0)
107(defvar *fps-accum* 0.0d0)
108(defvar *fps-samples* 0)
109(defvar *fps-last-time* 0.0d0)
110
111;; ESC triple-press
112(defvar *esc-count* 0)
113(defvar *esc-last-frame* 0)
114
115;; Metronome
116(defvar *metronome-on* nil)
117(defvar *metronome-bpm* 120)
118(defvar *metronome-last-beat* -1)
119(defvar *metronome-flash* 0.0 "Visual flash intensity 0-1, decays per frame.")
120(defvar *metronome-phase* 0.0 "Pendulum swing -1..1.")
121
122;; Identity
123(defvar *boot-handle* nil "Handle from config, set during boot splash.")
124
125;; Native notepat runtime state (defvar — SBCL standalone loses let* locals)
126(defvar *np-dw* 0)
127(defvar *np-dh* 0)
128(defvar *np-scale* 1)
129(defvar *np-sw* 0)
130(defvar *np-sh* 0)
131(defvar *np-screen* nil)
132(defvar *np-graph* nil)
133(defvar *np-input* nil)
134(defvar *np-audio* nil)
135(defvar *np-frame* 0)
136(defvar *np-display* nil)
137
138;; Network
139(defvar *ip-address* "")
140
141(defun refresh-ip ()
142 (handler-case
143 (let ((output (with-output-to-string (s)
144 (sb-ext:run-program "/sbin/ip" '("-4" "-o" "addr" "show")
145 :output s :error nil))))
146 (dolist (line (uiop:split-string output :separator '(#\Newline)))
147 (when (and (search "inet " line) (not (search "127.0.0.1" line)))
148 (let* ((inet-pos (search "inet " line))
149 (ip-start (+ inet-pos 5))
150 (slash-pos (position #\/ line :start ip-start)))
151 (when slash-pos
152 (setf *ip-address* (subseq line ip-start slash-pos))
153 (return))))))
154 (error () nil)))
155
156;;; ── Helpers ──
157
158(defun kill-all-voices (audio)
159 "Kill all active voices (on octave/wave change)."
160 (when audio
161 (maphash (lambda (code voice-id)
162 (declare (ignore code))
163 (audio-synth-kill audio voice-id))
164 *active-voices*))
165 (clrhash *active-voices*)
166 (clrhash *active-notes*))
167
168;;; ── Build metadata ──
169
170(defvar *build-name* "dev" "Build name from /etc/ac-build.")
171(defvar *build-variant* "c" "Build variant: c or cl.")
172
173(defun load-build-metadata ()
174 "Read /etc/ac-build: line 1=name, 2=hash, 3=timestamp, 4=variant."
175 (handler-case
176 (when (probe-file "/etc/ac-build")
177 (with-open-file (s "/etc/ac-build" :direction :input)
178 (let ((name (read-line s nil nil))
179 (hash (read-line s nil nil))
180 (ts (read-line s nil nil))
181 (variant (read-line s nil nil)))
182 (declare (ignore hash ts))
183 (when name (setf *build-name* name))
184 (when variant (setf *build-variant* variant)))))
185 (error () nil)))
186
187;;; ── Boot splash ──
188
189(defun time-greeting ()
190 "Return time-of-day greeting string."
191 (let ((hour (nth-value 2 (get-decoded-time))))
192 (cond ((and (>= hour 5) (< hour 12)) "good morning")
193 ((and (>= hour 12) (< hour 17)) "good afternoon")
194 (t "good evening"))))
195
196;;; ── JS Piece Runner ──
197
198(defun main-js (piece-path)
199 "Run a .mjs piece via the QuickJS bridge."
200 (format *error-output* "~%════════════════════════════════════~%")
201 (format *error-output* " AC Native OS (Common Lisp + QuickJS)~%")
202 (format *error-output* " SBCL ~A~%" (lisp-implementation-version))
203 (format *error-output* " piece: ~A~%" piece-path)
204 (format *error-output* "════════════════════════════════════~%~%")
205 (force-output *error-output*)
206
207 (let ((display (handler-case (ac-native.drm:drm-init)
208 (error (e)
209 (format *error-output* "[js] DRM error: ~A~%" e)
210 (force-output *error-output*) nil))))
211 (unless display
212 (format *error-output* "[js] FATAL: no display~%")
213 (force-output *error-output*) (sleep 30) (return-from main-js 1))
214
215 (let* ((dw (ac-native.drm:display-width display))
216 (dh (ac-native.drm:display-height display))
217 (scale (compute-pixel-scale dw))
218 (sw (floor dw scale))
219 (sh (floor dh scale))
220 (screen (fb-create sw sh))
221 (graph (make-graph :fb screen :screen screen))
222 (input (ac-native.input:input-init dw dh scale))
223 (audio (ac-native.audio:audio-init))
224 (frame 0))
225
226 (font-init)
227
228 ;; Initialize QuickJS bridge
229 (handler-case
230 (js-init graph screen audio sw sh)
231 (error (e)
232 (format *error-output* "[js] JS-INIT ERROR: ~A~%" e)
233 (force-output *error-output*)
234 (when audio (audio-destroy audio))
235 (ac-native.input:input-destroy input)
236 (fb-destroy screen)
237 (ac-native.drm:drm-destroy display)
238 (setf *js-fallback* t)
239 (return-from main-js (main))))
240
241 ;; Load the piece
242 (unless (js-load-piece piece-path)
243 (format *error-output* "[js] Failed to load piece, falling back to native notepat~%")
244 (force-output *error-output*)
245 (js-destroy)
246 ;; Cleanup and fall through to native
247 (when audio (audio-destroy audio))
248 (ac-native.input:input-destroy input)
249 (fb-destroy screen)
250 (ac-native.drm:drm-destroy display)
251 (setf *js-fallback* t)
252 (return-from main-js (main)))
253
254 ;; Call boot
255 (js-boot)
256
257 ;; Start Swank
258 (handler-case
259 (progn
260 (setf swank::*communication-style* :spawn)
261 (swank:create-server :port 4005 :dont-close t)
262 (format *error-output* "[js] Swank on :4005~%")
263 (force-output *error-output*))
264 (error (e)
265 (format *error-output* "[js] Swank failed: ~A~%" e)
266 (force-output *error-output*)))
267
268 ;; Main loop
269 (setf *running* t)
270 (unwind-protect
271 (loop while *running* do
272 (incf frame)
273
274 ;; Input → act
275 (dolist (ev (ac-native.input:input-poll input))
276 (let ((type (ac-native.input:event-type ev))
277 (code (ac-native.input:event-code ev))
278 (key (ac-native.input:event-key ev)))
279 ;; ESC triple-press to quit
280 (when (and (eq type :key-down) (= code ac-native.input:+key-esc+))
281 (when (> (- frame *esc-last-frame*) 90) (setf *esc-count* 0))
282 (incf *esc-count*)
283 (setf *esc-last-frame* frame)
284 (when (>= *esc-count* 3) (setf *running* nil)))
285 ;; Power button
286 (when (and (eq type :key-down) (= code ac-native.input:+key-power+))
287 (setf *running* nil))
288 ;; Pass to JS
289 (js-act (if (eq type :key-down) 1 0)
290 (or key "") code)))
291
292 ;; sim
293 (js-sim)
294
295 ;; paint
296 (js-paint frame)
297
298 ;; Check for jump or poweroff from JS
299 (when ac-native.js-bridge::*poweroff-requested*
300 (setf *running* nil))
301 (when ac-native.js-bridge::*jump-target*
302 ;; TODO: reload piece
303 (format *error-output* "[js] jump to ~A (not yet implemented)~%"
304 ac-native.js-bridge::*jump-target*)
305 (force-output *error-output*)
306 (setf ac-native.js-bridge::*jump-target* nil))
307
308 ;; Present
309 (ac-native.drm:drm-present display screen scale)
310 (frame-sync-60fps))
311
312 ;; Cleanup
313 (js-destroy)
314 (when audio (audio-destroy audio))
315 (ac-native.input:input-destroy input)
316 (fb-destroy screen)
317 (ac-native.drm:drm-destroy display)
318 (format *error-output* "[js] shutdown~%")
319 (force-output *error-output*)))))
320
321;;; ── Main ──
322
323(defvar *js-fallback* nil "Set to T when falling back from JS to prevent re-entry loop.")
324
325(defun run-cl-piece (paint-fn piece-name)
326 "Run a CL piece with DRM graphics, audio, and input. PAINT-FN is called each frame."
327 (format *error-output* "~%════════════════════════════════════~%")
328 (format *error-output* " ~A (Common Lisp)~%" piece-name)
329 (format *error-output* "════════════════════════════════════~%~%")
330 (force-output *error-output*)
331 (let ((display (ac-native.drm:drm-init)))
332 (unless display (return-from run-cl-piece))
333 (let* ((dw (ac-native.drm:display-width display))
334 (dh (ac-native.drm:display-height display))
335 (scale (cond ((>= (min dw dh) 1440) 6)
336 ((>= (min dw dh) 1080) 4)
337 ((>= (min dw dh) 720) 3)
338 (t 2)))
339 (sw (floor dw scale))
340 (sh (floor dh scale))
341 (screen (ac-native.framebuffer:fb-create sw sh))
342 (graph (ac-native.graph:graph-create screen))
343 (input (ac-native.input:input-init dw dh scale))
344 (audio (ac-native.audio:audio-init)))
345 (unwind-protect
346 (loop
347 ;; Input
348 (ac-native.input:input-poll input)
349 (dotimes (i (ac-native.input:input-event-count input))
350 (let ((ev (ac-native.input:input-event input i)))
351 (when (and (= (ac-native.input:event-type ev) 1)
352 (= (ac-native.input:event-code ev) 1))
353 (return)))) ; ESC
354 ;; Paint
355 (handler-case
356 (funcall paint-fn graph sw sh audio)
357 (error (e)
358 (format *error-output* "[piece] error: ~A~%" e)
359 (force-output *error-output*)))
360 ;; Present
361 (ac-native.drm:drm-present display screen scale)
362 (sleep 1/60))
363 ;; Cleanup
364 (when audio (ac-native.audio:audio-destroy audio))
365 (ac-native.input:input-destroy input)
366 (ac-native.framebuffer:fb-destroy screen)
367 (ac-native.drm:drm-destroy display)))))
368
369(defun main ()
370 "AC Native OS entry point. Runs .mjs pieces via QuickJS or native CL notepat.
371When called with --swank-only, starts Swank server and blocks (no graphics)."
372 ;; Swank-only mode: just start the REPL server and sleep forever
373 (when (member "--swank-only" (uiop:command-line-arguments) :test #'string=)
374 (format *error-output* "[swank] Starting Swank server on port 4005...~%")
375 (force-output *error-output*)
376 (handler-case
377 (progn
378 (setf swank::*communication-style* :spawn)
379 (swank:create-server :port 4005 :dont-close t)
380 (format *error-output* "[swank] Swank ready on port 4005~%")
381 (force-output *error-output*)
382 ;; Block forever — Swank handles connections in its own threads
383 (loop (sleep 3600)))
384 (error (e)
385 (format *error-output* "[swank] Failed: ~A~%" e)
386 (force-output *error-output*)
387 (return-from main))))
388
389 ;; --piece MODE: run a specific CL piece with graphics (launched by C binary)
390 (let ((piece-arg (second (member "--piece" (uiop:command-line-arguments) :test #'string=))))
391 (when piece-arg
392 (format *error-output* "[cl] Running CL piece: ~A~%" piece-arg)
393 (force-output *error-output*)
394 ;; Try to load the piece file and run its paint function
395 (let ((piece-path (format nil "/pieces/~A.lisp" piece-arg)))
396 (when (probe-file piece-path)
397 (handler-case
398 (progn
399 (load piece-path)
400 (let ((paint-fn (find-symbol "PAINT" (find-package
401 (intern (string-upcase (format nil "PIECE.~A" piece-arg)) :keyword)))))
402 (when (and paint-fn (fboundp paint-fn))
403 (return-from main (run-cl-piece paint-fn piece-arg)))))
404 (error (e)
405 (format *error-output* "[cl] Error loading ~A: ~A~%" piece-path e)
406 (force-output *error-output*)))))
407 ;; Fallback to native CL notepat
408 (setf *js-fallback* t)))
409
410 ;; Determine piece: config.json > command-line arg > default
411 (unless *js-fallback*
412 (let* ((cfg (handler-case (ac-native.config:load-config)
413 (error () (ac-native.config:make-config))))
414 (config-piece (ac-native.config:config-piece cfg))
415 (args (uiop:command-line-arguments))
416 (piece-name (or config-piece
417 (when args (first args))
418 "notepat"))
419 (piece-path (if (search "/" piece-name)
420 piece-name ; already a path
421 (format nil "/pieces/~A.mjs" piece-name))))
422 (when (probe-file piece-path)
423 (return-from main (main-js piece-path)))))
424 (setf *js-fallback* nil)
425
426 ;; No .mjs piece specified — fall back to native CL notepat
427 (format *error-output* "~%════════════════════════════════════~%")
428 (format *error-output* " notepat (Common Lisp)~%")
429 (format *error-output* " SBCL ~A~%" (lisp-implementation-version))
430 (format *error-output* "════════════════════════════════════~%~%")
431 (force-output *error-output*)
432
433 (init-key-note-map)
434
435 (setf *np-display* (handler-case (ac-native.drm:drm-init)
436 (error (e)
437 (format *error-output* "[notepat] DRM error: ~A~%" e)
438 (force-output *error-output*) nil)))
439 (unless *np-display*
440 (format *error-output* "[notepat] FATAL: no display~%")
441 (force-output *error-output*) (sleep 30) (return-from main 1))
442
443 (setf *np-dw* (ac-native.drm:display-width *np-display*)
444 *np-dh* (ac-native.drm:display-height *np-display*)
445 *np-scale* (compute-pixel-scale *np-dw*)
446 *np-sw* (floor *np-dw* *np-scale*)
447 *np-sh* (floor *np-dh* *np-scale*)
448 *np-screen* (fb-create *np-sw* *np-sh*)
449 *np-graph* (make-graph :fb *np-screen* :screen *np-screen*)
450 *np-input* (ac-native.input:input-init *np-dw* *np-dh* *np-scale*)
451 *np-audio* (ac-native.audio:audio-init)
452 *np-frame* 0)
453 (progn
454
455 (format *error-output* "[notepat] ~Dx~D scale:~D → ~Dx~D~%"
456 *np-dw* *np-dh* *np-scale* *np-sw* *np-sh*)
457 (format *error-output* "[notepat] audio: ~A~%"
458 (if *np-audio* "OK" "FAILED"))
459 (force-output *error-output*)
460
461 (font-init)
462 (load-build-metadata)
463
464 ;; ── Boot splash ──
465 (let* ((cfg (ac-native.config:load-config))
466 (handle (ac-native.config:config-handle cfg))
467 (has-handle (and handle (string/= handle "") (string/= handle "unknown")))
468 (greeting (time-greeting))
469 (splash-start (monotonic-time-ms)))
470 ;; Write tokens
471 (handler-case (ac-native.config:write-device-tokens cfg)
472 (error (e)
473 (format *error-output* "[notepat] token write error: ~A~%" e)
474 (force-output *error-output*)))
475 ;; Store handle for status display
476 (setf *boot-handle* (if has-handle handle nil))
477 ;; Show splash for 3 seconds or until keypress
478 (loop while (< (- (monotonic-time-ms) splash-start) 3000) do
479 (let ((events (ac-native.input:input-poll *np-input*)))
480 (when (some (lambda (ev) (eq (ac-native.input:event-type ev) :key-down)) events)
481 (return)))
482 ;; Paint splash
483 (graph-wipe *np-graph* (make-color :r 10 :g 12 :b 18))
484 (let ((cy (floor *np-sh* 3)))
485 (if has-handle
486 (progn
487 ;; Greeting
488 (graph-ink *np-graph* (make-color :r 140 :g 160 :b 200 :a 220))
489 (font-draw *np-graph* greeting
490 (- (floor *np-sw* 2) (floor (font-measure greeting) 2)) cy)
491 ;; @handle
492 (let ((htxt (format nil "@~A" handle)))
493 (graph-ink *np-graph* (make-color :r 80 :g 255 :b 140 :a 255))
494 (font-draw *np-graph* htxt
495 (- (floor *np-sw* 2) (floor (font-measure htxt) 2)) (+ cy 14)))
496 ;; Subtitle
497 (graph-ink *np-graph* (make-color :r 80 :g 80 :b 100 :a 160))
498 (font-draw *np-graph* "aesthetic.computer"
499 (- (floor *np-sw* 2) (floor (font-measure "aesthetic.computer") 2)) (+ cy 32)))
500 (progn
501 ;; No handle: just show name
502 (graph-ink *np-graph* (make-color :r 80 :g 255 :b 140 :a 255))
503 (font-draw *np-graph* "aesthetic.computer"
504 (- (floor *np-sw* 2) (floor (font-measure "aesthetic.computer") 2)) cy)
505 (graph-ink *np-graph* (make-color :r 140 :g 160 :b 200 :a 180))
506 (font-draw *np-graph* "notepat"
507 (- (floor *np-sw* 2) (floor (font-measure "notepat") 2)) (+ cy 18)))))
508 ;; Build name (bottom center)
509 (graph-ink *np-graph* (make-color :r 60 :g 60 :b 80 :a 120))
510 (font-draw *np-graph* *build-name*
511 (- (floor *np-sw* 2) (floor (font-measure *build-name*) 2)) (- *np-sh* 20))
512 ;; LISP tag (top right) when CL variant
513 (when (string= *build-variant* "cl")
514 (graph-ink *np-graph* (make-color :r 255 :g 200 :b 80 :a 200))
515 (font-draw *np-graph* "LISP" (- *np-sw* (font-measure "LISP") 6) 6)))
516 (ac-native.drm:drm-present *np-display* *np-screen* *np-scale*)
517 (frame-sync-60fps)))
518
519 ;; Start Swank server for remote REPL
520 (handler-case
521 (progn
522 (setf swank::*communication-style* :spawn)
523 (swank:create-server :port 4005 :dont-close t)
524 (format *error-output* "[notepat] Swank on :4005~%")
525 (force-output *error-output*))
526 (error (e)
527 (format *error-output* "[notepat] Swank failed: ~A~%" e)
528 (force-output *error-output*)))
529
530 ;; Main loop
531 (setf *running* t)
532 (unwind-protect
533 (loop while *running* do
534 (incf *np-frame*)
535
536 ;; FPS
537 (let ((now (monotonic-time-ms)))
538 (when (> *fps-last-time* 0.0d0)
539 (incf *fps-accum* (- now *fps-last-time*))
540 (incf *fps-samples*)
541 (when (>= *fps-samples* 30)
542 (setf *fps-display* (round (/ 30000.0d0 *fps-accum*)))
543 (setf *fps-accum* 0.0d0 *fps-samples* 0)))
544 (setf *fps-last-time* now))
545
546 ;; ── Metronome tick ──
547 (when (and *metronome-on* (> *metronome-bpm* 0) *np-audio*)
548 (let* ((now-ms (monotonic-time-ms))
549 (ms-per-beat (/ 60000.0d0 *metronome-bpm*))
550 (beat-number (floor now-ms ms-per-beat))
551 ;; Pendulum: sinusoidal swing over 2-beat period
552 (beat-phase (/ (mod now-ms (* ms-per-beat 2)) (* ms-per-beat 2))))
553 (setf *metronome-phase* (sin (* beat-phase pi 2.0d0)))
554 (when (/= beat-number *metronome-last-beat*)
555 (setf *metronome-last-beat* beat-number)
556 (setf *metronome-flash* 1.0)
557 (let ((downbeat (zerop (mod beat-number 4))))
558 (audio-synth *np-audio* :type 3 ; square
559 :tone (if downbeat 1200.0d0 800.0d0)
560 :duration 0.03d0
561 :volume (if downbeat 0.4d0 0.25d0)
562 :attack 0.001d0 :decay 0.02d0)))))
563
564 ;; Decay metronome flash
565 (when (> *metronome-flash* 0.0)
566 (decf *metronome-flash* 0.15)
567 (when (< *metronome-flash* 0.0) (setf *metronome-flash* 0.0)))
568
569 ;; ── Input ──
570 (dolist (ev (ac-native.input:input-poll *np-input*))
571 (let ((type (ac-native.input:event-type ev))
572 (code (ac-native.input:event-code ev)))
573
574 (when (eq type :key-down)
575 ;; ESC: triple-press to quit
576 (when (= code ac-native.input:+key-esc+)
577 (when (> (- *np-frame* *esc-last-frame*) 90) (setf *esc-count* 0))
578 (incf *esc-count*)
579 (setf *esc-last-frame* *np-frame*)
580 (when (and *np-audio* (< *esc-count* 3))
581 (audio-synth *np-audio* :type 3
582 :tone (if (= *esc-count* 1) 440.0d0 660.0d0)
583 :duration 0.08d0 :volume 0.15d0
584 :attack 0.002d0 :decay 0.06d0))
585 (when (>= *esc-count* 3) (setf *running* nil)))
586
587 ;; Power
588 (when (= code ac-native.input:+key-power+) (setf *running* nil))
589
590 ;; Shift: toggle quick mode
591 (when (= code 42) ; KEY_LEFTSHIFT
592 (setf *quick-mode* (not *quick-mode*)))
593
594 ;; Space: toggle metronome
595 (when (= code ac-native.input:+key-space+)
596 (setf *metronome-on* (not *metronome-on*))
597 (when *metronome-on*
598 (setf *metronome-last-beat* -1)))
599
600 ;; Minus / Equal: BPM control
601 (when (= code ac-native.input:+key-minus+)
602 (setf *metronome-bpm* (max 20 (- *metronome-bpm* 5))))
603 (when (= code ac-native.input:+key-equal+)
604 (setf *metronome-bpm* (min 300 (+ *metronome-bpm* 5))))
605
606 ;; Number keys: set octave (kills active voices)
607 (when (and (>= code ac-native.input:+key-1+)
608 (<= code ac-native.input:+key-9+))
609 (let ((new-oct (1+ (- code ac-native.input:+key-1+))))
610 (unless (= new-oct *octave*)
611 (kill-all-voices *np-audio*)
612 (setf *octave* new-oct))))
613
614 ;; Arrow up/down: octave
615 (when (= code ac-native.input:+key-up+)
616 (when (< *octave* 9)
617 (kill-all-voices *np-audio*)
618 (incf *octave*)))
619 (when (= code ac-native.input:+key-down+)
620 (when (> *octave* 1)
621 (kill-all-voices *np-audio*)
622 (decf *octave*)))
623
624 ;; Tab / Arrow left/right: cycle wave type
625 (when (or (= code ac-native.input:+key-tab+)
626 (= code ac-native.input:+key-right+))
627 (kill-all-voices *np-audio*)
628 (setf *wave-index* (mod (1+ *wave-index*) 5))
629 (when *np-audio*
630 (let ((tones #(660.0d0 550.0d0 440.0d0 330.0d0 220.0d0)))
631 (audio-synth *np-audio* :type *wave-index*
632 :tone (aref tones *wave-index*)
633 :duration 0.07d0 :volume 0.18d0
634 :attack 0.002d0 :decay 0.06d0))))
635 (when (= code ac-native.input:+key-left+)
636 (kill-all-voices *np-audio*)
637 (setf *wave-index* (mod (+ *wave-index* 4) 5))
638 (when *np-audio*
639 (let ((tones #(660.0d0 550.0d0 440.0d0 330.0d0 220.0d0)))
640 (audio-synth *np-audio* :type *wave-index*
641 :tone (aref tones *wave-index*)
642 :duration 0.07d0 :volume 0.18d0
643 :attack 0.002d0 :decay 0.06d0))))
644
645 ;; Note keys
646 (let ((mapping (gethash code *key-note-map*)))
647 (when (and mapping (not (gethash code *active-voices*)) *np-audio*)
648 (let* ((note-name (car mapping))
649 (oct-delta (cdr mapping))
650 (actual-octave (+ *octave* oct-delta))
651 (freq (note-to-freq note-name actual-octave))
652 (idx (position note-name *chromatic* :test #'string=))
653 (semitones (+ (* (- actual-octave 4) 12) (or idx 0)))
654 (pan (max -0.8d0 (min 0.8d0 (/ (- semitones 12) 15.0d0))))
655 (attack (if *quick-mode* 0.002d0 0.005d0))
656 (voice-id (audio-synth *np-audio*
657 :type *wave-index*
658 :tone freq
659 :volume 0.7d0
660 :duration 0
661 :attack attack
662 :decay 0.1d0
663 :pan pan)))
664 (setf (gethash code *active-voices*) voice-id)
665 (setf (gethash code *active-notes*)
666 (cons note-name actual-octave))))))
667
668 ;; Key up
669 (when (eq type :key-up)
670 (let ((voice-id (gethash code *active-voices*)))
671 (when (and voice-id *np-audio*)
672 (audio-synth-kill *np-audio* voice-id)
673 (remhash code *active-voices*)
674 (let ((note-info (gethash code *active-notes*)))
675 (when note-info
676 (setf (gethash note-info *trails*) 1.0)
677 (remhash code *active-notes*))))))))
678
679 ;; ── Trail decay ──
680 (let ((dead nil))
681 (maphash (lambda (note val)
682 (let ((new-val (- val 0.025)))
683 (if (<= new-val 0.0)
684 (push note dead)
685 (setf (gethash note *trails*) new-val))))
686 *trails*)
687 (dolist (n dead) (remhash n *trails*)))
688
689 ;; ── Background color from active notes ──
690 (let ((n (hash-table-count *active-notes*)))
691 (if (> n 0)
692 (let ((tr 0) (tg 0) (tb 0))
693 (maphash (lambda (code note-info)
694 (declare (ignore code))
695 (let ((rgb (note-color-rgb (car note-info))))
696 (incf tr (first rgb))
697 (incf tg (second rgb))
698 (incf tb (third rgb))))
699 *active-notes*)
700 (let ((target-r (floor (* (floor tr n) 35) 100))
701 (target-g (floor (* (floor tg n) 35) 100))
702 (target-b (floor (* (floor tb n) 35) 100)))
703 (setf *bg-r* (+ *bg-r* (floor (- target-r *bg-r*) 4)))
704 (setf *bg-g* (+ *bg-g* (floor (- target-g *bg-g*) 4)))
705 (setf *bg-b* (+ *bg-b* (floor (- target-b *bg-b*) 4)))))
706 (progn
707 (setf *bg-r* (+ *bg-r* (floor (- 20 *bg-r*) 8)))
708 (setf *bg-g* (+ *bg-g* (floor (- 20 *bg-g*) 8)))
709 (setf *bg-b* (+ *bg-b* (floor (- 25 *bg-b*) 8))))))
710
711 ;; Metronome flash brightens background
712 (when (> *metronome-flash* 0.0)
713 (let ((boost (floor (* *metronome-flash* 40))))
714 (setf *bg-r* (min 255 (+ *bg-r* boost)))
715 (setf *bg-g* (min 255 (+ *bg-g* boost)))
716 (setf *bg-b* (min 255 (+ *bg-b* boost)))))
717
718 ;; ══════════════ PAINT ══════════════
719 (graph-wipe *np-graph* (make-color :r *bg-r* :g *bg-g* :b *bg-b*))
720
721 ;; ── Trails ──
722 (maphash (lambda (trail-key val)
723 (let* ((note-name (car trail-key))
724 (oct (cdr trail-key))
725 (rgb (note-color-rgb note-name))
726 (note-idx (or (position note-name *chromatic* :test #'string=) 0))
727 (semi (+ (* (- oct 1) 12) note-idx))
728 (total-semitones (* 9 12))
729 (bar-h (max 2 (floor (- *np-sh* 30) total-semitones)))
730 (bar-y (+ 14 (floor (* semi (- *np-sh* 30)) total-semitones)))
731 (bar-w (max 1 (floor (* val *np-sw*))))
732 (bar-x (floor (- *np-sw* bar-w) 2))
733 (alpha (max 1 (min 255 (floor (* val 200))))))
734 (graph-ink *np-graph* (make-color :r (first rgb)
735 :g (second rgb)
736 :b (third rgb)
737 :a alpha))
738 (graph-box *np-graph* bar-x bar-y bar-w bar-h)))
739 *trails*)
740
741 ;; ── Active note bars ──
742 (maphash (lambda (code note-info)
743 (declare (ignore code))
744 (let* ((note-name (car note-info))
745 (oct (cdr note-info))
746 (rgb (note-color-rgb note-name))
747 (note-idx (or (position note-name *chromatic* :test #'string=) 0))
748 (semi (+ (* (- oct 1) 12) note-idx))
749 (total-semitones (* 9 12))
750 (bar-h (max 2 (floor (- *np-sh* 30) total-semitones)))
751 (bar-y (+ 14 (floor (* semi (- *np-sh* 30)) total-semitones))))
752 (graph-ink *np-graph* (make-color :r (min 255 (+ (first rgb) 40))
753 :g (min 255 (+ (second rgb) 40))
754 :b (min 255 (+ (third rgb) 40))
755 :a 220))
756 (graph-box *np-graph* 0 bar-y *np-sw* bar-h)))
757 *active-notes*)
758
759 ;; ── Metronome pendulum ──
760 (when *metronome-on*
761 (let* ((cx (floor *np-sw* 2))
762 (cy (- *np-sh* 24))
763 (arm-len (min 20 (floor *np-sh* 8)))
764 (bx (+ cx (floor (* *metronome-phase* arm-len))))
765 (bright (floor (* *metronome-flash* 255))))
766 ;; Arm line
767 (graph-ink *np-graph* (make-color :r 180 :g 180 :b 180 :a 120))
768 (graph-line *np-graph* cx cy bx (- cy arm-len))
769 ;; Bob
770 (graph-ink *np-graph* (make-color :r (min 255 (+ 180 bright))
771 :g (min 255 (+ 100 bright))
772 :b 60 :a 220))
773 (graph-circle *np-graph* bx (- cy arm-len) 3)))
774
775 ;; ── Wave type indicators (bottom bar) ──
776 (let* ((bar-y (- *np-sh* 14))
777 (btn-w (max 12 (floor *np-sw* 6)))
778 (gap 2)
779 (total-w (+ (* 5 btn-w) (* 4 gap)))
780 (start-x (floor (- *np-sw* total-w) 2)))
781 (dotimes (i 5)
782 (let* ((bx (+ start-x (* i (+ btn-w gap))))
783 (selected (= i *wave-index*))
784 (col (if selected
785 (make-color :r 255 :g 255 :b 255 :a 200)
786 (make-color :r 100 :g 100 :b 110 :a 140))))
787 ;; Button background
788 (if selected
789 (progn
790 (graph-ink *np-graph* (make-color :r 60 :g 50 :b 80 :a 200))
791 (graph-box *np-graph* bx bar-y btn-w 12))
792 (progn
793 (graph-ink *np-graph* (make-color :r 30 :g 28 :b 35 :a 150))
794 (graph-box *np-graph* bx bar-y btn-w 12)))
795 ;; Wave name (abbreviated to 3 chars)
796 (graph-ink *np-graph* col)
797 (let ((abbr (subseq (aref *wave-names* i) 0 (min 3 (length (aref *wave-names* i))))))
798 (font-draw *np-graph* abbr
799 (+ bx (floor (- btn-w (* (length abbr) 6)) 2))
800 (+ bar-y 2))))))
801
802 ;; ── Status text ──
803 ;; Top-left: piece name + mode indicators
804 (graph-ink *np-graph* (make-color :r 100 :g 100 :b 110 :a 150))
805 (font-draw *np-graph* "notepat" 3 3)
806
807 ;; Quick mode indicator
808 (when *quick-mode*
809 (graph-ink *np-graph* (make-color :r 255 :g 200 :b 50 :a 200))
810 (font-draw *np-graph* "Q" (+ 3 (* 8 6)) 3))
811
812 ;; Handle (top-left, after piece name)
813 (when *boot-handle*
814 (let ((htxt (format nil "@~A" *boot-handle*)))
815 (graph-ink *np-graph* (make-color :r 80 :g 255 :b 140 :a 140))
816 (font-draw *np-graph* htxt (+ 3 (* (if *quick-mode* 10 8) 6)) 3)))
817
818 ;; Octave (top-left, below title)
819 (graph-ink *np-graph* (make-color :r 160 :g 160 :b 170 :a 180))
820 (font-draw *np-graph* (format nil "OCT ~D" *octave*) 3 14)
821
822 ;; Metronome BPM (if on)
823 (when *metronome-on*
824 (graph-ink *np-graph* (make-color :r 180 :g 140 :b 60 :a 200))
825 (font-draw *np-graph* (format nil "~DBPM" *metronome-bpm*)
826 (+ 3 (* 7 6)) 14))
827
828 ;; FPS (top-right)
829 (let ((fps-txt (format nil "~D" *fps-display*)))
830 (graph-ink *np-graph* (make-color :r 80 :g 80 :b 90 :a 120))
831 (font-draw *np-graph* fps-txt (- *np-sw* (* (length fps-txt) 6) 3) 3))
832
833 ;; Voice count (top-right, below FPS)
834 (let ((vc (hash-table-count *active-voices*)))
835 (when (> vc 0)
836 (let ((txt (format nil "~Dv" vc)))
837 (graph-ink *np-graph* (make-color :r 200 :g 200 :b 200 :a 180))
838 (font-draw *np-graph* txt (- *np-sw* (* (length txt) 6) 3) 14))))
839
840 ;; IP + Swank (top center)
841 (when (> (length *ip-address*) 0)
842 (let ((txt (format nil "~A:4005" *ip-address*)))
843 (graph-ink *np-graph* (make-color :r 60 :g 180 :b 60 :a 160))
844 (font-draw *np-graph* txt (- (floor *np-sw* 2) (floor (font-measure txt) 2)) 3)))
845
846 ;; Refresh IP every ~5 seconds
847 (when (zerop (mod *np-frame* 300)) (refresh-ip))
848
849 ;; LISP tag (top right) — always visible in CL variant
850 (when (string= *build-variant* "cl")
851 (graph-ink *np-graph* (make-color :r 255 :g 200 :b 80 :a 160))
852 (font-draw *np-graph* "LISP" (- *np-sw* (font-measure "LISP") 4) 3))
853
854 ;; ── Present ──
855 (ac-native.drm:drm-present *np-display* *np-screen* *np-scale*)
856 (frame-sync-60fps))
857
858 ;; ── Cleanup ──
859 (when *np-audio* (ignore-errors (kill-all-voices *np-audio*)))
860 (when *np-audio* (ignore-errors (audio-destroy *np-audio*)))
861 (when *np-input* (ignore-errors (ac-native.input:input-destroy *np-input*)))
862 (when *np-screen* (ignore-errors (fb-destroy *np-screen*)))
863 (ignore-errors (ac-native.drm:drm-destroy *np-display*))
864 (format *error-output* "[notepat] shutdown~%")
865 (force-output *error-output*)))