docs/music/tools/basement-expression.sgl

1#!/usr/bin/env sigil

2;;; Separate patch and phrase auditions; both full forms share one candidate pool.

3(import (sigil list))

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

5(load (path (script-dir) "lib/album-arrangement.sgl"))

6(load (path (script-dir) "lib/song-source.sgl"))

7(import (crash soundtrack tools)

8 (crash soundtrack album arrangement)

9 (crash soundtrack songs))

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

12(define PHRASES '(3 12 14))

13(define PATCHES '(7 9 10 11))

15(define (setting form key value)

16 (if (member key form)

17 (set-field form key value)

18 (append form (list key value))))

20(define (patches parts pluck? acid?)

21 (replace-child parts 'instruments

22 (cons 'instruments

23 (map

24 (lambda (instrument)

25 (let ((id (field instrument id:))

26 (patch (field instrument patch:)))

27 (cond

28 ((and pluck? (= id 7))

29 (each pair '((index: 0.95) (cutoff: 1650) (resonance: 0.15)

30 (decay: 0.22) (release: 0.075))

31 (set! patch (setting patch (car pair) (cadr pair))))

32 (set-field instrument patch: patch))

33 ((and acid? (member id '(9 10 11)))

34 (each pair '((filter-decay: 0.09) (decay: 0.12) (sustain: 0.48))

35 (set! patch (setting patch (car pair) (cadr pair))))

36 (set-field instrument patch: patch))

37 (else instrument))))

38 (cdr (child parts 'instruments))))))

40(define (line p channel start instrument specs)

41 (add-notes

42 (append (take p 5)

43 (filter

44 (lambda (row) (pair? (cddr row)))

45 (map

46 (lambda (row)

47 (append (take row 2)

48 (filter

49 (lambda (cell)

50 (not (and (= (car cell) channel) (>= (cadr row) start))))

51 (cddr row))))

52 (skip p 5))))

53 (map

54 (lambda (spec)

55 (list (car spec) channel (cadr spec) instrument

56 (caddr spec) (list-ref spec 3)))

57 specs)))

59(define (develop p)

60 (case (field p id:)

61 ;; Recall the opening's rising gesture over D minor, then answer over F.

62 ((3)

63 (line

64 (line p 6 128 7

65 '((136 "D-4" 20 8) (144 "F-4" 18 8) (152 "A-4" 19 12)

66 (184 "E-4" 16 7)

67 (200 "F-4" 20 8) (208 "A-4" 18 8) (216 "G-4" 18 12)

68 (240 "E-4" 17 8) (248 "C-4" 18 7)))

69 7 128 8

70 '((176 "F-4" 13 12) (232 "C-5" 12 12))))

71 ;; The quiet A-pedal bridge states a connected question, then resolves.

72 ((12)

73 (line

74 (line p 6 0 7

75 '((16 "E-4" 18 8) (24 "G-4" 16 8) (32 "A-4" 19 12)

76 (64 "G-4" 17 8) (72 "E-4" 18 12)

77 (104 "B-3" 16 8) (112 "A-3" 18 12)))

78 7 0 8

79 '((48 "C-5" 11 12) (88 "E-4" 12 12))))

80 ;; Descending recall over C and G prepares the existing A-minor ending.

81 ((14)

82 (line

83 (line p 6 128 7

84 '((144 "G-4" 18 8) (152 "E-4" 17 8) (160 "C-4" 19 12)

85 (200 "D-4" 18 8) (208 "B-3" 17 8) (216 "G-3" 18 12)

86 (240 "E-4" 16 8) (248 "A-3" 17 7)))

87 7 128 8

88 '((176 "E-4" 12 12) (232 "D-4" 11 12))))

89 (else p)))

91(define (phrases parts)

92 (replace-child parts 'patterns

93 (cons 'patterns (map develop (cdr (child parts 'patterns))))))

95(define (channel-events p channel)

96 (filter

97 (lambda (row) (pair? (cddr row)))

98 (map

99 (lambda (row)

100 (append (take row 2)

101 (filter (lambda (cell) (= (car cell) channel)) (cddr row))))

102 (skip p 5))))

103

104(define (protect before after patch? phrase?)

105 (each key '(name: tempo: speed: channels: meter:)

106 (check (equal? (field before key) (field after key)) "Header changed" key))

107 (each section '(bus order history)

108 (check (equal? (child before section) (child after section))

109 "Protected section changed" section))

110 (each instrument (cdr (child before 'instruments))

111 (let* ((id (field instrument id:))

112 (new (list-find (lambda (i) (= (field i id:) id))

113 (cdr (child after 'instruments)))))

114 (check

115 (equal? instrument

116 (if (and patch? (member id PATCHES))

117 (set-field new patch: (field instrument patch:))

118 new))

119 "Protected instrument field changed" id)))

120 (each p (cdr (child before 'patterns))

121 (let ((new (pattern after (field p id:))))

122 (check (equal? (take p 5) (take new 5)) "Pattern clock changed")

123 (each channel CHANNELS

124 (unless (and phrase? (member (field p id:) PHRASES)

125 (member channel '(6 7)))

126 (check (equal? (channel-events p channel) (channel-events new channel))

127 "Protected performance changed" (field p id:) channel))))))

128

129(cli "basement-expression" (script-args) '()

130 (lambda (options)

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

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

133 (reference (path (root) "docs/music/alternates/basement-expression-i"))

134 (frozen? (file? (path reference "parts-before.cts")))

135 (source

136 (if frozen? (path reference "parts-before.cts")

137 (path (root) "docs/music/songs/basement-circuit/parts.cts")))

138 (layout-file

139 (if frozen? (path reference "arrangements.sgl")

140 (path (root) "docs/music/songs/basement-circuit/arrangements.sgl")))

141 (parts (read-score source))

142 (layout (read-score layout-file))

143 (arrangements (child layout 'arrangements))

144 (album (child arrangements 'album))

145 (pluck-parts (patches parts #t #f))

146 (acid-parts (patches parts #f #t))

147 (phrase-parts (phrases parts))

148 (combined (patches phrase-parts #t #t))

149 (base (build-song-score parts layout album))

150 (clips '()))

151 (ensure-directory output)

152 (unless frozen?

153 (apply-song-plans (list (song-plan "basement-circuit" motif)) "check" #f))

154 (protect parts pluck-parts #t #f)

155 (protect parts acid-parts #t #f)

156 (protect parts phrase-parts #f #t)

157 (protect parts combined #t #t)

158 (each spec (list (list "before" parts) (list "pluck" pluck-parts)

159 (list "acid" acid-parts) (list "phrases" phrase-parts)

160 (list "after" combined))

161 (write-canonical motif (path output (str "parts-" (car spec) ".cts"))

162 (cadr spec)))

163 (let ((destination (path output "arrangements.sgl")))

164 (if (file? destination)

165 (check (equal? (read-text layout-file) (read-text destination))

166 "Refusing to overwrite differing layout")

167 (copy-file layout-file destination)))

168 (each spec '((album "basement-circuit") (game "basement-circuit-game"))

169 (let* ((arrangement (child arrangements (car spec)))

170 (before-file (path output (str (cadr spec) "-before.cts"))))

171 (write-canonical motif before-file (build-song-score parts layout arrangement))

172 (unless frozen?

173 (check (equal? (read-text before-file)

174 (read-text (path (root) (field arrangement destination:))))

175 "Accepted score differs from shared reference" (car spec)))

176 (write-canonical motif (path output (str (cadr spec) "-after.cts"))

177 (build-song-score combined layout arrangement))))

178 (each spec

179 (list (list "exposed" "Exposed pluck / equal +18 dB monitoring" '(2) pluck-parts)

180 (list "pluck" "Calm groove / pluck patch only" '(2) pluck-parts)

181 (list "acid" "Tense groove / acid contour only" '(9) acid-parts)

182 (list "phrases" "Bridge and return / phrases only" '(4 5) phrase-parts))

183 (each variant '("before" "after")

184 (let* ((score

185 (if (equal? variant "before") base

186 (build-song-score (list-ref spec 3) layout album)))

187 (stem (str (car spec) "-" variant))

188 (sections

189 (append

190 (map

191 (lambda (id)

192 (let* ((p (pattern score id))

193 (p

194 (if (equal? (car spec) "exposed")

195 (transform

196 (set-field

197 (append (take p 5)

198 (filter (lambda (row) (< (cadr row) 128))

199 (skip p 5)))

200 rows: 128)

201 (lambda (row cell)

202 (and (= (car cell) 6) cell)))

203 p)))

204 (list (str "Album pattern " id) p)))

205 (caddr spec))

206 (list (list "Two-bar release / comparison gap" (phrase-rows 64 '())))))

207 (rows (apply + (map (lambda (s) (field (cadr s) rows:)) sections))))

208 (write-album motif output stem

209 (str "Basement Circuit / " (cadr spec) " / " variant)

210 score sections

211 '("parts-before.cts" "parts-after.cts" "arrangements.sgl")

212 "Expression I: isolated patch and phrasing auditions; no maintained score replaced."

213 "Each pair changes only its named feature; drum, sub, chord, swell and bus identity retained."

214 "2026-09-23")

215 (set! clips

216 (append clips

217 (list (dict stem: stem

218 label: (str (cadr spec) " / " variant)

219 duration_seconds: (/ (* rows 7.5) 124)

220 audition_gain_db: (if (equal? (car spec) "exposed") 18 0))))))))

221 (write-json-file (path output "comparison.json")

222 (dict slug: "basement-circuit"

223 title: "Basement Circuit"

224 audition: "expression-i"

225

              comment: "Four pairs, each BEFORE then AFTER: exposed pluck (+18 dB both), pluck in the calm mix, acid contour, melodic replies. Phrase pair retains original patches. Full candidate combines all three ideas."

226 full_duration_seconds: (/ (* 3648 7.5) 124)

227 clips: (list->array clips)))

228 (write-json-file (path output "source-checks.json")

229 (dict source_sha256: (song-hash source)

230 layout_sha256: (song-hash layout-file)

231 shared_patch_ids: PATCHES

232 shared_phrase_ids: PHRASES

233 changed_phrase_channels: '(6 7)

234 patch_comparisons_identical_performance: #t

235 phrase_comparison_original_patches: #t

236 drums_sub_chords_swell_bus_protected: #t

237 acid_notes_accents_slides_and_output_gain_preserved: #t

238 game_and_album_from_same_candidate_parts: #t))

239 (display "Basement Circuit isolated comparisons and synchronized full candidates ready.\n"))))