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