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>
19 ;;(define (write-me x) (write x) (newline) x)
20 (define (write-me x) x)
21 ;;(define (write-me x) (write x) (newline) x)
22 ;;(define (write-me-2 x y) (write "FOO") (write x) (write y) (newline) y)
28 - Use lilypond Pitch objects -- SCM pitch objects lead to
29 duplication. LilyPond pitch objects force meaningful names
30 (i.e. (ly:pitch-octave PITCH) )
32 - Pitches are musical objects. The pitches -> markup step should
33 happen earlier (during interpreting), brew-molecule () should only
34 dump reinterpret the markup as a molecule. " ; "
37 ;; pitch = (octave notename alteration)
39 ;; note = (notename . alteration)
41 ;; text = scm markup text -- see font.scm and input/test/markup.ly
46 ;; Ugh : naming chord::... ; this is scheme not C++
48 ;; * easier tweakability:
49 ;; - split chord::names-alists up into logical bits,
50 ;; such as chord::exceptions-delta, exceptions-oslash
51 ;; - iso just the 'style parameter, use a list, eg:
52 ;; \property ChordNames.ChordName \set
53 ;; #'style = #'(jazz delta oslash german-tonic german-Bb)
57 ;; * clean split/merge of bass/banter/american stuff
61 (define chord::names-alist-banter
64 (((0 . 0)) . ,empty-markup)
66 (((0 . 0) (2 . 0)) . ,empty-markup)
68 (((0 . 0) (2 . -1)) . ,(make-simple-markup "m"))
70 (((0 . 0) (1 . 0) (4 . 0))
71 . ,(make-super-markup (make-simple-markup "2 ")))
73 (((0 . 0) (3 . 0) (4 . 0))
74 . ,(make-super-markup (make-simple-markup "4 ")))
76 (((0 . 0) (2 . -1) (4 . -1)) . ,(make-simple-markup "dim"))
77 ; URG: Simply C:m5-/maj7 iso Cdim maj7
78 (((0 . 0) (2 . -1) (4 . -1) (6 . 0))
81 (make-simple-markup "m")
82 (make-super-markup (make-simple-markup "5-/maj7 ")))))
83 ; URG: Simply C:m5-/7 iso Cdim7
84 (((0 . 0) (2 . -1) (4 . -1) (6 . -1))
87 (make-simple-markup "m")
88 (make-super-markup (make-simple-markup "5-/7 ")))))
90 (((0 . 0) (2 . -1) (4 . -1) (6 . -2))
91 . ,(make-super-markup (make-simple-markup "o ")))
93 (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1))
95 (list (make-simple-markup "dim")
96 (make-simple-markup "9 "))))
97 (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1) (3 . -1))
99 (list (make-simple-markup "dim")
101 (make-simple-markup "11 ")))))
107 (define (pitch->note-name pitch)
108 (cons (cadr pitch) (caddr pitch)))
110 (define (accidental-markup acc)
111 "ACC is an int, return a markup making an accidental."
113 (make-line-markup (list empty-markup))
114 (make-smaller-markup (make-musicglyph-markup
115 (string-append "accidentals-"
116 (number->string acc))))))
118 (define (pitch->markup pitch)
122 (make-string 1 (integer->char (+ (modulo (+ (cadr pitch) 2) 7) 65))))
124 ;; (make-normal-size-superscript-markup
126 (accidental-markup (caddr pitch))))))
128 ;;; Hooks to override chord names and note names,
129 ;;; see input/tricks/german-chords.ly
131 (define pitch->markup-banter pitch->markup)
133 ;; We need also steps, to allow for Cc name override,
134 ;; see input/test/Cc-chords.ly
135 (define (pitch->chord-name-markup-banter pitch steps)
136 (pitch->markup-banter pitch))
138 (define pitch->note-name-markup-banter pitch->markup-banter)
140 (define (step->markup pitch)
142 (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))
150 (define (step->markup-banter pitch)
152 (if (= (cadr pitch) 6)
159 (step->markup pitch))))
161 (define pitch::semitone-vec #(0 2 4 5 7 9 11))
163 (define (pitch::semitone pitch)
164 (+ (* (car pitch) 12)
165 (vector-ref pitch::semitone-vec (modulo (cadr pitch) 7))
168 (define (pitch::< l r)
169 (< (pitch::semitone l) (pitch::semitone r)))
171 (define (pitch::transpose pitch delta)
172 (let ((simple-octave (+ (car pitch) (car delta)))
173 (simple-notename (+ (cadr pitch) (cadr delta))))
174 (let ((octave (+ simple-octave (quotient simple-notename 7)))
175 (notename (modulo simple-notename 7)))
176 (let ((accidental (- (+ (pitch::semitone pitch) (pitch::semitone delta))
177 (pitch::semitone `(,octave ,notename 0)))))
178 `(,octave ,notename ,accidental)))))
180 (define (pitch::diff pitch tonic)
181 (let ((simple-octave (- (car pitch) (car tonic)))
182 (simple-notename (- (cadr pitch) (cadr tonic))))
183 (let ((octave (+ simple-octave (quotient simple-notename 7)
184 (if (< simple-notename 0) -1 0)))
185 (notename (modulo simple-notename 7)))
186 (let ((accidental (- (pitch::semitone pitch)
187 (pitch::semitone tonic)
188 (pitch::semitone `(,octave ,notename 0)))))
189 `(,octave ,notename ,accidental)))))
191 (define (pitch::note-pitch pitch)
192 (+ (* (car pitch) 7) (cadr pitch)))
194 ;; markup: list of word
195 ;; word: string + optional list of property
196 ;; property: axis, kern, font (?), size
198 (define chord::minor-major-vec (list->vector '(0 -1 -1 0 -1 -1 0)))
201 ;; compute the relative-to-tonic pitch that goes with 'step'
202 (define (chord::step-pitch tonic step)
203 ;; urg, we only do this for thirds
204 (if (= (modulo step 2) 0)
206 (let loop ((i 1) (pitch tonic))
210 pitch `(0 2 ,(vector-ref chord::minor-major-vec
211 ;; -1 (step=1 -> vector=0) + 7 = 6
212 (modulo (+ i 6) 7)))))))))
214 (define (chord::additions steps)
216 * any even step (2, 4, 6)
217 * any uneven step that is chromatically altered,
218 (where 7-- == -1, 7- == 0, 7 == +1)
221 ?and jazz needs also:
223 * TODO: any uneven step that's lower than an uneven step which is
224 chromatically altered
226 (let ((evens (filter-list (lambda (x) (!= 0 (modulo (cadr x) 2))) steps))
228 (filter-list (lambda (x)
229 (let ((n (cadr x)) (a (caddr x)))
230 (or (and (= 6 n) (!= -1 a))
235 (highest (let ((h (car (last-pair steps))))
236 (if (and (not (null? h))
241 ;; Hmm, what if we have a step twice, can we ignore that?
242 (uniq-list (sort (apply append evens altered-unevens highest)
246 ;; FIXME: unLOOP, see ::additions
247 ;; find the pitches that are missing from `normal' chord
248 (define (chord::subtractions chord-pitches)
249 (let ((tonic (car chord-pitches)))
250 (let loop ((step 1) (pitches chord-pitches) (subtractions '()))
252 (let* ((pitch (car pitches))
253 (p-step (+ (- (pitch::note-pitch pitch)
254 (pitch::note-pitch tonic))
256 ;; pitch is an subtraction if
257 ;; a step is missing or
259 (loop (+ step 2) pitches
260 (cons (chord::step-pitch tonic step) subtractions))
261 ;; there are no pitches left, but base thirds are not yet done and
263 (= (length pitches) 1))
264 ;; present pitch is not missing step
266 (loop (+ step 2) pitches subtractions)
267 (loop (+ step 2) pitches
268 (cons (chord::step-pitch tonic step) subtractions)))
270 (loop (+ step 2) (cdr pitches) subtractions)
271 (loop step (cdr pitches) subtractions)))))
272 (reverse subtractions)))))
274 (define (chord::additions->markup-banter additions subtractions)
275 (if (pair? additions)
278 (let ((step (step->markup-banter (car additions))))
279 (if (or (pair? (cdr additions))
280 (pair? subtractions))
282 (list step (make-simple-markup "/")))
284 (chord::additions->markup-banter (cdr additions) subtractions)))
287 (define (chord::subtractions->markup-banter subtractions)
288 (if (pair? subtractions)
291 (make-simple-markup "no")
292 (let ((step (step->markup-jazz (car subtractions))))
293 (if (pair? (cdr subtractions))
295 (list step (make-simple-markup "/")))
297 (chord::subtractions->markup-banter (cdr subtractions))))
300 (define (chord::bass-and-inversion->markup-banter bass-and-inversion)
301 (if (and (pair? bass-and-inversion)
302 (or (car bass-and-inversion)
303 (cdr bass-and-inversion)))
306 (make-simple-markup "/")
307 (pitch->note-name-markup-banter
308 (if (car bass-and-inversion)
309 (car bass-and-inversion)
310 (cdr bass-and-inversion)))))
313 ;; FIXME: merge this function with inner-name-jazz, -american
314 ;; iso using chord::bass-and-inversion->markup-banter,
315 ;; call (chord::restyle 'chord::bass-and-inversion->markup- style)
316 ;; See: chord::exceptions-lookup
317 (define (chord::inner-name-banter tonic exception-part additions subtractions
318 bass-and-inversion steps)
323 Combine tonic, exception-part of chord name,
324 additions, subtractions and bass or inversion into chord name
327 (let* ((tonic-markup (pitch->chord-name-markup-banter tonic steps))
330 (if exception-part exception-part empty-markup)) ;;(make-simple-markup "")))
331 (sep-markup (make-simple-markup
332 (if (and (string-match "super"
333 (format "~s" except-markup))
334 (or (pair? additions)
335 (pair? subtractions)))
337 (adds-markup (chord::additions->markup-banter additions subtractions))
338 (subs-markup (chord::subtractions->markup-banter subtractions))
339 (b+i-markup (chord::bass-and-inversion->markup-banter
340 bass-and-inversion)))
349 (make-line-markup (list adds-markup subs-markup)))
352 (define (c++-pitch->scm p)
354 (list (ly:pitch-octave p) (ly:pitch-notename p) (ly:pitch-alteration p))
357 (define (chord::name-banter tonic exception-part unmatched-steps
358 bass-and-inversion steps)
359 (let ((additions (chord::additions unmatched-steps))
360 (subtractions (chord::subtractions unmatched-steps)))
362 (chord::inner-name-banter tonic exception-part additions subtractions
363 bass-and-inversion steps)))
366 (define chord-module (current-module))
367 (define (chord::restyle name style)
371 (string-append (symbol->string name)
372 (symbol->string style)))
377 ;; this is unintelligible.
381 ; - what's a helper, and why isn't it inside another function?
383 ; what is going out, what is coming in, howcome it produces #f
387 (define (chord::exceptions-lookup-helper
388 exceptions-alist try-steps unmatched-steps exception-part)
391 check exceptions-alist for biggest matching part of try-steps
392 return (MATCHED-EXCEPTION . UNMATCHED-STEPS)
395 (if (pair? try-steps)
396 ;; FIXME: junk '(0 . 0) from exceptions lists?
397 ;; if so: how to handle first '((0 . 0) . #f) entry?
399 ;; FIXME: either format exceptions list as real pitches, ie,
400 ;; including octave '((0 2 -1) ..), or drop octave
401 ;; from rest of calculations,
403 (map (lambda (x) (pitch->note-name x))
404 (append '((0 0 0)) try-steps))
407 (chord::exceptions-lookup-helper
408 #f '() unmatched-steps (cdr entry))
409 (let ((r (reverse try-steps)))
410 (chord::exceptions-lookup-helper
413 (cons (car r) unmatched-steps) #f))))
414 (cons exception-part unmatched-steps)))
418 (define (chord::exceptions-lookup style steps)
420 return (MATCHED-EXCEPTION . BASE-CHORD-WITH-UNMATCHED-STEPS)
421 BASE-CHORD-WITH-UNMATCHED-STEPS always includes (tonic 3 5)
425 (let* ((result (chord::exceptions-lookup-helper
426 (chord::restyle 'chord::names-alist- style)
428 (exception-part (car result))
429 (unmatched-steps (cdr result))
430 (matched-steps (if (= (length unmatched-steps) 0)
432 (+ 1 (- (length steps)
433 (length unmatched-steps)))))
434 (unmatched-with-1-3-5
435 (append (do ((i matched-steps (- i 1))
436 (base '() (cons `(0 ,(* (- i 1) 2) 0) base)))
440 (list exception-part unmatched-with-1-3-5)))
443 (define (chord::name->markup style tonic steps bass-and-inversion)
446 (let* ((lookup (write-me (chord::exceptions-lookup style steps)))
447 (exception-part (write-me (car lookup)))
448 (unmatched-steps (cadr lookup))
449 (func (chord::restyle 'chord::name- style))
453 (func tonic exception-part unmatched-steps bass-and-inversion steps)))
457 ;; Check for each subset of chord, full chord first, if there's a
458 ;; user-override. Split the chord into user-overridden and to-be-done
459 ;; parts, complete the missing user-override matched part with normal
460 ;; chord to be name-calculated.
462 ;; CHORD: (pitches (bass . inversion))
463 (define-public (chord->markup style chord)
464 (let* ((pitches (map c++-pitch->scm (car chord)))
465 (modifiers (cdr chord))
466 (bass-and-inversion (if (pair? modifiers)
467 (cons (c++-pitch->scm (car modifiers))
468 (c++-pitch->scm (cdr modifiers)))
470 (diff (pitch::diff '(0 0 0) (car pitches)))
471 (steps (if (cdr pitches) (map (lambda (x)
472 (pitch::transpose x diff))
476 (chord::name->markup style (car pitches) steps bass-and-inversion)))
483 ;; NOTE: Duplicates of chord names defined elsewhere occur in this list
484 ;; in order to prevent spurious superscripting of various chord names,
485 ;; such as maj7, maj9, etc.
487 ;; See input/test/american-chords.ly
489 ;; James Hammons, <jlhamm@pacificnet.net>
492 ;; DONT use non-ascii characters, even if ``it works'' in Windows
495 (define chord::names-alist-american
498 (((0 . 0)) . ,empty-markup)
499 (((0 . 0) (2 . 0)) . ,empty-markup)
501 (((0 . 0) (4 . 0)) . ,(make-simple-markup "5"))
503 (((0 . 0) (2 . -1)) . ,(make-simple-markup "m"))
504 (((0 . 0) (3 . 0) (4 . 0)) . ,(make-simple-markup "sus"))
505 (((0 . 0) (2 . -1) (4 . -1)) . ,(make-simple-markup "dim"))
506 ;Alternate: (((0 . 0) (2 . -1) (4 . -1)) . ("" (super "o")))
507 (((0 . 0) (2 . 0) (4 . 1)) . ,(make-simple-markup "aug"))
508 ;Alternate: (((0 . 0) (2 . 0) (4 . 1)) . ("+"))
509 (((0 . 0) (1 . 0) (4 . 0)) . ,(make-simple-markup "2"))
510 ;; Common seventh chords
511 (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) .
514 (make-super-markup (make-simple-markup "o"))
515 (make-simple-markup " 7"))))
516 (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . ,(make-simple-markup "maj7"))
517 ;; urg! should use (0 . 0 2 . -1) -> "m", and add "7" to that!!
518 (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . ,(make-simple-markup "m7"))
519 (((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . ,(make-simple-markup "7"))
520 (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . ,(make-simple-markup "m(maj7)"))
521 ;jazz: the delta, see jazz-chords.ly
522 ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2))
523 ;; . (super ((font-family . math) "N"))
525 (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) .
529 (make-combine-markup (make-simple-markup "o")
530 (make-simple-markup "/")))
531 (make-simple-markup " 7"))))
532 (((0 . 0) (2 . 0) (4 . 1) (6 . -1)) . ,(make-simple-markup "aug7"))
533 (((0 . 0) (2 . 0) (4 . -1) (6 . 0))
536 (make-simple-markup "maj7")
538 (make-raise-markup 0.2 (accidental-markup -1)))
539 (make-simple-markup "5"))))
540 (((0 . 0) (2 . 0) (4 . -1) (6 . -1)) .
543 (make-simple-markup "7")
544 (make-small-markup (make-raise-markup 0.2 (accidental-markup -1)))
545 (make-simple-markup "5"))))
546 (((0 . 0) (3 . 0) (4 . 0) (6 . -1)) . ,(make-simple-markup "7sus4"))
547 ;; Common ninth chords
548 (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0))
549 . ,(make-simple-markup "6/9")) ;; we don't want the '/no7'
550 (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) . ,(make-simple-markup "6"))
551 (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) . ,(make-simple-markup "m6"))
552 (((0 . 0) (2 . 0) (4 . 0) (1 . 0)) . ,(make-simple-markup "add9"))
553 (((0 . 0) (2 . 0) (4 . 0) (6 . 0) (1 . 0))
554 . ,(make-simple-markup "maj9"))
555 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0))
556 . ,(make-simple-markup "9"))
557 (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0))
558 . ,(make-simple-markup "m9"))
562 ;; American style chordnames use no "no",
563 ;; but otherwise very similar to banter for now
564 (define-public (chord::name-american tonic exception-part unmatched-steps
565 bass-and-inversion steps)
566 (let ((additions (chord::additions unmatched-steps))
568 (chord::inner-name-banter tonic exception-part additions subtractions
569 bass-and-inversion steps)))
577 ;; Jazz chords, by Atte Andr'e Jensen <atte@post.com>
578 ;; NBs: This uses the american list as a bass.
579 ;; Some defs take up more than one line,
580 ;; be carefull when messing with ;'s!!
585 ;; This is getting out-of hand? Only exceptional chord names that
586 ;; cannot be generated should be here.
587 ;; Maybe we should have inner-name-jazz and inner-name-american functions;
591 ;; DONT use non-ascii characters, even if ``it works'' in Windows
593 (define mathm-markup-object
594 (make-override-markup '(font-family . math) (make-simple-markup "M")))
596 (define mraise-arg `(make-line-markup
598 ,(make-simple-markup "m")
599 (make-raise-markup 0.5 (make-simple-markup arg)))))
601 (define (raise-some-for-jazz arg-list)
604 ("@" (make-raise-markup 0.3 ,(accidental-markup -1)))
605 ("#" (make-raise-markup 0.3 ,(accidental-markup 1)))
606 (else (make-raise-markup 0.8 ,x))))
609 (list (map do-one arg-list))))
611 (define chord::names-alist-jazz
615 ; major sixth chord = 6
616 (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) .
617 ,(make-raise-markup 0.5 (make-simple-markup "6")))
618 ; major seventh chord = triangle
619 ;; shouldn't this be a filled black triange, like this: ? --jcn
620 ;; (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . (((raise . 0.5)((font-family . math) "N"))))
621 (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) .
622 ,(make-raise-markup 0.5 mathm-markup-object))
624 ; major chord add nine = add9
625 (((0 . 0) (2 . 0) (4 . 0) (1 . 0))
626 . ,(make-raise-markup 0.5 (make-simple-markup "add9")))
627 ; major sixth chord with nine = 6/9
628 (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0))
629 . ,(make-raise-markup 0.5 (make-simple-markup "add9")))
632 ; minor sixth chord = m6
633 (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) .
636 ;; minor major seventh chord = m triangle
637 ;; shouldn't this be a filled black triange, like this: ? --jcn
638 ;;(((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (columns ("m") ((raise . 0.5)((font-family . math) "N"))))
639 (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) .
641 (list ((make-simple-markup "m") mathm-markup-object))))
642 ; minor seventh chord = m7
643 (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . ,(mraise-arg "7"))
644 ; minor sixth nine chord = m6/9
645 (((0 . 0) (2 . -1) (4 . 0) (5 . 0) (1 . 0)) . ,(mraise-arg "6/9"))
647 ; minor with added nine chord = madd9
648 (((0 . 0) (2 . -1) (4 . 0) (1 . 0)) . ,(mraise-arg "madd9"))
650 ; minor ninth chord = m9
651 (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) . ,(mraise-arg "add9"))
654 ; dominant seventh = 7
655 (((0 . 0) (2 . 0) (4 . 0) (6 . -1))
656 . ,(make-raise-markup 0.5 (make-simple-markup "7")))
657 ; augmented dominant = +7
658 ;(((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (((raise . 0.5) "+7"))) ; +7 with both raised
659 (((0 . 0) (2 . 0) (4 . +1) (6 . -1)) .
662 (make-simple-markup "+")
664 (make-raise-markup 0.5 (make-simple-markup "7")))))
665 ;(((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (columns((raise . 0.5) "7(")
666 ; ((raise . 0.3)(music (named ("accidentals-1"))))
667 ; ((raise . 0.5) "5)"))); 7(#5)
668 ; dominant flat 5 = 7(b5)
670 (((0 . 0) (2 . 0) (4 . -1) (6 . -1))
671 . ,(raise-some-for-jazz '( "7(" "@" "5)" )))
674 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0)) .
675 ,(raise-some-for-jazz '("7(9)")))
676 ; dominant flat 9 = 7(b9)
677 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1)) .
678 ,(raise-some-for-jazz '("7(" "@" "9)")))
680 ; dominant sharp 9 = 7(#9)
681 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1)) .
682 ,(raise-some-for-jazz '("7(" "#" "9)")))
684 ; dominant 13 = 7(13)
685 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (5 . 0)) .
686 ,(raise-some-for-jazz "7(13)"))
687 ; dominant flat 13 = 7(b13)
688 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (5 . -1)) .
689 ,(raise-some-for-jazz '( "7(" "@" "13)")))
691 ; dominant 9, 13 = 7(9,13)
692 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0) (5 . 0)) .
693 ,(raise-some-for-jazz '("7(9, 13)")))
694 ; dominant flat 9, 13 = 7(b9,13)
695 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1) (5 . 0)) .
696 ,(raise-some-for-jazz '("7(" "@" "9, 13)")))
698 ; dominant sharp 9, 13 = 7(#9,13)
699 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1) (5 . 0)) .
700 ,(raise-some-for-jazz '("7(" "#" "9,13)")))
702 ; dominant 9, flat 13 = 7(9,b13)
703 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0) (5 . -1)) .
704 ,(raise-some-for-jazz "7(9, " "@" "13)"))
706 ; dominant flat 9, flat 13 = 7(b9,b13)
707 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1) (5 . -1)) .
708 ,(raise-some-for-jazz '("7(" "@" "9, " "@" "13)")))
710 ; dominant sharp 9, flat 13 = 7(#9,b13)
711 (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1) (5 . -1)) .
712 ,(raise-some-for-jazz '("7(" "#" "9, " "@" "13)")))
714 ;; diminished chord(s)
715 ; diminished seventh chord = o
718 ;; DONT use non-ascii characters, even if ``it works'' in Windows
720 ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ((raise . 0.8) (size . -2) ("o")))
721 (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) .
722 ,(make-super-markup (make-simple-markup "o")))
724 ;; half diminshed chords
725 ;; half diminished seventh chord = slashed o
726 ;; (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (((raise . 0.8) "/o")))
727 (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) .
732 (make-simple-markup "o") (make-simple-markup "/")))
733 (make-simple-markup " 7"))))
734 ; half diminished seventh chord with major 9 = slashed o cancelation 9
735 (((0 . 0) (2 . -1) (4 . -1) (6 . -1) (1 . 0)) .
736 ,(raise-some-for-jazz '("/o(" "!" "9)")))
738 ;; Missing jazz chord definitions go here (note new syntax: see american for hints)
741 chord::names-alist-american))
743 (define (step->markup-alternate-jazz pitch)
746 (accidental-markup (caddr pitch))
748 (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))))))
750 (define (step->markup-jazz pitch)
751 (if (= (cadr pitch) 6)
753 ;; sharp 7 only included for completeness?
754 ((-2) (make-line-markup
756 (accidental-markup -1)
757 (make-simple-markup "7"))))
758 ((-1) (make-simple-markup "7"))
759 ((0) (make-simple-markup "maj7"))
760 ;;((0) (make-line-markup
761 ;; (list (make-simple-markup "maj7"))))
762 ((1) (make-line-markup
764 (accidental-markup 1) (make-simple-markup "7"))))
765 ((2) (make-line-markup
766 (list (accidental-markup 1)
767 (make-simple-markup "7")))))
768 (step->markup-alternate-jazz pitch)))
771 (define (xchord::additions->markup-jazz additions subtractions)
772 (if (pair? additions)
775 (let ((step (step->markup-jazz (car additions))))
776 (if (or (pair? (cdr additions))
777 (pair? subtractions))
778 (make-line-markup (list step (make-simple-markup "/")))
780 (chord::additions->markup-jazz (cdr additions) subtractions)))
783 (define (chord::>5? x)
789 ;; Perhaps all logic like this should be done earlier,
790 ;; so that in this markup-construction printing phase
791 ;; we can just blindly create markup from all additions.
793 ;; This depends maybe on the fact of code sharing,
794 ;; in this layout, we can share the functions chord::additions
795 ;; and chord::subtractions with banter.
796 (define (chord::additions->markup-jazz additions subtractions)
800 (chord::additions<=5->markup-jazz
801 (filter-out-list chord::>5? additions)
802 (filter-out-list chord::>5? subtractions))
803 (chord::additions>5->markup-jazz
804 (filter-list chord::>5? additions)
805 (filter-list chord::>5? subtractions)))))
809 (define (chord::additions<=5->markup-jazz additions subtractions)
810 (let ((sus (chord::sus-four-jazz additions)))
813 (list (make-simple-markup "sus")
814 (step->markup-jazz (car sus))))
818 (define (chord::additions>5->markup-jazz additions subtractions)
820 Compose markup of all additions
822 * if there's a subtraction:
824 - list all up to highest
825 * list all steps that are below an chromatically altered step
830 (if (not (null? subtractions))
831 (make-simple-markup "add")
833 ;; this is totally incomprehensible. Fix me, and docme.
835 ;; The function >5markup-jazz-helper cdrs through the list
836 ;; of additions in reverse order, ie, for c 7 9+:
837 ;; (1 1 1), (0 6 0), done
839 ;; For each step, it creates a markup, if necessary, and
840 ;; cons's it to the list.
842 ;; The list is reversed.
843 (let* ((radds (reverse additions))
844 (rmarkups (chord::additions>5->markup-jazz-helper
847 (if (or (null? subtractions) (null? radds))
851 (make-line-markup (reverse rmarkups)))))))
855 (define (chord::additions>5->markup-jazz-helper additions subtractions list-step)
857 Create markups for all additions
858 If list-step != #f, list all steps down to 5
859 If we encounter a chromatically altered step, turn on list-step
863 (if (not (member list-step subtractions))
864 (if (> 5 (cadr list-step))
866 (step->markup-jazz list-step)
868 (chord::additions>5->markup-jazz-helper
871 (chord::get-create-step additions
872 (- (cadr list-step) 2))))
874 (list (step->markup-jazz list-step)))
878 (if (pair? additions)
879 (let ((step (car additions)))
881 (step->markup-jazz step)
883 (chord::additions>5->markup-jazz-helper
886 (if ;;; possible fix --jcn
888 (or (and (!= 6 (cadr step)) (!= 0 (caddr step)))
889 (and (= 6 (cadr step)) (!= -1 (caddr step))))
890 ) ;;; possible fix --jcn
891 (chord::get-create-step additions (- (cadr step) 2))
895 (define (chord::sus-four-jazz chord-pitches)
896 "List of pitches that are step 2 or step 4"
898 (filter-list (lambda (x)
900 (or (= 1 (cadr x)) (= 3 (cadr x))))) chord-pitches))
902 (define (chord::get-create-step steps n)
903 (let* ((i (if (< n 0) (+ n 7) n))
904 (found (filter-list (lambda (x) (= i (cadr x))) steps)))
911 (define (chord::subtractions->markup-jazz subtractions)
912 (if (pair? subtractions)
915 (if (= 5 (cadr (car subtractions)))
918 (make-simple-markup "omit")
919 (let ((step (step->markup-jazz (car subtractions))))
920 (if (pair? (cdr subtractions))
922 (list (step (make-simple-markup "/"))))
925 (chord::subtractions->markup-jazz (cdr subtractions))))
928 ;; TODO: maybe merge with inner-name-banter
929 ;; Combine tonic, exception-part of chord name,
930 ;; additions, subtractions and bass or inversion into chord name
931 (define (chord::inner-name-jazz tonic exception-part additions subtractions
932 bass-and-inversion steps)
935 (pitch->chord-name-markup-banter tonic steps)
937 ;; why does list->string not work, format seems only hope...
938 (if (and (string-match "super" (format "~s" exception-part))
939 (or (pair? additions)
940 (pair? subtractions)))
941 (make-super-markup (make-simple-markup "/"))
947 (chord::additions->markup-jazz additions subtractions)
948 (chord::subtractions->markup-jazz subtractions))))
950 (chord::bass-and-inversion->markup-banter bass-and-inversion))))
952 ;; Jazz style--basically similar to american with minor changes
954 ;; Consider Dm6. When we get here:
955 ;; tonic = '(0 1 0) (note d=2)
956 ;; steps = '((0 0 0) '(0 2 -1) (0 4 0) (0 5 0))
957 ;; steps are transposed for tonic c, octave 0,
958 ;; so (car steps) is always (0 0 0)
960 ;; assuming that the exceptions-alist has an entry
961 ;; '(((0 . 0) (2 . -1)) . ("m"))
962 ;; (and NOT the full chord, like std jazz list, ugh)
963 ;; unmatch = '((0 0 0) (0 2 0) (0 4 0) (0 5 0))
966 ;; You can look very easily what happens, if you add some write-me calls,
967 ;; and run lilypond on a simple file, eg, containing only the chord c:m6:
969 ;; (let ((additions (write-me "adds: "
970 ;; (chord::additions (write-me "unmatched:"
971 ;; unmatched-steps))))
973 ;; If you set subtract #f, the chord::inner-name-jazz does not see any
974 ;; subtractions, ever, so they don't turn up in the chord name.
976 (define-public (chord::name-jazz tonic exception-part unmatched-steps
977 bass-and-inversion steps)
978 (let ((additions (chord::additions unmatched-steps))
979 ;; get no 'omit' or 'no'
980 ;; (subtractions #f))
981 (subtractions (chord::subtractions unmatched-steps)))
983 (chord::inner-name-jazz tonic exception-part additions subtractions
984 bass-and-inversion steps)))
986 ;; wip (set! chord::names-alist-jazz
987 (define chord::names-alist-jazz
990 (((0 . 0) (2 . -1)) . ,(make-simple-markup "m"))
992 ;; some fixups -- jcn
993 ; major seventh chord = triangle
994 (((0 . 0) (2 . 0) (4 . 0) (6 . 0))
995 . ,(make-raise-markup 0.5 mathm-markup-object))
997 ;; minor major seventh chord = m triangle
998 (((0 . 0) (2 . -1) (4 . 0) (6 . 0))
1001 (make-simple-markup "m")
1002 (make-raise-markup 0.5 mathm-markup-object))))
1003 ;; (((0 . 0) (2 . -1) (4 . 0) (6 . 0))
1004 ;; . (columns ("m") ((raise . 0.5)((font-family . math) "M"))))
1008 chord::names-alist-american))
1010 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1013 (define-public (new-chord-name-brew-molecule grob)
1016 (style-prop (ly:get-grob-property grob 'style))
1017 (style (if (symbol? style-prop) style-prop 'banter))
1018 (chord (ly:get-grob-property grob 'chord))
1019 (chordf (ly:get-grob-property grob 'chord-name-function))
1020 (ws (ly:get-grob-property grob 'word-space))
1021 (markup (chordf style chord))
1022 (molecule (interpret-markup grob
1023 (cons '((word-space . 0.0))
1024 (Font_interface::get_property_alist_chain grob))
1029 ;;; TODO: BUG : word-space is in local staff-space (?)
1031 (ly:combine-molecule-at-edge molecule
1032 X RIGHT (ly:make-molecule "" (cons 0 ws) '(-1 . 1) )