scm/chord-name.scm

   1 ;;;
   2 ;;; chord-name.scm -- Compile chord name
   3 ;;;
   4 ;;; source file of the GNU LilyPond music typesetter
   5 ;;;
   6 ;;; (c) 2000--2002 Jan Nieuwenhuizen <janneke@gnu.org>
   7 ;;;
   8
   9
  10 (use-modules
  11    (ice-9 debug)
  12    (ice-9 format)
  13    (ice-9 regex)
  14    (ice-9 string-fun)
  15    )
  16
  17
  18 (define-public (write-me x)
  19   "Write and return X. For debugging purposes. "
  20   (write x) (newline) x)
  21
  22 ;(define (dbg x) (write-me x))
  23 (define (dbg x) x)
  24
  25 ;;(define (write-me x) (write x) (newline) x)
  26 ;;(define (write-me-2 x y) (write "FOO") (write x) (write y) (newline) y)
  27
  28
  29 "
  30 TODO:
  31
  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) )
  35
  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.
  39
  40  [* naming chord::... ; this is scheme not C++]
  41  (yes - constructive naming suggestion here)
  42
  43  * easier tweakability:
  44     - split chord::names-alists up into logical bits,
  45       such as chord::exceptions-delta, exceptions-oslash
  46     - iso just the 'style parameter, use a list, eg:
  47       \property ChordNames.ChordName \set
  48         #'style = #'(jazz delta oslash german-tonic german-Bb)
  49
  50  * clean split/merge of bass/banter/american stuff.
  51    GET RID OF code duplication.
  52
  53  * fix FIXMEs
  54
  55  * doc strings
  56
  57 "
  58
  59 ;; " hey Emacs: string has ended
  60
  61
  62 ;; pitch = (octave notename alteration)
  63 ;;
  64 ;; note = (notename . alteration)
  65 ;;
  66 ;; markup = markup text -- see font.scm and input/test/markup.ly
  67
  68
  69 (define-public chord::exception-alist-banter
  70        `(
  71         ; C iso C.no3.no5
  72         (((0 . 0)) . ,empty-markup)
  73         ; C iso C.no5
  74         (((0 . 0) (2 . 0)) . ,empty-markup)
  75         ; Cm iso Cm.no5
  76         (((0 . 0) (2 . -1)) . ,(make-simple-markup "m"))
  77         ; C2 iso C2.no3
  78         (((0 . 0) (1 . 0) (4 . 0))
  79          . ,(make-normal-size-super-markup (make-simple-markup "2 ")))
  80         ; C4 iso C4.no3
  81         (((0 . 0) (3 . 0) (4 . 0))
  82          . ,(make-normal-size-super-markup (make-simple-markup "4 ")))
  83         ;; Cdim iso Cm5-
  84         (((0 . 0) (2 . -1) (4 . -1)) . ,(make-simple-markup "dim"))
  85         ; URG: Simply C:m5-/maj7 iso Cdim maj7
  86         (((0 . 0) (2 . -1) (4 . -1) (6 . 0))
  87          . ,(make-line-markup
  88              (list
  89               (make-simple-markup "m")
  90               (make-normal-size-super-markup (make-simple-markup "5-/maj7 ")))))
  91         ; URG: Simply C:m5-/7 iso Cdim7
  92         (((0 . 0) (2 . -1) (4 . -1) (6 . -1))
  93          . ,(make-line-markup
  94              (list
  95               (make-simple-markup "m")
  96               (make-normal-size-super-markup (make-simple-markup "5-/7 ")))))
  97         ; Co iso C:m5-/7-
  98         (((0 . 0) (2 . -1) (4 . -1) (6 . -2))
  99          . ,(make-super-markup (make-simple-markup "o")))
 100         ; Cdim9
 101         (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1))
 102          . ,(make-line-markup
 103              (list (make-simple-markup "dim")
 104                    (make-normal-size-super-markup (make-simple-markup "9 ")))))
 105         (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1) (3 . -1))
 106          . ,(make-line-markup
 107              (list (make-simple-markup "dim")
 108                                 (make-normal-size-super-markup
 109                                  (make-simple-markup "11 ")))))
 110
 111         ))
 112
 113 ; pitch->note-name: drops octave
 114 (define (pitch->note-name pitch)
 115   (cons (cadr pitch) (caddr pitch)))
 116
 117 (define (accidental->markup acc)
 118   "ACC is an int, return a markup making an accidental."
 119   (if (= acc 0)
 120       (make-line-markup (list empty-markup))
 121       (make-smaller-markup (make-musicglyph-markup
 122                             (string-append "accidentals-"
 123                                            (number->string acc))))))
 124
 125 (define (accidental->markupp acc pos)
 126
 127   (if (= acc 0)
 128       empty-markup
 129       (let ((acc-markup (make-musicglyph-markup
 130                          (string-append "accidentals-"
 131                                         (number->string acc)))))
 132
 133         (if (equal? pos 'columns)
 134             (make-line-markup (list (make-smaller-markup acc-markup)))
 135           (if (equal? pos 'super)
 136               (make-line-markup (list (make-super-markup acc-markup)))
 137               ;; not 'super or 'columns must be 'sub...
 138               (make-line-markup (list (make-sub-markup acc-markup))))))))
 139
 140
 141 ;; FIXME: possibly to be used for american/jazz style
 142 ;; However, only pos == columns is used, which seems to do
 143 ;; exactly what accidental->markup does...
 144 (define (amy-accidental->text acc) (accidental->textp acc 'columns))
 145
 146 ;; These not used
 147 ;;;(define (accidental->text-super acc) (accidental->textp acc 'simple-super))
 148 ;;(define (accidental->text-super acc) (accidental->textp acc 'super))
 149 ;;(define (accidental->text-sub acc) (accidental->textp acc 'sub))
 150
 151
 152 ;;
 153 ;; TODO: invent sensible way to make note name tweaking possible?
 154 ;;
 155 (define (pitch->markup pitch)
 156   (make-line-markup
 157    (list
 158     (make-simple-markup
 159      (vector-ref #("C" "D" "E" "F" "G" "A" "B")  (cadr pitch)))
 160     (make-normal-size-super-markup
 161      (accidental->markup (caddr pitch))))))
 162
 163 ;;; Hooks to override chord names and note names,
 164 ;;; see input/tricks/german-chords.ly
 165
 166 (define pitch->markup-banter pitch->markup)
 167
 168 ;; We need also steps, to allow for Cc name override,
 169 ;; see input/test/Cc-chords.ly
 170 (define (pitch->chord-name-markup-banter pitch steps)
 171   (pitch->markup-banter pitch))
 172
 173 (define pitch->note-name-markup-banter pitch->markup-banter)
 174
 175 (define (step->markup pitch)
 176   (string-append
 177    (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))
 178    (case (caddr pitch)
 179       ((-2) "--")
 180       ((-1) "-")
 181       ((0) "")
 182       ((1) "+")
 183       ((2) "++"))))
 184
 185 (define (step->markup-banter pitch)
 186   (make-simple-markup
 187    (if (= (cadr pitch) 6)
 188        (case (caddr pitch)
 189          ((-2)  "7-")
 190          ((-1) "7")
 191          ((0)  "maj7")
 192          ((1)  "7+")
 193          ((2)  "7+"))
 194        (step->markup pitch))))
 195
 196 (define (step->markup-previously-alternate-jazz pitch)
 197   (make-line-markup
 198    (list
 199     (accidental->markup (caddr pitch))
 200     (make-simple-markup
 201      (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))))))
 202
 203 (define (step->markup-previously-jazz pitch)
 204   (if (= (cadr pitch) 6)
 205       (case (caddr pitch)
 206         ;; sharp 7 only included for completeness?
 207         ((-2) (make-line-markup
 208                (list
 209                 (accidental->markup  -1)
 210                 (make-simple-markup "7"))))
 211         ((-1) (make-simple-markup "7"))
 212         ((0) (make-simple-markup "maj7"))
 213         ;;((0) (make-line-markup
 214         ;;      (list (make-simple-markup "maj7"))))
 215         ((1) (make-line-markup
 216               (list
 217                (accidental->markup 1) (make-simple-markup "7"))))
 218         ((2) (make-line-markup
 219               (list (accidental->markup 1)
 220                     (make-simple-markup "7")))))
 221       (step->markup-previously-alternate-jazz pitch)))
 222
 223
 224 (define pitch::semitone-vec #(0 2 4 5 7 9 11))
 225
 226 (define (pitch::semitone pitch)
 227   (+ (* (car pitch) 12)
 228      (vector-ref pitch::semitone-vec (modulo (cadr pitch) 7))
 229      (caddr pitch)))
 230
 231 (define (pitch::< l r)
 232   (< (pitch::semitone l) (pitch::semitone r)))
 233
 234 (define (pitch::transpose pitch delta)
 235   (let ((simple-octave (+ (car pitch) (car delta)))
 236         (simple-notename (+ (cadr pitch) (cadr delta))))
 237     (let ((octave (+ simple-octave (quotient simple-notename 7)))
 238            (notename (modulo simple-notename 7)))
 239       (let ((accidental (- (+ (pitch::semitone pitch) (pitch::semitone delta))
 240                            (pitch::semitone `(,octave ,notename 0)))))
 241         `(,octave ,notename ,accidental)))))
 242
 243 (define (pitch::diff pitch tonic)
 244   (let ((simple-octave (- (car pitch) (car tonic)))
 245         (simple-notename (- (cadr pitch) (cadr tonic))))
 246     (let ((octave (+ simple-octave (quotient simple-notename 7)
 247                      (if (< simple-notename 0) -1 0)))
 248           (notename (modulo simple-notename 7)))
 249       (let ((accidental (- (pitch::semitone pitch)
 250                           (pitch::semitone tonic)
 251                           (pitch::semitone `(,octave ,notename 0)))))
 252         `(,octave ,notename ,accidental)))))
 253
 254 (define (pitch::note-pitch pitch)
 255   (+ (* (car pitch) 7) (cadr pitch)))
 256
 257
 258 ; what's this?
 259 (define chord::minor-major-vec #(0 -1 -1 0 -1 -1 0))
 260
 261 ;; FIXME: unLOOP
 262 ;; compute the relative-to-tonic pitch that goes with 'step'
 263 (define (chord::step-pitch tonic step)
 264   ;; urg, we only do this for thirds
 265   (if (= (modulo step 2) 0)
 266     '(0 0 0)
 267     (let loop ((i 1) (pitch tonic))
 268       (if (= i step) pitch
 269         (loop (+ i 2)
 270               (pitch::transpose
 271                 pitch `(0 2 ,(vector-ref chord::minor-major-vec
 272                 ;; -1 (step=1 -> vector=0) + 7 = 6
 273                 (modulo (+ i 6) 7)))))))))
 274
 275 (define (chord::additions steps)
 276 " Return:
 277    * any even step (2, 4, 6)
 278    * any uneven step that is chromatically altered,
 279      (where 7-- == -1, 7- == 0, 7 == +1)
 280    * highest step
 281
 282 ?and jazz needs also:
 283
 284    * TODO: any uneven step that's lower than an uneven step which is
 285      chromatically altered
 286   "
 287   (let ((evens (filter-list (lambda (x) (!= 0 (modulo (cadr x) 2))) steps))
 288         (altered-unevens
 289          (filter-list (lambda (x)
 290                         (let ((n (cadr x)) (a (caddr x)))
 291                           (or (and (= 6 n) (!= -1 a))
 292                               (and (!= 6 n)
 293                                    (= 0 (modulo n 2))
 294                                    (!= 0 a)))))
 295                       steps))
 296         (highest (let ((h (car (last-pair steps))))
 297                    (if (and (not (null? h))
 298                             (or (> 4 (cadr h))
 299                                 (!= 0 (caddr h))))
 300                        (list (list h))
 301                        '()))))
 302     ;; Hmm, what if we have a step twice, can we ignore that?
 303     (uniq-list (sort (apply append evens altered-unevens highest)
 304                      pitch::<))))
 305
 306
 307 ;; FIXME: unLOOP, see ::additions
 308 ;; find the pitches that are missing from `normal' chord
 309 (define (chord::subtractions chord-pitches)
 310   (let ((tonic (car chord-pitches)))
 311     (let loop ((step 1) (pitches chord-pitches) (subtractions '()))
 312       (if (pair? pitches)
 313         (let* ((pitch (car pitches))
 314                (p-step (+ (- (pitch::note-pitch pitch)
 315                              (pitch::note-pitch tonic))
 316                           1)))
 317           ;; pitch is an subtraction if
 318           ;; a step is missing or
 319           (if (> p-step step)
 320             (loop (+ step 2) pitches
 321                 (cons (chord::step-pitch tonic step) subtractions))
 322           ;; there are no pitches left, but base thirds are not yet done and
 323           (if (and (<= step 5)
 324                    (= (length pitches) 1))
 325             ;; present pitch is not missing step
 326             (if (= p-step step)
 327               (loop (+ step 2) pitches subtractions)
 328               (loop (+ step 2) pitches
 329                     (cons (chord::step-pitch tonic step) subtractions)))
 330             (if (= p-step step)
 331               (loop (+ step 2) (cdr pitches) subtractions)
 332               (loop step (cdr pitches) subtractions)))))
 333         (reverse subtractions)))))
 334
 335 (define (chord::additions->markup-banter additions subtractions)
 336   (if (pair? additions)
 337       (make-line-markup
 338        (list
 339         (let ((step (step->markup-banter (car additions))))
 340           (if (or (pair? (cdr additions))
 341                   (pair? subtractions))
 342               (make-line-markup
 343                (list step (make-simple-markup "/")))
 344               step))
 345         (chord::additions->markup-banter (cdr additions) subtractions)))
 346       empty-markup))
 347
 348 (define (chord::subtractions->markup-banter subtractions)
 349   (if (pair? subtractions)
 350       (make-line-markup
 351        (list
 352         (make-simple-markup "no")
 353         (let ((step (step->markup-previously-jazz
 354                      (car subtractions))))
 355           (if (pair? (cdr subtractions))
 356               (make-line-markup
 357                (list step (make-simple-markup "/")))
 358               step))
 359         (chord::subtractions->markup-banter (cdr subtractions))))
 360       empty-markup))
 361
 362 (define (chord::bass-and-inversion->markup-banter bass-and-inversion)
 363   (if (and (pair? bass-and-inversion)
 364            (or (car bass-and-inversion)
 365                (cdr bass-and-inversion)))
 366       (make-line-markup
 367        (list
 368         (make-simple-markup "/")
 369         (pitch->note-name-markup-banter
 370          (if (car bass-and-inversion)
 371              (car bass-and-inversion)
 372              (cdr bass-and-inversion)))))
 373       empty-markup))
 374
 375 ;; FIXME: merge this function with inner-name-jazz, -american
 376 ;;        iso using chord::bass-and-inversion->markup-banter,
 377 ;;        See: chord::exceptions-lookup
 378 (define (chord::inner-name-banter tonic exception-part additions subtractions
 379                                   bass-and-inversion steps)
 380   "
 381
 382  Banter style
 383  Combine tonic, exception-part of chord name,
 384  additions, subtractions and bass or inversion into chord name
 385
 386 "
 387   (let* ((tonic-markup (pitch->chord-name-markup-banter tonic steps))
 388          (except-markup (if exception-part exception-part empty-markup))
 389          (sep-markup (if (and exception-part
 390                               (let ((s (format "~s" except-markup)))
 391                                 (and
 392                                  (string-match "super" s)
 393                                  ;; ugh ugh
 394                                  ;; python: `except_markup`[-5:] != '"o"))'
 395                                  (not (equal?
 396                                        "\"o\"))"
 397                                        (substring s
 398                                                   (- (string-length s) 5))))))
 399                               (or (pair? additions)
 400                                   (pair? subtractions)))
 401                          (make-super-markup (make-simple-markup "/"))
 402                          empty-markup))
 403          (adds-markup (chord::additions->markup-banter additions subtractions))
 404          (subs-markup (chord::subtractions->markup-banter subtractions))
 405          (b+i-markup (chord::bass-and-inversion->markup-banter
 406                       bass-and-inversion)))
 407
 408     (make-line-markup
 409      (list
 410       tonic-markup
 411       except-markup
 412       sep-markup
 413       (make-normal-size-super-markup
 414        (make-line-markup (list adds-markup subs-markup)))
 415       b+i-markup))))
 416
 417 (define (c++-pitch->scm p)
 418   (if (ly:pitch? p)
 419       (list (ly:pitch-octave p) (ly:pitch-notename p) (ly:pitch-alteration p))
 420       #f))
 421
 422 (define (chord::name-banter tonic exception-part unmatched-steps
 423                             bass-and-inversion steps)
 424   (let ((additions (chord::additions unmatched-steps))
 425         (subtractions (chord::subtractions unmatched-steps)))
 426
 427     (chord::inner-name-banter tonic exception-part additions subtractions
 428                               bass-and-inversion steps)))
 429
 430
 431 ;; see above.
 432 (define (chord::exceptions-lookup exceptions steps)
 433   "
 434    return (MATCHED-EXCEPTION . BASE-CHORD-WITH-UNMATCHED-STEPS)
 435    BASE-CHORD-WITH-UNMATCHED-STEPS always includes (tonic 3 5)
 436
 437 "
 438   ;; this is unintelligible.
 439   ;;
 440   (define (chord::exceptions-lookup-helper
 441            exception-alist try-steps unmatched-steps exception-part)
 442     "
 443
 444  check exception-alist for biggest matching part of try-steps
 445  return (MATCHED-EXCEPTION . UNMATCHED-STEPS)
 446
 447 "
 448     (if (pair? try-steps)
 449         ;; FIXME: junk '(0 . 0) from exceptions lists?
 450         ;;        if so: how to handle first '((0 . 0) . #f) entry?
 451         ;;
 452         ;; FIXME: either format exceptions list as real pitches, ie,
 453         ;;        including octave '((0 2 -1) ..), or drop octave
 454         ;;        from rest of calculations,
 455         (let ((entry (assoc
 456                       (map (lambda (x) (pitch->note-name x))
 457                            (append '((0 0 0)) try-steps))
 458                       exception-alist)))
 459           (if entry
 460               (chord::exceptions-lookup-helper
 461                #f '() unmatched-steps (cdr entry))
 462               (let ((r (reverse try-steps)))
 463                 (chord::exceptions-lookup-helper
 464                  exception-alist
 465                  (reverse (cdr r))
 466                  (cons (car r) unmatched-steps) #f))))
 467         (cons exception-part unmatched-steps)))
 468
 469   (let* ((result (chord::exceptions-lookup-helper
 470                   exceptions
 471                   steps '() #f))
 472            (exception-part (car result))
 473            (unmatched-steps (cdr result))
 474            (matched-steps (if (= (length unmatched-steps) 0)
 475                               3
 476                               (+ 1 (- (length steps)
 477                                       (length unmatched-steps)))))
 478            (unmatched-with-1-3-5
 479             (append (do ((i matched-steps (- i 1))
 480                          (base '() (cons `(0 ,(* (- i 1) 2) 0) base)))
 481                         ((= i 0) base)
 482                       ())
 483                     unmatched-steps)))
 484     (list exception-part unmatched-with-1-3-5)))
 485
 486
 487
 488 ;;; American style
 489 ;;;
 490
 491 ;; See input/test/american-chords.ly
 492 ;;
 493 ;; Original Version by James Hammons, <jlhamm@pacificnet.net>
 494 ;; Complete rewrite by Amelie Zapf, <amy@loueymoss.com>
 495
 496 ;; DONT use non-ascii characters, even if ``it works'' in Windows
 497
 498 ;;a white triangle
 499 (define mathm-markup-object
 500   (make-override-markup '(font-family . math) (make-simple-markup "M")))
 501
 502 ;a black triangle
 503 (define mathn-markup-object
 504   (make-override-markup '(font-family . math) (make-simple-markup "N")))
 505
 506 (define (step->markup-accidental pitch)
 507     (case (caddr pitch)
 508       ((-2) (accidental->markup -2))
 509       ((-1) (accidental->markup -1))
 510       ((0) empty-markup)
 511       ((1) (accidental->markup 1))
 512       ((2) (accidental->markup 2)))
 513     (make-simple-markup (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))))
 514
 515 (define-public chord::exception-alist-american
 516   `(
 517     (((0 . 0)) . ,empty-markup)
 518     (((0 . 0) (2 . -1)) . ,(make-simple-markup "m"))
 519
 520     ;; these should probably be normal-size?  --jcn
 521     ;;(((0 . 0) (4 . 0)) . ,(make-super-markup (make-simple-markup "5 ")))
 522     ;;(((0 . 0) (1 . 0) (4 . 0)) . ,(make-super-markup (make-simple-markup "2 ")))
 523
 524     (((0 . 0) (4 . 0)) . ,(make-normal-size-super-markup (make-simple-markup "5 ")))
 525     (((0 . 0) (1 . 0) (4 . 0)) . ,(make-normal-size-super-markup (make-simple-markup "2 ")))
 526
 527     ;;choose your symbol for the fully diminished chord
 528     (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ,(make-simple-markup "dim"))
 529     ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ,(make-line-markup (list empty-markup (make-super-markup (make-simple-markup "o")))))
 530     ))
 531
 532 (define (step->markup-american pitch)
 533   (case (cadr pitch)
 534     ((6) (case (caddr pitch)
 535            ((-2) (make-line-markup (list (accidental->markup -1) (make-simple-markup "7"))))
 536            ((-1) (make-simple-markup "7"))
 537            ((0) (make-simple-markup "maj7"))
 538            ((1) (make-line-markup (list (accidental->markup 1) (make-simple-markup "7"))))
 539            ((2) (make-line-markup (list (accidental->markup 2) (make-simple-markup "7"))))))
 540     ((4) (case (caddr pitch)
 541            ((-2) (make-line-markup (list (accidental->markup -2) (make-simple-markup "5"))))
 542            ;;choose your symbol for the diminished fifth
 543            ((-1) (make-simple-markup "-5"))
 544            ;;((-1) (make-line-markup (list (accidental->markup -1) (make-simple-markup "5")))))
 545            ((0) empty-markup)
 546            ;;choose your symbol for the augmented fifth
 547            ;;((1) (make-simple-markup "aug"))
 548            ;;((1) (make-line-markup (list (accidental->markup 1) (make-simple-markup "5")))))
 549            ((1) (make-simple-markup "+5"))
 550            ((2) (make-line-markup (list (accidental->markup 2) (make-simple-markup "5"))))))
 551     (else (if (and (= (car pitch) 0)
 552                    (= (cadr pitch) 3)
 553                    (= (caddr pitch) 0))
 554               (make-simple-markup "sus4")
 555               (step->markup-accidental pitch)))))
 556
 557 (define (chord::additions->markup-american additions subtractions)
 558   (if (pair? additions)
 559       ;; I don't like all this reasoning here, when we're actually typesetting.
 560       (if(and(pair? (cdr additions)) ;a further addition left over
 561              (or(and(= 0 (caddr(car additions))) ;this addition natural
 562                     (not(= 6 (cadr(car additions)))))
 563                 (and(= -1 (caddr(car additions)))
 564                     (= 6 (cadr(car additions)))))
 565              (or(and(= 0 (caddr(cadr additions))) ;the following addition natural
 566                     (not(= 6 (cadr(cadr additions)))))
 567                 (and(= -1 (caddr(cadr additions)))
 568                     (= 6 (cadr(cadr additions)))))
 569              (or(and(= (car(car additions)) (car(cadr additions))) ;both a third apart
 570                     (= 2 (- (cadr(cadr additions)) (cadr(car additions)))))
 571                 (and(= 1 (- (car(cadr additions)) (car(car additions))))
 572                     (= 5 (- (cadr(car additions)) (cadr(cadr additions))))))
 573              (or(null? subtractions) ;this or clause protects the "adds"
 574                 (and (pair? subtractions)
 575                      (or (< (car(cadr additions)) (car(car subtractions)))
 576                          (and(= (car(cadr additions)) (car(car subtractions)))
 577                              (< (cadr(cadr additions)) (cadr(car subtractions))))))))
 578          (chord::additions->markup-american (cdr additions) subtractions)
 579          (make-line-markup
 580           (list
 581            (let ((step (step->markup-american (car additions))))
 582              (if (or (pair? (cdr additions))
 583                      (pair? subtractions))
 584                  (if (and (pair? (cdr additions))
 585                           (or(< 3 (- (cadr(cadr additions)) (cadr(car additions))))
 586                              (and(< 0 (- (car(cadr additions)) (car(car additions))))
 587                                  (> 4 (- (cadr(car additions)) (cadr(cadr additions)))))))
 588                      (make-line-markup (list step (make-simple-markup " add")))
 589                      ;; tweak your favorite separator here
 590                      ;; (make-line-markup (list step (make-simple-markup "/")))
 591                      (make-line-markup (list step (make-simple-markup " "))))
 592                  step))
 593            (chord::additions->markup-american (cdr additions) subtractions))))
 594       empty-markup))
 595
 596 (define (chord::inner-name-american tonic exception-part additions subtractions
 597                                   bass-and-inversion steps)
 598   (let* ((tonic-markup (pitch->chord-name-markup-banter tonic steps))
 599          (except-markup (if exception-part exception-part empty-markup))
 600          (sep-markup (if (and (string-match "super" (format "~s" except-markup))
 601                               (or (pair? additions)
 602                                   (pair? subtractions)))
 603                          (make-super-markup (make-simple-markup "/"))
 604                          empty-markup))
 605          ;;this list contains all the additions that go "in line"
 606          (prefixes
 607           (filter-list
 608            (lambda (x)
 609              (let ((o (car x)) (n (cadr x)) (a (caddr x)))
 610                (and (not (and (= 0 o) (= 2 n))) ;gets rid of unwanted thirds
 611                     ;;change this if you want it differently
 612                     (not (and (= 0 o) (= 3 n) (= 0 a))) ;sus4
 613                     (not (and (= 0 o) (= 4 n) (!= 0 a)))))) ;alt5
 614            additions))
 615          ;;this list contains all the additions that are patched onto the end
 616          ;;of the chord symbol, usually sus4 and altered 5ths.
 617          (suffixes
 618           ;;take out the reverse if it bothers you in a pathological chord
 619           (reverse
 620            (filter-list
 621             (lambda (x)
 622               (let ((o (car x)) (n (cadr x)) (a (caddr x)))
 623                 (and(not (and (= 0 o) (= 2 n))) ;gets rid of unwanted thirds
 624                     ;;change this correspondingly
 625                     (or(and (= 0 o) (= 3 n) (= 0 a)) ;sus4
 626                        (and (= 0 o) (= 4 n) (!= 0 a)))))) ;alt5
 627             additions)))
 628          (relevant-subs (filter-list
 629                          (lambda (x) ;catches subtractions higher than 5th
 630                            (let((o (car x)) (n (cadr x)))
 631                              (or (> o 0)
 632                                  (> n 4))))
 633                          subtractions))
 634          (pref-markup (chord::additions->markup-american prefixes relevant-subs))
 635          (suff-markup (chord::additions->markup-american suffixes relevant-subs))
 636          (b+i-markup (chord::bass-and-inversion->markup-banter bass-and-inversion)))
 637     (make-line-markup
 638      (list
 639       tonic-markup except-markup sep-markup
 640       (make-normal-size-super-markup
 641        (make-line-markup (list pref-markup suff-markup)))
 642       b+i-markup))))
 643
 644 (define (chord::additions-american steps)
 645   (let ((evens (filter-list (lambda (x) (!= 0 (modulo (cadr x) 2))) steps))
 646         ;we let all the unevens pass for now, we'll fix that later.
 647         (unevens
 648          (filter-list (lambda (x)
 649                         (let ((n (cadr x)) (a (caddr x)))
 650                           (or (and (= 6 n) (!= -1 a))
 651                               (and (< 3 n)
 652                                    (= 0 (modulo n 2))))))
 653                       steps))
 654         (highest (let ((h (car (last-pair steps))))
 655                    (if (and (not (null? h))
 656                             (or (> 4 (cadr h))
 657                                 (!= 0 (caddr h))))
 658                        (list (list h))
 659                        '()))))
 660     (uniq-list (sort (apply append evens unevens highest)
 661                      pitch::<))))
 662
 663   ;; American style chordnames use no "no",
 664   ;; but otherwise very similar to banter for now
 665   (define-public (chord::name-american tonic exception-part unmatched-steps
 666                               bass-and-inversion steps)
 667   (let ((additions (chord::additions-american unmatched-steps))
 668         (subtractions (chord::subtractions unmatched-steps)))
 669     (chord::inner-name-american tonic exception-part additions subtractions
 670                               bass-and-inversion steps)))
 671
 672   ;;; Jazz style
 673   ;;;
 674 ;; Jazz chords, by Atte Andr'e Jensen <atte@post.com>
 675 ;; Complete rewrite by Amelie Zapf (amy@loueymoss.com)
 676
 677 ;; FIXME: identical to chord::exception-alist-american, apart from commented
 678 ;;        dim chord.  should merge.
 679 (define-public chord::exception-alist-jazz
 680   `(
 681     (((0 . 0)) . ,empty-markup)
 682     (((0 . 0) (2 . -1)) . ,(make-simple-markup "m"))
 683
 684     ;; these should probably be normal-size?  --jcn
 685     ;;(((0 . 0) (4 . 0)) . ,(make-super-markup (make-simple-markup "5 ")))
 686     ;;(((0 . 0) (1 . 0) (4 . 0)) . ,(make-super-markup (make-simple-markup "2 ")))
 687
 688     (((0 . 0) (4 . 0)) . ,(make-normal-size-super-markup (make-simple-markup "5 ")))
 689     (((0 . 0) (1 . 0) (4 . 0)) . ,(make-normal-size-super-markup (make-simple-markup "2 ")))
 690
 691     ;;choose your symbol for the fully diminished chord
 692     ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ,(make-simple-markup "dim"))
 693     (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ,(make-line-markup (list (make-simple-markup "") (make-super-markup (make-simple-markup "o")))))
 694     ))
 695
 696 ;; FIXME: rather similar to step->markup-american.  should merge.
 697 (define (step->markup-jazz pitch)
 698   (case (cadr pitch)
 699     ((6) (case (caddr pitch)
 700            ((-2) (make-line-markup (list (accidental->markup -1) (make-simple-markup "7"))))
 701            ((-1) (make-simple-markup "7"))
 702            ;;Pick your favorite maj7
 703            ((0) mathm-markup-object)  ;;a white triangle
 704            ;;((0) mathn-markup-object) ;;a black triangle
 705            ;;((0) (make-simple-markup "maj7")) ;;good old maj7
 706            ((1) (make-line-markup (list (accidental->markup 1) (make-simple-markup "7"))))
 707            ((2) (make-line-markup (list (accidental->markup 2) (make-simple-markup "7"))))))
 708     ((4) (case (caddr pitch)
 709            ((-2) (make-line-markup (list (accidental->markup -2) (make-simple-markup "5"))))
 710            ;;choose your symbol for the diminished fifth
 711            ;;((-1) (make-simple-markup "-5"))
 712            ((-1) (make-line-markup (list (accidental->markup -1) (make-simple-markup "5"))))
 713            ((0) empty-markup)
 714            ;;choose your symbol for the augmented fifth
 715            ;;((1) (make-simple-markup "aug"))
 716            ((1) (make-line-markup (list (accidental->markup 1) (make-simple-markup "5"))))
 717            ;;((1) (make-simple-markup "+5"))
 718            ((2) (make-line-markup (list (accidental->markup 2) (make-simple-markup "5"))))))
 719     (else (if (and (= (car pitch) 0)
 720                    (= (cadr pitch) 3)
 721                    (= (caddr pitch) 0))
 722               (make-simple-markup "sus4")
 723               (step->markup-accidental pitch)))))
 724
 725 ;; FIXME: identical to chord::additions->markup-american,
 726 ;; except for -jazz / -american suffixes on calls
 727 (define (chord::additions->markup-jazz additions subtractions)
 728   (if (pair? additions)
 729       ;; I don't like all this reasoning here, when we're actually typesetting.
 730       (if(and(pair? (cdr additions)) ;a further addition left over
 731              (or(and(= 0 (caddr(car additions))) ;this addition natural
 732                     (not(= 6 (cadr(car additions)))))
 733                 (and(= -1 (caddr(car additions)))
 734                     (= 6 (cadr(car additions)))))
 735              (or(and(= 0 (caddr(cadr additions))) ;the following addition natural
 736                     (not(= 6 (cadr(cadr additions)))))
 737                 (and(= -1 (caddr(cadr additions)))
 738                     (= 6 (cadr(cadr additions)))))
 739              (or(and(= (car(car additions)) (car(cadr additions))) ;both a third apart
 740                     (= 2 (- (cadr(cadr additions)) (cadr(car additions)))))
 741                 (and(= 1 (- (car(cadr additions)) (car(car additions))))
 742                     (= 5 (- (cadr(car additions)) (cadr(cadr additions))))))
 743              (or(null? subtractions) ;this or clause protects the "adds"
 744                 (and (pair? subtractions)
 745                      (or (< (car(cadr additions)) (car(car subtractions)))
 746                          (and(= (car(cadr additions)) (car(car subtractions)))
 747                              (< (cadr(cadr additions)) (cadr(car subtractions))))))))
 748          (chord::additions->markup-jazz (cdr additions) subtractions)
 749          (make-line-markup
 750           (list
 751            (let ((step (step->markup-jazz (car additions))))
 752              (if (or (pair? (cdr additions))
 753                      (pair? subtractions))
 754                  (if (and (pair? (cdr additions))
 755                           (or(< 3 (- (cadr(cadr additions)) (cadr(car additions))))
 756                              (and(< 0 (- (car(cadr additions)) (car(car additions))))
 757                                  (> 4 (- (cadr(car additions)) (cadr(cadr additions)))))))
 758                      (make-line-markup (list step (make-simple-markup " add")))
 759                      ;; tweak your favorite separator here
 760                      ;; (make-line-markup (list step (make-simple-markup "/")))
 761                      (make-line-markup (list step (make-simple-markup " "))))
 762                  step))
 763            (chord::additions->markup-jazz (cdr additions) subtractions))))
 764       empty-markup))
 765
 766 ;; FIXME: identical to chord::additions->markup-american.
 767 ;; except for -jazz / -american suffixes on calls
 768 (define (chord::inner-name-jazz tonic exception-part additions subtractions
 769                                 bass-and-inversion steps)
 770   (let* ((tonic-markup (pitch->chord-name-markup-banter tonic steps))
 771          (except-markup (if exception-part exception-part empty-markup))
 772          (sep-markup (if (and (string-match "super" (format "~s" except-markup))
 773                               (or (pair? additions)
 774                                   (pair? subtractions)))
 775                          (make-super-markup (make-simple-markup "/"))
 776                          empty-markup))
 777          ;;this list contains all the additions that go "in line"
 778          (prefixes
 779           (filter-list
 780            (lambda (x)
 781              (let ((o (car x)) (n (cadr x)) (a (caddr x)))
 782                (and (not (and (= 0 o) (= 2 n))) ;gets rid of unwanted thirds
 783                     ;;change this if you want it differently
 784                     (not (and (= 0 o) (= 3 n) (= 0 a))) ;sus4
 785                     (not (and (= 0 o) (= 4 n) (!= 0 a)))))) ;alt5
 786            additions))
 787          ;;this list contains all the additions that are patched onto the end
 788          ;;of the chord symbol, usually sus4 and altered 5ths.
 789          (suffixes
 790           ;;take out the reverse if it bothers you in a pathological chord
 791           (reverse
 792            (filter-list
 793             (lambda (x)
 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 correspondingly
 797                     (or(and (= 0 o) (= 3 n) (= 0 a)) ;sus4
 798                        (and (= 0 o) (= 4 n) (!= 0 a)))))) ;alt5
 799             additions)))
 800          (relevant-subs (filter-list
 801                          (lambda (x) ;catches subtractions higher than 5th
 802                            (let((o (car x)) (n (cadr x)))
 803                              (or (> o 0)
 804                                  (> n 4))))
 805                          subtractions))
 806          (pref-markup (chord::additions->markup-jazz prefixes relevant-subs))
 807          (suff-markup (chord::additions->markup-jazz suffixes relevant-subs))
 808          (b+i-markup (chord::bass-and-inversion->markup-banter bass-and-inversion)))
 809     (make-line-markup
 810      (list
 811       tonic-markup except-markup sep-markup
 812       (make-normal-size-super-markup
 813        (make-line-markup (list pref-markup suff-markup)))
 814       b+i-markup))))
 815
 816 (define (chord::name-jazz tonic exception-part unmatched-steps
 817                           bass-and-inversion steps)
 818   (let ((additions (chord::additions-american unmatched-steps))
 819         (subtractions (chord::subtractions unmatched-steps)))
 820     (chord::inner-name-jazz tonic exception-part additions subtractions
 821                             bass-and-inversion steps)))
 822
 823
 824 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 825
 826
 827 (define-public (new-chord->markup func ly-pitches bass inversion exceptions)
 828   "Entry point for New_chord_name_engraver. See chord-name.scm for the
 829 signature of FUNC.  LY-PITCHES, BASS and INVERSION are lily
 830 pitches. EXCEPTIONS is an alist (see scm file).
 831  "
 832
 833   (let* ((pitches (map c++-pitch->scm ly-pitches))
 834          (bass-and-inversion
 835           (cons (c++-pitch->scm bass)
 836                 (c++-pitch->scm inversion)))
 837          (diff (pitch::diff '(0 0 0) (car pitches)))
 838          (steps (if (cdr pitches) (map (lambda (x)
 839                                          (pitch::transpose x diff))
 840                                        (cdr pitches))
 841                     '()))
 842          (lookup (dbg (chord::exceptions-lookup exceptions steps)))
 843          (exception-part (dbg (car lookup)))
 844          (unmatched-steps (cadr lookup))
 845          (tonic (car pitches))
 846          )
 847
 848       (func tonic exception-part unmatched-steps bass-and-inversion steps)
 849       ))
 850
 851 (define-public (chord->markup-jazz . args)
 852   (apply new-chord->markup (cons chord::name-jazz args))
 853   )
 854
 855 (define-public (chord->markup-american . args)
 856   (apply new-chord->markup (cons chord::name-american args))
 857   )
 858
 859 (define-public (chord->markup-banter . args)
 860   (apply new-chord->markup (cons chord::name-banter args))
 861   )
 862
 863 (define-public (new-chord-name-brew-molecule grob)
 864   (let*
 865       (
 866        (ws (ly:get-grob-property grob 'word-space))
 867        (markup (ly:get-grob-property grob 'text))
 868        (molecule (interpret-markup grob
 869                                    (cons '((word-space . 0.0))
 870                                          (Font_interface::get_property_alist_chain grob))
 871                                    markup))
 872        )
 873
 874     ;;
 875     ;; chord names aren't in staffs, so WS is in global staff space.
 876     (if (number? ws)
 877         (ly:combine-molecule-at-edge
 878          molecule
 879          X RIGHT (ly:make-molecule "" (cons 0 ws) '(-1 . 1) )
 880          0.0)
 881         molecule)
 882     ))
 883
 884 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 885
 886 (define-public (set-chord-name-style sym)
 887   "Return music expressions that set the chord naming style. For
 888 inline use in .ly file"
 889
 890   (define (chord-name-style-setter function exceptions)
 891     (context-spec-music
 892      (make-sequential-music
 893       (list (make-property-set 'chordNameFunction function)
 894             (make-property-set 'chordNameExceptions exceptions)))
 895      "ChordNames"
 896      )
 897     )
 898
 899   (ly:export
 900    (case sym
 901      ((jazz)
 902       (chord-name-style-setter chord->markup-jazz
 903                                chord::exception-alist-jazz))
 904      ((banter)
 905       (chord-name-style-setter chord->markup-banter
 906                                chord::exception-alist-banter))
 907      ((american)
 908       (chord-name-style-setter chord->markup-american
 909                                chord::exception-alist-american))
 910      )))
 911
 912