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>
21 - Use lilypond Pitch objects -- SCM pitch objects leads to duplication.
23 - Pitches are musical objects. The pitches -> markup step should
24 happen earlier (during interpreting), brew-molecule () should only
25 dump reinterpret the markup as a molecule.
30 ;; pitch = (octave notename alteration)
32 ;; note = (notename . alteration)
34 ;; text = scm markup text -- see font.scm and input/test/markup.ly
39 ;; Ugh : naming chord::... ; this is scheme not C++
41 ;; * easier tweakability:
42 ;; - split chord::names-alists up into logical bits,
43 ;; such as chord::exceptions-delta, exceptions-oslash
44 ;; - iso just the 'style parameter, use a list, eg:
45 ;; \property ChordNames.ChordName \set
46 ;; #'style = #'(jazz delta oslash german-tonic german-Bb)
50 ;; * clean split/merge of bass/banter/american stuff
54 (define-public chord::names-alist-banter '())
55 (set! chord::names-alist-banter
59 (((0 . 0)) . (,simple-markup ""))
61 (((0 . 0) (2 . 0)) . (,simple-markup ""))
63 (((0 . 0) (2 . -1)) . (,simple-markup "m"))
65 (((0 . 0) (1 . 0) (4 . 0)) . (,super-markup (,simple-markup "2 ")))
67 (((0 . 0) (3 . 0) (4 . 0)) . (,super-markup (,simple-markup "4 ")))
69 (((0 . 0) (2 . -1) (4 . -1)) . (,simple-markup "dim"))
70 ; URG: Simply C:m5-/maj7 iso Cdim maj7
71 (((0 . 0) (2 . -1) (4 . -1) (6 . 0)) . (,line-markup ((,simple-markup "m") (,super-markup (,simple-markup "5-/maj7 ")))))
72 ; URG: Simply C:m5-/7 iso Cdim7
73 (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (,line-markup ((,simple-markup "m") (,super-markup (,simple-markup "5-/7 ")))))
75 (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (,super-markup (,simple-markup "o ")))
77 (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1)) . (,line-markup ((,simple-markup "dim")
78 (,simple-markup "9 "))))
79 (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1) (3 . -1))
80 . (,line-markup ((,simple-markup "dim")
81 (,super-markup (,simple-markup "11 ")))))
84 chord::names-alist-banter))
88 (define (pitch->note-name pitch)
89 (cons (cadr pitch) (caddr pitch)))
91 (define (accidental-markup acc)
92 "ACC is an int, return a markup making an accidental."
95 `(,smaller-markup (,musicglyph-markup ,(string-append "accidentals-" (number->string acc))))
98 (define (pitch->markup 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->markup-banter pitch->markup)
111 ;; We need also steps, to allow for Cc name override,
112 ;; see input/test/Cc-chords.ly
113 (define (pitch->chord-name-markup-banter pitch steps)
114 (pitch->markup-banter pitch))
116 (define pitch->note-name-markup-banter pitch->markup-banter)
118 (define (step->markup pitch)
120 (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))
128 (define (step->markup-banter pitch)
130 (if (= (cadr pitch) 6)
137 (step->markup pitch))))
139 (define pitch::semitone-vec #(0 2 4 5 7 9 11))
141 (define (pitch::semitone pitch)
142 (+ (* (car pitch) 12)
143 (vector-ref pitch::semitone-vec (modulo (cadr pitch) 7))
146 (define (pitch::< l r)
147 (< (pitch::semitone l) (pitch::semitone r)))
149 (define (pitch::transpose pitch delta)
150 (let ((simple-octave (+ (car pitch) (car delta)))
151 (simple-notename (+ (cadr pitch) (cadr delta))))
152 (let ((octave (+ simple-octave (quotient simple-notename 7)))
153 (notename (modulo simple-notename 7)))
154 (let ((accidental (- (+ (pitch::semitone pitch) (pitch::semitone delta))
155 (pitch::semitone `(,octave ,notename 0)))))
156 `(,octave ,notename ,accidental)))))
158 (define (pitch::diff pitch tonic)
159 (let ((simple-octave (- (car pitch) (car tonic)))
160 (simple-notename (- (cadr pitch) (cadr tonic))))
161 (let ((octave (+ simple-octave (quotient simple-notename 7)
162 (if (< simple-notename 0) -1 0)))
163 (notename (modulo simple-notename 7)))
164 (let ((accidental (- (pitch::semitone pitch)
165 (pitch::semitone tonic)
166 (pitch::semitone `(,octave ,notename 0)))))
167 `(,octave ,notename ,accidental)))))
169 (define (pitch::note-pitch pitch)
170 (+ (* (car pitch) 7) (cadr pitch)))
172 ;; markup: list of word
173 ;; word: string + optional list of property
174 ;; property: axis, kern, font (?), size
176 (define chord::minor-major-vec (list->vector '(0 -1 -1 0 -1 -1 0)))
179 ;; compute the relative-to-tonic pitch that goes with 'step'
180 (define (chord::step-pitch tonic step)
181 ;; urg, we only do this for thirds
182 (if (= (modulo step 2) 0)
184 (let loop ((i 1) (pitch tonic))
188 pitch `(0 2 ,(vector-ref chord::minor-major-vec
189 ;; -1 (step=1 -> vector=0) + 7 = 6
190 (modulo (+ i 6) 7)))))))))
192 (define (chord::additions steps)
194 * any even step (2, 4, 6)
195 * any uneven step that is chromatically altered,
196 (where 7-- == -1, 7- == 0, 7 == +1)
199 ?and jazz needs also:
201 * TODO: any uneven step that's lower than an uneven step which is
202 chromatically altered
204 (let ((evens (filter-list (lambda (x) (!= 0 (modulo (cadr x) 2))) steps))
206 (filter-list (lambda (x)
207 (let ((n (cadr x)) (a (caddr x)))
208 (or (and (= 6 n) (!= -1 a))
213 (highest (let ((h (car (last-pair steps))))
214 (if (and (not (null? h))
219 ;; Hmm, what if we have a step twice, can we ignore that?
220 (uniq-list (sort (apply append evens altered-unevens highest)
224 ;; FIXME: unLOOP, see ::additions
225 ;; find the pitches that are missing from `normal' chord
226 (define (chord::subtractions chord-pitches)
227 (let ((tonic (car chord-pitches)))
228 (let loop ((step 1) (pitches chord-pitches) (subtractions '()))
230 (let* ((pitch (car pitches))
231 (p-step (+ (- (pitch::note-pitch pitch)
232 (pitch::note-pitch tonic))
234 ;; pitch is an subtraction if
235 ;; a step is missing or
237 (loop (+ step 2) pitches
238 (cons (chord::step-pitch tonic step) subtractions))
239 ;; there are no pitches left, but base thirds are not yet done and
241 (= (length pitches) 1))
242 ;; present pitch is not missing step
244 (loop (+ step 2) pitches subtractions)
245 (loop (+ step 2) pitches
246 (cons (chord::step-pitch tonic step) subtractions)))
248 (loop (+ step 2) (cdr pitches) subtractions)
249 (loop step (cdr pitches) subtractions)))))
250 (reverse subtractions)))))
252 (define (chord::additions->markup-banter additions subtractions)
253 (if (pair? additions)
256 (let ((step (step->markup-banter (car additions))))
257 (if (or (pair? (cdr additions))
258 (pair? subtractions))
260 (list step (list simple-markup "/")))
263 (chord::additions->markup-banter (cdr additions) subtractions)))
264 (list simple-markup "")
268 (define (chord::subtractions->markup-banter subtractions)
269 (if (pair? subtractions)
271 (list simple-markup "no")
272 (let ((step (step->markup-jazz (car subtractions))))
273 (if (pair? (cdr subtractions))
274 (list line-markup (list step (list simple-markup "/")))
276 (chord::subtractions->markup-banter (cdr subtractions)))
277 (list simple-markup "")
280 (define (chord::bass-and-inversion->markup-banter bass-and-inversion)
281 (if (and (pair? bass-and-inversion)
282 (or (car bass-and-inversion)
283 (cdr bass-and-inversion)))
287 (list simple-markup "/")
288 (pitch->note-name-markup-banter
289 (if (car bass-and-inversion)
290 (car bass-and-inversion)
291 (cdr bass-and-inversion)))
293 (list simple-markup "")
296 ;; FIXME: merge this function with inner-name-jazz, -american
297 ;; iso using chord::bass-and-inversion->markup-banter,
298 ;; call (chord::restyle 'chord::bass-and-inversion->markup- style)
299 ;; See: chord::exceptions-lookup
300 (define (chord::inner-name-banter tonic exception-part additions subtractions
301 bass-and-inversion steps)
306 Combine tonic, exception-part of chord name,
307 additions, subtractions and bass or inversion into chord name
310 (let* ((tonic-markup (pitch->chord-name-markup-banter tonic steps))
311 (except-markup exception-part)
312 (sep-markup (list simple-markup
313 (if (and (string-match "super" (format "~s" except-markup))
314 (or (pair? additions)
315 (pair? subtractions)))
318 (adds-markup (chord::additions->markup-banter additions subtractions))
319 (subs-markup (chord::subtractions->markup-banter subtractions))
320 (b+i-markup (chord::bass-and-inversion->markup-banter bass-and-inversion)))
327 (,line-markup (,adds-markup ,subs-markup))
333 (define (c++-pitch->scm p)
335 (list (ly:pitch-octave p) (ly:pitch-notename p) (ly:pitch-alteration p))
338 (define-public (chord::name-banter tonic exception-part unmatched-steps
339 bass-and-inversion steps)
340 (let ((additions (chord::additions unmatched-steps))
341 (subtractions (chord::subtractions unmatched-steps)))
343 (chord::inner-name-banter tonic exception-part additions subtractions
344 bass-and-inversion steps)))
347 (define (chord::restyle name style)
348 (primitive-eval ;; "UGGHGUGHUGHG"
351 (string-append (symbol->string name)
352 (symbol->string style)))))
354 ;; check exceptions-alist for biggest matching part of try-steps
355 ;; return (MATCHED-EXCEPTION . UNMATCHED-STEPS)
356 (define (chord::exceptions-lookup-helper
357 exceptions-alist try-steps unmatched-steps exception-part)
358 (if (pair? try-steps)
359 ;; FIXME: junk '(0 . 0) from exceptions lists?
360 ;; if so: how to handle first '((0 . 0) . #f) entry?
362 ;; FIXME: either format exceptions list as real pitches, ie,
363 ;; including octave '((0 2 -1) ..), or drop octave
364 ;; from rest of calculations,
366 (map (lambda (x) (pitch->note-name x))
367 (append '((0 0 0)) try-steps))
370 (chord::exceptions-lookup-helper
371 #f '() unmatched-steps (cdr entry))
372 (let ((r (reverse try-steps)))
373 (chord::exceptions-lookup-helper
376 (cons (car r) unmatched-steps) #f))))
377 (cons exception-part unmatched-steps)))
379 ;; return (MATCHED-EXCEPTION . BASE-CHORD-WITH-UNMATCHED-STEPS)
380 ;; BASE-CHORD-WITH-UNMATCHED-STEPS always includes (tonic 3 5)
381 (define (chord::exceptions-lookup style steps)
382 (let* ((result (chord::exceptions-lookup-helper
383 (chord::restyle 'chord::names-alist- style)
385 (exception-part (car result))
386 (unmatched-steps (cdr result))
387 (matched-steps (if (= (length unmatched-steps) 0)
389 (+ 1 (- (length steps)
390 (length unmatched-steps)))))
391 (unmatched-with-1-3-5
392 (append (do ((i matched-steps (- i 1))
393 (base '() (cons `(0 ,(* (- i 1) 2) 0) base)))
397 (list exception-part unmatched-with-1-3-5)))
400 (define (chord::name->markup style tonic steps bass-and-inversion)
401 (let* ((lookup (chord::exceptions-lookup style steps))
402 (exception-part (car lookup))
403 (unmatched-steps (cadr lookup))
404 (func (chord::restyle 'chord::name- style))
409 (func tonic exception-part unmatched-steps bass-and-inversion steps)))
413 ;; Check for each subset of chord, full chord first, if there's a
414 ;; user-override. Split the chord into user-overridden and to-be-done
415 ;; parts, complete the missing user-override matched part with normal
416 ;; chord to be name-calculated.
418 ;; CHORD: (pitches (bass . inversion))
419 (define-public (chord->markup style chord)
420 (let* ((pitches (map c++-pitch->scm (car chord)))
421 (modifiers (cdr chord))
422 (bass-and-inversion (if (pair? modifiers)
423 (cons (c++-pitch->scm (car modifiers))
424 (c++-pitch->scm (cdr modifiers)))
426 (diff (pitch::diff '(0 0 0) (car pitches)))
427 (steps (if (cdr pitches) (map (lambda (x)
428 (pitch::transpose x diff))
432 (chord::name->markup style (car pitches) steps bass-and-inversion)
440 ;; NOTE: Duplicates of chord names defined elsewhere occur in this list
441 ;; in order to prevent spurious superscripting of various chord names,
442 ;; such as maj7, maj9, etc.
444 ;; See input/test/american-chords.ly
446 ;; James Hammons, <jlhamm@pacificnet.net>
449 ;; DONT use non-ascii characters, even if ``it works'' in Windows
451 (define-public chord::names-alist-american '())
453 (set! chord::names-alist-american
456 (((0 . 0)) . ,empty-markup)
457 (((0 . 0) (2 . 0)) . ,empty-markup)
459 (((0 . 0) (4 . 0)) . (,simple-markup "5"))
461 (((0 . 0) (2 . -1)) . (,simple-markup "m"))
462 (((0 . 0) (3 . 0) (4 . 0)) . (,simple-markup "sus"))
463 (((0 . 0) (2 . -1) (4 . -1)) . (,simple-markup "dim"))
464 ;Alternate: (((0 . 0) (2 . -1) (4 . -1)) . ("" (super "o")))
465 (((0 . 0) (2 . 0) (4 . 1)) . (,simple-markup "aug"))
466 ;Alternate: (((0 . 0) (2 . 0) (4 . 1)) . ("+"))
467 (((0 . 0) (1 . 0) (4 . 0)) . (,simple-markup "2"))
468 ;; Common seventh chords
469 (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) .
471 ((,super-markup (,simple-markup "o"))
472 (,simple-markup " 7"))))
473 (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . (,simple-markup "maj7"))
474 ;; urg! should use (0 . 0 2 . -1) -> "m", and add "7" to that!!
475 (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . (,simple-markup "m7"))
476 (((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . (,simple-markup "7"))
477 (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (,simple-markup "m(maj7)"))
478 ;jazz: the delta, see jazz-chords.ly
479 ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (super ((font-family . math) "N"))
481 (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) .
484 (,combine-markup (,simple-markup "o")
485 (,simple-markup "/")))
486 (,simple-markup " 7"))))
487 (((0 . 0) (2 . 0) (4 . 1) (6 . -1)) . (,simple-markup "aug7"))
488 (((0 . 0) (2 . 0) (4 . -1) (6 . 0))
490 ((,simple-markup "maj7")
491 (,small-markup (,raise-markup 0.2 ,(accidental-markup -1)))
492 (,simple-markup "5"))))
493 (((0 . 0) (2 . 0) (4 . -1) (6 . -1)) .
495 ((,simple-markup "7")
496 (,small-markup (,raise-markup 0.2 ,(accidental-markup -1)))
497 (,simple-markup "5"))))
498 (((0 . 0) (3 . 0) (4 . 0) (6 . -1)) . (,simple-markup "7sus4"))
499 ;; Common ninth chords
500 (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) . (,simple-markup "6/9")) ;; we don't want the '/no7'
501 (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) . (,simple-markup "6"))
502 (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) . (,simple-markup "m6"))
503 (((0 . 0) (2 . 0) (4 . 0) (1 . 0)) . (,simple-markup "add9"))
504 (((0 . 0) (2 . 0) (4 . 0) (6 . 0) (1 . 0)) . (,simple-markup "maj9"))
505 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0)) . (,simple-markup "9"))
506 (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) . (,simple-markup "m9"))
509 chord::names-alist-american))
512 ;; American style chordnames use no "no",
513 ;; but otherwise very similar to banter for now
514 (define-public (chord::name-american tonic exception-part unmatched-steps
515 bass-and-inversion steps)
516 (let ((additions (chord::additions unmatched-steps))
518 (chord::inner-name-banter tonic exception-part additions subtractions
519 bass-and-inversion steps)))
529 ;; Jazz chords, by Atte Andr'e Jensen <atte@post.com>
530 ;; NBs: This uses the american list as a bass.
531 ;; Some defs take up more than one line,
532 ;; be carefull when messing with ;'s!!
537 ;; This is getting out-of hand? Only exceptional chord names that
538 ;; cannot be generated should be here.
539 ;; Maybe we should have inner-name-jazz and inner-name-american functions;
543 ;; DONT use non-ascii characters, even if ``it works'' in Windows
545 (define mathm-markup-object `(,override-markup (font-family . math) (,simple-markup "M")))
546 (define mraise-arg `(,line-markup
547 ((,simple-markup "m")
548 (,raise-markup 0.5 (,simple-markup arg)))))
550 (define (raise-some-for-jazz arg-list)
553 ("@" `(,raise-markup 0.3 ,(accidental-markup -1)))
554 ("#" `(,raise-markup 0.3 ,(accidental-markup 1)))
555 (else `(,raise-markup 0.8 ,x))))
557 `(line-markup ,(map do-one arg-list)))
559 (define-public chord::names-alist-jazz '())
560 (set! chord::names-alist-jazz
564 ; major sixth chord = 6
565 (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) .
566 (,raise-markup 0.5 (,simple-markup "6")))
567 ; major seventh chord = triangle
568 ;; shouldn't this be a filled black triange, like this: ? --jcn
569 ;; (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . (((raise . 0.5)((font-family . math) "N"))))
570 (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) .
576 ; major chord add nine = add9
577 (((0 . 0) (2 . 0) (4 . 0) (1 . 0)) . (,raise-markup 0.5 (,simple-markup "add9")))
578 ; major sixth chord with nine = 6/9
579 (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) . (,raise-markup 0.5 (,simple-markup "add9")))
582 ; minor sixth chord = m6
583 (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) .
586 ;; minor major seventh chord = m triangle
587 ;; shouldn't this be a filled black triange, like this: ? --jcn
588 ;;(((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (columns ("m") ((raise . 0.5)((font-family . math) "N"))))
589 (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) .
590 (,line-markup (,simple-markup "m") ,mathm-markup-object))
591 ; minor seventh chord = m7
592 (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . ,(mraise-arg "7"))
593 ; minor sixth nine chord = m6/9
594 (((0 . 0) (2 . -1) (4 . 0) (5 . 0) (1 . 0)) . ,(mraise-arg "6/9"))
596 ; minor with added nine chord = madd9
597 (((0 . 0) (2 . -1) (4 . 0) (1 . 0)) . ,(mraise-arg "madd9"))
599 ; minor ninth chord = m9
600 (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) . ,(mraise-arg "add9"))
603 ; dominant seventh = 7
604 (((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . (,raise-markup 0.5 (,simple-markup "7")))
605 ; augmented dominant = +7
606 ;(((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (((raise . 0.5) "+7"))) ; +7 with both raised
607 (((0 . 0) (2 . 0) (4 . +1) (6 . -1)) .
608 (,line-markup ((,simple-markup "+")
609 (,raise-markup 0.5 (,simple-markup "7"))))) ; +7 with 7 raised
610 ;(((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (columns((raise . 0.5) "7(")
611 ; ((raise . 0.3)(music (named ("accidentals-1"))))
612 ; ((raise . 0.5) "5)"))); 7(#5)
613 ; dominant flat 5 = 7(b5)
615 (((0 . 0) (2 . 0) (4 . -1) (6 . -1)) . ,(raise-some-for-jazz '( "7(" "@" "5)" )))
618 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0)) .
619 ,(raise-some-for-jazz '("7(9)")))
620 ; dominant flat 9 = 7(b9)
621 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1)) .
622 ,(raise-some-for-jazz '("7(" "@" "9)")))
624 ; dominant sharp 9 = 7(#9)
625 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1)) .
626 ,(raise-some-for-jazz '("7(" "#" "9)")))
628 ; dominant 13 = 7(13)
629 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (5 . 0)) .
630 ,(raise-some-for-jazz "7(13)"))
631 ; dominant flat 13 = 7(b13)
632 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (5 . -1)) .
633 ,(raise-some-for-jazz '( "7(" "@" "13)")))
635 ; dominant 9, 13 = 7(9,13)
636 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0) (5 . 0)) .
637 ,(raise-some-for-jazz '("7(9, 13)")))
638 ; dominant flat 9, 13 = 7(b9,13)
639 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1) (5 . 0)) .
640 ,(raise-some-for-jazz '("7(" "@" "9, 13)")))
642 ; dominant sharp 9, 13 = 7(#9,13)
643 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1) (5 . 0)) .
644 ,(raise-some-for-jazz '("7(" "#" "9,13)")))
646 ; dominant 9, flat 13 = 7(9,b13)
647 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0) (5 . -1)) .
648 ,(raise-some-for-jazz "7(9, " "@" "13)"))
650 ; dominant flat 9, flat 13 = 7(b9,b13)
651 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1) (5 . -1)) .
652 ,(raise-some-for-jazz '("7(" "@" "9, " "@" "13)")))
654 ; dominant sharp 9, flat 13 = 7(#9,b13)
655 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1) (5 . -1)) .
656 ,(raise-some-for-jazz '("7(" "#" "9, " "@" "13)")))
658 ;; diminished chord(s)
659 ; diminished seventh chord = o
662 ;; DONT use non-ascii characters, even if ``it works'' in Windows
664 ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ((raise . 0.8) (size . -2) ("o")))
665 (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) .
666 (,super-markup (,simple-markup "o")))
668 ;; half diminshed chords
669 ;; half diminished seventh chord = slashed o
670 ;; (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (((raise . 0.8) "/o")))
671 (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) .
672 (,line-markup (,super-markup
673 (,combine-markup (,simple-markup "o") (,simple-markup "/")))
674 (,simple-markup " 7")))
675 ; half diminished seventh chord with major 9 = slashed o cancelation 9
676 (((0 . 0) (2 . -1) (4 . -1) (6 . -1) (1 . 0)) .
677 ,(raise-some-for-jazz '("/o(" "!" "9)")))
679 ;; Missing jazz chord definitions go here (note new syntax: see american for hints)
682 chord::names-alist-american))
684 (define (step->markup-alternate-jazz pitch)
686 (,(accidental-markup (caddr pitch))
687 (,simple-markup (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))))))
689 (define (step->markup-jazz pitch)
690 (if (= (cadr pitch) 6)
692 ;; sharp 7 only included for completeness?
695 (,(accidental-markup -1)
696 (,simple-markup "7"))
698 ((-1) `(,simple-markup "7"))
699 ((0) `(,simple-markup "maj7"))
701 (,(accidental-markup 1)
702 (,simple-markup "7"))))
704 (,(accidental-markup 1)
705 (,simple-markup "7"))))
707 (step->markup-alternate-jazz pitch)))
709 (define (xchord::additions->markup-jazz additions subtractions)
710 (if (pair? additions)
712 (let ((step (step->markup-jazz (car additions))))
713 (if (or (pair? (cdr additions))
714 (pair? subtractions))
715 (list step (list simple-markup "/"))
717 (chord::additions->markup-jazz (cdr additions) subtractions))
721 (define (chord::>5? x)
727 ;; Perhaps all logic like this should be done earlier,
728 ;; so that in this markup-construction printing phase
729 ;; we can just blindly create markup from all additions.
731 ;; This depends maybe on the fact of code sharing,
732 ;; in this layout, we can share the functions chord::additions
733 ;; and chord::subtractions with banter.
734 (define (chord::additions->markup-jazz additions subtractions)
738 ,(chord::additions<=5->markup-jazz (filter-out-list chord::>5? additions)
739 (filter-out-list chord::>5? subtractions))
740 ,(chord::additions>5->markup-jazz (filter-list chord::>5? additions)
741 (filter-list chord::>5? subtractions)))))
746 (define (chord::additions<=5->markup-jazz additions subtractions)
747 (let ((sus (chord::sus-four-jazz additions)))
749 `(,line-markup ((,simple-markup "sus")
750 ,(step->markup-jazz (car sus))))
751 `(,simple-markup "")))
755 (define (chord::additions>5->markup-jazz additions subtractions)
757 Compose markup of all additions
759 * if there's a subtraction:
761 - list all up to highest
762 * list all steps that are below an chromatically altered step
766 (,(if (not (null? subtractions))
767 `(,simple-markup "add")
771 `(,simple-markup "fixme")
772 ;; this is totally incomprehensible. Fix me, and docme.
774 ((radds (reverse additions)))
776 (reverse (chord::additions>5->markup-jazz-helper
779 (if (or (null? subtractions) (null? radds))
786 (define (chord::additions>5->markup-jazz-helper additions subtractions list-step)
788 Create markups for all additions
789 If list-step != #f, list all steps down to 5
790 If we encounter a chromatically altered step, turn on list-step
794 (if (not (member list-step subtractions))
795 (if (> 5 (cadr list-step))
796 (cons (step->markup-jazz list-step)
797 (chord::additions>5->markup-jazz-helper
800 (chord::get-create-step additions
801 (- (cadr list-step) 2))))
802 (step->markup-jazz list-step))
803 (chord::get-create-step additions (- (cadr list-step) 2)))
804 (if (pair? additions)
805 (let ((step (car additions)))
806 (cons (step->markup-jazz step)
807 (chord::additions>5->markup-jazz-helper
810 (if (or (and (!= 6 (cadr step)) (!= 0 (caddr step)))
811 (and (= 6 (cadr step)) (!= -1 (caddr step))))
812 (chord::get-create-step additions (- (cadr step) 2))
816 (define (chord::sus-four-jazz chord-pitches)
817 "List of pitches that are step 2 or step 4"
819 (filter-list (lambda (x)
821 (or (= 1 (cadr x)) (= 3 (cadr x))))) chord-pitches))
823 (define (chord::get-create-step steps n)
824 (let* ((i (if (< n 0) (+ n 7) n))
825 (found (filter-list (lambda (x) (= i (cadr x))) steps)))
832 (define (chord::subtractions->markup-jazz subtractions)
833 (if (pair? subtractions)
835 (,(if (= 5 (cadr (car subtractions)))
837 ((,simple-markup "omit")
840 ((step (step->markup-jazz (car subtractions))))
841 (if (pair? (cdr subtractions))
842 `(,line-markup ( step (,simple-markup "/")))
845 ,(chord::subtractions->markup-jazz (cdr subtractions))))
848 ;; TODO: maybe merge with inner-name-banter
849 ;; Combine tonic, exception-part of chord name,
850 ;; additions, subtractions and bass or inversion into chord name
851 (define (chord::inner-name-jazz tonic exception-part additions subtractions
852 bass-and-inversion steps)
855 ,(pitch->chord-name-markup-banter tonic steps)
857 ;; why does list->string not work, format seems only hope...
858 ,(if (and (string-match "super" (format "~s" exception-part))
859 (or (pair? additions)
860 (pair? subtractions)))
861 (list super-markup (list simple-markup "/"))
869 ,(chord::additions->markup-jazz additions subtractions)
870 ,(chord::subtractions->markup-jazz subtractions))))
872 ,(chord::bass-and-inversion->markup-banter bass-and-inversion))))
874 ;; Jazz style--basically similar to american with minor changes
876 ;; Consider Dm6. When we get here:
877 ;; tonic = '(0 1 0) (note d=2)
878 ;; steps = '((0 0 0) '(0 2 -1) (0 4 0) (0 5 0))
879 ;; steps are transposed for tonic c, octave 0,
880 ;; so (car steps) is always (0 0 0)
882 ;; assuming that the exceptions-alist has an entry
883 ;; '(((0 . 0) (2 . -1)) . ("m"))
884 ;; (and NOT the full chord, like std jazz list, ugh)
885 ;; unmatch = '((0 0 0) (0 2 0) (0 4 0) (0 5 0))
888 ;; You can look very easily what happens, if you add some write-me calls,
889 ;; and run lilypond on a simple file, eg, containing only the chord c:m6:
891 ;; (let ((additions (write-me "adds: "
892 ;; (chord::additions (write-me "unmatched:"
893 ;; unmatched-steps))))
895 ;; If you set subtract #f, the chord::inner-name-jazz does not see any
896 ;; subtractions, ever, so they don't turn up in the chord name.
898 (define-public (chord::name-jazz tonic exception-part unmatched-steps
899 bass-and-inversion steps)
900 (let ((additions (chord::additions unmatched-steps))
901 ;; get no 'omit' or 'no'
902 ;; (subtractions #f))
903 (subtractions (chord::subtractions unmatched-steps)))
905 (chord::inner-name-jazz tonic exception-part additions subtractions
906 bass-and-inversion steps)))
908 ;; wip (set! chord::names-alist-jazz
909 (define chord::names-alist-jazz
912 (((0 . 0) (2 . -1)) . ("m"))
914 ;; some fixups -- jcn
915 ; major seventh chord = triangle
916 (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) .
917 (,raise-markup 0.5 ,mathm-markup-object))
919 ;; minor major seventh chord = m triangle
920 (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) .
921 (,line-markup ((,simple-markup "m")
922 (,raise-markup 0.5 ,mathm-markup-object))))
923 ;; (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (columns ("m") ((raise . 0.5)((font-family . math) "M"))))
927 chord::names-alist-american))
929 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
932 (define-public (new-chord-name-brew-molecule grob)
935 (style-prop (ly:get-grob-property grob 'style))
936 (style (if (symbol? style-prop) style-prop 'banter))
937 (chord (ly:get-grob-property grob 'chord))
938 (chordf (ly:get-grob-property grob 'chord-name-function))
939 (ws (ly:get-grob-property grob 'word-space))
940 (markup (chordf style chord))
941 (molecule (interpret-markup grob
942 (cons '((word-space . 0.0))
943 (Font_interface::get_property_alist_chain grob))
948 ;;; TODO: BUG : word-space is in local staff-space (?)
950 (ly:combine-molecule-at-edge molecule
951 X RIGHT (ly:make-molecule "" (cons 0 ws) '(-1 . 1) )