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
14 ;; (octave notename accidental)
18 ;; text: scm markup text -- see font.scm and input/test/markup.ly
23 ;; * clean split of base/banter/american stuff
24 ;; * text definition is rather ad-hoc
25 ;; * do without format module
26 ;; * finish and check american names
27 ;; * make notename (tonic) configurable from mudela
28 ;; * fix append/cons stuff in inner-name-banter
33 (define chord::names-alist-banter '())
34 (set! chord::names-alist-banter
40 (((0 . 0) (2 . 0)) . #f)
42 (((0 . 0) (2 . -1)) . ("m"))
44 (((0 . 0) (1 . 0) (4 . 0)) . (super "2"))
46 (((0 . 0) (3 . 0) (4 . 0)) . (super "4"))
48 (((0 . 0) (2 . -1) (4 . -1)) . ("dim"))
51 (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (super "o"))
53 (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1)) . ("dim" (super "9")))
54 (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1) (3 . -1)) . ("dim" (super "11")))
56 chord::names-alist-banter))
59 ;; NOTE: Duplicates of chord names defined elsewhere occur in this list
60 ;; in order to prevent spurious superscripting of various chord names,
61 ;; such as maj7, maj9, etc.
63 ;; See input/test/american-chords.ly
65 ;; James Hammons, <jlhamm@pacificnet.net>
67 (define chord::names-alist-american '())
68 (set! chord::names-alist-american
72 (((0 . 0) (2 . 0)) . #f)
74 (((0 . 0) (4 . 0)) . ("5"))
76 (((0 . 0) (2 . -1)) . ("m"))
77 (((0 . 0) (3 . 0) (4 . 0)) . ("sus"))
78 (((0 . 0) (2 . -1) (4 . -1)) . ("dim"))
79 ;Alternate: (((0 . 0) (2 . -1) (4 . -1)) . ((super "o")))
80 (((0 . 0) (2 . 0) (4 . 1)) . ("aug"))
81 ;Alternate: (((0 . 0) (2 . 0) (4 . 1)) . ("+"))
82 (((0 . 0) (1 . 0) (4 . 0)) . ("2"))
83 ;; Common seventh chords
84 (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (rows (super "o") "7"))
85 (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . ("maj7"))
86 (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . ("m7"))
87 (((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . ("7"))
88 (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . ("m(maj7)"))
89 ;jazz: the delta, see jazz-chords.ly
90 ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (super ((font-family . "math") "N"))
92 (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (rows ((raise . 1) "o") ((raise . 0.5) ((kern . -0.5) ((font-relative-size . -3) "/"))) "7")) ; slashed o
93 (((0 . 0) (2 . 0) (4 . 1) (6 . -1)) . ("aug7"))
94 (((0 . 0) (2 . 0) (4 . -1) (6 . 0)) . (rows "maj7" ((font-relative-size . -2) ((raise . 0.2) (music (named "accidentals--1")))) "5"))
95 (((0 . 0) (2 . 0) (4 . -1) (6 . -1)) . (rows "7" ((font-relative-size . -2) ((raise . 0.2) (music (named "accidentals--1")))) "5"))
96 (((0 . 0) (3 . 0) (4 . 0) (6 . -1)) . ("7sus4"))
97 ;; Common ninth chords
98 (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) . ("6/9")) ;; we don't want the '/no7'
99 (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) . ("6"))
100 (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) . ("m6"))
101 (((0 . 0) (2 . 0) (4 . 0) (1 . 0)) . ("add9"))
102 (((0 . 0) (2 . 0) (4 . 0) (6 . 0) (1 . 0)) . ("maj9"))
103 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0)) . ("9"))
104 (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) . ("m9"))
107 chord::names-alist-american))
109 ;; Jazz chords, by Atte André Jensen
110 ;; Note: This uses the american list as a base
112 (define chord::names-alist-jazz '())
113 (set! chord::names-alist-jazz
116 ; half diminished seventh chord = slashed o
117 (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (("o" (type . "super")) ("/" (size . -2) (offset . (-0.58 . 0.5))) ))
118 ; diminished seventh chord = o
119 (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (("o" (type . "super"))))
120 ; major seventh chord = triangle
121 (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . ((super ((font-family . "math") "N")) (size . -3)))
122 ; minor major seventh chord = m triangle
123 (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (("m") ((super ((font-family . math) "N")) (size . -3))))
124 ; augmented dominant = +7
125 (((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (super "+7"))
127 ;; Missing jazz chord definitions go here (note new syntax: see american for hints)
130 chord::names-alist-american))
135 (define (pitch->note-name pitch)
136 (cons (cadr pitch) (caddr pitch)))
138 (define (pitch->text pitch)
140 (make-string 1 (integer->char (+ (modulo (+ (cadr pitch) 2) 7) 65)))
141 (if (= (caddr pitch) 0)
148 (append '((font-relative-size . -2))
149 (list (append '((raise . 0.6))
151 (string-append "accidentals-"
152 (number->string (caddr pitch)))))))))))))))
154 (define (step->text pitch)
156 (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))
164 (define (pitch->text-banter pitch)
167 (define (step->text-banter pitch)
168 (if (= (cadr pitch) 6)
177 (define pitch::semitone-vec (list->vector '(0 2 4 5 7 9 11)))
179 (define (pitch::semitone pitch)
180 (+ (* (car pitch) 12)
181 (vector-ref pitch::semitone-vec (modulo (cadr pitch) 7))
184 (define (pitch::transpose pitch delta)
185 (let ((simple-octave (+ (car pitch) (car delta)))
186 (simple-notename (+ (cadr pitch) (cadr delta))))
187 (let ((octave (+ simple-octave (quotient simple-notename 7)))
188 (notename (modulo simple-notename 7)))
189 (let ((accidental (- (+ (pitch::semitone pitch) (pitch::semitone delta))
190 (pitch::semitone `(,octave ,notename 0)))))
191 `(,octave ,notename ,accidental)))))
193 (define (pitch::diff pitch tonic)
194 (let ((simple-octave (- (car pitch) (car tonic)))
195 (simple-notename (- (cadr pitch) (cadr tonic))))
196 (let ((octave (+ simple-octave (quotient simple-notename 7)
197 (if (< simple-notename 0) -1 0)))
198 (notename (modulo simple-notename 7)))
199 (let ((accidental (- (pitch::semitone pitch)
200 (pitch::semitone tonic)
201 (pitch::semitone `(,octave ,notename 0)))))
202 `(,octave ,notename ,accidental)))))
204 (define (pitch::note-pitch pitch)
205 (+ (* (car pitch) 7) (cadr pitch)))
207 (define (chord::step tonic pitch)
208 (- (pitch::note-pitch pitch) (pitch::note-pitch tonic)))
210 ;; text: list of word
211 ;; word: string + optional list of property
212 ;; property: align, kern, font (?), size
214 (define chord::minor-major-vec (list->vector '(0 -1 -1 0 -1 -1 0)))
216 ;; compute the relative-to-tonic pitch that goes with 'step'
217 (define (chord::step-pitch tonic step)
218 ;; urg, we only do this for thirds
219 (if (= (modulo step 2) 0)
221 (let loop ((i 1) (pitch tonic))
225 pitch `(0 2 ,(vector-ref chord::minor-major-vec
226 ;; -1 (step=1 -> vector=0) + 7 = 6
227 (modulo (+ i 6) 7)))))))))
229 ;; find the pitches that are not part of `normal' chord
230 (define (chord::additions chord-pitches)
231 (let ((tonic (car chord-pitches)))
232 ;; walk the chord steps: 1, 3, 5
233 (let loop ((step 1) (pitches chord-pitches) (additions '()))
235 (let* ((pitch (car pitches))
236 (p-step (+ (- (pitch::note-pitch pitch)
237 (pitch::note-pitch tonic))
239 ;; pitch is an addition if
241 ;; it comes before this step or
243 ;; its step is even or
244 (= (modulo p-step 2) 0)
245 ;; has same step, but different accidental or
247 (not (equal? pitch (chord::step-pitch tonic step))))
248 ;; is the last of the chord and not one of base thirds
250 (= (length pitches) 1)))
251 (loop step (cdr pitches) (cons pitch additions))
253 (loop step (cdr pitches) additions)
254 (loop (+ step 2) pitches additions))))
255 (reverse additions)))))
257 ;; find the pitches that are missing from `normal' chord
258 (define (chord::subtractions chord-pitches)
259 (let ((tonic (car chord-pitches)))
260 (let loop ((step 1) (pitches chord-pitches) (subtractions '()))
262 (let* ((pitch (car pitches))
263 (p-step (+ (- (pitch::note-pitch pitch)
264 (pitch::note-pitch tonic))
266 ;; pitch is an subtraction if
267 ;; a step is missing or
269 (loop (+ step 2) pitches
270 (cons (chord::step-pitch tonic step) subtractions))
271 ;; there are no pitches left, but base thirds are not yet done and
273 (= (length pitches) 1))
274 ;; present pitch is not missing step
276 (loop (+ step 2) pitches subtractions)
277 (loop (+ step 2) pitches
278 (cons (chord::step-pitch tonic step) subtractions)))
280 (loop (+ step 2) (cdr pitches) subtractions)
281 (loop step (cdr pitches) subtractions)))))
282 (reverse subtractions)))))
284 ;; combine tonic, user-specified chordname,
285 ;; additions, subtractions and base or inversion to chord name
287 (define (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)
290 (pitch->text-banter tonic)
291 (if user-name user-name '())
292 ;; why does list->string not work, format seems only hope...
293 (if (and (string-match "super" (format "~s" user-name))
294 (or (pair? additions)
295 (pair? subtractions)))
298 (let loop ((from additions) (to '()))
300 (let ((p (car from)))
304 (list 'super (step->text-banter p))
305 (if (or (pair? (cdr from))
306 (pair? subtractions))
310 (let loop ((from subtractions) (to '()))
312 (let ((p (car from)))
317 (list 'super (step->text-banter p))
318 (if (pair? (cdr from))
322 (if (and (pair? base-and-inversion)
323 (or (car base-and-inversion)
324 (cdr base-and-inversion)))
326 (if (car base-and-inversion)
328 (car base-and-inversion))
330 (cdr base-and-inversion)))
335 (define (chord::name-banter tonic user-name pitches base-and-inversion)
336 (let ((additions (chord::additions pitches))
337 (subtractions (chord::subtractions pitches)))
338 (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)))
340 ;; american chordnames use no "no",
341 ;; but otherwise very similar to banter for now
342 (define (chord::name-american tonic user-name pitches base-and-inversion)
343 (let ((additions (chord::additions pitches))
345 (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)))
347 ;; Jazz style--basically similar to american with minor changes
348 (define (chord::name-jazz tonic user-name pitches base-and-inversion)
349 (let ((additions (chord::additions pitches))
351 (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)))
355 ;; Check for each subset of chord, full chord first, if there's a
356 ;; user-override. Split the chord into user-overridden and to-be-done
357 ;; parts, complete the missing user-override matched part with normal
358 ;; chord to be name-calculated.
360 (define (default-chord-name-function style pitches base-and-inversion)
361 ;(display "pitches:") (display pitches) (newline)
362 ;(display "style:") (display style) (newline)
363 ;(display "b&i:") (display base-and-inversion) (newline)
364 (let ((diff (pitch::diff '(0 0 0) (car pitches)))
366 (ly-eval (string->symbol (string-append "chord::name-" style))))
368 (ly-eval (string->symbol (string-append "chord::names-alist-" style)))))
369 (let loop ((note-names (reverse pitches))
372 (if (pair? note-names)
376 (pitch->note-name (pitch::transpose x diff)))
380 ;; urg? found: break loop
381 (loop '() chord (cdr entry))
382 (loop (cdr note-names) (cons (car note-names) chord) #f)))
383 (let* ((transposed (if pitches
384 (map (lambda (x) (pitch::transpose x diff)) chord)
386 (matched (if (= (length chord) 0)
388 (- (length pitches) (length chord))))
390 (append (do ((i matched (- i 1))
391 (base '() (cons `(0 ,(* (- i 1) 2) 0) base)))
395 (name-func (car pitches) user-name completed base-and-inversion))))))