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