2 ;;; chord-name.scm -- Compile chord name
4 ;;; source file of the GNU LilyPond music typesetter
6 ;;; (c) 2000--2001 Jan Nieuwenhuizen <janneke@gnu.org>
17 ;; pitch = (octave notename accidental)
19 ;; note = (notename . accidental)
21 ;; text = scm markup text -- see font.scm and input/test/markup.ly
26 ;; * easier tweakability:
27 ;; - split chord::names-alists up into logical bits,
28 ;; such as chord::exceptions-delta, exceptions-oslash
29 ;; - iso just the 'style parameter, use a list, eg:
30 ;; \property ChordNames.ChordName \set
31 ;; #'style = #'(jazz delta oslash german-tonic german-Bb)
35 ;; * clean split/merge of bass/banter/american stuff
39 (define chord::names-alist-banter '())
40 (set! chord::names-alist-banter
46 (((0 . 0) (2 . 0)) . #f)
48 (((0 . 0) (2 . -1)) . ("m"))
50 (((0 . 0) (1 . 0) (4 . 0)) . ("" (super "2") " "))
52 (((0 . 0) (3 . 0) (4 . 0)) . ("" (super "4") " " ))
54 (((0 . 0) (2 . -1) (4 . -1)) . ("dim"))
55 ; URG: Simply C:m5-/maj7 iso Cdim maj7
56 (((0 . 0) (2 . -1) (4 . -1) (6 . 0)) . ("m" (super "5-/maj7" " ")))
57 ; URG: Simply C:m5-/7 iso Cdim7
58 (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . ("m" (super "5-/7" " ")))
60 (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ("" (super "o") " "))
62 (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1)) . ("dim" (super "9") " "))
63 (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1) (3 . -1)) . ("dim" (super "11") " "))
65 chord::names-alist-banter))
69 ;; duh, no docstrings for
70 ;; "No real superscript, just raised and small"
71 '((raise . 1) (font-relative-size . -2)))
73 (define (accidental->textp acc pos)
76 (list '(music (font-relative-size . -2))
77 (list pos (string-append "accidentals-" (number->string acc))))))
79 (define (accidental->text acc) (accidental->textp acc 'columns))
80 (define (accidental->text-super acc) (accidental->textp acc 'simple-super))
81 (define (accidental->text-sub acc) (accidental->textp acc 'sub))
83 (define (pitch->note-name pitch)
84 (cons (cadr pitch) (caddr pitch)))
86 (define (pitch->text pitch)
89 '(font-relative-size . 2)
90 (make-string 1 (integer->char (+ (modulo (+ (cadr pitch) 2) 7) 65))))
91 (accidental->text-super (caddr pitch))))
94 ;;; Hooks to override chord names and note names,
95 ;;; see input/tricks/german-chords.ly
97 (define (pitch->text-banter pitch)
100 ;; We need also steps, to allow for Cc name override,
101 ;; see input/test/Cc-chords.ly
102 (define (pitch->chord-name-text-banter pitch steps)
103 (pitch->text-banter pitch))
105 (define (pitch->note-name-text-banter pitch)
106 (pitch->text-banter pitch))
108 (define (step->text pitch)
110 (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))
118 (define (step->text-banter pitch)
119 (if (= (cadr pitch) 6)
128 (define pitch::semitone-vec (list->vector '(0 2 4 5 7 9 11)))
130 (define (pitch::semitone pitch)
131 (+ (* (car pitch) 12)
132 (vector-ref pitch::semitone-vec (modulo (cadr pitch) 7))
135 (define (pitch::< l r)
136 (< (pitch::semitone l) (pitch::semitone r)))
138 (define (pitch::transpose pitch delta)
139 (let ((simple-octave (+ (car pitch) (car delta)))
140 (simple-notename (+ (cadr pitch) (cadr delta))))
141 (let ((octave (+ simple-octave (quotient simple-notename 7)))
142 (notename (modulo simple-notename 7)))
143 (let ((accidental (- (+ (pitch::semitone pitch) (pitch::semitone delta))
144 (pitch::semitone `(,octave ,notename 0)))))
145 `(,octave ,notename ,accidental)))))
147 (define (pitch::diff pitch tonic)
148 (let ((simple-octave (- (car pitch) (car tonic)))
149 (simple-notename (- (cadr pitch) (cadr tonic))))
150 (let ((octave (+ simple-octave (quotient simple-notename 7)
151 (if (< simple-notename 0) -1 0)))
152 (notename (modulo simple-notename 7)))
153 (let ((accidental (- (pitch::semitone pitch)
154 (pitch::semitone tonic)
155 (pitch::semitone `(,octave ,notename 0)))))
156 `(,octave ,notename ,accidental)))))
158 (define (pitch::note-pitch pitch)
159 (+ (* (car pitch) 7) (cadr pitch)))
161 (define (chord::text? text)
162 (not (or (not text) (empty? text) (unspecified? text))))
164 (define (chord::text-cleanup dirty)
166 Recursively remove '() #f, and #<unspecified> from markup text tree.
167 This allows us to leave else parts of (if # #) off.
168 Otherwise, you'd have to do (if # # '()), and you'd have to
169 filter-out the '() anyway.
172 (let ((r (car dirty)))
174 (cons (if (pair? r) (chord::text-cleanup r) r)
175 (chord::text-cleanup (cdr dirty)))
176 (chord::text-cleanup (cdr dirty))))
177 (if (chord::text? dirty)
181 (define (text-append l . r)
182 (if (not (chord::text? r))
184 (if (not (chord::text? l))
187 (list 'columns l (car r))
188 (text-append (list 'columns l (car r)) (cdr r))))))
190 (define (chord::step tonic pitch)
191 (- (pitch::note-pitch pitch) (pitch::note-pitch tonic)))
193 ;; text: list of word
194 ;; word: string + optional list of property
195 ;; property: align, kern, font (?), size
197 (define chord::minor-major-vec (list->vector '(0 -1 -1 0 -1 -1 0)))
200 ;; compute the relative-to-tonic pitch that goes with 'step'
201 (define (chord::step-pitch tonic step)
202 ;; urg, we only do this for thirds
203 (if (= (modulo step 2) 0)
205 (let loop ((i 1) (pitch tonic))
209 pitch `(0 2 ,(vector-ref chord::minor-major-vec
210 ;; -1 (step=1 -> vector=0) + 7 = 6
211 (modulo (+ i 6) 7)))))))))
213 (define (chord::additions steps)
215 * any even step (2, 4, 6)
216 * any uneven step that is chromatically altered,
217 (where 7-- == -1, 7- == 0, 7 == +1)
220 ?and jazz needs also:
222 * TODO: any uneven step that's lower than an uneven step which is
223 chromatically altered
225 (let ((evens (filter-list (lambda (x) (!= 0 (modulo (cadr x) 2))) steps))
227 (filter-list (lambda (x)
228 (let ((n (cadr x)) (a (caddr x)))
229 (or (and (= 6 n) (!= -1 a))
234 (highest (let ((h (car (last-pair steps))))
235 (if (and (not (empty? h))
240 ;; Hmm, what if we have a step twice, can we ignore that?
241 (uniq-list (sort (apply append evens altered-unevens highest)
245 ;; FIXME: unLOOP, see ::additions
246 ;; find the pitches that are missing from `normal' chord
247 (define (chord::subtractions chord-pitches)
248 (let ((tonic (car chord-pitches)))
249 (let loop ((step 1) (pitches chord-pitches) (subtractions '()))
251 (let* ((pitch (car pitches))
252 (p-step (+ (- (pitch::note-pitch pitch)
253 (pitch::note-pitch tonic))
255 ;; pitch is an subtraction if
256 ;; a step is missing or
258 (loop (+ step 2) pitches
259 (cons (chord::step-pitch tonic step) subtractions))
260 ;; there are no pitches left, but base thirds are not yet done and
262 (= (length pitches) 1))
263 ;; present pitch is not missing step
265 (loop (+ step 2) pitches subtractions)
266 (loop (+ step 2) pitches
267 (cons (chord::step-pitch tonic step) subtractions)))
269 (loop (+ step 2) (cdr pitches) subtractions)
270 (loop step (cdr pitches) subtractions)))))
271 (reverse subtractions)))))
273 (define (chord::additions->text-banter additions subtractions)
274 (if (pair? additions)
276 (let ((step (step->text-banter (car additions))))
277 (if (or (pair? (cdr additions))
278 (pair? subtractions))
279 (text-append step "/")
281 (chord::additions->text-banter (cdr additions) subtractions))
284 (define (chord::subtractions->text-banter subtractions)
285 (if (pair? subtractions)
288 (let ((step (step->text-jazz (car subtractions))))
289 (if (pair? (cdr subtractions))
290 (text-append step "/")
292 (chord::subtractions->text-banter (cdr subtractions)))
295 (define (chord::bass-and-inversion->text-banter bass-and-inversion)
296 (if (and (pair? bass-and-inversion)
297 (or (car bass-and-inversion)
298 (cdr bass-and-inversion)))
299 (list "/" (if (car bass-and-inversion)
300 (pitch->note-name-text-banter
301 (car bass-and-inversion))
302 (pitch->note-name-text-banter
303 (cdr bass-and-inversion))))))
305 ;; FIXME: merge this function with inner-name-jazz, -american
306 ;; iso using chord::bass-and-inversion->text-banter,
307 ;; call (chord::restyle 'chord::bass-and-inversion->text- style)
308 ;; See: chord::exceptions-lookup
311 ;; Combine tonic, exception-part of chord name,
312 ;; additions, subtractions and bass or inversion into chord name
313 (define (chord::inner-name-banter tonic exception-part additions subtractions
314 bass-and-inversion steps)
315 (let* ((tonic-text (pitch->chord-name-text-banter tonic steps))
316 (except-text exception-part)
317 (sep-text (if (and (string-match "super" (format "~s" except-text))
318 (or (pair? additions)
319 (pair? subtractions)))
320 (list simple-super "/")))
321 (adds-text (chord::additions->text-banter additions subtractions))
322 (subs-text (chord::subtractions->text-banter subtractions))
323 (b+i-text (chord::bass-and-inversion->text-banter bass-and-inversion)))
325 tonic-text except-text " " sep-text
326 ;;(list (list simple-super) adds-text subs-text)
327 (list (list '((raise . 1) (font-relative-size . -1))) adds-text subs-text)
330 (define (chord::name-banter tonic exception-part unmatched-steps
331 bass-and-inversion steps)
332 (let ((additions (chord::additions unmatched-steps))
333 (subtractions (chord::subtractions unmatched-steps)))
334 (chord::inner-name-banter tonic exception-part additions subtractions
335 bass-and-inversion steps)))
338 (define (c++-pitch->scm p)
340 (list (pitch-octave p) (pitch-notename p) (pitch-alteration p))
343 (define (chord::name-banter tonic exception-part unmatched-steps
344 bass-and-inversion steps)
345 (let ((additions (chord::additions unmatched-steps))
346 (subtractions (chord::subtractions unmatched-steps)))
347 (chord::inner-name-banter tonic exception-part additions subtractions
348 bass-and-inversion steps)))
350 (define (chord::restyle name style)
351 (primitive-eval (string->symbol
352 (string-append (symbol->string name)
353 (symbol->string style)))))
355 ;; check exceptions-alist for biggest matching part of try-steps
356 ;; return (MATCHED-EXCEPTION . UNMATCHED-STEPS)
357 (define (chord::exceptions-lookup-helper
358 exceptions-alist try-steps unmatched-steps exception-part)
359 (if (pair? try-steps)
360 ;; FIXME: junk '(0 . 0) from exceptions lists?
361 ;; if so: how to handle first '((0 . 0) . #f) entry?
363 ;; FIXME: either format exceptions list as real pitches, ie,
364 ;; including octave '((0 2 -1) ..), or drop octave
365 ;; from rest of calculations,
367 (map (lambda (x) (pitch->note-name x))
368 (append '((0 0 0)) try-steps))
371 (chord::exceptions-lookup-helper
372 #f '() unmatched-steps (cdr entry))
373 (let ((r (reverse try-steps)))
374 (chord::exceptions-lookup-helper
377 (cons (car r) unmatched-steps) #f))))
378 (cons exception-part unmatched-steps)))
380 ;; return (MATCHED-EXCEPTION . BASE-CHORD-WITH-UNMATCHED-STEPS)
381 ;; BASE-CHORD-WITH-UNMATCHED-STEPS always includes (tonic 3 5)
382 (define (chord::exceptions-lookup style steps)
383 (let* ((result (chord::exceptions-lookup-helper
384 (chord::restyle 'chord::names-alist- style)
386 (exception-part (car result))
387 (unmatched-steps (cdr result))
388 (matched-steps (if (= (length unmatched-steps) 0)
390 (+ 1 (- (length steps)
391 (length unmatched-steps)))))
392 (unmatched-with-1-3-5
393 (append (do ((i matched-steps (- i 1))
394 (base '() (cons `(0 ,(* (- i 1) 2) 0) base)))
398 (list exception-part unmatched-with-1-3-5)))
401 (define (chord::name->text style tonic steps bass-and-inversion)
402 (let* ((lookup (chord::exceptions-lookup style steps))
403 (exception-part (car lookup))
404 (unmatched-steps (cadr lookup)))
405 ((chord::restyle 'chord::name- style)
406 tonic exception-part unmatched-steps bass-and-inversion steps)))
410 ;; Check for each subset of chord, full chord first, if there's a
411 ;; user-override. Split the chord into user-overridden and to-be-done
412 ;; parts, complete the missing user-override matched part with normal
413 ;; chord to be name-calculated.
415 ;; CHORD: (pitches (bass . inversion))
416 (define (default-chord-name-function style chord)
417 (let* ((pitches (map c++-pitch->scm (car chord)))
418 (modifiers (cdr chord))
419 (bass-and-inversion (if (pair? modifiers)
420 (cons (c++-pitch->scm (car modifiers))
421 (c++-pitch->scm (cdr modifiers)))
423 (diff (pitch::diff '(0 0 0) (car pitches)))
424 (steps (if (cdr pitches) (map (lambda (x)
425 (pitch::transpose x diff))
428 (chord::name->text style (car pitches) steps bass-and-inversion)))
435 ;; NOTE: Duplicates of chord names defined elsewhere occur in this list
436 ;; in order to prevent spurious superscripting of various chord names,
437 ;; such as maj7, maj9, etc.
439 ;; See input/test/american-chords.ly
441 ;; James Hammons, <jlhamm@pacificnet.net>
444 ;; DONT use non-ascii characters, even if ``it works'' in Windows
446 (define chord::names-alist-american '())
448 (set! chord::names-alist-american
452 (((0 . 0) (2 . 0)) . #f)
454 (((0 . 0) (4 . 0)) . ("5"))
456 (((0 . 0) (2 . -1)) . ("m"))
457 (((0 . 0) (3 . 0) (4 . 0)) . ("sus"))
458 (((0 . 0) (2 . -1) (4 . -1)) . ("dim"))
459 ;Alternate: (((0 . 0) (2 . -1) (4 . -1)) . ("" (super "o")))
460 (((0 . 0) (2 . 0) (4 . 1)) . ("aug"))
461 ;Alternate: (((0 . 0) (2 . 0) (4 . 1)) . ("+"))
462 (((0 . 0) (1 . 0) (4 . 0)) . ("2"))
463 ;; Common seventh chords
464 (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ("" (super "o") " " "7"))
465 (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . ("maj7"))
466 ;; urg! should use (0 . 0 2 . -1) -> "m", and add "7" to that!!
467 (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . ("m7"))
468 (((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . ("7"))
469 (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . ("m(maj7)"))
470 ;jazz: the delta, see jazz-chords.ly
471 ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (super ((font-family . math) "N"))
473 (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (columns (super (overstrike "o") "/") " " "7"))
475 (((0 . 0) (2 . 0) (4 . 1) (6 . -1)) . ("aug7"))
476 (((0 . 0) (2 . 0) (4 . -1) (6 . 0)) . (columns "maj7" ((font-relative-size . -2) ((raise . 0.2) (music (named "accidentals--1")))) "5"))
477 (((0 . 0) (2 . 0) (4 . -1) (6 . -1)) . (columns "7" ((font-relative-size . -2) ((raise . 0.2) (music (named "accidentals--1")))) "5"))
478 (((0 . 0) (3 . 0) (4 . 0) (6 . -1)) . ("7sus4"))
479 ;; Common ninth chords
480 (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) . ("6/9")) ;; we don't want the '/no7'
481 (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) . ("6"))
482 (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) . ("m6"))
483 (((0 . 0) (2 . 0) (4 . 0) (1 . 0)) . ("add9"))
484 (((0 . 0) (2 . 0) (4 . 0) (6 . 0) (1 . 0)) . ("maj9"))
485 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0)) . ("9"))
486 (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) . ("m9"))
489 chord::names-alist-american))
492 ;; American style chordnames use no "no",
493 ;; but otherwise very similar to banter for now
494 (define (chord::name-american tonic exception-part unmatched-steps
495 bass-and-inversion steps)
496 (let ((additions (chord::additions unmatched-steps))
498 (chord::inner-name-banter tonic exception-part additions subtractions
499 bass-and-inversion steps)))
509 ;; Jazz chords, by Atte Andr'e Jensen <atte@post.com>
510 ;; NBs: This uses the american list as a bass.
511 ;; Some defs take up more than one line,
512 ;; be carefull when messing with ;'s!!
517 ;; This is getting out-of hand? Only exceptional chord names that
518 ;; cannot be generated should be here.
519 ;; Maybe we should have inner-name-jazz and inner-name-american functions;
523 ;; DONT use non-ascii characters, even if ``it works'' in Windows
525 (define chord::names-alist-jazz '())
526 (set! chord::names-alist-jazz
530 ; major sixth chord = 6
531 (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) . (((raise . 0.5) "6")))
532 ; major seventh chord = triangle
533 ;; shouldn't this be a filled black triange, like this: ? --jcn
534 ;; (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . (((raise . 0.5)((font-family . math) "N"))))
535 (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . (((raise . 0.5)((font-family . math) "M"))))
536 ; major chord add nine = add9
537 (((0 . 0) (2 . 0) (4 . 0) (1 . 0)) . (((raise . 0.5) "add9")))
538 ; major sixth chord with nine = 6/9
539 (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) . (((raise . 0.5) "6/9")))
542 ; minor sixth chord = m6
543 (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) . (columns("m")((raise . 0.5) "6")))
544 ;; minor major seventh chord = m triangle
545 ;; shouldn't this be a filled black triange, like this: ? --jcn
546 ;;(((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (columns ("m") ((raise . 0.5)((font-family . math) "N"))))
547 (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (columns ("m") ((raise . 0.5)((font-family . math) "M"))))
548 ; minor seventh chord = m7
549 (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . (columns("m")((raise . 0.5) "7")))
550 ; minor sixth nine chord = m6/9
551 (((0 . 0) (2 . -1) (4 . 0) (5 . 0) (1 . 0)) . (columns("m")((raise . 0.5) "6/9")))
552 ; minor with added nine chord = madd9
553 (((0 . 0) (2 . -1) (4 . 0) (1 . 0)) . (columns("m")((raise . 0.5) "add9")))
554 ; minor ninth chord = m9
555 (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) . (columns("m")((raise . 0.5) "9")))
558 ; dominant seventh = 7
559 (((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . (((raise . 0.5) "7")))
560 ; augmented dominant = +7
561 ;(((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (((raise . 0.5) "+7"))) ; +7 with both raised
562 (((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (columns("+")((raise . 0.5) "7"))) ; +7 with 7 raised
563 ;(((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (columns((raise . 0.5) "7(")
564 ; ((raise . 0.3)(music (named ("accidentals-1"))))
565 ; ((raise . 0.5) "5)"))); 7(#5)
566 ; dominant flat 5 = 7(b5)
567 (((0 . 0) (2 . 0) (4 . -1) (6 . -1)) . (columns((raise . 0.5) "7(")
568 ((raise . 0.3)(music (named ("accidentals--1"))))
569 ((raise . 0.5) "5)")))
571 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0)) . (((raise . 0.8)"7(9)")))
572 ; dominant flat 9 = 7(b9)
573 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1)) . (
575 ((raise . 0.3)(music (named ("accidentals--1"))))
576 ((raise . 0.8)"9)")))
577 ; dominant sharp 9 = 7(#9)
578 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1)) . (
580 ((raise . 0.3)(music (named ("accidentals-1"))))
581 ((raise . 0.8)"9)")))
582 ; dominant 13 = 7(13)
583 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (5 . 0)) . (((raise . 0.8)"7(13)")))
584 ; dominant flat 13 = 7(b13)
585 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (5 . -1)) . (
587 ((raise . 0.3)(music (named ("accidentals--1"))))
588 ((raise . 0.8)"13)")))
589 ; dominant 9, 13 = 7(9,13)
590 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0) (5 . 0)) . (((raise . 0.8)"7(9, 13)")))
591 ; dominant flat 9, 13 = 7(b9,13)
592 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1) (5 . 0)) . (
594 ((raise . 0.3)(music (named ("accidentals--1"))))
595 ((raise . 0.8)"9, 13)")))
596 ; dominant sharp 9, 13 = 7(#9,13)
597 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1) (5 . 0)) . (
599 ((raise . 0.3)(music (named ("accidentals-1"))))
600 ((raise . 0.8)"9, 13)")))
601 ; dominant 9, flat 13 = 7(9,b13)
602 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0) (5 . -1)) . (
603 ((raise . 0.8)"7(9, ")
604 ((raise . 0.3)(music (named ("accidentals--1"))))
605 ((raise . 0.8)"13)")))
606 ; dominant flat 9, flat 13 = 7(b9,b13)
607 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1) (5 . -1)) . (
609 ((raise . 0.3)(music (named ("accidentals--1"))))
611 ((raise . 0.3)(music (named ("accidentals--1"))))
612 ((raise . 0.8)"13)")))
613 ; dominant sharp 9, flat 13 = 7(#9,b13)
614 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1) (5 . -1)) . (
616 ((raise . 0.3)(music (named ("accidentals-1"))))
618 ((raise . 0.3)(music (named ("accidentals--1"))))
619 ((raise . 0.8)"13)")))
621 ;; diminished chord(s)
622 ; diminished seventh chord = o
625 ;; DONT use non-ascii characters, even if ``it works'' in Windows
627 ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ((raise . 0.8) (size . -2) ("o")))
628 (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ("" (super "o")))
630 ;; half diminshed chords
631 ;; half diminished seventh chord = slashed o
632 ;; (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (((raise . 0.8) "/o")))
633 (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (columns (super (overstrike "o") "/") " " "7")) ; slashed o
635 ; half diminished seventh chord with major 9 = slashed o cancelation 9
636 (((0 . 0) (2 . -1) (4 . -1) (6 . -1) (1 . 0)) . (
638 ((raise . 0.3)(music (named ("accidentals-0"))))
639 ((raise . 0.8)"9)")));
641 ;; Missing jazz chord definitions go here (note new syntax: see american for hints)
644 chord::names-alist-american))
646 (define (step->text-alternate-jazz pitch)
648 (accidental->text (caddr pitch))
649 (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))))
651 (define (step->text-jazz pitch)
652 (if (= (cadr pitch) 6)
654 ;; sharp 7 only included for completeness?
655 ((-2) (text-append (accidental->text -1) '("7")))
658 ((1) (text-append (accidental->text-super 1) '("7")))
659 ((2) (text-append (accidental->text-super 2) '("7"))))
660 (step->text-alternate-jazz pitch)))
662 (define (xchord::additions->text-jazz additions subtractions)
663 (if (pair? additions)
665 (let ((step (step->text-jazz (car additions))))
666 (if (or (pair? (cdr additions))
667 (pair? subtractions))
668 (text-append step "/")
670 (chord::additions->text-jazz (cdr additions) subtractions))
673 (define (chord::>5? x)
679 ;; Perhaps all logic like this should be done earlier,
680 ;; so that in this text-construction printing phase
681 ;; we can just blindly create text from all additions.
683 ;; This depends maybe on the fact of code sharing,
684 ;; in this layout, we can share the functions chord::additions
685 ;; and chord::subtractions with banter.
686 (define (chord::additions->text-jazz additions subtractions)
688 (chord::additions<=5->text-jazz (filter-out-list chord::>5? additions)
689 (filter-out-list chord::>5? subtractions))
690 (chord::additions>5->text-jazz (filter-list chord::>5? additions)
691 (filter-list chord::>5? subtractions))))
694 (define (chord::additions<=5->text-jazz additions subtractions)
695 (let ((sus (chord::sus-four-jazz additions)))
697 (text-append '("sus") (step->text-jazz (car sus)))
700 (define (chord::additions>5->text-jazz additions subtractions)
702 Compose text of all additions
704 * if there's a subtraction:
706 - list all up to highest
707 * list all steps that are below an chromatically altered step
710 (if (not (empty? subtractions)) "add" '())
711 (let ((radds (reverse additions)))
712 (reverse (chord::additions>5->text-jazz-helper
715 (if (or (empty? subtractions) (empty? radds))
718 (define (chord::additions>5->text-jazz-helper additions subtractions list-step)
720 Create texts for all additions
721 If list-step != #f, list all steps down to 5
722 If we encounter a chromatically altered step, turn on list-step
726 (if (not (member list-step subtractions))
727 (if (> 5 (cadr list-step))
728 (cons (step->text-jazz list-step)
729 (chord::additions>5->text-jazz-helper
732 (chord::get-create-step additions
733 (- (cadr list-step) 2))))
734 (step->text-jazz list-step))
735 (chord::get-create-step additions (- (cadr list-step) 2)))
736 (if (pair? additions)
737 (let ((step (car additions)))
738 (cons (step->text-jazz step)
739 (chord::additions>5->text-jazz-helper
742 (if (or (and (!= 6 (cadr step)) (!= 0 (caddr step)))
743 (and (= 6 (cadr step)) (!= -1 (caddr step))))
744 (chord::get-create-step additions (- (cadr step) 2))
748 (define (chord::sus-four-jazz chord-pitches)
749 "List of pitches that are step 2 or step 4"
750 (filter-list (lambda (x)
752 (or (= 1 (cadr x)) (= 3 (cadr x))))) chord-pitches))
754 (define (chord::get-create-step steps n)
755 (let* ((i (if (< n 0) (+ n 7) n))
756 (found (filter-list (lambda (x) (= i (cadr x))) steps)))
763 (define (chord::subtractions->text-jazz subtractions)
764 (if (pair? subtractions)
766 (if (= 5 (cadr (car subtractions)))
769 (let ((step (step->text-jazz (car subtractions))))
770 (if (pair? (cdr subtractions))
771 (text-append step "/")
774 (chord::subtractions->text-jazz (cdr subtractions)))
778 ;; TODO: maybe merge with inner-name-banter
779 ;; Combine tonic, exception-part of chord name,
780 ;; additions, subtractions and bass or inversion into chord name
781 (define (chord::inner-name-jazz tonic exception-part additions subtractions
782 bass-and-inversion steps)
784 (pitch->chord-name-text-banter tonic steps)
786 ;; why does list->string not work, format seems only hope...
787 (if (and (string-match "super" (format "~s" exception-part))
788 (or (pair? additions)
789 (pair? subtractions)))
790 (list simple-super "/"))
792 (list `(,simple-super)
793 (chord::additions->text-jazz additions subtractions)
794 (chord::subtractions->text-jazz subtractions))
795 (chord::bass-and-inversion->text-banter bass-and-inversion)))
797 ;; Jazz style--basically similar to american with minor changes
799 ;; Consider Dm6. When we get here:
800 ;; tonic = '(0 1 0) (note d=2)
801 ;; steps = '((0 0 0) '(0 2 -1) (0 4 0) (0 5 0))
802 ;; steps are transposed for tonic c, octave 0,
803 ;; so (car steps) is always (0 0 0)
805 ;; assuming that the exceptions-alist has an entry
806 ;; '(((0 . 0) (2 . -1)) . ("m"))
807 ;; (and NOT the full chord, like std jazz list, ugh)
808 ;; unmatch = '((0 0 0) (0 2 0) (0 4 0) (0 5 0))
811 ;; You can look very easily what happens, if you add some write-me calls,
812 ;; and run lilypond on a simple file, eg, containing only the chord c:m6:
814 ;; (let ((additions (write-me "adds: "
815 ;; (chord::additions (write-me "unmatched:"
816 ;; unmatched-steps))))
818 ;; If you set subtract #f, the chord::inner-name-jazz does not see any
819 ;; subtractions, ever, so they don't turn up in the chord name.
821 (define (chord::name-jazz tonic exception-part unmatched-steps
822 bass-and-inversion steps)
823 (let ((additions (chord::additions unmatched-steps))
824 ;; get no 'omit' or 'no'
825 ;; (subtractions #f))
826 (subtractions (chord::subtractions unmatched-steps)))
827 (chord::inner-name-jazz tonic exception-part additions subtractions
828 bass-and-inversion steps)))
830 ;; wip (set! chord::names-alist-jazz
831 (define chord::names-alist-jazz
834 (((0 . 0) (2 . -1)) . ("m"))
836 ;; some fixups -- jcn
837 ; major seventh chord = triangle
838 (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . (((raise . 0.5)((font-family . math) "N"))))
839 ;; (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . (((raise . 0.5)((font-family . math) "M"))))
841 ;; minor major seventh chord = m triangle
842 (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (columns ("m") ((raise . 0.5)((font-family . math) "N"))))
843 ;; (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (columns ("m") ((raise . 0.5)((font-family . math) "M"))))
847 chord::names-alist-american))