docs/music/tools/lib/album-arrangement.sgl

1;;; Shared finite-score operations, derived from the first album pilot composer.

2(define-library (crash soundtrack album arrangement)

3 (import (sigil shell prelude)

4 (sigil list)

5 (crash soundtrack tools))

6 (export CHANNELS off attack? pattern put-cell empty-pattern add-notes phrase

7 transform level unchanged write-album phrase-rows)

8 (begin

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

10 (define (off ch) (list ch "===" 0 0 "000"))

11 (define (attack? cell)

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

13 (define (pattern source ident)

14 (or (list-find (lambda (p) (= (field p id:) ident))

15 (cdr (child source 'patterns)))

16 (error "Missing pattern" ident)))

18 (define (put-cell p row cell)

19 (check (< row (field p rows:)) "Cell exceeds pattern" row)

20 (let* ((rows (skip p 5))

21 (old (or (list-find (lambda (r) (= (cadr r) row)) rows)

22 (list 'row row)))

23 (cells (cons cell

24 (filter (lambda (c) (not (= (car c) (car cell))))

25 (cddr old))))

26 (replacement

27 (append (take old 2)

28 (list-sort (lambda (a b) (< (car a) (car b))) cells))))

29 (append (take p 5)

30 (list-sort (lambda (a b) (< (cadr a) (cadr b)))

31 (cons replacement

32 (filter (lambda (r) (not (= (cadr r) row))) rows))))))

34 (define (empty-pattern bars)

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

36 (append '(row 0) (map off CHANNELS))))

38 ;;; A note spec is (row channel pitch instrument level held-rows).

39 ;;; End gates are explicit, including melodic responses in otherwise empty bars.

40 (define (phrase bars notes)

41 (fold-left

42 (lambda (p n)

43 (let* ((row (list-ref n 0))

44 (ch (list-ref n 1))

45 (cell (list ch

46 (list-ref n 2)

47 (list-ref n 3)

48 (list-ref n 4)

49 "000")))

50 (put-cell (put-cell p row cell)

51 (+ row (list-ref n 5))

52 (off ch))))

53 (empty-pattern bars)

54 notes))

56 ;;; A transform returns a cell or #f. Missing channels are released at entry,

57 ;;; so removing an instrument cannot accidentally sustain it across a section.

58 (define (transform p fn)

59 (let* ((rows

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

61 (map (lambda (r)

62 (append (take r 2)

63 (filter (lambda (c) c)

64 (map (lambda (c)

65 (let ((clean

66 (if (starts-with? (list-ref c 4) "B")

67 (append (take c 4) '("000"))

68 c)))

69 (fn (cadr r) clean)))

70 (cddr r)))))

71 (skip p 5))))

72 (result (append (take p 5) rows))

73 (entry (or (list-find (lambda (r) (= (cadr r) 0)) rows)

74 '(row 0))))

75 (each ch CHANNELS

76 (unless (assoc ch (cddr entry))

77 (set! result (put-cell result 0 (off ch)))))

78 result))

80 (define (level cell factor)

81 (if (attack? cell)

82 (append (take cell 3)

83 (list (max 1 (round (* (list-ref cell 3) factor)))

84 (list-ref cell 4)))

85 cell))

87 (define (unchanged row cell) cell)

89 (define (add-notes p notes)

90 (fold-left

91 (lambda (result note)

92 (let* ((row (car note))

93 (ch (cadr note))

94 (cell (append (list ch)

95 (take (skip note 2) 3)

96 '("000"))))

97 (put-cell (put-cell result row cell)

98 (+ row (list-ref note 5))

99 (off ch))))

100 p

101 notes))

102 (define (phrase-rows rows notes)

103 (add-notes (set-field (empty-pattern 1) rows: rows) notes))

104

105 (define (write-album motif output slug title base sections sources . provenance)

106 (let ((bar-rows (if (member meter: base) (apply * (field base meter:)) 16))

107 (patterns '())

108 (timeline '())

109 (offset 0)

110 (ident 0))

111 (each spec sections

112 (let* ((p (set-field (transform (cadr spec) unchanged) id: ident))

113 (rows (field p rows:)))

114 (set! patterns (append patterns (list p)))

115 (set! timeline

116 (append timeline

117 (list (dict pattern: ident

118 label: (car spec)

119 start_bar: (+ 1 (quotient offset bar-rows))

120 bars: (/ rows bar-rows)

121 start_seconds: (/ (* offset 2.5 (field base speed:)) (field base tempo:))))))

122 (set! offset (+ offset rows))

123 (set! ident (+ ident 1))))

124 (let* ((score (set-field base name: title))

125 (destination (path output (str slug ".cts"))))

126 (set! score (replace-child score 'patterns (cons 'patterns patterns)))

127 (set! score

128 (replace-child score 'order

129 (cons 'order (map (lambda (p) (field p id:)) patterns))))

130 (set! score

131 (replace-child score 'history

132 (list 'history

133 (list "codex" (if (> (length provenance) 2) (caddr provenance) "2026-09-21")

134 (if (pair? provenance) (car provenance)

135

                      "Album opening pair I: finite arrangement, composed entrance, bridge, reprise and ending. Game sources remain unchanged; provenance and section map accompany this score."))

136 (list "codex" (if (> (length provenance) 2) (caddr provenance) "2026-09-21")

137 (if (and (pair? provenance) (pair? (cdr provenance))) (cadr provenance)

138

                      "Accepted instruments and onsets retained. Explicit final gates and two bars for natural room decay; no playback jumps. Arranged with album-compose-opening.sgl.")))))

139 (write-canonical motif destination score)

140 ($ ,motif tune check ,destination)

141 (write-json-file (path output (str slug "-map.json"))

142 (dict title: title

143 duration_seconds: (/ (* offset 2.5 (field base speed:)) (field base tempo:))

144 sources: (list->array sources)

145 sections: (list->array timeline)))

146 (println "~a: ~a bars, ~a seconds" title (/ offset bar-rows)

147 (/ (* offset 2.5 (field base speed:)) (field base tempo:))))))

148 ))