scm/chord-name.scm

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