2 ;;; chord-name.scm -- Compile chord name
4 ;;; source file of the GNU LilyPond music typesetter
6 ;;; (c) 2000--2002 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 ;; Ugh : naming chord::... ; this is scheme not C++
28 ;; * easier tweakability:
29 ;; - split chord::names-alists up into logical bits,
30 ;; such as chord::exceptions-delta, exceptions-oslash
31 ;; - iso just the 'style parameter, use a list, eg:
32 ;; \property ChordNames.ChordName \set
33 ;; #'style = #'(jazz delta oslash german-tonic german-Bb)
37 ;; * clean split/merge of bass/banter/american stuff
41 (define-public chord::names-alist-banter '())
42 (set! chord::names-alist-banter
46 (((0 . 0)) . (,simple-markup ""))
48 (((0 . 0) (2 . 0)) . (,simple-markup ""))
50 (((0 . 0) (2 . -1)) . (,simple-markup "m"))
52 (((0 . 0) (1 . 0) (4 . 0)) . (,super-markup (,simple-markup "2 ")))
54 (((0 . 0) (3 . 0) (4 . 0)) . (,super-markup (,simple-markup "4 ")))
56 (((0 . 0) (2 . -1) (4 . -1)) . (,simple-markup "dim"))
57 ; URG: Simply C:m5-/maj7 iso Cdim maj7
58 (((0 . 0) (2 . -1) (4 . -1) (6 . 0)) . (,line-markup ((,simple-markup "m") (,super-markup "5-/maj7 "))))
59 ; URG: Simply C:m5-/7 iso Cdim7
60 (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (,line-markup ((,simple-markup "m") (,super-markup "5-/7 "))))
62 (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (,super-markup (,simple-markup "o ")))
64 (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1)) . (,line-markup ((,simple-markup "dim")
65 (,simple-markup "9 "))))
66 (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1) (3 . -1))
67 . (,line-markup ((,simple-markup "dim")
68 (,super-markup (,simple-markup "11 ")))))
71 chord::names-alist-banter))
75 ;; duh, no docstrings for
76 ;; "No real superscript, just raised and small"
77 '((raise . 1) (font-relative-size . -2)))
79 (define (accidental->textp acc pos)
82 (list '(music (font-relative-size . -2))
83 (list pos (string-append "accidentals-" (number->string acc))))))
85 (define (accidental->text acc) (accidental->textp acc 'columns))
86 (define (accidental->text-super acc) (accidental->textp acc 'simple-super))
87 (define (accidental->text-sub acc) (accidental->textp acc 'sub))
89 (define (pitch->note-name pitch)
90 (cons (cadr pitch) (caddr pitch)))
92 (define (accidental-markup acc)
94 (list simple-markup "")
95 (list musicglyph-markup (string-append "accidentals-" (number->string acc)))
98 (define (pitch->text pitch)
102 (make-string 1 (integer->char (+ (modulo (+ (cadr pitch) 2) 7) 65))))
103 (list normal-size-superscript-markup
104 (accidental-markup (caddr pitch))))))
106 ;;; Hooks to override chord names and note names,
107 ;;; see input/tricks/german-chords.ly
109 (define (pitch->text-banter pitch)
112 ;; We need also steps, to allow for Cc name override,
113 ;; see input/test/Cc-chords.ly
114 (define (pitch->chord-name-text-banter pitch steps)
115 (pitch->text-banter pitch))
117 (define (pitch->note-name-text-banter pitch)
118 (pitch->text-banter pitch))
120 (define (step->text pitch)
122 (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))
130 (define (step->text-banter pitch)
131 (if (= (cadr pitch) 6)
133 ((-2) (list simple-markup "7-"))
134 ((-1) (list simple-markup "7"))
135 ((0) (list simple-markup "maj7"))
136 ((1) (list simple-markup "7+"))
137 ((2) (list simple-markup "7+")))
140 (define pitch::semitone-vec #(0 2 4 5 7 9 11))
142 (define (pitch::semitone pitch)
143 (+ (* (car pitch) 12)
144 (vector-ref pitch::semitone-vec (modulo (cadr pitch) 7))
147 (define (pitch::< l r)
148 (< (pitch::semitone l) (pitch::semitone r)))
150 (define (pitch::transpose pitch delta)
151 (let ((simple-octave (+ (car pitch) (car delta)))
152 (simple-notename (+ (cadr pitch) (cadr delta))))
153 (let ((octave (+ simple-octave (quotient simple-notename 7)))
154 (notename (modulo simple-notename 7)))
155 (let ((accidental (- (+ (pitch::semitone pitch) (pitch::semitone delta))
156 (pitch::semitone `(,octave ,notename 0)))))
157 `(,octave ,notename ,accidental)))))
159 (define (pitch::diff pitch tonic)
160 (let ((simple-octave (- (car pitch) (car tonic)))
161 (simple-notename (- (cadr pitch) (cadr tonic))))
162 (let ((octave (+ simple-octave (quotient simple-notename 7)
163 (if (< simple-notename 0) -1 0)))
164 (notename (modulo simple-notename 7)))
165 (let ((accidental (- (pitch::semitone pitch)
166 (pitch::semitone tonic)
167 (pitch::semitone `(,octave ,notename 0)))))
168 `(,octave ,notename ,accidental)))))
170 (define (pitch::note-pitch pitch)
171 (+ (* (car pitch) 7) (cadr pitch)))
173 (define (chord::text? text)
174 (not (or (not text) (null? text) (unspecified? text))))
177 (define (chord::step tonic pitch)
178 (- (pitch::note-pitch pitch) (pitch::note-pitch tonic)))
180 ;; text: list of word
181 ;; word: string + optional list of property
182 ;; property: axis, kern, font (?), size
184 (define chord::minor-major-vec (list->vector '(0 -1 -1 0 -1 -1 0)))
187 ;; compute the relative-to-tonic pitch that goes with 'step'
188 (define (chord::step-pitch tonic step)
189 ;; urg, we only do this for thirds
190 (if (= (modulo step 2) 0)
192 (let loop ((i 1) (pitch tonic))
196 pitch `(0 2 ,(vector-ref chord::minor-major-vec
197 ;; -1 (step=1 -> vector=0) + 7 = 6
198 (modulo (+ i 6) 7)))))))))
200 (define (chord::additions steps)
202 * any even step (2, 4, 6)
203 * any uneven step that is chromatically altered,
204 (where 7-- == -1, 7- == 0, 7 == +1)
207 ?and jazz needs also:
209 * TODO: any uneven step that's lower than an uneven step which is
210 chromatically altered
212 (let ((evens (filter-list (lambda (x) (!= 0 (modulo (cadr x) 2))) steps))
214 (filter-list (lambda (x)
215 (let ((n (cadr x)) (a (caddr x)))
216 (or (and (= 6 n) (!= -1 a))
221 (highest (let ((h (car (last-pair steps))))
222 (if (and (not (null? h))
227 ;; Hmm, what if we have a step twice, can we ignore that?
228 (uniq-list (sort (apply append evens altered-unevens highest)
232 ;; FIXME: unLOOP, see ::additions
233 ;; find the pitches that are missing from `normal' chord
234 (define (chord::subtractions chord-pitches)
235 (let ((tonic (car chord-pitches)))
236 (let loop ((step 1) (pitches chord-pitches) (subtractions '()))
238 (let* ((pitch (car pitches))
239 (p-step (+ (- (pitch::note-pitch pitch)
240 (pitch::note-pitch tonic))
242 ;; pitch is an subtraction if
243 ;; a step is missing or
245 (loop (+ step 2) pitches
246 (cons (chord::step-pitch tonic step) subtractions))
247 ;; there are no pitches left, but base thirds are not yet done and
249 (= (length pitches) 1))
250 ;; present pitch is not missing step
252 (loop (+ step 2) pitches subtractions)
253 (loop (+ step 2) pitches
254 (cons (chord::step-pitch tonic step) subtractions)))
256 (loop (+ step 2) (cdr pitches) subtractions)
257 (loop step (cdr pitches) subtractions)))))
258 (reverse subtractions)))))
260 (define (chord::additions->text-banter additions subtractions)
261 (if (pair? additions)
264 (let ((step (step->text-banter (car additions))))
265 (if (or (pair? (cdr additions))
266 (pair? subtractions))
268 (list step (list simple-markup "/")))
271 (chord::additions->text-banter (cdr additions) subtractions)))
272 (list simple-markup "")
276 (define (chord::subtractions->text-banter subtractions)
277 (if (pair? subtractions)
279 (list simple-markup "no")
280 (let ((step (step->text-jazz (car subtractions))))
281 (if (pair? (cdr subtractions))
282 (list line-markup (list step (list simple-markup "/")))
284 (chord::subtractions->text-banter (cdr subtractions)))
285 (list simple-markup "")
288 (define (chord::bass-and-inversion->text-banter bass-and-inversion)
289 (if (and (pair? bass-and-inversion)
290 (or (car bass-and-inversion)
291 (cdr bass-and-inversion)))
295 (list simple-markup "/")
296 (pitch->note-name-text-banter
297 (if (car bass-and-inversion)
298 (car bass-and-inversion)
299 (cdr bass-and-inversion)))
301 (list simple-markup "")
304 ;; FIXME: merge this function with inner-name-jazz, -american
305 ;; iso using chord::bass-and-inversion->text-banter,
306 ;; call (chord::restyle 'chord::bass-and-inversion->text- style)
307 ;; See: chord::exceptions-lookup
310 ;; Combine tonic, exception-part of chord name,
311 ;; additions, subtractions and bass or inversion into chord name
312 (define (chord::inner-name-banter tonic exception-part additions subtractions
313 bass-and-inversion steps)
314 (let* ((tonic-text (pitch->chord-name-text-banter tonic steps))
315 (except-text exception-part)
316 (sep-text (list simple-markup
317 (if (and (string-match "super" (format "~s" except-text))
318 (or (pair? additions)
319 (pair? subtractions)))
322 (adds-text (chord::additions->text-banter additions subtractions))
323 (subs-text (chord::subtractions->text-banter subtractions))
324 (b+i-text (chord::bass-and-inversion->text-banter bass-and-inversion)))
331 (,line-markup (,adds-text ,subs-text))
337 (define (c++-pitch->scm p)
339 (list (ly:pitch-octave p) (ly:pitch-notename p) (ly:pitch-alteration p))
342 (define-public (chord::name-banter tonic exception-part unmatched-steps
343 bass-and-inversion steps)
344 (let ((additions (chord::additions unmatched-steps))
345 (subtractions (chord::subtractions unmatched-steps)))
347 (chord::inner-name-banter tonic exception-part additions subtractions
348 bass-and-inversion steps)))
351 (define (chord::restyle name style)
352 (primitive-eval ;; "UGGHGUGHUGHG"
355 (string-append (symbol->string name)
356 (symbol->string style)))))
358 ;; check exceptions-alist for biggest matching part of try-steps
359 ;; return (MATCHED-EXCEPTION . UNMATCHED-STEPS)
360 (define (chord::exceptions-lookup-helper
361 exceptions-alist try-steps unmatched-steps exception-part)
362 (if (pair? try-steps)
363 ;; FIXME: junk '(0 . 0) from exceptions lists?
364 ;; if so: how to handle first '((0 . 0) . #f) entry?
366 ;; FIXME: either format exceptions list as real pitches, ie,
367 ;; including octave '((0 2 -1) ..), or drop octave
368 ;; from rest of calculations,
370 (map (lambda (x) (pitch->note-name x))
371 (append '((0 0 0)) try-steps))
374 (chord::exceptions-lookup-helper
375 #f '() unmatched-steps (cdr entry))
376 (let ((r (reverse try-steps)))
377 (chord::exceptions-lookup-helper
380 (cons (car r) unmatched-steps) #f))))
381 (cons exception-part unmatched-steps)))
383 ;; return (MATCHED-EXCEPTION . BASE-CHORD-WITH-UNMATCHED-STEPS)
384 ;; BASE-CHORD-WITH-UNMATCHED-STEPS always includes (tonic 3 5)
385 (define (chord::exceptions-lookup style steps)
386 (let* ((result (chord::exceptions-lookup-helper
387 (chord::restyle 'chord::names-alist- style)
389 (exception-part (car result))
390 (unmatched-steps (cdr result))
391 (matched-steps (if (= (length unmatched-steps) 0)
393 (+ 1 (- (length steps)
394 (length unmatched-steps)))))
395 (unmatched-with-1-3-5
396 (append (do ((i matched-steps (- i 1))
397 (base '() (cons `(0 ,(* (- i 1) 2) 0) base)))
401 (list exception-part unmatched-with-1-3-5)))
404 (define (chord::name->text style tonic steps bass-and-inversion)
405 (let* ((lookup (chord::exceptions-lookup style steps))
406 (exception-part (car lookup))
407 (unmatched-steps (cadr lookup)))
409 ((chord::restyle 'chord::name- style)
410 tonic exception-part unmatched-steps bass-and-inversion steps)))
412 (define (mydisplay x)
419 ;; Check for each subset of chord, full chord first, if there's a
420 ;; user-override. Split the chord into user-overridden and to-be-done
421 ;; parts, complete the missing user-override matched part with normal
422 ;; chord to be name-calculated.
424 ;; CHORD: (pitches (bass . inversion))
425 (define-public (default-chord-name-function style chord)
426 (let* ((pitches (map c++-pitch->scm (car chord)))
427 (modifiers (cdr chord))
428 (bass-and-inversion (if (pair? modifiers)
429 (cons (c++-pitch->scm (car modifiers))
430 (c++-pitch->scm (cdr modifiers)))
432 (diff (pitch::diff '(0 0 0) (car pitches)))
433 (steps (if (cdr pitches) (map (lambda (x)
434 (pitch::transpose x diff))
437 (chord::name->text style (car pitches) steps bass-and-inversion)
445 ;; NOTE: Duplicates of chord names defined elsewhere occur in this list
446 ;; in order to prevent spurious superscripting of various chord names,
447 ;; such as maj7, maj9, etc.
449 ;; See input/test/american-chords.ly
451 ;; James Hammons, <jlhamm@pacificnet.net>
454 ;; DONT use non-ascii characters, even if ``it works'' in Windows
456 (define-public chord::names-alist-american '())
458 (set! chord::names-alist-american
462 (((0 . 0) (2 . 0)) . #f)
464 (((0 . 0) (4 . 0)) . ("5"))
466 (((0 . 0) (2 . -1)) . ("m"))
467 (((0 . 0) (3 . 0) (4 . 0)) . ("sus"))
468 (((0 . 0) (2 . -1) (4 . -1)) . ("dim"))
469 ;Alternate: (((0 . 0) (2 . -1) (4 . -1)) . ("" (super "o")))
470 (((0 . 0) (2 . 0) (4 . 1)) . ("aug"))
471 ;Alternate: (((0 . 0) (2 . 0) (4 . 1)) . ("+"))
472 (((0 . 0) (1 . 0) (4 . 0)) . ("2"))
473 ;; Common seventh chords
474 (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ("" (super "o") " " "7"))
475 (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . ("maj7"))
476 ;; urg! should use (0 . 0 2 . -1) -> "m", and add "7" to that!!
477 (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . ("m7"))
478 (((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . ("7"))
479 (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . ("m(maj7)"))
480 ;jazz: the delta, see jazz-chords.ly
481 ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (super ((font-family . math) "N"))
483 (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (columns (super (overstrike "o") "/") " " "7"))
485 (((0 . 0) (2 . 0) (4 . 1) (6 . -1)) . ("aug7"))
486 (((0 . 0) (2 . 0) (4 . -1) (6 . 0)) . (columns "maj7" ((font-relative-size . -2) ((raise . 0.2) (music (named "accidentals--1")))) "5"))
487 (((0 . 0) (2 . 0) (4 . -1) (6 . -1)) . (columns "7" ((font-relative-size . -2) ((raise . 0.2) (music (named "accidentals--1")))) "5"))
488 (((0 . 0) (3 . 0) (4 . 0) (6 . -1)) . ("7sus4"))
489 ;; Common ninth chords
490 (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) . ("6/9")) ;; we don't want the '/no7'
491 (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) . ("6"))
492 (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) . ("m6"))
493 (((0 . 0) (2 . 0) (4 . 0) (1 . 0)) . ("add9"))
494 (((0 . 0) (2 . 0) (4 . 0) (6 . 0) (1 . 0)) . ("maj9"))
495 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0)) . ("9"))
496 (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) . ("m9"))
499 chord::names-alist-american))
502 ;; American style chordnames use no "no",
503 ;; but otherwise very similar to banter for now
504 (define-public (chord::name-american tonic exception-part unmatched-steps
505 bass-and-inversion steps)
506 (let ((additions (chord::additions unmatched-steps))
508 (chord::inner-name-banter tonic exception-part additions subtractions
509 bass-and-inversion steps)))
519 ;; Jazz chords, by Atte Andr'e Jensen <atte@post.com>
520 ;; NBs: This uses the american list as a bass.
521 ;; Some defs take up more than one line,
522 ;; be carefull when messing with ;'s!!
527 ;; This is getting out-of hand? Only exceptional chord names that
528 ;; cannot be generated should be here.
529 ;; Maybe we should have inner-name-jazz and inner-name-american functions;
533 ;; DONT use non-ascii characters, even if ``it works'' in Windows
535 (define-public chord::names-alist-jazz '())
536 (set! chord::names-alist-jazz
540 ; major sixth chord = 6
541 (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) . (((raise . 0.5) "6")))
542 ; major seventh chord = triangle
543 ;; shouldn't this be a filled black triange, like this: ? --jcn
544 ;; (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . (((raise . 0.5)((font-family . math) "N"))))
545 (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . (((raise . 0.5)((font-family . math) "M"))))
546 ; major chord add nine = add9
547 (((0 . 0) (2 . 0) (4 . 0) (1 . 0)) . (((raise . 0.5) "add9")))
548 ; major sixth chord with nine = 6/9
549 (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) . (((raise . 0.5) "6/9")))
552 ; minor sixth chord = m6
553 (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) . (columns("m")((raise . 0.5) "6")))
554 ;; minor major seventh chord = m triangle
555 ;; shouldn't this be a filled black triange, like this: ? --jcn
556 ;;(((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (columns ("m") ((raise . 0.5)((font-family . math) "N"))))
557 (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (columns ("m") ((raise . 0.5)((font-family . math) "M"))))
558 ; minor seventh chord = m7
559 (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . (columns("m")((raise . 0.5) "7")))
560 ; minor sixth nine chord = m6/9
561 (((0 . 0) (2 . -1) (4 . 0) (5 . 0) (1 . 0)) . (columns("m")((raise . 0.5) "6/9")))
562 ; minor with added nine chord = madd9
563 (((0 . 0) (2 . -1) (4 . 0) (1 . 0)) . (columns("m")((raise . 0.5) "add9")))
564 ; minor ninth chord = m9
565 (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) . (columns("m")((raise . 0.5) "9")))
568 ; dominant seventh = 7
569 (((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . (((raise . 0.5) "7")))
570 ; augmented dominant = +7
571 ;(((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (((raise . 0.5) "+7"))) ; +7 with both raised
572 (((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (columns("+")((raise . 0.5) "7"))) ; +7 with 7 raised
573 ;(((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (columns((raise . 0.5) "7(")
574 ; ((raise . 0.3)(music (named ("accidentals-1"))))
575 ; ((raise . 0.5) "5)"))); 7(#5)
576 ; dominant flat 5 = 7(b5)
577 (((0 . 0) (2 . 0) (4 . -1) (6 . -1)) . (columns((raise . 0.5) "7(")
578 ((raise . 0.3)(music (named ("accidentals--1"))))
579 ((raise . 0.5) "5)")))
581 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0)) . (((raise . 0.8)"7(9)")))
582 ; dominant flat 9 = 7(b9)
583 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1)) . (
585 ((raise . 0.3)(music (named ("accidentals--1"))))
586 ((raise . 0.8)"9)")))
587 ; dominant sharp 9 = 7(#9)
588 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1)) . (
590 ((raise . 0.3)(music (named ("accidentals-1"))))
591 ((raise . 0.8)"9)")))
592 ; dominant 13 = 7(13)
593 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (5 . 0)) . (((raise . 0.8)"7(13)")))
594 ; dominant flat 13 = 7(b13)
595 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (5 . -1)) . (
597 ((raise . 0.3)(music (named ("accidentals--1"))))
598 ((raise . 0.8)"13)")))
599 ; dominant 9, 13 = 7(9,13)
600 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0) (5 . 0)) . (((raise . 0.8)"7(9, 13)")))
601 ; dominant flat 9, 13 = 7(b9,13)
602 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1) (5 . 0)) . (
604 ((raise . 0.3)(music (named ("accidentals--1"))))
605 ((raise . 0.8)"9, 13)")))
606 ; dominant sharp 9, 13 = 7(#9,13)
607 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1) (5 . 0)) . (
609 ((raise . 0.3)(music (named ("accidentals-1"))))
610 ((raise . 0.8)"9, 13)")))
611 ; dominant 9, flat 13 = 7(9,b13)
612 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0) (5 . -1)) . (
613 ((raise . 0.8)"7(9, ")
614 ((raise . 0.3)(music (named ("accidentals--1"))))
615 ((raise . 0.8)"13)")))
616 ; dominant flat 9, flat 13 = 7(b9,b13)
617 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1) (5 . -1)) . (
619 ((raise . 0.3)(music (named ("accidentals--1"))))
621 ((raise . 0.3)(music (named ("accidentals--1"))))
622 ((raise . 0.8)"13)")))
623 ; dominant sharp 9, flat 13 = 7(#9,b13)
624 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1) (5 . -1)) . (
626 ((raise . 0.3)(music (named ("accidentals-1"))))
628 ((raise . 0.3)(music (named ("accidentals--1"))))
629 ((raise . 0.8)"13)")))
631 ;; diminished chord(s)
632 ; diminished seventh chord = o
635 ;; DONT use non-ascii characters, even if ``it works'' in Windows
637 ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ((raise . 0.8) (size . -2) ("o")))
638 (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ("" (super "o")))
640 ;; half diminshed chords
641 ;; half diminished seventh chord = slashed o
642 ;; (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (((raise . 0.8) "/o")))
643 (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (columns (super (overstrike "o") "/") " " "7")) ; slashed o
645 ; half diminished seventh chord with major 9 = slashed o cancelation 9
646 (((0 . 0) (2 . -1) (4 . -1) (6 . -1) (1 . 0)) . (
648 ((raise . 0.3)(music (named ("accidentals-0"))))
649 ((raise . 0.8)"9)")));
651 ;; Missing jazz chord definitions go here (note new syntax: see american for hints)
654 chord::names-alist-american))
656 (define (step->text-alternate-jazz pitch)
658 (accidental->text (caddr pitch))
659 (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))))
661 (define (step->text-jazz pitch)
662 (if (= (cadr pitch) 6)
664 ;; sharp 7 only included for completeness?
665 ((-2) (text-append (accidental->text -1) '("7")))
668 ((1) (text-append (accidental->text-super 1) '("7")))
669 ((2) (text-append (accidental->text-super 2) '("7"))))
670 (step->text-alternate-jazz pitch)))
672 (define (xchord::additions->text-jazz additions subtractions)
673 (if (pair? additions)
675 (let ((step (step->text-jazz (car additions))))
676 (if (or (pair? (cdr additions))
677 (pair? subtractions))
678 (text-append step "/")
680 (chord::additions->text-jazz (cdr additions) subtractions))
683 (define (chord::>5? x)
689 ;; Perhaps all logic like this should be done earlier,
690 ;; so that in this text-construction printing phase
691 ;; we can just blindly create text from all additions.
693 ;; This depends maybe on the fact of code sharing,
694 ;; in this layout, we can share the functions chord::additions
695 ;; and chord::subtractions with banter.
696 (define (chord::additions->text-jazz additions subtractions)
698 (chord::additions<=5->text-jazz (filter-out-list chord::>5? additions)
699 (filter-out-list chord::>5? subtractions))
700 (chord::additions>5->text-jazz (filter-list chord::>5? additions)
701 (filter-list chord::>5? subtractions))))
704 (define (chord::additions<=5->text-jazz additions subtractions)
705 (let ((sus (chord::sus-four-jazz additions)))
707 (text-append '("sus") (step->text-jazz (car sus)))
710 (define (chord::additions>5->text-jazz additions subtractions)
712 Compose text of all additions
714 * if there's a subtraction:
716 - list all up to highest
717 * list all steps that are below an chromatically altered step
720 (if (not (null? subtractions)) "add" '())
721 (let ((radds (reverse additions)))
722 (reverse (chord::additions>5->text-jazz-helper
725 (if (or (null? subtractions) (null? radds))
728 (define (chord::additions>5->text-jazz-helper additions subtractions list-step)
730 Create texts for all additions
731 If list-step != #f, list all steps down to 5
732 If we encounter a chromatically altered step, turn on list-step
736 (if (not (member list-step subtractions))
737 (if (> 5 (cadr list-step))
738 (cons (step->text-jazz list-step)
739 (chord::additions>5->text-jazz-helper
742 (chord::get-create-step additions
743 (- (cadr list-step) 2))))
744 (step->text-jazz list-step))
745 (chord::get-create-step additions (- (cadr list-step) 2)))
746 (if (pair? additions)
747 (let ((step (car additions)))
748 (cons (step->text-jazz step)
749 (chord::additions>5->text-jazz-helper
752 (if (or (and (!= 6 (cadr step)) (!= 0 (caddr step)))
753 (and (= 6 (cadr step)) (!= -1 (caddr step))))
754 (chord::get-create-step additions (- (cadr step) 2))
758 (define (chord::sus-four-jazz chord-pitches)
759 "List of pitches that are step 2 or step 4"
760 (filter-list (lambda (x)
762 (or (= 1 (cadr x)) (= 3 (cadr x))))) chord-pitches))
764 (define (chord::get-create-step steps n)
765 (let* ((i (if (< n 0) (+ n 7) n))
766 (found (filter-list (lambda (x) (= i (cadr x))) steps)))
773 (define (chord::subtractions->text-jazz subtractions)
774 (if (pair? subtractions)
776 (if (= 5 (cadr (car subtractions)))
779 (let ((step (step->text-jazz (car subtractions))))
780 (if (pair? (cdr subtractions))
781 (text-append step "/")
784 (chord::subtractions->text-jazz (cdr subtractions)))
788 ;; TODO: maybe merge with inner-name-banter
789 ;; Combine tonic, exception-part of chord name,
790 ;; additions, subtractions and bass or inversion into chord name
791 (define (chord::inner-name-jazz tonic exception-part additions subtractions
792 bass-and-inversion steps)
794 (pitch->chord-name-text-banter tonic steps)
796 ;; why does list->string not work, format seems only hope...
797 (if (and (string-match "super" (format "~s" exception-part))
798 (or (pair? additions)
799 (pair? subtractions)))
800 (list simple-super "/"))
802 (list `(,simple-super)
803 (chord::additions->text-jazz additions subtractions)
804 (chord::subtractions->text-jazz subtractions))
805 (chord::bass-and-inversion->text-banter bass-and-inversion)))
807 ;; Jazz style--basically similar to american with minor changes
809 ;; Consider Dm6. When we get here:
810 ;; tonic = '(0 1 0) (note d=2)
811 ;; steps = '((0 0 0) '(0 2 -1) (0 4 0) (0 5 0))
812 ;; steps are transposed for tonic c, octave 0,
813 ;; so (car steps) is always (0 0 0)
815 ;; assuming that the exceptions-alist has an entry
816 ;; '(((0 . 0) (2 . -1)) . ("m"))
817 ;; (and NOT the full chord, like std jazz list, ugh)
818 ;; unmatch = '((0 0 0) (0 2 0) (0 4 0) (0 5 0))
821 ;; You can look very easily what happens, if you add some write-me calls,
822 ;; and run lilypond on a simple file, eg, containing only the chord c:m6:
824 ;; (let ((additions (write-me "adds: "
825 ;; (chord::additions (write-me "unmatched:"
826 ;; unmatched-steps))))
828 ;; If you set subtract #f, the chord::inner-name-jazz does not see any
829 ;; subtractions, ever, so they don't turn up in the chord name.
831 (define-public (chord::name-jazz tonic exception-part unmatched-steps
832 bass-and-inversion steps)
833 (let ((additions (chord::additions unmatched-steps))
834 ;; get no 'omit' or 'no'
835 ;; (subtractions #f))
836 (subtractions (chord::subtractions unmatched-steps)))
837 (chord::inner-name-jazz tonic exception-part additions subtractions
838 bass-and-inversion steps)))
840 ;; wip (set! chord::names-alist-jazz
841 (define chord::names-alist-jazz
844 (((0 . 0) (2 . -1)) . ("m"))
846 ;; some fixups -- jcn
847 ; major seventh chord = triangle
848 (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . (((raise . 0.5)((font-family . math) "N"))))
849 ;; (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . (((raise . 0.5)((font-family . math) "M"))))
851 ;; minor major seventh chord = m triangle
852 (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (columns ("m") ((raise . 0.5)((font-family . math) "N"))))
853 ;; (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (columns ("m") ((raise . 0.5)((font-family . math) "M"))))
857 chord::names-alist-american))
859 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
862 (define-public (new-chord-name-brew-molecule grob)
865 (style-prop (ly:get-grob-property grob 'style))
866 (style (if (symbol? style-prop) style-prop 'banter))
867 (chord (ly:get-grob-property grob 'chord))
868 (chordf (ly:get-grob-property grob 'chord-name-function))
869 (ws (ly:get-grob-property grob 'word-space))
870 (markup (chordf style chord))
871 (molecule (interpret-markup grob
872 (cons '((word-space . 0.0))
873 (Font_interface::get_property_alist_chain grob))
878 ;;; TODO: BUG : word-space is in local staff-space (?)
880 (ly:combine-molecule-at-edge molecule
881 X RIGHT (ly:make-molecule "" (cons 0 ws) '(-1 . 1) )