docs/music/tools/album-audit.sgl

1#!/usr/bin/env sigil

2;;; Finite album playback audit; game-loop audits deliberately require Bxx.

3(import (sigil list) (sigil args))

4(load (path (script-dir) "lib/core.sgl"))

5(import (crash soundtrack tools))

6(initialize (path (script-dir) "../../.."))

8(define CHANNELS '(1 2 3 4 5 6 7 8))

9(define POLICIES

10 '(("cold-boot" "Cold Boot" 7 (7))

11 ("relay-ghost" "Relay Ghost" 7 (6 7))

12 ("black-glass" "Black Glass" #f ())

13 ("quiet-array" "Quiet Array" #f (6 7))

14 ("closed-loop" "Closed Loop" #f (6 7))

15 ("shadow-protocol" "Shadow Protocol" #f (5 6))

16 ("blind-spot" "Blind Spot" #f (6))

17 ("sector-drift" "Sector Drift" #f (6 7))

18 ("dirty-cache" "Dirty Cache" #f (7))

19 ("basement-circuit" "Basement Circuit" 7 (7))

20 ("dead-sector" "Dead Sector" #f (6 7))

21 ("obsidian-index" "Obsidian Index" #f (6 7))

22 ("breach-vector" "Breach Vector" #f ())

23 ("clock-edge" "Clock Edge" #f (7))

24 ("glass-current" "Glass Current" 9 (6 7))))

25(define (attack? cell)

26 (not (member (cadr cell) '("..." "==="))))

28;;; Obsidian's side pad must follow the main harmony and release before changes.

29(define (audit-veil-row row position previous-off)

30 (let ((left (assoc 5 (cddr row)))

31 (right (assoc 8 (cddr row))))

32 (check (equal? (if left (cadr left) #f)

33 (if right (cadr right) #f))

34 "Obsidian pad root/gate mismatch"

35 position)

36 (cond

37 ((not left) previous-off)

38 ((equal? (cadr left) "===") position)

39 (else

40 (check (and previous-off (>= (- position previous-off) 6))

41 "Obsidian pad release gap below six rows"

42 position)

43 (check (= (caddr right)

44 (cond ((= (caddr left) 6) 16)

45 ((= (caddr left) 7) 17)

46 ((= (caddr left) 10) 18)

47 (else -1)))

48 "Obsidian pad voicing mismatch"

49 position)

50 #f))))

52(define (audit motif slug file)

53 (let* ((policy (or (assoc slug POLICIES) (error "Missing review policy" slug)))

54 (score (read-score file))

55 (legacy? (member slug '("shadow-protocol" "dirty-cache" "breach-vector")))

56 (grid (if (member meter: score) (field score meter:) '(4 4)))

57 (bar-rows (apply * grid))

58 (patterns (cdr (child score 'patterns)))

59 (orders (cdr (child score 'order)))

60 (expected (make-vector 9 '()))

61 (gated (make-vector 9 #f))

62 (instruments (make-vector 9 '()))

63 (numerator (* 44100 5 (field score speed:)))

64 (denominator (* 2 (field score tempo:)))

65 (offset 0)

66 (pad-off -6)

67 (count 0)

68 (worst 0)

69 (odd-onsets '()))

70 (check (equal? (read-text file) (canonical motif file)) "Noncanonical source" file)

71 ($ ,motif tune check ,file)

72 (check (and (= (field score speed:) (if (equal? slug "breach-vector") 4 (if legacy? 6 3)))

73 (= (field score channels:) 8)

74 (equal? grid (if legacy? '(4 4) '(8 4))))

75 "Unexpected grid" slug)

76 (check (equal? (field score name:)

77 (cadr policy))

78 "Album title mismatch" slug)

79 (each ident orders

80 (let ((p (list-find (lambda (p) (= (field p id:) ident)) patterns)))

81 (check p "Missing ordered pattern" ident)

82 (each r (skip p 5)

83 (when (equal? slug "obsidian-index")

84 (set! pad-off (audit-veil-row r (+ offset (cadr r)) pad-off)))

85 (each c (cddr r)

86 (let ((ch (car c))

87 (fx (list-ref c 4)))

88 (check (not (any (lambda (prefix) (starts-with? fx prefix)) '("B" "D" "F")))

89 "Album must be finite with a fixed clock" slug ident (cadr r) fx)

90 (cond

91 ((equal? (cadr c) "===") (vector-set! gated ch #f))

92 ((attack? c)

93 (when (and (not legacy?) (odd? (cadr r)))

94 (set! odd-onsets (cons (list ident (cadr r) ch) odd-onsets)))

95 (when (member ch (list-ref policy 3))

96 (check (= (modulo (cadr r) (if legacy? 2 4)) 0) "Mallet/bell off eighth grid" ident r))

97 (unless (and (starts-with? fx "3") (vector-ref gated ch))

98 (vector-set! expected ch

99 (cons (quotient (+ (* 2 (+ offset (cadr r)) numerator) denominator)

100 (* 2 denominator))

101 (vector-ref expected ch))))

102 (vector-set! gated ch #t)

103 (unless (member (caddr c) (vector-ref instruments ch))

104 (vector-set! instruments ch

105 (cons (caddr c) (vector-ref instruments ch)))))))))

106 (set! offset (+ offset (field p rows:)))))

107 ;; Only the declared original transition may retain its four 32nd hits.

108 (check (if (caddr policy)

109 (equal? (reverse odd-onsets)

110 (map (lambda (row) (list (caddr policy) row 2))

111 '(121 123 125 127)))

112 (null? odd-onsets))

113 "Unexpected off-sixteenth attacks" slug odd-onsets)

114 (each ch CHANNELS

115 (check (not (vector-ref gated ch)) "Channel remains gated at end" slug ch)

116 (let* ((actual (filter (lambda (t) (= (list-ref t 5) 1)) (ticks motif file ch)))

117 (times (reverse (vector-ref expected ch)))

118 (voices

119 (fold-left

120 (lambda (total id)

121 (let* ((inst (list-find (lambda (i) (= (field i id:) id))

122 (cdr (child score 'instruments))))

123 (layers (member layers: inst)))

124 (+ total 1 (if layers (length (cadr layers)) 0))))

125 0 (vector-ref instruments ch))))

126 (check (<= voices 8) "Voice budget exceeded" slug ch voices)

127 (check (= (length actual) (length times)) "Missing/extra compiled attack" slug ch)

128 (list-for-each

129 (lambda (tick expected-sample)

130 (let ((delta (abs (- (car tick) expected-sample))))

131 (check (<= delta 1) "Compiled attack drift" slug ch delta)

132 (set! worst (max worst delta))))

133 actual times)

134 (set! count (+ count (length actual)))))

135 (let* ((last (list-find (lambda (p) (= (field p id:) (car (reverse orders)))) patterns))

136 (rows (skip last 5)))

137 (check (and (= (field last rows:) (* 2 bar-rows))

138 (= (length rows) 1)

139 (= (length (cddr (car rows))) 8)

140 (every (lambda (c) (equal? (cadr c) "===")) (cddr (car rows))))

141 "Missing two-bar release tail" slug))

142 (dict title: (field score name:)

143 attacks: count

144 maximum_clock_error_samples: worst

145 intentional_32nd_snare_hits: (length odd-onsets)

146 duration_seconds: (/ (* offset numerator) (* denominator 44100.0))

147 all_final_gates_released: #t)))

148

149(cli "album-audit" (script-args)

150 (list (option name: 'source long: "source" value: "FILE"))

151 (lambda (options)

152 (let* ((motif (require-tool (option-ref options 'motif)))

153 (output (option-ref options 'output))

154 (tracks (or (option-ref options 'tracks) '("cold-boot" "relay-ghost"))))

155 (check (or (not (option-ref options 'source)) (= (length tracks) 1))

156 "--source requires exactly one --track policy")

157 (ensure-directory output)

158 (write-json-file (path output "album-score-check.json")

159 (list->array

160 (map (lambda (slug)

161 (audit motif slug

162 (or (option-ref options 'source)

163 (path (root) "docs/music/album" (str slug ".cts")))))

164 tracks)))

165 (println "Album scores and compiled clocks passed."))))