2 ;;; chord-name.scm -- Compile chord name
4 ;;; source file of the GNU LilyPond music typesetter
6 ;;; (c) 2000--2003 Jan Nieuwenhuizen <janneke@gnu.org>
19 ;(define (dbg x) (write-me "" x))
22 ;;(define (write-me x) (write x) (newline) x)
23 ;;(define (write-me-2 x y) (write "FOO") (write x) (write y) (newline) y)
29 * Use lilypond Pitch objects -- SCM pitch objects lead to
30 duplication. LilyPond pitch objects force meaningful names
31 (i.e. (ly:pitch-octave PITCH) )
33 * Pitches are musical objects. The pitches -> markup step should
34 happen earlier (during interpreting), brew-molecule () should only
35 dump reinterpret the markup as a molecule.
37 * chord:: prefix is a poor-man's namespace device.
38 We have a module system to prevent export to userland.
39 Nested functions can take care of many other clashes. --hwn.
41 * easier tweakability:
43 - split chord::names-alists up into logical bits,
44 such as chord::exceptions-delta, exceptions-oslash
45 - iso just the 'style parameter, use a list, eg:
46 \property ChordNames.ChordName \set
47 #'style = #'(jazz delta oslash german-tonic german-Bb)
49 * clean split/merge of bass/banter/american stuff.
50 GET RID OF code duplication.
58 ;; " hey Emacs: string has ended
61 ;; pitch = (octave notename alteration)
63 ;; note = (notename . alteration)
65 ;; markup = markup text -- see font.scm and input/test/markup.ly
68 (define-public chord::exception-alist-banter
71 (((0 . 0)) . ,empty-markup)
73 (((0 . 0) (2 . 0)) . ,empty-markup)
75 (((0 . 0) (2 . -1)) . ,(make-simple-markup "m"))
77 (((0 . 0) (1 . 0) (4 . 0))
78 . ,(make-normal-size-super-markup (make-simple-markup "2 ")))
80 (((0 . 0) (3 . 0) (4 . 0))
81 . ,(make-normal-size-super-markup (make-simple-markup "4 ")))
83 (((0 . 0) (2 . -1) (4 . -1)) . ,(make-simple-markup "dim"))
84 ; URG: Simply C:m5-/maj7 iso Cdim maj7
85 (((0 . 0) (2 . -1) (4 . -1) (6 . 0))
88 (make-simple-markup "m")
89 (make-normal-size-super-markup (make-simple-markup "5-/maj7 ")))))
90 ; URG: Simply C:m5-/7 iso Cdim7
91 (((0 . 0) (2 . -1) (4 . -1) (6 . -1))
94 (make-simple-markup "m")
95 (make-normal-size-super-markup (make-simple-markup "5-/7 ")))))
97 (((0 . 0) (2 . -1) (4 . -1) (6 . -2))
98 . ,(make-super-markup (make-simple-markup "o")))
100 (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1))
102 (list (make-simple-markup "dim")
103 (make-normal-size-super-markup (make-simple-markup "9 ")))))
104 (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1) (3 . -1))
106 (list (make-simple-markup "dim")
107 (make-normal-size-super-markup
108 (make-simple-markup "11 ")))))
112 ; pitch->note-name: drops octave
113 (define (pitch->note-name pitch)
114 (cons (cadr pitch) (caddr pitch)))
116 (define (old-accidental->markup acc)
117 "ACC is an int, return a markup making an accidental."
119 (make-line-markup (list empty-markup))
120 (make-smaller-markup (make-musicglyph-markup
121 (string-append "accidentals-"
122 (number->string acc))))))
127 ;; FIXME: possibly to be used for american/jazz style
128 ;; However, only pos == columns is used, which seems to do
129 ;; exactly what old-accidental->markup does...
130 (define (amy-accidental->text acc) (accidental->textp acc 'columns))
134 ;;;(define (accidental->text-super acc) (accidental->textp acc 'simple-super))
135 ;;(define (accidental->text-super acc) (accidental->textp acc 'super))
136 ;;(define (accidental->text-sub acc) (accidental->textp acc 'sub))
140 ;; TODO: invent sensible way to make note name tweaking possible?
142 (define (old-pitch->markup pitch)
146 (vector-ref #("C" "D" "E" "F" "G" "A" "B") (cadr pitch)))
147 (make-normal-size-super-markup
148 (old-accidental->markup (caddr pitch))))))
150 ;;; Hooks to override chord names and note names,
151 ;;; see input/tricks/german-chords.ly
153 (define old-pitch->markup-banter old-pitch->markup)
155 ;; We need also steps, to allow for Cc name override,
156 ;; see input/test/Cc-chords.ly
157 (define (pitch->chord-name-markup-banter pitch steps)
158 (old-pitch->markup-banter pitch))
160 (define pitch->note-name-markup-banter old-pitch->markup-banter)
162 (define (step->markup pitch)
164 (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))
172 (define (step->markup-banter pitch)
174 (if (= (cadr pitch) 6)
181 (step->markup pitch))))
183 (define (step->markup-previously-alternate-jazz pitch)
186 (old-accidental->markup (caddr pitch))
188 (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))))))
190 (define (step->markup-previously-jazz pitch)
191 (if (= (cadr pitch) 6)
193 ;; sharp 7 only included for completeness?
194 ((-2) (make-line-markup
196 (old-accidental->markup -1)
197 (make-simple-markup "7"))))
198 ((-1) (make-simple-markup "7"))
199 ((0) (make-simple-markup "maj7"))
200 ;;((0) (make-line-markup
201 ;; (list (make-simple-markup "maj7"))))
202 ((1) (make-line-markup
204 (old-accidental->markup 1) (make-simple-markup "7"))))
205 ((2) (make-line-markup
206 (list (old-accidental->markup 1)
207 (make-simple-markup "7")))))
208 (step->markup-previously-alternate-jazz pitch)))
211 (define pitch::semitone-vec #(0 2 4 5 7 9 11))
213 (define (pitch::semitone pitch)
214 (+ (* (car pitch) 12)
215 (vector-ref pitch::semitone-vec (modulo (cadr pitch) 7))
218 (define (pitch::< l r)
219 (< (pitch::semitone l) (pitch::semitone r)))
221 (define (pitch::transpose pitch delta)
222 (let ((simple-octave (+ (car pitch) (car delta)))
223 (simple-notename (+ (cadr pitch) (cadr delta))))
224 (let ((octave (+ simple-octave (quotient simple-notename 7)))
225 (notename (modulo simple-notename 7)))
226 (let ((accidental (- (+ (pitch::semitone pitch) (pitch::semitone delta))
227 (pitch::semitone `(,octave ,notename 0)))))
228 `(,octave ,notename ,accidental)))))
230 (define (pitch::diff pitch tonic)
231 (let ((simple-octave (- (car pitch) (car tonic)))
232 (simple-notename (- (cadr pitch) (cadr tonic))))
233 (let ((octave (+ simple-octave (quotient simple-notename 7)
234 (if (< simple-notename 0) -1 0)))
235 (notename (modulo simple-notename 7)))
236 (let ((accidental (- (pitch::semitone pitch)
237 (pitch::semitone tonic)
238 (pitch::semitone `(,octave ,notename 0)))))
239 `(,octave ,notename ,accidental)))))
241 (define (pitch::note-pitch pitch)
242 (+ (* (car pitch) 7) (cadr pitch)))
246 (define chord::minor-major-vec #(0 -1 -1 0 -1 -1 0))
249 ;; compute the relative-to-tonic pitch that goes with 'step'
250 (define (chord::step-pitch tonic step)
251 ;; urg, we only do this for thirds
252 (if (= (modulo step 2) 0)
254 (let loop ((i 1) (pitch tonic))
258 pitch `(0 2 ,(vector-ref chord::minor-major-vec
259 ;; -1 (step=1 -> vector=0) + 7 = 6
260 (modulo (+ i 6) 7)))))))))
262 (define (chord::additions steps)
264 * any even step (2, 4, 6)
265 * any uneven step that is chromatically altered,
266 (where 7-- == -1, 7- == 0, 7 == +1)
269 ?and jazz needs also:
271 * TODO: any uneven step that's lower than an uneven step which is
272 chromatically altered
274 (let ((evens (filter-list (lambda (x) (!= 0 (modulo (cadr x) 2))) steps))
276 (filter-list (lambda (x)
277 (let ((n (cadr x)) (a (caddr x)))
278 (or (and (= 6 n) (!= -1 a))
283 (highest (let ((h (car (last-pair steps))))
284 (if (and (not (null? h))
289 ;; Hmm, what if we have a step twice, can we ignore that?
290 (uniq-list (sort (apply append evens altered-unevens highest)
294 ;; FIXME: unLOOP, see ::additions
295 ;; find the pitches that are missing from `normal' chord
296 (define (chord::subtractions chord-pitches)
297 (let ((tonic (car chord-pitches)))
298 (let loop ((step 1) (pitches chord-pitches) (subtractions '()))
300 (let* ((pitch (car pitches))
301 (p-step (+ (- (pitch::note-pitch pitch)
302 (pitch::note-pitch tonic))
304 ;; pitch is an subtraction if
305 ;; a step is missing or
307 (loop (+ step 2) pitches
308 (cons (chord::step-pitch tonic step) subtractions))
309 ;; there are no pitches left, but base thirds are not yet done and
311 (= (length pitches) 1))
312 ;; present pitch is not missing step
314 (loop (+ step 2) pitches subtractions)
315 (loop (+ step 2) pitches
316 (cons (chord::step-pitch tonic step) subtractions)))
318 (loop (+ step 2) (cdr pitches) subtractions)
319 (loop step (cdr pitches) subtractions)))))
320 (reverse subtractions)))))
322 (define (chord::additions->markup-banter additions subtractions)
323 (if (pair? additions)
326 (let ((step (step->markup-banter (car additions))))
327 (if (or (pair? (cdr additions))
328 (pair? subtractions))
330 (list step (make-simple-markup "/")))
332 (chord::additions->markup-banter (cdr additions) subtractions)))
335 (define (chord::subtractions->markup-banter subtractions)
336 (if (pair? subtractions)
339 (make-simple-markup "no")
340 (let ((step (step->markup-previously-jazz
341 (car subtractions))))
342 (if (pair? (cdr subtractions))
344 (list step (make-simple-markup "/")))
346 (chord::subtractions->markup-banter (cdr subtractions))))
349 (define (chord::bass-and-inversion->markup-banter bass-and-inversion)
350 (if (and (pair? bass-and-inversion)
351 (or (car bass-and-inversion)
352 (cdr bass-and-inversion)))
355 (make-simple-markup "/")
356 (pitch->note-name-markup-banter
357 (if (car bass-and-inversion)
358 (car bass-and-inversion)
359 (cdr bass-and-inversion)))))
362 ;; FIXME: merge this function with inner-name-jazz, -american
363 ;; iso using chord::bass-and-inversion->markup-banter,
364 ;; See: chord::exceptions-lookup
365 (define (chord::inner-name-banter tonic exception-part additions subtractions
366 bass-and-inversion steps)
370 Combine tonic, exception-part of chord name,
371 additions, subtractions and bass or inversion into chord name
374 (let* ((tonic-markup (pitch->chord-name-markup-banter tonic steps))
375 (except-markup (if exception-part exception-part empty-markup))
376 ;; UGR. How do we know if we should add a separator or not?
377 ;; maybe just add extra column to exception list?
378 (sep-markup (if (and exception-part
379 (let ((s (format "~s" except-markup)))
381 (string-match "super" s)
383 ;; python: `except_markup`[-5:] != '"o"))'
387 (- (string-length s) 5))))))
388 (or (pair? additions)
389 (pair? subtractions)))
390 (make-super-markup (make-simple-markup "/"))
392 (adds-markup (chord::additions->markup-banter additions subtractions))
393 (subs-markup (chord::subtractions->markup-banter subtractions))
394 (b+i-markup (chord::bass-and-inversion->markup-banter
395 bass-and-inversion)))
402 (make-normal-size-super-markup
403 (make-line-markup (list adds-markup subs-markup)))
406 (define (c++-pitch->scm p)
408 (list (ly:pitch-octave p) (ly:pitch-notename p) (ly:pitch-alteration p))
411 (define (chord::name-banter tonic exception-part unmatched-steps
412 bass-and-inversion steps)
413 (let ((additions (chord::additions unmatched-steps))
414 (subtractions (chord::subtractions unmatched-steps)))
416 (chord::inner-name-banter tonic exception-part additions subtractions
417 bass-and-inversion steps)))
421 (define (chord::exceptions-lookup exceptions steps)
423 return (MATCHED-EXCEPTION . BASE-CHORD-WITH-UNMATCHED-STEPS)
424 BASE-CHORD-WITH-UNMATCHED-STEPS always includes (tonic 3 5)
427 ;; this is unintelligible.
429 (define (chord::exceptions-lookup-helper
430 exception-alist try-steps unmatched-steps exception-part)
433 check exception-alist for biggest matching part of try-steps
434 return (MATCHED-EXCEPTION . UNMATCHED-STEPS)
437 (if (pair? try-steps)
438 ;; FIXME: junk '(0 . 0) from exceptions lists?
439 ;; if so: how to handle first '((0 . 0) . #f) entry?
441 ;; FIXME: either format exceptions list as real pitches, ie,
442 ;; including octave '((0 2 -1) ..), or drop octave
443 ;; from rest of calculations,
445 (map (lambda (x) (pitch->note-name x))
446 (append '((0 0 0)) try-steps))
449 (chord::exceptions-lookup-helper
450 #f '() unmatched-steps (cdr entry))
451 (let ((r (reverse try-steps)))
452 (chord::exceptions-lookup-helper
455 (cons (car r) unmatched-steps) #f))))
456 (cons exception-part unmatched-steps)))
458 (let* ((result (chord::exceptions-lookup-helper
461 (exception-part (car result))
462 (unmatched-steps (cdr result))
463 (matched-steps (if (= (length unmatched-steps) 0)
465 (+ 1 (- (length steps)
466 (length unmatched-steps)))))
467 (unmatched-with-1-3-5
468 (append (do ((i matched-steps (- i 1))
469 (base '() (cons `(0 ,(* (- i 1) 2) 0) base)))
473 (list exception-part unmatched-with-1-3-5)))
480 ;; See input/test/american-chords.ly
482 ;; Original Version by James Hammons, <jlhamm@pacificnet.net>
483 ;; Complete rewrite by Amelie Zapf, <amy@loueymoss.com>
485 ;; DONT use non-ascii characters, even if ``it works'' in Windows
488 (define mathm-markup-object
489 (make-override-markup '(font-family . math) (make-simple-markup "M")))
492 (define mathn-markup-object
493 (make-override-markup '(font-family . math) (make-simple-markup "N")))
495 (define (step->markup-accidental pitch)
499 ((-2) (old-accidental->markup -2))
500 ((-1) (old-accidental->markup -1))
502 ((1) (old-accidental->markup 1))
503 ((2) (old-accidental->markup 2)))
504 (make-simple-markup (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))))))
506 (define-public chord::exception-alist-american
508 (((0 . 0)) . ,empty-markup)
509 (((0 . 0) (2 . -1)) . ,(make-simple-markup "m"))
511 ;; these should probably be normal-size? --jcn
512 ;;(((0 . 0) (4 . 0)) . ,(make-super-markup (make-simple-markup "5 ")))
513 ;;(((0 . 0) (1 . 0) (4 . 0)) . ,(make-super-markup (make-simple-markup "2 ")))
515 (((0 . 0) (4 . 0)) . ,(make-normal-size-super-markup (make-simple-markup "5 ")))
516 (((0 . 0) (1 . 0) (4 . 0)) . ,(make-normal-size-super-markup (make-simple-markup "2 ")))
518 ;;choose your symbol for the fully diminished chord
519 (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ,(make-simple-markup "dim"))
520 ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ,(make-line-markup (list empty-markup (make-super-markup (make-simple-markup "o")))))
523 (define (step->markup-american pitch)
525 ((6) (case (caddr pitch)
526 ((-2) (make-line-markup (list (old-accidental->markup -1) (make-simple-markup "7"))))
527 ((-1) (make-simple-markup "7"))
528 ((0) (make-simple-markup "maj7"))
529 ((1) (make-line-markup (list (old-accidental->markup 1) (make-simple-markup "7"))))
530 ((2) (make-line-markup (list (old-accidental->markup 2) (make-simple-markup "7"))))))
531 ((4) (case (caddr pitch)
532 ((-2) (make-line-markup (list (old-accidental->markup -2) (make-simple-markup "5"))))
533 ;;choose your symbol for the diminished fifth
534 ((-1) (make-simple-markup "-5"))
535 ;;((-1) (make-line-markup (list (old-accidental->markup -1) (make-simple-markup "5")))))
537 ;;choose your symbol for the augmented fifth
538 ;;((1) (make-simple-markup "aug"))
539 ;;((1) (make-line-markup (list (old-accidental->markup 1) (make-simple-markup "5")))))
540 ((1) (make-simple-markup "+5"))
541 ((2) (make-line-markup (list (old-accidental->markup 2) (make-simple-markup "5"))))))
542 (else (if (and (= (car pitch) 0)
545 (make-simple-markup "sus4")
546 (step->markup-accidental pitch)))))
548 (define (chord::additions->markup-american additions subtractions)
549 (if (pair? additions)
550 ;; I don't like all this reasoning here, when we're actually typesetting.
551 (if(and(pair? (cdr additions)) ;a further addition left over
552 (or(and(= 0 (caddr(car additions))) ;this addition natural
553 (not(= 6 (cadr(car additions)))))
554 (and(= -1 (caddr(car additions)))
555 (= 6 (cadr(car additions)))))
556 (or(and(= 0 (caddr(cadr additions))) ;the following addition natural
557 (not(= 6 (cadr(cadr additions)))))
558 (and(= -1 (caddr(cadr additions)))
559 (= 6 (cadr(cadr additions)))))
560 (or(and(= (car(car additions)) (car(cadr additions))) ;both a third apart
561 (= 2 (- (cadr(cadr additions)) (cadr(car additions)))))
562 (and(= 1 (- (car(cadr additions)) (car(car additions))))
563 (= 5 (- (cadr(car additions)) (cadr(cadr additions))))))
564 (or(null? subtractions) ;this or clause protects the "adds"
565 (and (pair? subtractions)
566 (or (< (car(cadr additions)) (car(car subtractions)))
567 (and(= (car(cadr additions)) (car(car subtractions)))
568 (< (cadr(cadr additions)) (cadr(car subtractions))))))))
569 (chord::additions->markup-american (cdr additions) subtractions)
572 (let ((step (step->markup-american (car additions))))
573 (if (or (pair? (cdr additions))
574 (pair? subtractions))
575 (if (and (pair? (cdr additions))
576 (or(< 3 (- (cadr(cadr additions)) (cadr(car additions))))
577 (and(< 0 (- (car(cadr additions)) (car(car additions))))
578 (> 4 (- (cadr(car additions)) (cadr(cadr additions)))))))
579 (make-line-markup (list step (make-simple-markup " add")))
580 ;; tweak your favorite separator here
581 ;; (make-line-markup (list step (make-simple-markup "/")))
582 (make-line-markup (list step (make-simple-markup " "))))
584 (chord::additions->markup-american (cdr additions) subtractions))))
587 (define (chord::inner-name-american tonic exception-part additions subtractions
588 bass-and-inversion steps)
589 (let* ((tonic-markup (pitch->chord-name-markup-banter tonic steps))
590 (except-markup (if exception-part exception-part empty-markup))
591 ;; UGR. How do we know if we should add a separator or not?
592 ;; maybe just add extra column to exception list?
593 (sep-markup (if (and exception-part
594 (let ((s (format "~s" except-markup)))
596 (string-match "super" s)
598 ;; python: `except_markup`[-7:] != '"o"))'
602 (- (string-length s) 7))))))
603 (or (pair? additions)
604 (pair? subtractions)))
605 (make-super-markup (make-simple-markup "/"))
607 ;;this list contains all the additions that go "in line"
611 (let ((o (car x)) (n (cadr x)) (a (caddr x)))
612 (and (not (and (= 0 o) (= 2 n))) ;gets rid of unwanted thirds
613 ;;change this if you want it differently
614 (not (and (= 0 o) (= 3 n) (= 0 a))) ;sus4
615 (not (and (= 0 o) (= 4 n) (!= 0 a)))))) ;alt5
617 ;;this list contains all the additions that are patched onto the end
618 ;;of the chord symbol, usually sus4 and altered 5ths.
620 ;;take out the reverse if it bothers you in a pathological chord
624 (let ((o (car x)) (n (cadr x)) (a (caddr x)))
625 (and(not (and (= 0 o) (= 2 n))) ;gets rid of unwanted thirds
626 ;;change this correspondingly
627 (or(and (= 0 o) (= 3 n) (= 0 a)) ;sus4
628 (and (= 0 o) (= 4 n) (!= 0 a)))))) ;alt5
630 (relevant-subs (filter-list
631 (lambda (x) ;catches subtractions higher than 5th
632 (let((o (car x)) (n (cadr x)))
636 (pref-markup (chord::additions->markup-american prefixes relevant-subs))
637 (suff-markup (chord::additions->markup-american suffixes relevant-subs))
638 (b+i-markup (chord::bass-and-inversion->markup-banter bass-and-inversion)))
641 tonic-markup except-markup sep-markup
642 (make-normal-size-super-markup
643 (make-line-markup (list pref-markup suff-markup)))
646 (define (chord::additions-american steps)
647 (let ((evens (filter-list (lambda (x) (!= 0 (modulo (cadr x) 2))) steps))
648 ;we let all the unevens pass for now, we'll fix that later.
650 (filter-list (lambda (x)
651 (let ((n (cadr x)) (a (caddr x)))
652 (or (and (= 6 n) (!= -1 a))
654 (= 0 (modulo n 2))))))
656 (highest (let ((h (car (last-pair steps))))
657 (if (and (not (null? h))
662 (uniq-list (sort (apply append evens unevens highest)
665 ;; American style chordnames use no "no",
666 ;; but otherwise very similar to banter for now
667 (define-public (chord::name-american tonic exception-part unmatched-steps
668 bass-and-inversion steps)
669 (let ((additions (chord::additions-american unmatched-steps))
670 (subtractions (chord::subtractions unmatched-steps)))
671 (chord::inner-name-american tonic exception-part additions subtractions
672 bass-and-inversion steps)))
676 ;; Jazz chords, by Atte Andr'e Jensen <atte@post.com>
677 ;; Complete rewrite by Amelie Zapf (amy@loueymoss.com)
679 ;; FIXME: identical to chord::exception-alist-american, apart from commented
680 ;; dim chord. should merge.
681 (define-public chord::exception-alist-jazz
683 (((0 . 0)) . ,empty-markup)
684 (((0 . 0) (2 . -1)) . ,(make-simple-markup "m"))
686 ;; these should probably be normal-size? --jcn
687 ;;(((0 . 0) (4 . 0)) . ,(make-super-markup (make-simple-markup "5 ")))
688 ;;(((0 . 0) (1 . 0) (4 . 0)) . ,(make-super-markup (make-simple-markup "2 ")))
690 (((0 . 0) (4 . 0)) . ,(make-normal-size-super-markup (make-simple-markup "5 ")))
691 (((0 . 0) (1 . 0) (4 . 0)) . ,(make-normal-size-super-markup (make-simple-markup "2 ")))
693 ;;choose your symbol for the fully diminished chord
694 ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ,(make-simple-markup "dim"))
695 (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ,(make-line-markup (list (make-simple-markup "") (make-super-markup (make-simple-markup "o")))))
698 ;; FIXME: rather similar to step->markup-american. should merge.
699 (define (step->markup-jazz pitch)
701 ((6) (case (caddr pitch)
702 ((-2) (make-line-markup (list (old-accidental->markup -1) (make-simple-markup "7"))))
703 ((-1) (make-simple-markup "7"))
704 ;;Pick your favorite maj7
705 ((0) mathm-markup-object) ;;a white triangle
706 ;;((0) mathn-markup-object) ;;a black triangle
707 ;;((0) (make-simple-markup "maj7")) ;;good old maj7
708 ((1) (make-line-markup (list (old-accidental->markup 1) (make-simple-markup "7"))))
709 ((2) (make-line-markup (list (old-accidental->markup 2) (make-simple-markup "7"))))))
710 ((4) (case (caddr pitch)
711 ((-2) (make-line-markup (list (old-accidental->markup -2) (make-simple-markup "5"))))
712 ;;choose your symbol for the diminished fifth
713 ;;((-1) (make-simple-markup "-5"))
714 ((-1) (make-line-markup (list (old-accidental->markup -1) (make-simple-markup "5"))))
716 ;;choose your symbol for the augmented fifth
717 ;;((1) (make-simple-markup "aug"))
718 ((1) (make-line-markup (list (old-accidental->markup 1) (make-simple-markup "5"))))
719 ;;((1) (make-simple-markup "+5"))
720 ((2) (make-line-markup (list (old-accidental->markup 2) (make-simple-markup "5"))))))
721 (else (if (and (= (car pitch) 0)
724 (make-simple-markup "sus4")
725 (step->markup-accidental pitch)))))
727 ;; FIXME: identical to chord::additions->markup-american,
728 ;; except for -jazz / -american suffixes on calls
729 (define (chord::additions->markup-jazz additions subtractions)
730 (if (pair? additions)
731 ;; I don't like all this reasoning here, when we're actually typesetting.
732 (if(and(pair? (cdr additions)) ;a further addition left over
733 (or(and(= 0 (caddr(car additions))) ;this addition natural
734 (not(= 6 (cadr(car additions)))))
735 (and(= -1 (caddr(car additions)))
736 (= 6 (cadr(car additions)))))
737 (or(and(= 0 (caddr(cadr additions))) ;the following addition natural
738 (not(= 6 (cadr(cadr additions)))))
739 (and(= -1 (caddr(cadr additions)))
740 (= 6 (cadr(cadr additions)))))
741 (or(and(= (car(car additions)) (car(cadr additions))) ;both a third apart
742 (= 2 (- (cadr(cadr additions)) (cadr(car additions)))))
743 (and(= 1 (- (car(cadr additions)) (car(car additions))))
744 (= 5 (- (cadr(car additions)) (cadr(cadr additions))))))
745 (or(null? subtractions) ;this or clause protects the "adds"
746 (and (pair? subtractions)
747 (or (< (car(cadr additions)) (car(car subtractions)))
748 (and(= (car(cadr additions)) (car(car subtractions)))
749 (< (cadr(cadr additions)) (cadr(car subtractions))))))))
750 (chord::additions->markup-jazz (cdr additions) subtractions)
753 (let ((step (step->markup-jazz (car additions))))
754 (if (or (pair? (cdr additions))
755 (pair? subtractions))
756 (if (and (pair? (cdr additions))
757 (or(< 3 (- (cadr(cadr additions)) (cadr(car additions))))
758 (and(< 0 (- (car(cadr additions)) (car(car additions))))
759 (> 4 (- (cadr(car additions)) (cadr(cadr additions)))))))
760 (make-line-markup (list step (make-simple-markup " add")))
761 ;; tweak your favorite separator here
762 ;; (make-line-markup (list step (make-simple-markup "/")))
763 (make-line-markup (list step (make-simple-markup " "))))
765 (chord::additions->markup-jazz (cdr additions) subtractions))))
768 ;; FIXME: identical to chord::additions->markup-american.
769 ;; except for -jazz / -american suffixes on calls
770 (define (chord::inner-name-jazz tonic exception-part additions subtractions
771 bass-and-inversion steps)
772 (let* ((tonic-markup (pitch->chord-name-markup-banter tonic steps))
773 (except-markup (if exception-part exception-part empty-markup))
774 ;; UGR. How do we know if we should add a separator or not?
775 ;; maybe just add extra column to exception list?
776 (sep-markup (if (and exception-part
777 (let ((s (format "~s" except-markup)))
779 (string-match "super" s)
781 ;; python: `except_markup`[-7:] != '"o"))'
785 (- (string-length s) 7))))))
786 (or (pair? additions)
787 (pair? subtractions)))
788 (make-super-markup (make-simple-markup "/"))
790 ;;this list contains all the additions that go "in line"
794 (let ((o (car x)) (n (cadr x)) (a (caddr x)))
795 (and (not (and (= 0 o) (= 2 n))) ;gets rid of unwanted thirds
796 ;;change this if you want it differently
797 (not (and (= 0 o) (= 3 n) (= 0 a))) ;sus4
798 (not (and (= 0 o) (= 4 n) (!= 0 a)))))) ;alt5
800 ;;this list contains all the additions that are patched onto the end
801 ;;of the chord symbol, usually sus4 and altered 5ths.
803 ;;take out the reverse if it bothers you in a pathological chord
807 (let ((o (car x)) (n (cadr x)) (a (caddr x)))
808 (and(not (and (= 0 o) (= 2 n))) ;gets rid of unwanted thirds
809 ;;change this correspondingly
810 (or(and (= 0 o) (= 3 n) (= 0 a)) ;sus4
811 (and (= 0 o) (= 4 n) (!= 0 a)))))) ;alt5
813 (relevant-subs (filter-list
814 (lambda (x) ;catches subtractions higher than 5th
815 (let((o (car x)) (n (cadr x)))
819 (pref-markup (chord::additions->markup-jazz prefixes relevant-subs))
820 (suff-markup (chord::additions->markup-jazz suffixes relevant-subs))
821 (b+i-markup (chord::bass-and-inversion->markup-banter bass-and-inversion)))
824 tonic-markup except-markup sep-markup
825 (make-normal-size-super-markup
826 (make-line-markup (list pref-markup suff-markup)))
829 (define (chord::name-jazz tonic exception-part unmatched-steps
830 bass-and-inversion steps)
831 (let ((additions (chord::additions-american unmatched-steps))
832 (subtractions (chord::subtractions unmatched-steps)))
833 (chord::inner-name-jazz tonic exception-part additions subtractions
834 bass-and-inversion steps)))
837 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
840 (define-public (new-chord->markup func ly-pitches bass inversion context)
841 "Entry point for New_chord_name_engraver. See chord-name.scm for the
842 signature of FUNC. LY-PITCHES, BASS and INVERSION are lily
843 pitches. EXCEPTIONS is an alist (see scm file).
846 (let* ((pitches (map c++-pitch->scm ly-pitches))
847 (exceptions (ly:get-context-property context 'chordNameExceptions))
849 (cons (c++-pitch->scm bass)
850 (c++-pitch->scm inversion)))
851 (diff (pitch::diff '(0 0 0) (car pitches)))
852 (steps (if (cdr pitches) (map (lambda (x)
853 (pitch::transpose x diff))
856 (lookup (dbg (chord::exceptions-lookup exceptions steps)))
857 (exception-part (dbg (car lookup)))
858 (unmatched-steps (cadr lookup))
859 (tonic (car pitches))
862 (func tonic exception-part unmatched-steps bass-and-inversion steps)
865 (define-public (chord->markup-jazz . args)
866 (apply new-chord->markup (cons chord::name-jazz args))
869 (define-public (chord->markup-american . args)
870 (apply new-chord->markup (cons chord::name-american args))
873 (define-public (chord->markup-banter . args)
874 (apply new-chord->markup (cons chord::name-banter args))
877 (define-public (new-chord-name-brew-molecule grob)
880 (ws (ly:get-grob-property grob 'word-space))
881 (markup (ly:get-grob-property grob 'text))
882 (molecule (interpret-markup grob
883 (cons '((word-space . 0.0))
884 (Font_interface::get_property_alist_chain grob))
889 ;; chord names aren't in staffs, so WS is in global staff space.
891 (ly:molecule-combine-at-edge
893 X RIGHT (ly:make-molecule "" (cons 0 ws) '(-1 . 1) )
898 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
900 (define-public (set-chord-name-style sym)
901 "Return music expressions that set the chord naming style. For
902 inline use in .ly file"
904 (define (chord-name-style-setter function exceptions)
906 (make-sequential-music
907 (list (make-property-set 'chordNameFunction function)
908 (make-property-set 'chordNameExceptions exceptions)))
916 (chord-name-style-setter chord->markup-jazz
917 chord::exception-alist-jazz))
919 (chord-name-style-setter chord->markup-banter
920 chord::exception-alist-banter))
922 (chord-name-style-setter chord->markup-american
923 chord::exception-alist-american))
926 (chord-name-style-setter ignatzek-chord-names
928 ((double-plus-new-banter)
929 (chord-name-style-setter double-plus-new-chord->markup-banter
930 chord::exception-alist-banter))
932 ((double-plus-new-jazz)
933 (chord-name-style-setter double-plus-new-chord->markup-jazz
934 chord::exception-alist-jazz))
937 ;; can't put this in double-plus-new-chord-name.scm, because we can't
938 ;; ly:load that very easily.
939 (define-public (set-double-plus-new-chord-name-style style options)
940 "Return music expressions that set the chord naming style. For
941 inline use in .ly file"
943 (define (chord-name-style-setter function)
945 (make-sequential-music
946 (list (make-property-set 'chordNameFunction function)
948 ;; urg , misuse of chordNameExceptions function.
949 (make-property-set 'chordNameExceptions options)))
955 (chord-name-style-setter double-plus-new-chord->markup-banter))
958 (chord-name-style-setter double-plus-new-chord->markup-jazz)))))