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>
18 (define-public (write-me x)
19 "Write and return X. For debugging purposes. "
20 (write x) (newline) x)
22 ;(define (dbg x) (write-me x))
25 ;;(define (write-me x) (write x) (newline) x)
26 ;;(define (write-me-2 x y) (write "FOO") (write x) (write y) (newline) y)
32 * Use lilypond Pitch objects -- SCM pitch objects lead to
33 duplication. LilyPond pitch objects force meaningful names
34 (i.e. (ly:pitch-octave PITCH) )
36 * Pitches are musical objects. The pitches -> markup step should
37 happen earlier (during interpreting), brew-molecule () should only
38 dump reinterpret the markup as a molecule.
40 * chord:: prefix is a poor-man's namespace device.
41 We have a module system to prevent export to userland.
42 Nested functions can take care of many other clashes. --hwn.
44 * easier tweakability:
46 - split chord::names-alists up into logical bits,
47 such as chord::exceptions-delta, exceptions-oslash
48 - iso just the 'style parameter, use a list, eg:
49 \property ChordNames.ChordName \set
50 #'style = #'(jazz delta oslash german-tonic german-Bb)
52 * clean split/merge of bass/banter/american stuff.
53 GET RID OF code duplication.
61 ;; " hey Emacs: string has ended
64 ;; pitch = (octave notename alteration)
66 ;; note = (notename . alteration)
68 ;; markup = markup text -- see font.scm and input/test/markup.ly
71 (define-public chord::exception-alist-banter
74 (((0 . 0)) . ,empty-markup)
76 (((0 . 0) (2 . 0)) . ,empty-markup)
78 (((0 . 0) (2 . -1)) . ,(make-simple-markup "m"))
80 (((0 . 0) (1 . 0) (4 . 0))
81 . ,(make-normal-size-super-markup (make-simple-markup "2 ")))
83 (((0 . 0) (3 . 0) (4 . 0))
84 . ,(make-normal-size-super-markup (make-simple-markup "4 ")))
86 (((0 . 0) (2 . -1) (4 . -1)) . ,(make-simple-markup "dim"))
87 ; URG: Simply C:m5-/maj7 iso Cdim maj7
88 (((0 . 0) (2 . -1) (4 . -1) (6 . 0))
91 (make-simple-markup "m")
92 (make-normal-size-super-markup (make-simple-markup "5-/maj7 ")))))
93 ; URG: Simply C:m5-/7 iso Cdim7
94 (((0 . 0) (2 . -1) (4 . -1) (6 . -1))
97 (make-simple-markup "m")
98 (make-normal-size-super-markup (make-simple-markup "5-/7 ")))))
100 (((0 . 0) (2 . -1) (4 . -1) (6 . -2))
101 . ,(make-super-markup (make-simple-markup "o")))
103 (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1))
105 (list (make-simple-markup "dim")
106 (make-normal-size-super-markup (make-simple-markup "9 ")))))
107 (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1) (3 . -1))
109 (list (make-simple-markup "dim")
110 (make-normal-size-super-markup
111 (make-simple-markup "11 ")))))
115 ; pitch->note-name: drops octave
116 (define (pitch->note-name pitch)
117 (cons (cadr pitch) (caddr pitch)))
119 (define (accidental->markup acc)
120 "ACC is an int, return a markup making an accidental."
122 (make-line-markup (list empty-markup))
123 (make-smaller-markup (make-musicglyph-markup
124 (string-append "accidentals-"
125 (number->string acc))))))
128 (define (accidental->markupp acc pos)
132 (let ((acc-markup (make-musicglyph-markup
133 (string-append "accidentals-"
134 (number->string acc)))))
136 (if (equal? pos 'columns)
137 (make-line-markup (list (make-smaller-markup acc-markup)))
138 (if (equal? pos 'super)
139 (make-line-markup (list (make-super-markup acc-markup)))
140 ;; not 'super or 'columns must be 'sub...
141 (make-line-markup (list (make-sub-markup acc-markup))))))))
146 ;; FIXME: possibly to be used for american/jazz style
147 ;; However, only pos == columns is used, which seems to do
148 ;; exactly what accidental->markup does...
149 (define (amy-accidental->text acc) (accidental->textp acc 'columns))
153 ;;;(define (accidental->text-super acc) (accidental->textp acc 'simple-super))
154 ;;(define (accidental->text-super acc) (accidental->textp acc 'super))
155 ;;(define (accidental->text-sub acc) (accidental->textp acc 'sub))
159 ;; TODO: invent sensible way to make note name tweaking possible?
161 (define (pitch->markup pitch)
165 (vector-ref #("C" "D" "E" "F" "G" "A" "B") (cadr pitch)))
166 (make-normal-size-super-markup
167 (accidental->markup (caddr pitch))))))
169 ;;; Hooks to override chord names and note names,
170 ;;; see input/tricks/german-chords.ly
172 (define pitch->markup-banter pitch->markup)
174 ;; We need also steps, to allow for Cc name override,
175 ;; see input/test/Cc-chords.ly
176 (define (pitch->chord-name-markup-banter pitch steps)
177 (pitch->markup-banter pitch))
179 (define pitch->note-name-markup-banter pitch->markup-banter)
181 (define (step->markup pitch)
183 (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))
191 (define (step->markup-banter pitch)
193 (if (= (cadr pitch) 6)
200 (step->markup pitch))))
202 (define (step->markup-previously-alternate-jazz pitch)
205 (accidental->markup (caddr pitch))
207 (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))))))
209 (define (step->markup-previously-jazz pitch)
210 (if (= (cadr pitch) 6)
212 ;; sharp 7 only included for completeness?
213 ((-2) (make-line-markup
215 (accidental->markup -1)
216 (make-simple-markup "7"))))
217 ((-1) (make-simple-markup "7"))
218 ((0) (make-simple-markup "maj7"))
219 ;;((0) (make-line-markup
220 ;; (list (make-simple-markup "maj7"))))
221 ((1) (make-line-markup
223 (accidental->markup 1) (make-simple-markup "7"))))
224 ((2) (make-line-markup
225 (list (accidental->markup 1)
226 (make-simple-markup "7")))))
227 (step->markup-previously-alternate-jazz pitch)))
230 (define pitch::semitone-vec #(0 2 4 5 7 9 11))
232 (define (pitch::semitone pitch)
233 (+ (* (car pitch) 12)
234 (vector-ref pitch::semitone-vec (modulo (cadr pitch) 7))
237 (define (pitch::< l r)
238 (< (pitch::semitone l) (pitch::semitone r)))
240 (define (pitch::transpose pitch delta)
241 (let ((simple-octave (+ (car pitch) (car delta)))
242 (simple-notename (+ (cadr pitch) (cadr delta))))
243 (let ((octave (+ simple-octave (quotient simple-notename 7)))
244 (notename (modulo simple-notename 7)))
245 (let ((accidental (- (+ (pitch::semitone pitch) (pitch::semitone delta))
246 (pitch::semitone `(,octave ,notename 0)))))
247 `(,octave ,notename ,accidental)))))
249 (define (pitch::diff pitch tonic)
250 (let ((simple-octave (- (car pitch) (car tonic)))
251 (simple-notename (- (cadr pitch) (cadr tonic))))
252 (let ((octave (+ simple-octave (quotient simple-notename 7)
253 (if (< simple-notename 0) -1 0)))
254 (notename (modulo simple-notename 7)))
255 (let ((accidental (- (pitch::semitone pitch)
256 (pitch::semitone tonic)
257 (pitch::semitone `(,octave ,notename 0)))))
258 `(,octave ,notename ,accidental)))))
260 (define (pitch::note-pitch pitch)
261 (+ (* (car pitch) 7) (cadr pitch)))
265 (define chord::minor-major-vec #(0 -1 -1 0 -1 -1 0))
268 ;; compute the relative-to-tonic pitch that goes with 'step'
269 (define (chord::step-pitch tonic step)
270 ;; urg, we only do this for thirds
271 (if (= (modulo step 2) 0)
273 (let loop ((i 1) (pitch tonic))
277 pitch `(0 2 ,(vector-ref chord::minor-major-vec
278 ;; -1 (step=1 -> vector=0) + 7 = 6
279 (modulo (+ i 6) 7)))))))))
281 (define (chord::additions steps)
283 * any even step (2, 4, 6)
284 * any uneven step that is chromatically altered,
285 (where 7-- == -1, 7- == 0, 7 == +1)
288 ?and jazz needs also:
290 * TODO: any uneven step that's lower than an uneven step which is
291 chromatically altered
293 (let ((evens (filter-list (lambda (x) (!= 0 (modulo (cadr x) 2))) steps))
295 (filter-list (lambda (x)
296 (let ((n (cadr x)) (a (caddr x)))
297 (or (and (= 6 n) (!= -1 a))
302 (highest (let ((h (car (last-pair steps))))
303 (if (and (not (null? h))
308 ;; Hmm, what if we have a step twice, can we ignore that?
309 (uniq-list (sort (apply append evens altered-unevens highest)
313 ;; FIXME: unLOOP, see ::additions
314 ;; find the pitches that are missing from `normal' chord
315 (define (chord::subtractions chord-pitches)
316 (let ((tonic (car chord-pitches)))
317 (let loop ((step 1) (pitches chord-pitches) (subtractions '()))
319 (let* ((pitch (car pitches))
320 (p-step (+ (- (pitch::note-pitch pitch)
321 (pitch::note-pitch tonic))
323 ;; pitch is an subtraction if
324 ;; a step is missing or
326 (loop (+ step 2) pitches
327 (cons (chord::step-pitch tonic step) subtractions))
328 ;; there are no pitches left, but base thirds are not yet done and
330 (= (length pitches) 1))
331 ;; present pitch is not missing step
333 (loop (+ step 2) pitches subtractions)
334 (loop (+ step 2) pitches
335 (cons (chord::step-pitch tonic step) subtractions)))
337 (loop (+ step 2) (cdr pitches) subtractions)
338 (loop step (cdr pitches) subtractions)))))
339 (reverse subtractions)))))
341 (define (chord::additions->markup-banter additions subtractions)
342 (if (pair? additions)
345 (let ((step (step->markup-banter (car additions))))
346 (if (or (pair? (cdr additions))
347 (pair? subtractions))
349 (list step (make-simple-markup "/")))
351 (chord::additions->markup-banter (cdr additions) subtractions)))
354 (define (chord::subtractions->markup-banter subtractions)
355 (if (pair? subtractions)
358 (make-simple-markup "no")
359 (let ((step (step->markup-previously-jazz
360 (car subtractions))))
361 (if (pair? (cdr subtractions))
363 (list step (make-simple-markup "/")))
365 (chord::subtractions->markup-banter (cdr subtractions))))
368 (define (chord::bass-and-inversion->markup-banter bass-and-inversion)
369 (if (and (pair? bass-and-inversion)
370 (or (car bass-and-inversion)
371 (cdr bass-and-inversion)))
374 (make-simple-markup "/")
375 (pitch->note-name-markup-banter
376 (if (car bass-and-inversion)
377 (car bass-and-inversion)
378 (cdr bass-and-inversion)))))
381 ;; FIXME: merge this function with inner-name-jazz, -american
382 ;; iso using chord::bass-and-inversion->markup-banter,
383 ;; See: chord::exceptions-lookup
384 (define (chord::inner-name-banter tonic exception-part additions subtractions
385 bass-and-inversion steps)
389 Combine tonic, exception-part of chord name,
390 additions, subtractions and bass or inversion into chord name
393 (let* ((tonic-markup (pitch->chord-name-markup-banter tonic steps))
394 (except-markup (if exception-part exception-part empty-markup))
395 ;; UGR. How do we know if we should add a separator or not?
396 ;; maybe just add extra column to exception list?
397 (sep-markup (if (and exception-part
398 (let ((s (format "~s" except-markup)))
400 (string-match "super" s)
402 ;; python: `except_markup`[-5:] != '"o"))'
406 (- (string-length s) 5))))))
407 (or (pair? additions)
408 (pair? subtractions)))
409 (make-super-markup (make-simple-markup "/"))
411 (adds-markup (chord::additions->markup-banter additions subtractions))
412 (subs-markup (chord::subtractions->markup-banter subtractions))
413 (b+i-markup (chord::bass-and-inversion->markup-banter
414 bass-and-inversion)))
421 (make-normal-size-super-markup
422 (make-line-markup (list adds-markup subs-markup)))
425 (define (c++-pitch->scm p)
427 (list (ly:pitch-octave p) (ly:pitch-notename p) (ly:pitch-alteration p))
430 (define (chord::name-banter tonic exception-part unmatched-steps
431 bass-and-inversion steps)
432 (let ((additions (chord::additions unmatched-steps))
433 (subtractions (chord::subtractions unmatched-steps)))
435 (chord::inner-name-banter tonic exception-part additions subtractions
436 bass-and-inversion steps)))
440 (define (chord::exceptions-lookup exceptions steps)
442 return (MATCHED-EXCEPTION . BASE-CHORD-WITH-UNMATCHED-STEPS)
443 BASE-CHORD-WITH-UNMATCHED-STEPS always includes (tonic 3 5)
446 ;; this is unintelligible.
448 (define (chord::exceptions-lookup-helper
449 exception-alist try-steps unmatched-steps exception-part)
452 check exception-alist for biggest matching part of try-steps
453 return (MATCHED-EXCEPTION . UNMATCHED-STEPS)
456 (if (pair? try-steps)
457 ;; FIXME: junk '(0 . 0) from exceptions lists?
458 ;; if so: how to handle first '((0 . 0) . #f) entry?
460 ;; FIXME: either format exceptions list as real pitches, ie,
461 ;; including octave '((0 2 -1) ..), or drop octave
462 ;; from rest of calculations,
464 (map (lambda (x) (pitch->note-name x))
465 (append '((0 0 0)) try-steps))
468 (chord::exceptions-lookup-helper
469 #f '() unmatched-steps (cdr entry))
470 (let ((r (reverse try-steps)))
471 (chord::exceptions-lookup-helper
474 (cons (car r) unmatched-steps) #f))))
475 (cons exception-part unmatched-steps)))
477 (let* ((result (chord::exceptions-lookup-helper
480 (exception-part (car result))
481 (unmatched-steps (cdr result))
482 (matched-steps (if (= (length unmatched-steps) 0)
484 (+ 1 (- (length steps)
485 (length unmatched-steps)))))
486 (unmatched-with-1-3-5
487 (append (do ((i matched-steps (- i 1))
488 (base '() (cons `(0 ,(* (- i 1) 2) 0) base)))
492 (list exception-part unmatched-with-1-3-5)))
499 ;; See input/test/american-chords.ly
501 ;; Original Version by James Hammons, <jlhamm@pacificnet.net>
502 ;; Complete rewrite by Amelie Zapf, <amy@loueymoss.com>
504 ;; DONT use non-ascii characters, even if ``it works'' in Windows
507 (define mathm-markup-object
508 (make-override-markup '(font-family . math) (make-simple-markup "M")))
511 (define mathn-markup-object
512 (make-override-markup '(font-family . math) (make-simple-markup "N")))
514 (define (step->markup-accidental pitch)
518 ((-2) (accidental->markup -2))
519 ((-1) (accidental->markup -1))
521 ((1) (accidental->markup 1))
522 ((2) (accidental->markup 2)))
523 (make-simple-markup (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))))))
525 (define-public chord::exception-alist-american
527 (((0 . 0)) . ,empty-markup)
528 (((0 . 0) (2 . -1)) . ,(make-simple-markup "m"))
530 ;; these should probably be normal-size? --jcn
531 ;;(((0 . 0) (4 . 0)) . ,(make-super-markup (make-simple-markup "5 ")))
532 ;;(((0 . 0) (1 . 0) (4 . 0)) . ,(make-super-markup (make-simple-markup "2 ")))
534 (((0 . 0) (4 . 0)) . ,(make-normal-size-super-markup (make-simple-markup "5 ")))
535 (((0 . 0) (1 . 0) (4 . 0)) . ,(make-normal-size-super-markup (make-simple-markup "2 ")))
537 ;;choose your symbol for the fully diminished chord
538 (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ,(make-simple-markup "dim"))
539 ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ,(make-line-markup (list empty-markup (make-super-markup (make-simple-markup "o")))))
542 (define (step->markup-american pitch)
544 ((6) (case (caddr pitch)
545 ((-2) (make-line-markup (list (accidental->markup -1) (make-simple-markup "7"))))
546 ((-1) (make-simple-markup "7"))
547 ((0) (make-simple-markup "maj7"))
548 ((1) (make-line-markup (list (accidental->markup 1) (make-simple-markup "7"))))
549 ((2) (make-line-markup (list (accidental->markup 2) (make-simple-markup "7"))))))
550 ((4) (case (caddr pitch)
551 ((-2) (make-line-markup (list (accidental->markup -2) (make-simple-markup "5"))))
552 ;;choose your symbol for the diminished fifth
553 ((-1) (make-simple-markup "-5"))
554 ;;((-1) (make-line-markup (list (accidental->markup -1) (make-simple-markup "5")))))
556 ;;choose your symbol for the augmented fifth
557 ;;((1) (make-simple-markup "aug"))
558 ;;((1) (make-line-markup (list (accidental->markup 1) (make-simple-markup "5")))))
559 ((1) (make-simple-markup "+5"))
560 ((2) (make-line-markup (list (accidental->markup 2) (make-simple-markup "5"))))))
561 (else (if (and (= (car pitch) 0)
564 (make-simple-markup "sus4")
565 (step->markup-accidental pitch)))))
567 (define (chord::additions->markup-american additions subtractions)
568 (if (pair? additions)
569 ;; I don't like all this reasoning here, when we're actually typesetting.
570 (if(and(pair? (cdr additions)) ;a further addition left over
571 (or(and(= 0 (caddr(car additions))) ;this addition natural
572 (not(= 6 (cadr(car additions)))))
573 (and(= -1 (caddr(car additions)))
574 (= 6 (cadr(car additions)))))
575 (or(and(= 0 (caddr(cadr additions))) ;the following addition natural
576 (not(= 6 (cadr(cadr additions)))))
577 (and(= -1 (caddr(cadr additions)))
578 (= 6 (cadr(cadr additions)))))
579 (or(and(= (car(car additions)) (car(cadr additions))) ;both a third apart
580 (= 2 (- (cadr(cadr additions)) (cadr(car additions)))))
581 (and(= 1 (- (car(cadr additions)) (car(car additions))))
582 (= 5 (- (cadr(car additions)) (cadr(cadr additions))))))
583 (or(null? subtractions) ;this or clause protects the "adds"
584 (and (pair? subtractions)
585 (or (< (car(cadr additions)) (car(car subtractions)))
586 (and(= (car(cadr additions)) (car(car subtractions)))
587 (< (cadr(cadr additions)) (cadr(car subtractions))))))))
588 (chord::additions->markup-american (cdr additions) subtractions)
591 (let ((step (step->markup-american (car additions))))
592 (if (or (pair? (cdr additions))
593 (pair? subtractions))
594 (if (and (pair? (cdr additions))
595 (or(< 3 (- (cadr(cadr additions)) (cadr(car additions))))
596 (and(< 0 (- (car(cadr additions)) (car(car additions))))
597 (> 4 (- (cadr(car additions)) (cadr(cadr additions)))))))
598 (make-line-markup (list step (make-simple-markup " add")))
599 ;; tweak your favorite separator here
600 ;; (make-line-markup (list step (make-simple-markup "/")))
601 (make-line-markup (list step (make-simple-markup " "))))
603 (chord::additions->markup-american (cdr additions) subtractions))))
606 (define (chord::inner-name-american tonic exception-part additions subtractions
607 bass-and-inversion steps)
608 (let* ((tonic-markup (pitch->chord-name-markup-banter tonic steps))
609 (except-markup (if exception-part exception-part empty-markup))
610 ;; UGR. How do we know if we should add a separator or not?
611 ;; maybe just add extra column to exception list?
612 (sep-markup (if (and exception-part
613 (let ((s (format "~s" except-markup)))
615 (string-match "super" s)
617 ;; python: `except_markup`[-7:] != '"o"))'
621 (- (string-length s) 7))))))
622 (or (pair? additions)
623 (pair? subtractions)))
624 (make-super-markup (make-simple-markup "/"))
626 ;;this list contains all the additions that go "in line"
630 (let ((o (car x)) (n (cadr x)) (a (caddr x)))
631 (and (not (and (= 0 o) (= 2 n))) ;gets rid of unwanted thirds
632 ;;change this if you want it differently
633 (not (and (= 0 o) (= 3 n) (= 0 a))) ;sus4
634 (not (and (= 0 o) (= 4 n) (!= 0 a)))))) ;alt5
636 ;;this list contains all the additions that are patched onto the end
637 ;;of the chord symbol, usually sus4 and altered 5ths.
639 ;;take out the reverse if it bothers you in a pathological chord
643 (let ((o (car x)) (n (cadr x)) (a (caddr x)))
644 (and(not (and (= 0 o) (= 2 n))) ;gets rid of unwanted thirds
645 ;;change this correspondingly
646 (or(and (= 0 o) (= 3 n) (= 0 a)) ;sus4
647 (and (= 0 o) (= 4 n) (!= 0 a)))))) ;alt5
649 (relevant-subs (filter-list
650 (lambda (x) ;catches subtractions higher than 5th
651 (let((o (car x)) (n (cadr x)))
655 (pref-markup (chord::additions->markup-american prefixes relevant-subs))
656 (suff-markup (chord::additions->markup-american suffixes relevant-subs))
657 (b+i-markup (chord::bass-and-inversion->markup-banter bass-and-inversion)))
660 tonic-markup except-markup sep-markup
661 (make-normal-size-super-markup
662 (make-line-markup (list pref-markup suff-markup)))
665 (define (chord::additions-american steps)
666 (let ((evens (filter-list (lambda (x) (!= 0 (modulo (cadr x) 2))) steps))
667 ;we let all the unevens pass for now, we'll fix that later.
669 (filter-list (lambda (x)
670 (let ((n (cadr x)) (a (caddr x)))
671 (or (and (= 6 n) (!= -1 a))
673 (= 0 (modulo n 2))))))
675 (highest (let ((h (car (last-pair steps))))
676 (if (and (not (null? h))
681 (uniq-list (sort (apply append evens unevens highest)
684 ;; American style chordnames use no "no",
685 ;; but otherwise very similar to banter for now
686 (define-public (chord::name-american tonic exception-part unmatched-steps
687 bass-and-inversion steps)
688 (let ((additions (chord::additions-american unmatched-steps))
689 (subtractions (chord::subtractions unmatched-steps)))
690 (chord::inner-name-american tonic exception-part additions subtractions
691 bass-and-inversion steps)))
695 ;; Jazz chords, by Atte Andr'e Jensen <atte@post.com>
696 ;; Complete rewrite by Amelie Zapf (amy@loueymoss.com)
698 ;; FIXME: identical to chord::exception-alist-american, apart from commented
699 ;; dim chord. should merge.
700 (define-public chord::exception-alist-jazz
702 (((0 . 0)) . ,empty-markup)
703 (((0 . 0) (2 . -1)) . ,(make-simple-markup "m"))
705 ;; these should probably be normal-size? --jcn
706 ;;(((0 . 0) (4 . 0)) . ,(make-super-markup (make-simple-markup "5 ")))
707 ;;(((0 . 0) (1 . 0) (4 . 0)) . ,(make-super-markup (make-simple-markup "2 ")))
709 (((0 . 0) (4 . 0)) . ,(make-normal-size-super-markup (make-simple-markup "5 ")))
710 (((0 . 0) (1 . 0) (4 . 0)) . ,(make-normal-size-super-markup (make-simple-markup "2 ")))
712 ;;choose your symbol for the fully diminished chord
713 ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ,(make-simple-markup "dim"))
714 (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ,(make-line-markup (list (make-simple-markup "") (make-super-markup (make-simple-markup "o")))))
717 ;; FIXME: rather similar to step->markup-american. should merge.
718 (define (step->markup-jazz pitch)
720 ((6) (case (caddr pitch)
721 ((-2) (make-line-markup (list (accidental->markup -1) (make-simple-markup "7"))))
722 ((-1) (make-simple-markup "7"))
723 ;;Pick your favorite maj7
724 ((0) mathm-markup-object) ;;a white triangle
725 ;;((0) mathn-markup-object) ;;a black triangle
726 ;;((0) (make-simple-markup "maj7")) ;;good old maj7
727 ((1) (make-line-markup (list (accidental->markup 1) (make-simple-markup "7"))))
728 ((2) (make-line-markup (list (accidental->markup 2) (make-simple-markup "7"))))))
729 ((4) (case (caddr pitch)
730 ((-2) (make-line-markup (list (accidental->markup -2) (make-simple-markup "5"))))
731 ;;choose your symbol for the diminished fifth
732 ;;((-1) (make-simple-markup "-5"))
733 ((-1) (make-line-markup (list (accidental->markup -1) (make-simple-markup "5"))))
735 ;;choose your symbol for the augmented fifth
736 ;;((1) (make-simple-markup "aug"))
737 ((1) (make-line-markup (list (accidental->markup 1) (make-simple-markup "5"))))
738 ;;((1) (make-simple-markup "+5"))
739 ((2) (make-line-markup (list (accidental->markup 2) (make-simple-markup "5"))))))
740 (else (if (and (= (car pitch) 0)
743 (make-simple-markup "sus4")
744 (step->markup-accidental pitch)))))
746 ;; FIXME: identical to chord::additions->markup-american,
747 ;; except for -jazz / -american suffixes on calls
748 (define (chord::additions->markup-jazz additions subtractions)
749 (if (pair? additions)
750 ;; I don't like all this reasoning here, when we're actually typesetting.
751 (if(and(pair? (cdr additions)) ;a further addition left over
752 (or(and(= 0 (caddr(car additions))) ;this addition natural
753 (not(= 6 (cadr(car additions)))))
754 (and(= -1 (caddr(car additions)))
755 (= 6 (cadr(car additions)))))
756 (or(and(= 0 (caddr(cadr additions))) ;the following addition natural
757 (not(= 6 (cadr(cadr additions)))))
758 (and(= -1 (caddr(cadr additions)))
759 (= 6 (cadr(cadr additions)))))
760 (or(and(= (car(car additions)) (car(cadr additions))) ;both a third apart
761 (= 2 (- (cadr(cadr additions)) (cadr(car additions)))))
762 (and(= 1 (- (car(cadr additions)) (car(car additions))))
763 (= 5 (- (cadr(car additions)) (cadr(cadr additions))))))
764 (or(null? subtractions) ;this or clause protects the "adds"
765 (and (pair? subtractions)
766 (or (< (car(cadr additions)) (car(car subtractions)))
767 (and(= (car(cadr additions)) (car(car subtractions)))
768 (< (cadr(cadr additions)) (cadr(car subtractions))))))))
769 (chord::additions->markup-jazz (cdr additions) subtractions)
772 (let ((step (step->markup-jazz (car additions))))
773 (if (or (pair? (cdr additions))
774 (pair? subtractions))
775 (if (and (pair? (cdr additions))
776 (or(< 3 (- (cadr(cadr additions)) (cadr(car additions))))
777 (and(< 0 (- (car(cadr additions)) (car(car additions))))
778 (> 4 (- (cadr(car additions)) (cadr(cadr additions)))))))
779 (make-line-markup (list step (make-simple-markup " add")))
780 ;; tweak your favorite separator here
781 ;; (make-line-markup (list step (make-simple-markup "/")))
782 (make-line-markup (list step (make-simple-markup " "))))
784 (chord::additions->markup-jazz (cdr additions) subtractions))))
787 ;; FIXME: identical to chord::additions->markup-american.
788 ;; except for -jazz / -american suffixes on calls
789 (define (chord::inner-name-jazz tonic exception-part additions subtractions
790 bass-and-inversion steps)
791 (let* ((tonic-markup (pitch->chord-name-markup-banter tonic steps))
792 (except-markup (if exception-part exception-part empty-markup))
793 ;; UGR. How do we know if we should add a separator or not?
794 ;; maybe just add extra column to exception list?
795 (sep-markup (if (and exception-part
796 (let ((s (format "~s" except-markup)))
798 (string-match "super" s)
800 ;; python: `except_markup`[-7:] != '"o"))'
804 (- (string-length s) 7))))))
805 (or (pair? additions)
806 (pair? subtractions)))
807 (make-super-markup (make-simple-markup "/"))
809 ;;this list contains all the additions that go "in line"
813 (let ((o (car x)) (n (cadr x)) (a (caddr x)))
814 (and (not (and (= 0 o) (= 2 n))) ;gets rid of unwanted thirds
815 ;;change this if you want it differently
816 (not (and (= 0 o) (= 3 n) (= 0 a))) ;sus4
817 (not (and (= 0 o) (= 4 n) (!= 0 a)))))) ;alt5
819 ;;this list contains all the additions that are patched onto the end
820 ;;of the chord symbol, usually sus4 and altered 5ths.
822 ;;take out the reverse if it bothers you in a pathological chord
826 (let ((o (car x)) (n (cadr x)) (a (caddr x)))
827 (and(not (and (= 0 o) (= 2 n))) ;gets rid of unwanted thirds
828 ;;change this correspondingly
829 (or(and (= 0 o) (= 3 n) (= 0 a)) ;sus4
830 (and (= 0 o) (= 4 n) (!= 0 a)))))) ;alt5
832 (relevant-subs (filter-list
833 (lambda (x) ;catches subtractions higher than 5th
834 (let((o (car x)) (n (cadr x)))
838 (pref-markup (chord::additions->markup-jazz prefixes relevant-subs))
839 (suff-markup (chord::additions->markup-jazz suffixes relevant-subs))
840 (b+i-markup (chord::bass-and-inversion->markup-banter bass-and-inversion)))
843 tonic-markup except-markup sep-markup
844 (make-normal-size-super-markup
845 (make-line-markup (list pref-markup suff-markup)))
848 (define (chord::name-jazz tonic exception-part unmatched-steps
849 bass-and-inversion steps)
850 (let ((additions (chord::additions-american unmatched-steps))
851 (subtractions (chord::subtractions unmatched-steps)))
852 (chord::inner-name-jazz tonic exception-part additions subtractions
853 bass-and-inversion steps)))
856 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
859 (define-public (new-chord->markup func ly-pitches bass inversion exceptions)
860 "Entry point for New_chord_name_engraver. See chord-name.scm for the
861 signature of FUNC. LY-PITCHES, BASS and INVERSION are lily
862 pitches. EXCEPTIONS is an alist (see scm file).
865 (let* ((pitches (map c++-pitch->scm ly-pitches))
867 (cons (c++-pitch->scm bass)
868 (c++-pitch->scm inversion)))
869 (diff (pitch::diff '(0 0 0) (car pitches)))
870 (steps (if (cdr pitches) (map (lambda (x)
871 (pitch::transpose x diff))
874 (lookup (dbg (chord::exceptions-lookup exceptions steps)))
875 (exception-part (dbg (car lookup)))
876 (unmatched-steps (cadr lookup))
877 (tonic (car pitches))
880 (func tonic exception-part unmatched-steps bass-and-inversion steps)
883 (define-public (chord->markup-jazz . args)
884 (apply new-chord->markup (cons chord::name-jazz args))
887 (define-public (chord->markup-american . args)
888 (apply new-chord->markup (cons chord::name-american args))
891 (define-public (chord->markup-banter . args)
892 (apply new-chord->markup (cons chord::name-banter args))
895 (define-public (new-chord-name-brew-molecule grob)
898 (ws (ly:get-grob-property grob 'word-space))
899 (markup (ly:get-grob-property grob 'text))
900 (molecule (interpret-markup grob
901 (cons '((word-space . 0.0))
902 (Font_interface::get_property_alist_chain grob))
907 ;; chord names aren't in staffs, so WS is in global staff space.
909 (ly:combine-molecule-at-edge
911 X RIGHT (ly:make-molecule "" (cons 0 ws) '(-1 . 1) )
916 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
918 (define-public (set-chord-name-style sym)
919 "Return music expressions that set the chord naming style. For
920 inline use in .ly file"
922 (define (chord-name-style-setter function exceptions)
924 (make-sequential-music
925 (list (make-property-set 'chordNameFunction function)
926 (make-property-set 'chordNameExceptions exceptions)))
934 (chord-name-style-setter chord->markup-jazz
935 chord::exception-alist-jazz))
937 (chord-name-style-setter chord->markup-banter
938 chord::exception-alist-banter))
940 (chord-name-style-setter chord->markup-american
941 chord::exception-alist-american))
943 ((double-plus-new-banter)
944 (chord-name-style-setter double-plus-new-chord->markup-banter
945 chord::exception-alist-banter))
947 ((double-plus-new-jazz)
948 (chord-name-style-setter double-plus-new-chord->markup-jazz
949 chord::exception-alist-jazz))
952 ;; can't put this in double-plus-new-chord-name.scm, because we can't
953 ;; ly:load that very easily.
954 (define-public (set-double-plus-new-chord-name-style style options)
955 "Return music expressions that set the chord naming style. For
956 inline use in .ly file"
958 (define (chord-name-style-setter function)
960 (make-sequential-music
961 (list (make-property-set 'chordNameFunction function)
962 (make-property-set 'chordNameExceptions options)))
968 (chord-name-style-setter double-plus-new-chord->markup-banter))
971 (chord-name-style-setter double-plus-new-chord->markup-jazz)))))