docs/music/tools/fault-line-rock-form.sgl

1#!/usr/bin/env sigil

2;;; Composition II: rock-led form, two solos and a soft secondary melody.

3(import (sigil list))

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

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

6(import (crash soundtrack tools)

7 (crash soundtrack album arrangement))

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

10(define BASE "docs/music/alternates/fault-line-composition-i")

11;;; Guitar root, bass root, third, fourth.

12(define CHORDS

13 '(("D-3" "D-2" "F-3" "G-3")

14 ("A#2" "A#1" "D-3" "D#3")

15 ("G-2" "G-1" "A#2" "C-3")

16 ("A-2" "A-1" "C-3" "D-3")))

17;;; Row, guitar pitch role, gate, open chord?, bass/kick anchor?.

18(define DRIVE-CALL

19 '((0 0 3 #f #t) (6 0 1 #f #f) (12 0 3 #f #t)

20 (18 0 3 #t #t) (24 2 1 #f #f) (26 3 1 #f #f) (30 0 1 #f #t)))

21(define DRIVE-REPLY

22 '((0 0 3 #f #t) (8 0 2 #t #t) (14 2 1 #f #f)

23 (18 0 3 #f #t) (24 0 5 #t #t) (30 0 1 #f #f)))

24(define HALF-CALL

25 '((0 0 6 #f #t) (10 0 2 #f #t) (16 0 6 #t #t) (26 0 3 #f #t)))

26(define HALF-REPLY

27 '((0 0 3 #f #t) (12 2 2 #f #f) (16 0 10 #t #t) (28 0 3 #f #t)))

29(define (first-bars p bars)

30 (transform

31 (append (list 'pattern id: 0 rows: (* bars 32))

32 (filter (lambda (r) (< (cadr r) (* bars 32))) (skip p 5)))

33 unchanged))

35(define (new-riff base half?)

36 (let ((p (transform base

37 (lambda (row cell) (and (= (car cell) 8) cell)))))

38 (each bar '(0 1 2 3 4 5 6 7)

39 (let* ((chord (list-ref CHORDS (quotient bar 2)))

40 (offset (* bar 32))

41 (specs (if half?

42 (if (even? bar) HALF-CALL HALF-REPLY)

43 (if (even? bar) DRIVE-CALL DRIVE-REPLY))))

44 (each spec specs

45 (let ((row (+ offset (car spec)))

46 (pitch (list-ref chord (cadr spec)))

47 (gate (caddr spec))

48 (open? (list-ref spec 3)))

49 (set! p

50 (add-notes p

51 (list (list row 5 pitch (if open? 6 5) (if open? 31 28) gate)

52 (list row 6 pitch (if open? 8 7) (if open? 21 17) gate))))

53 (when (list-ref spec 4)

54 (set! p

55 (add-notes p

56 (list (list row 4 (cadr chord) 4 (if open? 33 32) gate)

57 (list row 1 "C-2" 1 (if (= (car spec) 0) 40 35)

58 (min gate 3))))))))

59 (each row (if half? '(24) '(8 24))

60 (set! p

61 (add-notes p (list (list (+ offset row) 2 "F#3" 2 31 3)))))

62 (each row (if half? '(0 8 16 24) '(0 4 8 12 16 20 24 28))

63 (set! p

64 (add-notes p

65 (list (list (+ offset row) 3 "C-8" 3

66 (if (= (modulo row 8) 0) 17 11) 2)))))

67 ;; A restrained ghost gives alternate replies a small lift.

68 (when (and (not half?) (= (modulo bar 4) 3))

69 (set! p

70 (add-notes p (list (list (+ offset 20) 2 "F#3" 2 12 2)))))))

71 p))

73(define (copy-melody backing melody source-channel instrument factor start)

74 (let ((p (transform backing

75 (lambda (row cell) (and (not (= (car cell) 7)) cell)))))

76 (each row (skip melody 5)

77 (when (>= (cadr row) start)

78 (let ((cell (assoc source-channel (cddr row))))

79 (when cell

80 (set! p

81 (put-cell p (cadr row)

82 (if (attack? cell)

83 (list 7 (cadr cell) instrument

84 (round (* (list-ref cell 3) factor)) (list-ref cell 4))

85 (append '(7) (cdr cell)))))))))

86 p))

88(define (harmonic-turn p)

89 (let ((result (empty-pattern 8)) (index 0))

90 (each source-pair '(2 1 0 3)

91 (each row (skip p 5)

92 (when (<= (* source-pair 64) (cadr row) (+ (* source-pair 64) 63))

93 (each cell (cddr row)

94 (set! result

95 (put-cell result (+ (* index 64) (- (cadr row) (* source-pair 64))) cell)))))

96 (set! index (+ index 1)))

97 (transform result unchanged)))

99(define ALT-SOLO

100 '((0 "D-4" 27 8) (10 "F-4" 27 4) (16 "G-4" 29 10)

101 (28 "A-4" 30 8) (38 "G-4" 27 4) (44 "F-4" 26 10) (56 "D-4" 25 6)

102 (64 "F-4" 28 12) (78 "A-4" 29 6) (88 "C-5" 30 10)

103 (102 "A-4" 27 4) (108 "G-4" 26 4) (116 "F-4" 27 10)

104 (128 "G-4" 28 8) (138 "A-4" 26 4) (144 "A#4" 30 12)

105 (160 "D-5" 30 10) (174 "C-5" 27 6) (184 "A#4" 28 6)

106 (192 "A-4" 29 12) (208 "G-4" 27 6) (218 "E-4" 26 4)

107 (224 "G-4" 28 8) (236 "A-4" 29 6) (248 "D-5" 28 6)))

108

109(define (alternate-solo p)

110 (let ((result (transform p (lambda (row cell) (and (not (= (car cell) 7)) cell)))))

111 (set! result

112 (add-notes result

113 (map (lambda (n) (list (car n) 7 (cadr n) 9 (caddr n) (list-ref n 3))) ALT-SOLO)))

114 ;; Connected whole-tone rise in the first phrase, with an explicit stop.

115 (set! result (put-cell result 18 '(7 "..." 0 0 "304")))

116 (set! result (put-cell result 22 '(7 "..." 0 0 "300")))

117 result))

118

119(define (strip-entry p)

120 (append (take p 5)

121 (filter (lambda (r) (pair? (cddr r)))

122 (map (lambda (r)

123 (append (take r 2)

124 (filter (lambda (c)

125 (not (and (= (cadr r) 0) (equal? (cadr c) "==="))))

126 (cddr r))))

127 (skip p 5)))))

128

129(define (flat form) (trim (score-text form)))

130(define (layout-text names arrangements)

131 (str "(song version: 1\n (phrases\n"

132 (string-join (map (lambda (p) (str " " (flat p))) names) "\n")

133 ")\n (arrangements\n"

134 (string-join

135 (map (lambda (a)

136 (str " (" (symbol->string (car a)) " destination: "

137 (flat (field a destination:)) "\n"

138 (string-join (map (lambda (s) (str " " (flat s))) (skip a 3)) "\n")

139 ")"))

140 arrangements)

141 "\n")

142 "))\n"))

143

144(cli "fault-line-rock-form" (script-args) '()

145 (lambda (options)

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

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

148 (parts (read-score (path (root) BASE "parts.cts")))

149 (layout (read-score (path (root) BASE "arrangements.sgl")))

150 (riff (transform (pattern parts 3) unchanged))

151 (drive (new-riff riff #f))

152 (half (new-riff riff #t))

153 (new

154 (list

155 (list "Short clean invitation"

156 (transform (first-bars (pattern parts 1) 4)

157 (lambda (row cell)

158 (and (or (member (car cell) '(5 6 7 8))

159 (and (= (car cell) 4) (>= row 64))) cell))))

160 (list "Driving variation"

161 (copy-melody drive (pattern parts 4) 7 13 1.05 128))

162 (list "Lower-register alternate solo" (alternate-solo drive))

163 (list "Rock harmonic turn"

164 (copy-melody (harmonic-turn riff) (pattern parts 5) 5 13 0.9 0))

165 (list "Half-time weight"

166 (copy-melody half (pattern parts 4) 7 13 0.95 0))

167 (list "Final driving theme"

168 (copy-melody drive (pattern parts 10) 7 9 1 0))

169 (list "Rock coda" (first-bars drive 4))

170 (list "Final band chord"

171 (pattern (read-score

172 (path (root) "docs/music/alternates/fault-line-bass-lock-vii/fault-line-after.cts")) 4))))

173 (names (cdr (child layout 'phrases)))

174 (pool (cdr (child parts 'patterns)))

175 (ident 15))

176 (each spec new

177 (set! names (append names (list (list (car spec) ident))))

178 (set! pool (append pool (list (strip-entry (set-field (cadr spec) id: ident)))))

179 (set! ident (+ ident 1)))

180 (set! parts (replace-child parts 'patterns (cons 'patterns pool)))

181 (set! parts (replace-child parts 'order (cons 'order (map cadr names))))

182 (define (arrangement role ids)

183 (let* ((old (child (child layout 'arrangements) role))

184 (template (cadr (child old 'template)))

185 (refs '()) (labels '()) (index 0))

186 (each id ids

187 (let* ((p (transform (pattern parts id) unchanged))

188 (name (car (list-find (lambda (n) (= (cadr n) id)) names)))

189 (row0 (list-find (lambda (r) (= (cadr r) 0)) (skip p 5)))

190 (offs (filter (lambda (c) (equal? (cadr c) "===")) (cddr row0)))

191 (effects

192 (cond ((and (eq? role 'game) (= index 1)) '((255 8 "B00")))

193 ((and (eq? role 'game) (= index (- (length ids) 1))) '((255 8 "B03")))

194 (else '()))))

195 (set! refs

196 (append refs (list (list index name (cons 'entry-offs offs) (cons 'effects effects)))))

197 (set! labels (append labels (list (list index name))))

198 (set! index (+ index 1))))

199 (set! template (replace-child template 'order (cons 'order (map car labels))))

200 (set! template

201 (replace-child template 'history

202 (append (child template 'history)

203 '(("codex" "2026-09-23"

204

                   "Composition II: short clean intro and one interlude frame an extended rock form, contrasting solos, driving and half-time variations, retained soft secondary melody.")))))

205 (append (list role destination: (field old destination:)

206 (list 'template template) (child old 'bank) (cons 'patterns refs))

207 (if (eq? role 'album) (list (cons 'labels labels)) '()))))

208 (let ((arrangements

209 (list (arrangement 'game '(1 2 8 3 16 4 18 9 19 20))

210 (arrangement 'album '(15 3 16 4 17 18 5 8 9 10 19 20 21 22 14)))))

211 (write-canonical motif (path output "parts.cts") parts)

212 (write-text (path output "arrangements.sgl") (layout-text names arrangements))

213 (println "Rock-led shared arrangement ready: ~a" output)))))