1 ;;; chord.scm -- to be included in/to replace chord-name.scm
2 ;;; 2000 janneke@gnu.org
7 ;; urg, these two only to guess if a '/' is needed to separate
8 ;; user-chord-name and additions/subtractions
13 ;; The regex module may not be available, or may be broken.
14 (define chord-use-regex
15 (let ((os (string-downcase (vector-ref (uname) 0))))
16 (not (equal? "cygwin" (substring os 0 (min 6 (string-length os)))))))
18 ;; If you have trouble with regex, define #f
19 (define chord-use-regex #t)
20 ;;(define chord-use-regex #f)
23 ;; (octave notename accidental)
28 ;; word: string + optional list of property
29 ;; property: size, style, font, super, offset
34 ;; * clean split of base/banter/american stuff
35 ;; * text definition is rather ad-hoc
36 ;; * do without format module
37 ;; * finish and check american names
38 ;; * make notename (tonic) configurable from mudela
39 ;; * fix append/cons stuff in inner-name-banter
44 (define chord::names-alist-banter '())
45 (set! chord::names-alist-banter
51 (((0 . 0) (2 . 0)) . #f)
53 (((0 . 0) (2 . -1)) . ("m"))
55 (((0 . 0) (1 . 0) (4 . 0)) . (("2" (type . "super"))))
57 (((0 . 0) (3 . 0) (4 . 0)) . (("4" (type . "super"))))
59 (((0 . 0) (2 . -1) (4 . -1)) . ("dim"))
62 (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (("o" (type . "super"))))
64 (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1)) . ("dim" ("9" (type . "super"))))
65 (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1) (3 . -1)) . ("dim" ("11" (type . "super"))))
67 chord::names-alist-banter))
70 ;; NOTE: Duplicates of chord names defined elsewhere occur in this list
71 ;; in order to prevent spurious superscripting of various chord names,
72 ;; such as maj7, maj9, etc.
74 ;; See input/test/american-chords.ly
76 ;; James Hammons, <jlhamm@pacificnet.net>
78 (define chord::names-alist-american '())
79 (set! chord::names-alist-american
83 (((0 . 0) (2 . 0)) . #f)
85 (((0 . 0) (4 . 0)) . ("5"))
87 (((0 . 0) (2 . -1)) . ("m"))
88 (((0 . 0) (3 . 0) (4 . 0)) . ("sus"))
89 (((0 . 0) (2 . -1) (4 . -1)) . ("dim"))
90 ;Alternate: (((0 . 0) (2 . -1) (4 . -1)) . (("o" (type . "super"))))
91 (((0 . 0) (2 . 0) (4 . 1)) . ("aug"))
92 ;Alternate: (((0 . 0) (2 . 0) (4 . 1)) . ("+"))
93 (((0 . 0) (1 . 0) (4 . 0)) . ("2"))
94 ;; Common seventh chords
95 (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (("o" (type . "super")) "7"))
96 (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . ("maj7"))
97 (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . ("m7"))
98 (((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . ("7"))
99 (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . ("m(maj7)"))
100 ;jazz: the delta, see jazz-chords.ly
101 ;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (("N" (type . "super") (style . "msam") (size . -3))))
102 (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (("o" (type . "super")) ("/" (size . -2) (offset . (-0.58 . 0.5))) "7")) ; slashed o
103 (((0 . 0) (2 . 0) (4 . 1) (6 . -1)) . ("aug7"))
104 (((0 . 0) (2 . 0) (4 . -1) (6 . 0)) . (("maj7") ("accidentals--1" (font . "feta") (type . "super")) ("5")))
105 (((0 . 0) (3 . 0) (4 . 0) (6 . -1)) . ("7sus4"))
106 ;; Common ninth chords
107 (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) . ("6/9")) ;; we don't want the '/no7'
108 (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) . ("maj6"))
109 (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) . ("m6"))
110 (((0 . 0) (2 . 0) (4 . 0) (1 . 0)) . ("add9"))
111 (((0 . 0) (2 . 0) (4 . 0) (6 . 0) (1 . 0)) . ("maj9"))
112 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0)) . ("9"))
113 (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) . ("m9"))
116 chord::names-alist-american))
121 (define (pitch->note-name pitch)
122 (cons (cadr pitch) (caddr pitch)))
124 (define (pitch->text pitch)
126 (make-string 1 (integer->char (+ (modulo (+ (cadr pitch) 2) 7) 65)))
127 (if (= (caddr pitch) 0)
129 (list (list (string-append "accidentals-"
130 (number->string (caddr pitch)))
131 ;; Keep accidentals from being too large
132 '(font . "feta") '(type . "super") )))))
134 (define (step->text pitch)
136 (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))
144 (define (pitch->text-banter pitch)
147 (define (step->text-banter pitch)
148 (if (= (cadr pitch) 6)
157 (define pitch::semitone-vec (list->vector '(0 2 4 5 7 9 11)))
159 (define (pitch::semitone pitch)
160 (+ (* (car pitch) 12)
161 (vector-ref pitch::semitone-vec (modulo (cadr pitch) 7))
164 (define (pitch::transpose pitch delta)
165 (let ((simple-octave (+ (car pitch) (car delta)))
166 (simple-notename (+ (cadr pitch) (cadr delta))))
167 (let ((octave (+ simple-octave (quotient simple-notename 7)))
168 (notename (modulo simple-notename 7)))
169 (let ((accidental (- (+ (pitch::semitone pitch) (pitch::semitone delta))
170 (pitch::semitone `(,octave ,notename 0)))))
171 `(,octave ,notename ,accidental)))))
173 (define (pitch::diff pitch tonic)
174 (let ((simple-octave (- (car pitch) (car tonic)))
175 (simple-notename (- (cadr pitch) (cadr tonic))))
176 (let ((octave (+ simple-octave (quotient simple-notename 7)
177 (if (< simple-notename 0) -1 0)))
178 (notename (modulo simple-notename 7)))
179 (let ((accidental (- (pitch::semitone pitch)
180 (pitch::semitone tonic)
181 (pitch::semitone `(,octave ,notename 0)))))
182 `(,octave ,notename ,accidental)))))
184 (define (pitch::note-pitch pitch)
185 (+ (* (car pitch) 7) (cadr pitch)))
187 (define (chord::step tonic pitch)
188 (- (pitch::note-pitch pitch) (pitch::note-pitch tonic)))
190 ;; text: list of word
191 ;; word: string + optional list of property
192 ;; property: align, kern, font (?), size
194 (define chord::minor-major-vec (list->vector '(0 -1 -1 0 -1 -1 0)))
196 ;; compute the relative-to-tonic pitch that goes with 'step'
197 (define (chord::step-pitch tonic step)
198 ;; urg, we only do this for thirds
199 (if (= (modulo step 2) 0)
201 (let loop ((i 1) (pitch tonic))
205 pitch `(0 2 ,(vector-ref chord::minor-major-vec
206 ;; -1 (step=1 -> vector=0) + 7 = 6
207 (modulo (+ i 6) 7)))))))))
209 ;; find the pitches that are not part of `normal' chord
210 (define (chord::additions chord-pitches)
211 (let ((tonic (car chord-pitches)))
212 ;; walk the chord steps: 1, 3, 5
213 (let loop ((step 1) (pitches chord-pitches) (additions '()))
215 (let* ((pitch (car pitches))
216 (p-step (+ (- (pitch::note-pitch pitch)
217 (pitch::note-pitch tonic))
219 ;; pitch is an addition if
221 ;; it comes before this step or
223 ;; its step is even or
224 (= (modulo p-step 2) 0)
225 ;; has same step, but different accidental or
227 (not (equal? pitch (chord::step-pitch tonic step))))
228 ;; is the last of the chord and not one of base thirds
230 (= (length pitches) 1)))
231 (loop step (cdr pitches) (cons pitch additions))
233 (loop step (cdr pitches) additions)
234 (loop (+ step 2) pitches additions))))
235 (reverse additions)))))
237 ;; find the pitches that are missing from `normal' chord
238 (define (chord::subtractions chord-pitches)
239 (let ((tonic (car chord-pitches)))
240 (let loop ((step 1) (pitches chord-pitches) (subtractions '()))
242 (let* ((pitch (car pitches))
243 (p-step (+ (- (pitch::note-pitch pitch)
244 (pitch::note-pitch tonic))
246 ;; pitch is an subtraction if
247 ;; a step is missing or
249 (loop (+ step 2) pitches
250 (cons (chord::step-pitch tonic step) subtractions))
251 ;; there are no pitches left, but base thirds are not yet done and
253 (= (length pitches) 1))
254 ;; present pitch is not missing step
256 (loop (+ step 2) pitches subtractions)
257 (loop (+ step 2) pitches
258 (cons (chord::step-pitch tonic step) subtractions)))
260 (loop (+ step 2) (cdr pitches) subtractions)
261 (loop step (cdr pitches) subtractions)))))
262 (reverse subtractions)))))
264 ;; combine tonic, user-specified chordname,
265 ;; additions, subtractions and base or inversion to chord name
267 (define (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)
268 (apply append (pitch->text-banter tonic)
269 (if user-name user-name '())
270 ;; why does list->string not work, format seems only hope...
271 (if (and chord-use-regex
272 (string-match "super" (format "~s" user-name))
273 (or (pair? additions)
274 (pair? subtractions)))
275 '(("/" (type . "super")))
277 (let loop ((from additions) (to '()))
279 (let ((p (car from)))
283 (cons (step->text-banter p) '((type . "super")))
284 (if (or (pair? (cdr from))
285 (pair? subtractions))
286 '(("/" (type . "super")))
289 (let loop ((from subtractions) (to '()))
291 (let ((p (car from)))
294 (cons '("no" (type . "super"))
296 (cons (step->text-banter p) '((type . "super")))
297 (if (pair? (cdr from))
298 '(("/" (type . "super")))
301 (if (and (pair? base-and-inversion)
302 (or (car base-and-inversion)
303 (cdr base-and-inversion)))
305 (if (car base-and-inversion)
307 (car base-and-inversion))
309 (cdr base-and-inversion)))
314 (define (chord::name-banter tonic user-name pitches base-and-inversion)
315 (let ((additions (chord::additions pitches))
316 (subtractions (chord::subtractions pitches)))
317 (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)))
319 ;; american chordnames use no "no",
320 ;; but otherwise very similar to banter for now
321 (define (chord::name-american tonic user-name pitches base-and-inversion)
322 (let ((additions (chord::additions pitches))
324 (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)))
328 ;; Check for each subset of chord, full chord first, if there's a
329 ;; user-override. Split the chord into user-overridden and to-be-done
330 ;; parts, complete the missing user-override matched part with normal
331 ;; chord to be name-calculated.
333 (define (default-chord-name-function style pitches base-and-inversion)
334 ;(display "pitches:") (display pitches) (newline)
335 ;(display "style:") (display style) (newline)
336 ;(display "b&i:") (display base-and-inversion) (newline)
337 (let ((diff (pitch::diff '(0 0 0) (car pitches)))
339 (ly-eval (string->symbol (string-append "chord::name-" style))))
341 (ly-eval (string->symbol (string-append "chord::names-alist-" style)))))
342 (let loop ((note-names (reverse pitches))
345 (if (pair? note-names)
349 (pitch->note-name (pitch::transpose x diff)))
353 ;; urg? found: break loop
354 (loop '() chord (cdr entry))
355 (loop (cdr note-names) (cons (car note-names) chord) #f)))
356 (let* ((transposed (if pitches
357 (map (lambda (x) (pitch::transpose x diff)) chord)
359 (matched (if (= (length chord) 0)
361 (- (length pitches) (length chord))))
363 (append (do ((i matched (- i 1))
364 (base '() (cons `(0 ,(* (- i 1) 2) 0) base)))
368 (name-func (car pitches) user-name completed base-and-inversion))))))