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   *  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.
  43
  44    * easier tweakability:
  45
  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)
  51
  52  * clean split/merge of bass/banter/american stuff.
  53    GET RID OF code duplication.
  54
  55  * fix FIXMEs
  56
  57  * doc strings
  58
  59 "
  60
  61 ;; " hey Emacs: string has ended
  62
  63
  64 ;; pitch = (octave notename alteration)
  65 ;;
  66 ;; note = (notename . alteration)
  67 ;;
  68 ;; markup = markup text -- see font.scm and input/test/markup.ly
  69
  70
  71 (define-public chord::exception-alist-banter
  72        `(
  73         ; C iso C.no3.no5
  74         (((0 . 0)) . ,empty-markup)
  75         ; C iso C.no5
  76         (((0 . 0) (2 . 0)) . ,empty-markup)
  77         ; Cm iso Cm.no5
  78         (((0 . 0) (2 . -1)) . ,(make-simple-markup "m"))
  79         ; C2 iso C2.no3
  80         (((0 . 0) (1 . 0) (4 . 0))
  81          . ,(make-normal-size-super-markup (make-simple-markup "2 ")))
  82         ; C4 iso C4.no3
  83         (((0 . 0) (3 . 0) (4 . 0))
  84          . ,(make-normal-size-super-markup (make-simple-markup "4 ")))
  85         ;; Cdim iso Cm5-
  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))
  89          . ,(make-line-markup
  90              (list
  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))
  95          . ,(make-line-markup
  96              (list
  97               (make-simple-markup "m")
  98               (make-normal-size-super-markup (make-simple-markup "5-/7 ")))))
  99         ; Co iso C:m5-/7-
 100         (((0 . 0) (2 . -1) (4 . -1) (6 . -2))
 101          . ,(make-super-markup (make-simple-markup "o")))
 102         ; Cdim9
 103         (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1))
 104          . ,(make-line-markup
 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))
 108          . ,(make-line-markup
 109              (list (make-simple-markup "dim")
 110                                 (make-normal-size-super-markup
 111                                  (make-simple-markup "11 ")))))
 112
 113         ))
 114
 115 ; pitch->note-name: drops octave
 116 (define (pitch->note-name pitch)
 117   (cons (cadr pitch) (caddr pitch)))
 118
 119 (define (accidental->markup acc)
 120   "ACC is an int, return a markup making an accidental."
 121   (if (= acc 0)
 122       (make-line-markup (list empty-markup))
 123       (make-smaller-markup (make-musicglyph-markup
 124                             (string-append "accidentals-"
 125                                            (number->string acc))))))
 126
 127 ; unused.
 128 (define (accidental->markupp acc pos)
 129
 130   (if (= acc 0)
 131       empty-markup
 132       (let ((acc-markup (make-musicglyph-markup
 133                          (string-append "accidentals-"
 134                                         (number->string acc)))))
 135
 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))))))))
 142
 143
 144 ; unused.
 145
 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))
 150
 151
 152 ;; These not used
 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))
 156
 157
 158 ;;
 159 ;; TODO: invent sensible way to make note name tweaking possible?
 160 ;;
 161 (define (pitch->markup pitch)
 162   (make-line-markup
 163    (list
 164     (make-simple-markup
 165      (vector-ref #("C" "D" "E" "F" "G" "A" "B")  (cadr pitch)))
 166     (make-normal-size-super-markup
 167      (accidental->markup (caddr pitch))))))
 168
 169 ;;; Hooks to override chord names and note names,
 170 ;;; see input/tricks/german-chords.ly
 171
 172 (define pitch->markup-banter pitch->markup)
 173
 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))
 178
 179 (define pitch->note-name-markup-banter pitch->markup-banter)
 180
 181 (define (step->markup pitch)
 182   (string-append
 183    (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))
 184    (case (caddr pitch)
 185       ((-2) "--")
 186       ((-1) "-")
 187       ((0) "")
 188       ((1) "+")
 189       ((2) "++"))))
 190
 191 (define (step->markup-banter pitch)
 192   (make-simple-markup
 193    (if (= (cadr pitch) 6)
 194        (case (caddr pitch)
 195          ((-2)  "7-")
 196          ((-1) "7")
 197          ((0)  "maj7")
 198          ((1)  "7+")
 199          ((2)  "7+"))
 200        (step->markup pitch))))
 201
 202 (define (step->markup-previously-alternate-jazz pitch)
 203   (make-line-markup
 204    (list
 205     (accidental->markup (caddr pitch))
 206     (make-simple-markup
 207      (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))))))
 208
 209 (define (step->markup-previously-jazz pitch)
 210   (if (= (cadr pitch) 6)
 211       (case (caddr pitch)
 212         ;; sharp 7 only included for completeness?
 213         ((-2) (make-line-markup
 214                (list
 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
 222               (list
 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)))
 228
 229
 230 (define pitch::semitone-vec #(0 2 4 5 7 9 11))
 231
 232 (define (pitch::semitone pitch)
 233   (+ (* (car pitch) 12)
 234      (vector-ref pitch::semitone-vec (modulo (cadr pitch) 7))
 235      (caddr pitch)))
 236
 237 (define (pitch::< l r)
 238   (< (pitch::semitone l) (pitch::semitone r)))
 239
 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)))))
 248
 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)))))
 259
 260 (define (pitch::note-pitch pitch)
 261   (+ (* (car pitch) 7) (cadr pitch)))
 262
 263
 264 ; what's this?
 265 (define chord::minor-major-vec #(0 -1 -1 0 -1 -1 0))
 266
 267 ;; FIXME: unLOOP
 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)
 272     '(0 0 0)
 273     (let loop ((i 1) (pitch tonic))
 274       (if (= i step) pitch
 275         (loop (+ i 2)
 276               (pitch::transpose
 277                 pitch `(0 2 ,(vector-ref chord::minor-major-vec
 278                 ;; -1 (step=1 -> vector=0) + 7 = 6
 279                 (modulo (+ i 6) 7)))))))))
 280
 281 (define (chord::additions steps)
 282 " Return:
 283    * any even step (2, 4, 6)
 284    * any uneven step that is chromatically altered,
 285      (where 7-- == -1, 7- == 0, 7 == +1)
 286    * highest step
 287
 288 ?and jazz needs also:
 289
 290    * TODO: any uneven step that's lower than an uneven step which is
 291      chromatically altered
 292   "
 293   (let ((evens (filter-list (lambda (x) (!= 0 (modulo (cadr x) 2))) steps))
 294         (altered-unevens
 295          (filter-list (lambda (x)
 296                         (let ((n (cadr x)) (a (caddr x)))
 297                           (or (and (= 6 n) (!= -1 a))
 298                               (and (!= 6 n)
 299                                    (= 0 (modulo n 2))
 300                                    (!= 0 a)))))
 301                       steps))
 302         (highest (let ((h (car (last-pair steps))))
 303                    (if (and (not (null? h))
 304                             (or (> 4 (cadr h))
 305                                 (!= 0 (caddr h))))
 306                        (list (list h))
 307                        '()))))
 308     ;; Hmm, what if we have a step twice, can we ignore that?
 309     (uniq-list (sort (apply append evens altered-unevens highest)
 310                      pitch::<))))
 311
 312
 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 '()))
 318       (if (pair? pitches)
 319         (let* ((pitch (car pitches))
 320                (p-step (+ (- (pitch::note-pitch pitch)
 321                              (pitch::note-pitch tonic))
 322                           1)))
 323           ;; pitch is an subtraction if
 324           ;; a step is missing or
 325           (if (> p-step step)
 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
 329           (if (and (<= step 5)
 330                    (= (length pitches) 1))
 331             ;; present pitch is not missing step
 332             (if (= p-step step)
 333               (loop (+ step 2) pitches subtractions)
 334               (loop (+ step 2) pitches
 335                     (cons (chord::step-pitch tonic step) subtractions)))
 336             (if (= p-step step)
 337               (loop (+ step 2) (cdr pitches) subtractions)
 338               (loop step (cdr pitches) subtractions)))))
 339         (reverse subtractions)))))
 340
 341 (define (chord::additions->markup-banter additions subtractions)
 342   (if (pair? additions)
 343       (make-line-markup
 344        (list
 345         (let ((step (step->markup-banter (car additions))))
 346           (if (or (pair? (cdr additions))
 347                   (pair? subtractions))
 348               (make-line-markup
 349                (list step (make-simple-markup "/")))
 350               step))
 351         (chord::additions->markup-banter (cdr additions) subtractions)))
 352       empty-markup))
 353
 354 (define (chord::subtractions->markup-banter subtractions)
 355   (if (pair? subtractions)
 356       (make-line-markup
 357        (list
 358         (make-simple-markup "no")
 359         (let ((step (step->markup-previously-jazz
 360                      (car subtractions))))
 361           (if (pair? (cdr subtractions))
 362               (make-line-markup
 363                (list step (make-simple-markup "/")))
 364               step))
 365         (chord::subtractions->markup-banter (cdr subtractions))))
 366       empty-markup))
 367
 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)))
 372       (make-line-markup
 373        (list
 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)))))
 379       empty-markup))
 380
 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)
 386   "
 387
 388  Banter style
 389  Combine tonic, exception-part of chord name,
 390  additions, subtractions and bass or inversion into chord name
 391
 392 "
 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)))
 399                                 (and
 400                                  (string-match "super" s)
 401                                  ;; ugh ugh
 402                                  ;; python: `except_markup`[-5:] != '"o"))'
 403                                  (not (equal?
 404                                        "\"o\"))"
 405                                        (substring s
 406                                                   (- (string-length s) 5))))))
 407                               (or (pair? additions)
 408                                   (pair? subtractions)))
 409                          (make-super-markup (make-simple-markup "/"))
 410                          empty-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)))
 415
 416     (make-line-markup
 417      (list
 418       tonic-markup
 419       except-markup
 420       sep-markup
 421       (make-normal-size-super-markup
 422        (make-line-markup (list adds-markup subs-markup)))
 423       b+i-markup))))
 424
 425 (define (c++-pitch->scm p)
 426   (if (ly:pitch? p)
 427       (list (ly:pitch-octave p) (ly:pitch-notename p) (ly:pitch-alteration p))
 428       #f))
 429
 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)))
 434
 435     (chord::inner-name-banter tonic exception-part additions subtractions
 436                               bass-and-inversion steps)))
 437
 438
 439 ;; see above.
 440 (define (chord::exceptions-lookup exceptions steps)
 441   "
 442    return (MATCHED-EXCEPTION . BASE-CHORD-WITH-UNMATCHED-STEPS)
 443    BASE-CHORD-WITH-UNMATCHED-STEPS always includes (tonic 3 5)
 444
 445 "
 446   ;; this is unintelligible.
 447   ;;
 448   (define (chord::exceptions-lookup-helper
 449            exception-alist try-steps unmatched-steps exception-part)
 450     "
 451
 452  check exception-alist for biggest matching part of try-steps
 453  return (MATCHED-EXCEPTION . UNMATCHED-STEPS)
 454
 455 "
 456     (if (pair? try-steps)
 457         ;; FIXME: junk '(0 . 0) from exceptions lists?
 458         ;;        if so: how to handle first '((0 . 0) . #f) entry?
 459         ;;
 460         ;; FIXME: either format exceptions list as real pitches, ie,
 461         ;;        including octave '((0 2 -1) ..), or drop octave
 462         ;;        from rest of calculations,
 463         (let ((entry (assoc
 464                       (map (lambda (x) (pitch->note-name x))
 465                            (append '((0 0 0)) try-steps))
 466                       exception-alist)))
 467           (if entry
 468               (chord::exceptions-lookup-helper
 469                #f '() unmatched-steps (cdr entry))
 470               (let ((r (reverse try-steps)))
 471                 (chord::exceptions-lookup-helper
 472                  exception-alist
 473                  (reverse (cdr r))
 474                  (cons (car r) unmatched-steps) #f))))
 475         (cons exception-part unmatched-steps)))
 476
 477   (let* ((result (chord::exceptions-lookup-helper
 478                   exceptions
 479                   steps '() #f))
 480            (exception-part (car result))
 481            (unmatched-steps (cdr result))
 482            (matched-steps (if (= (length unmatched-steps) 0)
 483                               3
 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)))
 489                         ((= i 0) base)
 490                       ())
 491                     unmatched-steps)))
 492     (list exception-part unmatched-with-1-3-5)))
 493
 494
 495
 496 ;;; American style
 497 ;;;
 498
 499 ;; See input/test/american-chords.ly
 500 ;;
 501 ;; Original Version by James Hammons, <jlhamm@pacificnet.net>
 502 ;; Complete rewrite by Amelie Zapf, <amy@loueymoss.com>
 503
 504 ;; DONT use non-ascii characters, even if ``it works'' in Windows
 505
 506 ;;a white triangle
 507 (define mathm-markup-object
 508   (make-override-markup '(font-family . math) (make-simple-markup "M")))
 509
 510 ;a black triangle
 511 (define mathn-markup-object
 512   (make-override-markup '(font-family . math) (make-simple-markup "N")))
 513
 514 (define (step->markup-accidental pitch)
 515   (make-line-markup
 516    (list
 517     (case (caddr pitch)
 518       ((-2) (accidental->markup -2))
 519       ((-1) (accidental->markup -1))
 520       ((0) empty-markup)
 521       ((1) (accidental->markup 1))
 522       ((2) (accidental->markup 2)))
 523     (make-simple-markup (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))))))
 524
 525 (define-public chord::exception-alist-american
 526   `(
 527     (((0 . 0)) . ,empty-markup)
 528     (((0 . 0) (2 . -1)) . ,(make-simple-markup "m"))
 529
 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 ")))
 533
 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 ")))
 536
 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")))))
 540     ))
 541
 542 (define (step->markup-american pitch)
 543   (case (cadr 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")))))
 555            ((0) empty-markup)
 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)
 562                    (= (cadr pitch) 3)
 563                    (= (caddr pitch) 0))
 564               (make-simple-markup "sus4")
 565               (step->markup-accidental pitch)))))
 566
 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)
 589          (make-line-markup
 590           (list
 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 " "))))
 602                  step))
 603            (chord::additions->markup-american (cdr additions) subtractions))))
 604       empty-markup))
 605
 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)))
 614                                 (and
 615                                  (string-match "super" s)
 616                                  ;; ugh ugh
 617                                  ;; python: `except_markup`[-7:] != '"o"))'
 618                                  (not (equal?
 619                                        "\"o\"))))"
 620                                        (substring s
 621                                                   (- (string-length s) 7))))))
 622                               (or (pair? additions)
 623                                   (pair? subtractions)))
 624                          (make-super-markup (make-simple-markup "/"))
 625                          empty-markup))
 626          ;;this list contains all the additions that go "in line"
 627          (prefixes
 628           (filter-list
 629            (lambda (x)
 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
 635            additions))
 636          ;;this list contains all the additions that are patched onto the end
 637          ;;of the chord symbol, usually sus4 and altered 5ths.
 638          (suffixes
 639           ;;take out the reverse if it bothers you in a pathological chord
 640           (reverse
 641            (filter-list
 642             (lambda (x)
 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
 648             additions)))
 649          (relevant-subs (filter-list
 650                          (lambda (x) ;catches subtractions higher than 5th
 651                            (let((o (car x)) (n (cadr x)))
 652                              (or (> o 0)
 653                                  (> n 4))))
 654                          subtractions))
 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)))
 658     (make-line-markup
 659      (list
 660       tonic-markup except-markup sep-markup
 661       (make-normal-size-super-markup
 662        (make-line-markup (list pref-markup suff-markup)))
 663       b+i-markup))))
 664
 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.
 668         (unevens
 669          (filter-list (lambda (x)
 670                         (let ((n (cadr x)) (a (caddr x)))
 671                           (or (and (= 6 n) (!= -1 a))
 672                               (and (< 3 n)
 673                                    (= 0 (modulo n 2))))))
 674                       steps))
 675         (highest (let ((h (car (last-pair steps))))
 676                    (if (and (not (null? h))
 677                             (or (> 4 (cadr h))
 678                                 (!= 0 (caddr h))))
 679                        (list (list h))
 680                        '()))))
 681     (uniq-list (sort (apply append evens unevens highest)
 682                      pitch::<))))
 683
 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)))
 692
 693   ;;; Jazz style
 694   ;;;
 695 ;; Jazz chords, by Atte Andr'e Jensen <atte@post.com>
 696 ;; Complete rewrite by Amelie Zapf (amy@loueymoss.com)
 697
 698 ;; FIXME: identical to chord::exception-alist-american, apart from commented
 699 ;;        dim chord.  should merge.
 700 (define-public chord::exception-alist-jazz
 701   `(
 702     (((0 . 0)) . ,empty-markup)
 703     (((0 . 0) (2 . -1)) . ,(make-simple-markup "m"))
 704
 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 ")))
 708
 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 ")))
 711
 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")))))
 715     ))
 716
 717 ;; FIXME: rather similar to step->markup-american.  should merge.
 718 (define (step->markup-jazz pitch)
 719   (case (cadr 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"))))
 734            ((0) empty-markup)
 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)
 741                    (= (cadr pitch) 3)
 742                    (= (caddr pitch) 0))
 743               (make-simple-markup "sus4")
 744               (step->markup-accidental pitch)))))
 745
 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)
 770          (make-line-markup
 771           (list
 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 " "))))
 783                  step))
 784            (chord::additions->markup-jazz (cdr additions) subtractions))))
 785       empty-markup))
 786
 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)))
 797                                 (and
 798                                  (string-match "super" s)
 799                                  ;; ugh ugh
 800                                  ;; python: `except_markup`[-7:] != '"o"))'
 801                                  (not (equal?
 802                                        "\"o\"))))"
 803                                        (substring s
 804                                                   (- (string-length s) 7))))))
 805                               (or (pair? additions)
 806                                   (pair? subtractions)))
 807                          (make-super-markup (make-simple-markup "/"))
 808                          empty-markup))
 809          ;;this list contains all the additions that go "in line"
 810          (prefixes
 811           (filter-list
 812            (lambda (x)
 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
 818            additions))
 819          ;;this list contains all the additions that are patched onto the end
 820          ;;of the chord symbol, usually sus4 and altered 5ths.
 821          (suffixes
 822           ;;take out the reverse if it bothers you in a pathological chord
 823           (reverse
 824            (filter-list
 825             (lambda (x)
 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
 831             additions)))
 832          (relevant-subs (filter-list
 833                          (lambda (x) ;catches subtractions higher than 5th
 834                            (let((o (car x)) (n (cadr x)))
 835                              (or (> o 0)
 836                                  (> n 4))))
 837                          subtractions))
 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)))
 841     (make-line-markup
 842      (list
 843       tonic-markup except-markup sep-markup
 844       (make-normal-size-super-markup
 845        (make-line-markup (list pref-markup suff-markup)))
 846       b+i-markup))))
 847
 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)))
 854
 855
 856 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 857
 858
 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).
 863  "
 864
 865   (let* ((pitches (map c++-pitch->scm ly-pitches))
 866          (bass-and-inversion
 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))
 872                                        (cdr pitches))
 873                     '()))
 874          (lookup (dbg (chord::exceptions-lookup exceptions steps)))
 875          (exception-part (dbg (car lookup)))
 876          (unmatched-steps (cadr lookup))
 877          (tonic (car pitches))
 878          )
 879
 880       (func tonic exception-part unmatched-steps bass-and-inversion steps)
 881       ))
 882
 883 (define-public (chord->markup-jazz . args)
 884   (apply new-chord->markup (cons chord::name-jazz args))
 885   )
 886
 887 (define-public (chord->markup-american . args)
 888   (apply new-chord->markup (cons chord::name-american args))
 889   )
 890
 891 (define-public (chord->markup-banter . args)
 892   (apply new-chord->markup (cons chord::name-banter args))
 893   )
 894
 895 (define-public (new-chord-name-brew-molecule grob)
 896   (let*
 897       (
 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))
 903                                    markup))
 904        )
 905
 906     ;;
 907     ;; chord names aren't in staffs, so WS is in global staff space.
 908     (if (number? ws)
 909         (ly:combine-molecule-at-edge
 910          molecule
 911          X RIGHT (ly:make-molecule "" (cons 0 ws) '(-1 . 1) )
 912          0.0)
 913         molecule)
 914     ))
 915
 916 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 917
 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"
 921
 922   (define (chord-name-style-setter function exceptions)
 923     (context-spec-music
 924      (make-sequential-music
 925       (list (make-property-set 'chordNameFunction function)
 926             (make-property-set 'chordNameExceptions exceptions)))
 927      "ChordNames"
 928      )
 929     )
 930
 931   (ly:export
 932    (case sym
 933      ((jazz)
 934       (chord-name-style-setter chord->markup-jazz
 935                                chord::exception-alist-jazz))
 936      ((banter)
 937       (chord-name-style-setter chord->markup-banter
 938                                chord::exception-alist-banter))
 939      ((american)
 940       (chord-name-style-setter chord->markup-american
 941                                chord::exception-alist-american))
 942      )))
 943
 944