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--2001 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 ;; pitch = (octave notename accidental)
  18 ;;
  19 ;; note = (notename . accidental)
  20 ;;
  21 ;; text = scm markup text -- see font.scm and input/test/markup.ly
  22
  23
  24 ;; TODO
  25 ;;
  26 ;; * easier tweakability:
  27 ;;    - split chord::names-alists up into logical bits,
  28 ;;      such as chord::exceptions-delta, exceptions-oslash
  29 ;;    - iso just the 'style parameter, use a list, eg:
  30 ;;      \property ChordNames.ChordName \set
  31 ;;        #'style = #'(jazz delta oslash german-tonic german-Bb)
  32 ;;
  33 ;; * fix FIXMEs
  34 ;;
  35 ;; * clean split/merge of bass/banter/american stuff
  36 ;;
  37 ;; * doc strings
  38
  39 (define chord::names-alist-banter '())
  40 (set! chord::names-alist-banter
  41       (append
  42         '(
  43         ; C iso C.no3.no5
  44         (((0 . 0)) . #f)
  45         ; C iso C.no5
  46         (((0 . 0) (2 . 0)) . #f)
  47         ; Cm iso Cm.no5
  48         (((0 . 0) (2 . -1)) . ("m"))
  49         ; C2 iso C2.no3
  50         (((0 . 0) (1 . 0) (4 . 0)) . ("" (super "2")))
  51         ; C4 iso C4.no3
  52         (((0 . 0) (3 . 0) (4 . 0)) . ("" (super "4")))
  53         ;; Cdim iso Cm5-
  54         (((0 . 0) (2 . -1) (4 . -1)) . ("dim"))
  55         ; Co iso Cm5-7-
  56         (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ("" (super "o")))
  57         ; Cdim9
  58         (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1)) . ("dim" (super "9")))
  59         (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1) (3 . -1)) . ("dim" (super "11")))
  60         )
  61       chord::names-alist-banter))
  62
  63 ;;;;;;;;;;
  64 (define simple-super
  65 ;; duh, no docstrings for
  66 ;;  "No real superscript, just raised and small"
  67   '((raise . 1) (font-relative-size . -2)))
  68
  69 (define (accidental->textp acc pos)
  70   (if (= acc 0)
  71       '()
  72       (list '(music (font-relative-size . -2))
  73                    (list pos (string-append "accidentals-" (number->string acc))))))
  74
  75 (define (accidental->text acc) (accidental->textp acc 'columns))
  76 (define (accidental->text-super acc) (accidental->textp acc 'simple-super))
  77 (define (accidental->text-sub acc) (accidental->textp acc 'sub))
  78
  79 (define (pitch->note-name pitch)
  80   (cons (cadr pitch) (caddr pitch)))
  81
  82 (define (pitch->text pitch)
  83   (text-append
  84    (list
  85     '(font-relative-size . 2)
  86     (make-string 1 (integer->char (+ (modulo (+ (cadr pitch) 2) 7) 65))))
  87    (accidental->text-super (caddr pitch))))
  88
  89
  90 ;;; Hooks to override chord names and note names,
  91 ;;; see input/tricks/german-chords.ly
  92
  93 (define (pitch->text-banter pitch)
  94   (pitch->text pitch))
  95
  96 ;; We need also steps, to allow for Cc name override,
  97 ;; see input/test/Cc-chords.ly
  98 (define (pitch->chord-name-text-banter pitch steps)
  99   (pitch->text-banter pitch))
 100
 101 (define (pitch->note-name-text-banter pitch)
 102   (pitch->text-banter pitch))
 103
 104 (define (step->text pitch)
 105   (list (string-append
 106     (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))
 107     (case (caddr pitch)
 108       ((-2) "--")
 109       ((-1) "-")
 110       ((0) "")
 111       ((1) "+")
 112       ((2) "++")))))
 113
 114 (define (step->text-banter pitch)
 115   (if (= (cadr pitch) 6)
 116       (case (caddr pitch)
 117         ((-2) '("7-"))
 118         ((-1) '("7"))
 119         ((0) '("maj7"))
 120         ((1) '("7+"))
 121         ((2) '("7+")))
 122       (step->text pitch)))
 123
 124 (define pitch::semitone-vec (list->vector '(0 2 4 5 7 9 11)))
 125
 126 (define (pitch::semitone pitch)
 127   (+ (* (car pitch) 12)
 128      (vector-ref pitch::semitone-vec (modulo (cadr pitch) 7))
 129      (caddr pitch)))
 130
 131 (define (pitch::< l r)
 132   (< (pitch::semitone l) (pitch::semitone r)))
 133
 134 (define (pitch::transpose pitch delta)
 135   (let ((simple-octave (+ (car pitch) (car delta)))
 136         (simple-notename (+ (cadr pitch) (cadr delta))))
 137     (let ((octave (+ simple-octave (quotient simple-notename 7)))
 138            (notename (modulo simple-notename 7)))
 139       (let ((accidental (- (+ (pitch::semitone pitch) (pitch::semitone delta))
 140                            (pitch::semitone `(,octave ,notename 0)))))
 141         `(,octave ,notename ,accidental)))))
 142
 143 (define (pitch::diff pitch tonic)
 144   (let ((simple-octave (- (car pitch) (car tonic)))
 145         (simple-notename (- (cadr pitch) (cadr tonic))))
 146     (let ((octave (+ simple-octave (quotient simple-notename 7)
 147                      (if (< simple-notename 0) -1 0)))
 148           (notename (modulo simple-notename 7)))
 149       (let ((accidental (- (pitch::semitone pitch)
 150                           (pitch::semitone tonic)
 151                           (pitch::semitone `(,octave ,notename 0)))))
 152         `(,octave ,notename ,accidental)))))
 153
 154 (define (pitch::note-pitch pitch)
 155   (+ (* (car pitch) 7) (cadr pitch)))
 156
 157 (define (chord::text? text)
 158   (not (or (not text) (empty? text) (unspecified? text))))
 159
 160 (define (chord::text-cleanup dirty)
 161   "
 162    Recursively remove '() #f, and #<unspecified> from markup text tree.
 163    This allows us to leave else parts of (if # #) off.
 164    Otherwise, you'd have to do (if # # '()), and you'd have to
 165    filter-out the '() anyway.
 166   "
 167   (if (pair? dirty)
 168       (let ((r (car dirty)))
 169         (if (chord::text? r)
 170             (cons (if (pair? r) (chord::text-cleanup r) r)
 171                   (chord::text-cleanup (cdr dirty)))
 172             (chord::text-cleanup (cdr dirty))))
 173       (if (chord::text? dirty)
 174           dirty
 175           '())))
 176
 177 (define (text-append l . r)
 178   (if (not (chord::text? r))
 179       l
 180       (if (not (chord::text? l))
 181           r
 182           (if (empty? (cdr r))
 183               (list 'columns l (car r))
 184               (text-append (list 'columns l (car r)) (cdr r))))))
 185
 186 (define (chord::step tonic pitch)
 187  (- (pitch::note-pitch pitch) (pitch::note-pitch tonic)))
 188
 189 ;; text: list of word
 190 ;; word: string + optional list of property
 191 ;; property: align, kern, font (?), size
 192
 193 (define chord::minor-major-vec (list->vector '(0 -1 -1 0 -1 -1 0)))
 194
 195 ;; FIXME: unLOOP
 196 ;; compute the relative-to-tonic pitch that goes with 'step'
 197 (define (chord::step-pitch tonic step)
 198   ;; urg, we only do this for thirds
 199   (if (= (modulo step 2) 0)
 200     '(0 0 0)
 201     (let loop ((i 1) (pitch tonic))
 202       (if (= i step) pitch
 203         (loop (+ i 2)
 204               (pitch::transpose
 205                 pitch `(0 2 ,(vector-ref chord::minor-major-vec
 206                 ;; -1 (step=1 -> vector=0) + 7 = 6
 207                 (modulo (+ i 6) 7)))))))))
 208
 209 (define (chord::additions steps)
 210 " Return:
 211    * any even step (2, 4, 6)
 212    * any uneven step that is chromatically altered,
 213      (where 7-- == -1, 7- == 0, 7 == +1)
 214    * highest step
 215
 216 ?and jazz needs also:
 217
 218    * TODO: any uneven step that's lower than an uneven step which is
 219      chromatically altered
 220   "
 221   (let ((evens (filter-list (lambda (x) (!= 0 (modulo (cadr x) 2))) steps))
 222         (altered-unevens
 223          (filter-list (lambda (x)
 224                         (let ((n (cadr x)) (a (caddr x)))
 225                           (or (and (= 6 n) (!= -1 a))
 226                               (and (!= 6 n)
 227                                    (= 0 (modulo n 2))
 228                                    (!= 0 a)))))
 229                       steps))
 230         (highest (let ((h (car (last-pair steps))))
 231                    (if (and (not (empty? h))
 232                             (or (> 4 (cadr h))
 233                                 (!= 0 (caddr h))))
 234                        (list (list h))
 235                        '()))))
 236     ;; Hmm, what if we have a step twice, can we ignore that?
 237     (uniq-list (sort (apply append evens altered-unevens highest)
 238                      pitch::<))))
 239
 240
 241 ;; FIXME: unLOOP, see ::additions
 242 ;; find the pitches that are missing from `normal' chord
 243 (define (chord::subtractions chord-pitches)
 244   (let ((tonic (car chord-pitches)))
 245     (let loop ((step 1) (pitches chord-pitches) (subtractions '()))
 246       (if (pair? pitches)
 247         (let* ((pitch (car pitches))
 248                (p-step (+ (- (pitch::note-pitch pitch)
 249                              (pitch::note-pitch tonic))
 250                           1)))
 251           ;; pitch is an subtraction if
 252           ;; a step is missing or
 253           (if (> p-step step)
 254             (loop (+ step 2) pitches
 255                 (cons (chord::step-pitch tonic step) subtractions))
 256           ;; there are no pitches left, but base thirds are not yet done and
 257           (if (and (<= step 5)
 258                    (= (length pitches) 1))
 259             ;; present pitch is not missing step
 260             (if (= p-step step)
 261               (loop (+ step 2) pitches subtractions)
 262               (loop (+ step 2) pitches
 263                     (cons (chord::step-pitch tonic step) subtractions)))
 264             (if (= p-step step)
 265               (loop (+ step 2) (cdr pitches) subtractions)
 266               (loop step (cdr pitches) subtractions)))))
 267         (reverse subtractions)))))
 268
 269 (define (chord::additions->text-banter additions subtractions)
 270   (if (pair? additions)
 271       (text-append
 272        (let ((step (step->text-banter (car additions))))
 273          (if (or (pair? (cdr additions))
 274                  (pair? subtractions))
 275              (text-append step "/")
 276              step))
 277       (chord::additions->text-banter (cdr additions) subtractions))
 278   '()))
 279
 280 (define (chord::subtractions->text-banter subtractions)
 281   (if (pair? subtractions)
 282       (text-append
 283        '("no")
 284        (let ((step (step->text-jazz (car subtractions))))
 285          (if (pair? (cdr subtractions))
 286                         (text-append step "/")
 287                         step))
 288        (chord::subtractions->text-banter (cdr subtractions)))
 289       '()))
 290
 291 (define (chord::bass-and-inversion->text-banter bass-and-inversion)
 292   (if (and (pair? bass-and-inversion)
 293            (or (car bass-and-inversion)
 294                (cdr bass-and-inversion)))
 295       (list "/" (if (car bass-and-inversion)
 296                     (pitch->note-name-text-banter
 297                      (car bass-and-inversion))
 298                     (pitch->note-name-text-banter
 299                      (cdr bass-and-inversion))))))
 300
 301 ;; FIXME: merge this function with inner-name-jazz, -american
 302 ;;        iso using chord::bass-and-inversion->text-banter,
 303 ;;        call (chord::restyle 'chord::bass-and-inversion->text- style)
 304 ;;        See: chord::exceptions-lookup
 305 ;;
 306 ;; Banter style
 307 ;; Combine tonic, exception-part of chord name,
 308 ;; additions, subtractions and bass or inversion into chord name
 309 (define (chord::inner-name-banter tonic exception-part additions subtractions
 310                                   bass-and-inversion steps)
 311   (let ((tonic-text (pitch->chord-name-text-banter tonic steps))
 312         (except-text exception-part)
 313         (sep-text (if (and (string-match "super" (format "~s" exception-part))
 314                             (or (pair? additions)
 315                                 (pair? subtractions)))
 316                        (list simple-super "/")))
 317         (adds-text (chord::additions->text-banter additions subtractions))
 318         (subs-text (chord::subtractions->text-banter subtractions))
 319         (b+i-text (chord::bass-and-inversion->text-banter bass-and-inversion)))
 320     (text-append
 321      tonic-text except-text sep-text
 322      (list (list simple-super) adds-text subs-text)
 323      b+i-text)))
 324
 325 (define (chord::name-banter tonic exception-part unmatched-steps
 326                             bass-and-inversion steps)
 327   (let ((additions (chord::additions unmatched-steps))
 328         (subtractions (chord::subtractions unmatched-steps)))
 329     (chord::inner-name-banter tonic exception-part additions subtractions
 330                               bass-and-inversion steps)))
 331
 332
 333 (define (c++-pitch->scm p)
 334   (if (pitch? p)
 335       (list (pitch-octave p) (pitch-notename p) (pitch-alteration p))
 336       #f))
 337
 338 (define (chord::name-banter tonic exception-part unmatched-steps
 339                             bass-and-inversion steps)
 340   (let ((additions (chord::additions unmatched-steps))
 341         (subtractions (chord::subtractions unmatched-steps)))
 342     (chord::inner-name-banter tonic exception-part additions subtractions
 343                               bass-and-inversion steps)))
 344
 345 (define (chord::restyle name style)
 346   (ly-eval (string->symbol
 347             (string-append (symbol->string name)
 348                            (symbol->string style)))))
 349
 350 ;; check exceptions-alist for biggest matching part of try-steps
 351 ;; return (MATCHED-EXCEPTION . UNMATCHED-STEPS)
 352 (define (chord::exceptions-lookup-helper
 353          exceptions-alist try-steps unmatched-steps exception-part)
 354   (if (pair? try-steps)
 355       ;; FIXME: junk '(0 . 0) from exceptions lists?
 356       ;;        if so: how to handle first '((0 . 0) . #f) entry?
 357       ;;
 358       ;; FIXME: either format exceptions list as real pitches, ie,
 359       ;;        including octave '((0 2 -1) ..), or drop octave
 360       ;;        from rest of calculations,
 361       (let ((entry (assoc
 362                     (map (lambda (x) (pitch->note-name x))
 363                          (append '((0 0 0)) try-steps))
 364                     exceptions-alist)))
 365         (if entry
 366             (chord::exceptions-lookup-helper
 367              #f '() unmatched-steps (cdr entry))
 368             (let ((r (reverse try-steps)))
 369               (chord::exceptions-lookup-helper
 370                exceptions-alist
 371                (reverse (cdr r))
 372                (cons (car r) unmatched-steps) #f))))
 373       (cons exception-part unmatched-steps)))
 374
 375 ;; return (MATCHED-EXCEPTION . BASE-CHORD-WITH-UNMATCHED-STEPS)
 376 ;; BASE-CHORD-WITH-UNMATCHED-STEPS always includes (tonic 3 5)
 377 (define (chord::exceptions-lookup style steps)
 378   (let* ((result (chord::exceptions-lookup-helper
 379                   (chord::restyle 'chord::names-alist- style)
 380                   steps '() #f))
 381            (exception-part (car result))
 382            (unmatched-steps (cdr result))
 383            (matched-steps (if (= (length unmatched-steps) 0)
 384                               3
 385                               (+ 1 (- (length steps)
 386                                       (length unmatched-steps)))))
 387            (unmatched-with-1-3-5
 388             (append (do ((i matched-steps (- i 1))
 389                          (base '() (cons `(0 ,(* (- i 1) 2) 0) base)))
 390                         ((= i 0) base)
 391                       ())
 392                     unmatched-steps)))
 393     (list exception-part unmatched-with-1-3-5)))
 394
 395
 396 (define (chord::name->text style tonic steps bass-and-inversion)
 397   (let* ((lookup (chord::exceptions-lookup style steps))
 398          (exception-part (car lookup))
 399          (unmatched-steps (cadr lookup)))
 400     ((chord::restyle 'chord::name- style)
 401      tonic exception-part unmatched-steps bass-and-inversion steps)))
 402
 403 ;; C++ entry point
 404 ;;
 405 ;; Check for each subset of chord, full chord first, if there's a
 406 ;; user-override.  Split the chord into user-overridden and to-be-done
 407 ;; parts, complete the missing user-override matched part with normal
 408 ;; chord to be name-calculated.
 409 ;;
 410 ;; CHORD: (pitches (bass . inversion))
 411 (define (default-chord-name-function style chord)
 412   (let* ((pitches (map c++-pitch->scm (car chord)))
 413          (modifiers (cdr chord))
 414          (bass-and-inversion (if (pair? modifiers)
 415                                  (cons (c++-pitch->scm (car modifiers))
 416                                        (c++-pitch->scm (cdr modifiers)))
 417                                  '(() . ())))
 418          (diff (pitch::diff '(0 0 0) (car pitches)))
 419          (steps (if (cdr pitches) (map (lambda (x)
 420                                          (pitch::transpose x diff))
 421                                        (cdr pitches))
 422                     '())))
 423     (chord::name->text style (car pitches) steps bass-and-inversion)))
 424
 425 ;;;
 426 ;;; American style
 427 ;;;
 428
 429
 430 ;; NOTE: Duplicates of chord names defined elsewhere occur in this list
 431 ;; in order to prevent spurious superscripting of various chord names,
 432 ;; such as maj7, maj9, etc.
 433 ;;
 434 ;; See input/test/american-chords.ly
 435 ;;
 436 ;; James Hammons, <jlhamm@pacificnet.net>
 437 ;;
 438
 439 ;; DONT use non-ascii characters, even if ``it works'' in Windows
 440
 441 (define chord::names-alist-american '())
 442
 443 (set! chord::names-alist-american
 444       (append
 445        '(
 446          (((0 . 0)) . #f)
 447          (((0 . 0) (2 . 0)) . #f)
 448          ;; Root-fifth chord
 449          (((0 . 0) (4 . 0)) . ("5"))
 450          ;; Common triads
 451          (((0 . 0) (2 . -1)) . ("m"))
 452          (((0 . 0) (3 . 0) (4 . 0)) . ("sus"))
 453          (((0 . 0) (2 . -1) (4 . -1)) . ("dim"))
 454 ;Alternate:      (((0 . 0) (2 . -1) (4 . -1)) . ("" (super "o")))
 455          (((0 . 0) (2 . 0) (4 . 1)) . ("aug"))
 456 ;Alternate:      (((0 . 0) (2 . 0) (4 . 1)) . ("+"))
 457          (((0 . 0) (1 . 0) (4 . 0)) . ("2"))
 458          ;; Common seventh chords
 459          (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ("" (super "o") "7"))
 460          (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . ("maj7"))
 461          ;; urg! should use (0 . 0 2 . -1) -> "m", and add "7" to that!!
 462          (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . ("m7"))
 463          (((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . ("7"))
 464          (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . ("m(maj7)"))
 465          ;jazz: the delta, see jazz-chords.ly
 466          ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) .  (super ((font-family . math) "N"))
 467          ;; slashed o
 468          (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (columns (super (overstrike "o") "/") "7"))
 469
 470          (((0 . 0) (2 . 0) (4 . 1) (6 . -1)) . ("aug7"))
 471          (((0 . 0) (2 . 0) (4 . -1) (6 . 0)) . (columns "maj7" ((font-relative-size . -2) ((raise . 0.2) (music (named "accidentals--1")))) "5"))
 472          (((0 . 0) (2 . 0) (4 . -1) (6 . -1)) . (columns "7" ((font-relative-size . -2) ((raise . 0.2) (music (named "accidentals--1")))) "5"))
 473          (((0 . 0) (3 . 0) (4 . 0) (6 . -1)) . ("7sus4"))
 474          ;; Common ninth chords
 475          (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) . ("6/9")) ;; we don't want the '/no7'
 476          (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) . ("6"))
 477          (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) . ("m6"))
 478          (((0 . 0) (2 . 0) (4 . 0) (1 . 0)) . ("add9"))
 479          (((0 . 0) (2 . 0) (4 . 0) (6 . 0) (1 . 0)) . ("maj9"))
 480          (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0)) . ("9"))
 481          (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) . ("m9"))
 482
 483          )
 484       chord::names-alist-american))
 485
 486
 487 ;; American style chordnames use no "no",
 488 ;; but otherwise very similar to banter for now
 489 (define (chord::name-american tonic exception-part unmatched-steps
 490                               bass-and-inversion steps)
 491   (let ((additions (chord::additions unmatched-steps))
 492         (subtractions #f))
 493     (chord::inner-name-banter tonic exception-part additions subtractions
 494                               bass-and-inversion steps)))
 495
 496
 497
 498 ;;;
 499 ;;; Jazz style
 500 ;;;
 501
 502
 503
 504 ;; Jazz chords, by Atte Andr'e Jensen <atte@post.com>
 505 ;; NBs: This uses the american list as a bass.
 506 ;;      Some defs take up more than one line,
 507 ;; be carefull when messing with ;'s!!
 508
 509
 510 ;; FIXME
 511 ;;
 512 ;; This is getting out-of hand?  Only exceptional chord names that
 513 ;; cannot be generated should be here.
 514 ;; Maybe we should have inner-name-jazz and inner-name-american functions;
 515 ;;
 516 ;;
 517 ;;
 518 ;; DONT use non-ascii characters, even if ``it works'' in Windows
 519
 520 (define chord::names-alist-jazz '())
 521 (set! chord::names-alist-jazz
 522       (append
 523       '(
 524         ;; major chords
 525         ; major sixth chord = 6
 526         (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) . (((raise . 0.5) "6")))
 527         ; major seventh chord = triangle
 528         ;; shouldn't this be a filled black triange, like this:  ? --jcn
 529         ;; (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) .  (((raise . 0.5)((font-family . math) "N"))))
 530         (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) .  (((raise . 0.5)((font-family . math) "M"))))
 531         ; major chord add nine = add9
 532         (((0 . 0) (2 . 0) (4 . 0) (1 . 0)) . (((raise . 0.5) "add9")))
 533         ; major sixth chord with nine = 6/9
 534         (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) . (((raise . 0.5) "6/9")))
 535
 536         ;; minor chords
 537         ; minor sixth chord = m6
 538         (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) . (columns("m")((raise . 0.5) "6")))
 539         ;; minor major seventh chord = m triangle
 540         ;; shouldn't this be a filled black triange, like this:  ? --jcn
 541         ;;(((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (columns ("m") ((raise . 0.5)((font-family . math) "N"))))
 542         (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (columns ("m") ((raise . 0.5)((font-family . math) "M"))))
 543         ; minor seventh chord = m7
 544         (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . (columns("m")((raise . 0.5) "7")))
 545         ; minor sixth nine chord = m6/9
 546         (((0 . 0) (2 . -1) (4 . 0) (5 . 0) (1 . 0)) . (columns("m")((raise . 0.5) "6/9")))
 547         ; minor with added nine chord = madd9
 548         (((0 . 0) (2 . -1) (4 . 0) (1 . 0)) . (columns("m")((raise . 0.5) "add9")))
 549         ; minor ninth chord = m9
 550         (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) . (columns("m")((raise . 0.5) "9")))
 551
 552         ;; dominant chords
 553         ; dominant seventh = 7
 554         (((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . (((raise . 0.5) "7")))
 555         ; augmented dominant = +7
 556         ;(((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (((raise . 0.5) "+7"))) ; +7 with both raised
 557         (((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (columns("+")((raise . 0.5) "7"))) ; +7 with 7 raised
 558         ;(((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (columns((raise . 0.5) "7(")
 559         ;       ((raise . 0.3)(music (named ("accidentals-1"))))
 560         ;       ((raise . 0.5) "5)"))); 7(#5)
 561         ; dominant flat 5 = 7(b5)
 562         (((0 . 0) (2 . 0) (4 . -1) (6 . -1)) . (columns((raise . 0.5) "7(")
 563                 ((raise . 0.3)(music (named ("accidentals--1"))))
 564                 ((raise . 0.5) "5)")))
 565         ; dominant 9 = 7(9)
 566         (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0)) . (((raise . 0.8)"7(9)")))
 567         ; dominant flat 9 = 7(b9)
 568         (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1)) . (
 569                 ((raise . 0.8)"7(")
 570                 ((raise . 0.3)(music (named ("accidentals--1"))))
 571                 ((raise . 0.8)"9)")))
 572         ; dominant sharp 9 = 7(#9)
 573         (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1)) . (
 574                 ((raise . 0.8)"7(")
 575                 ((raise . 0.3)(music (named ("accidentals-1"))))
 576                 ((raise . 0.8)"9)")))
 577         ; dominant 13 = 7(13)
 578         (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (5 . 0)) . (((raise . 0.8)"7(13)")))
 579         ; dominant flat 13 = 7(b13)
 580         (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (5 . -1)) . (
 581                 ((raise . 0.8)"7(")
 582                 ((raise . 0.3)(music (named ("accidentals--1"))))
 583                 ((raise . 0.8)"13)")))
 584         ; dominant 9, 13 = 7(9,13)
 585         (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0) (5 . 0)) . (((raise . 0.8)"7(9, 13)")))
 586         ; dominant flat 9, 13 = 7(b9,13)
 587         (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1) (5 . 0)) . (
 588                 ((raise . 0.8)"7(")
 589                 ((raise . 0.3)(music (named ("accidentals--1"))))
 590                 ((raise . 0.8)"9, 13)")))
 591         ; dominant sharp 9, 13 = 7(#9,13)
 592         (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1) (5 . 0)) . (
 593                 ((raise . 0.8)"7(")
 594                 ((raise . 0.3)(music (named ("accidentals-1"))))
 595                 ((raise . 0.8)"9, 13)")))
 596         ; dominant 9, flat 13 = 7(9,b13)
 597         (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0) (5 . -1)) . (
 598                 ((raise . 0.8)"7(9, ")
 599                 ((raise . 0.3)(music (named ("accidentals--1"))))
 600                 ((raise . 0.8)"13)")))
 601         ; dominant flat 9, flat 13 = 7(b9,b13)
 602         (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1) (5 . -1)) . (
 603                 ((raise . 0.8)"7(")
 604                 ((raise . 0.3)(music (named ("accidentals--1"))))
 605                 ((raise . 0.8)"9, ")
 606                 ((raise . 0.3)(music (named ("accidentals--1"))))
 607                 ((raise . 0.8)"13)")))
 608         ; dominant sharp 9, flat 13 = 7(#9,b13)
 609         (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1) (5 . -1)) . (
 610                 ((raise . 0.8)"7(")
 611                 ((raise . 0.3)(music (named ("accidentals-1"))))
 612                 ((raise . 0.8)"9, ")
 613                 ((raise . 0.3)(music (named ("accidentals--1"))))
 614                 ((raise . 0.8)"13)")))
 615
 616         ;; diminished chord(s)
 617         ; diminished seventh chord =  o
 618
 619
 620         ;; DONT use non-ascii characters, even if ``it works'' in Windows
 621
 622         ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ((raise . 0.8) (size . -2) ("o")))
 623         (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ("" (super "o")))
 624
 625         ;; half diminshed chords
 626         ;; half diminished seventh chord = slashed o
 627         ;; (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (((raise . 0.8) "/o")))
 628         (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (columns (super (overstrike "o") "/") "7")) ; slashed o
 629
 630         ; half diminished seventh chord  with major 9 = slashed o cancelation 9
 631         (((0 . 0) (2 . -1) (4 . -1) (6 . -1) (1 . 0)) . (
 632                 ((raise . 0.8)"/o(")
 633                 ((raise . 0.3)(music (named ("accidentals-0"))))
 634                 ((raise . 0.8)"9)")));
 635
 636 ;; Missing jazz chord definitions go here (note new syntax: see american for hints)
 637
 638         )
 639       chord::names-alist-american))
 640
 641 (define (step->text-alternate-jazz pitch)
 642   (text-append
 643    (accidental->text (caddr pitch))
 644    (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))))
 645
 646 (define (step->text-jazz pitch)
 647   (if (= (cadr pitch) 6)
 648       (case (caddr pitch)
 649         ;; sharp 7 only included for completeness?
 650         ((-2) (text-append (accidental->text -1) '("7")))
 651         ((-1) '("7"))
 652         ((0) '("maj7"))
 653         ((1) (text-append (accidental->text-super 1) '("7")))
 654         ((2) (text-append (accidental->text-super 2) '("7"))))
 655       (step->text-alternate-jazz pitch)))
 656
 657 (define (xchord::additions->text-jazz additions subtractions)
 658   (if (pair? additions)
 659       (text-append
 660        (let ((step (step->text-jazz (car additions))))
 661          (if (or (pair? (cdr additions))
 662                  (pair? subtractions))
 663              (text-append step "/")
 664              step))
 665       (chord::additions->text-jazz (cdr additions) subtractions))
 666   '()))
 667
 668 (define (chord::>5? x)
 669   (or (> (car x) 0)
 670       (> (cadr x) 4)))
 671
 672
 673 ;; FIXME:
 674 ;; Perhaps all logic like this should be done earlier,
 675 ;; so that in this text-construction printing phase
 676 ;; we can just blindly create text from all additions.
 677 ;;
 678 ;; This depends maybe on the fact of code sharing,
 679 ;; in this layout, we can share the functions chord::additions
 680 ;; and chord::subtractions with banter.
 681 (define (chord::additions->text-jazz additions subtractions)
 682   (text-append
 683    (chord::additions<=5->text-jazz (filter-out-list chord::>5? additions)
 684                                    (filter-out-list chord::>5? subtractions))
 685    (chord::additions>5->text-jazz (filter-list chord::>5? additions)
 686                                   (filter-list chord::>5? subtractions))))
 687
 688 ;; FIXME
 689 (define (chord::additions<=5->text-jazz additions subtractions)
 690   (let ((sus (chord::sus-four-jazz additions)))
 691     (if (pair? sus)
 692         (text-append '("sus") (step->text-jazz (car sus)))
 693         '())))
 694
 695 (define (chord::additions>5->text-jazz additions subtractions)
 696   "
 697 Compose text of all additions
 698
 699   * if there's a subtraction:
 700     - add `add'
 701     - list all up to highest
 702   * list all steps that are below an chromatically altered step
 703   "
 704   (text-append
 705    (if (not (empty? subtractions)) "add" '())
 706    (let ((radds (reverse additions)))
 707      (reverse (chord::additions>5->text-jazz-helper
 708                radds
 709                subtractions
 710                (if (or (empty? subtractions) (empty? radds))
 711                    #f (car radds)))))))
 712
 713 (define (chord::additions>5->text-jazz-helper additions subtractions list-step)
 714   "
 715 Create texts for all additions
 716 If list-step != #f, list all steps down to 5
 717 If we encounter a chromatically altered step, turn on list-step
 718 "
 719
 720   (if list-step
 721       (if (not (member list-step subtractions))
 722           (if (> 5 (cadr list-step))
 723               (cons (step->text-jazz list-step)
 724                     (chord::additions>5->text-jazz-helper
 725                      additions
 726                      subtractions
 727                      (chord::get-create-step additions
 728                                              (- (cadr list-step) 2))))
 729               (step->text-jazz list-step))
 730           (chord::get-create-step additions (- (cadr list-step) 2)))
 731       (if (pair? additions)
 732           (let ((step (car additions)))
 733             (cons (step->text-jazz step)
 734                   (chord::additions>5->text-jazz-helper
 735                    (cdr additions)
 736                    subtractions
 737                    (if (or (and (!= 6 (cadr step)) (!= 0 (caddr step)))
 738                            (and (= 6 (cadr step)) (!= -1 (caddr step))))
 739                        (chord::get-create-step additions (- (cadr step) 2))
 740                        #f))))
 741           '())))
 742
 743 (define (chord::sus-four-jazz chord-pitches)
 744   "List of pitches that are step 2 or step 4"
 745   (filter-list (lambda (x)
 746                  (and (= 0 (car x))
 747                       (or (= 1 (cadr x)) (= 3 (cadr x))))) chord-pitches))
 748
 749 (define (chord::get-create-step steps n)
 750   (let* ((i (if (< n 0) (+ n 7) n))
 751          (found (filter-list (lambda (x) (= i (cadr x))) steps)))
 752     (if (empty? found)
 753         (if (!= i 6)
 754             (list 0 i 0)
 755             (list 0 6 -1))
 756         (car found))))
 757
 758 (define (chord::subtractions->text-jazz subtractions)
 759   (if (pair? subtractions)
 760       (text-append
 761        (if (= 5 (cadr (car subtractions)))
 762            (text-append
 763             '("omit")
 764             (let ((step (step->text-jazz (car subtractions))))
 765               (if (pair? (cdr subtractions))
 766                   (text-append step "/")
 767                   step)))
 768            '())
 769        (chord::subtractions->text-jazz (cdr subtractions)))
 770       '()))
 771
 772
 773 ;; TODO: maybe merge with inner-name-banter
 774 ;; Combine tonic, exception-part of chord name,
 775 ;; additions, subtractions and bass or inversion into chord name
 776 (define (chord::inner-name-jazz tonic exception-part additions subtractions
 777                                   bass-and-inversion steps)
 778     (text-append
 779      (pitch->chord-name-text-banter tonic steps)
 780      exception-part
 781      ;; why does list->string not work, format seems only hope...
 782      (if (and (string-match "super" (format "~s" exception-part))
 783               (or (pair? additions)
 784                   (pair? subtractions)))
 785          (list simple-super "/"))
 786
 787      (list `(,simple-super)
 788            (chord::additions->text-jazz additions subtractions)
 789            (chord::subtractions->text-jazz subtractions))
 790      (chord::bass-and-inversion->text-banter bass-and-inversion)))
 791
 792 ;; Jazz style--basically similar to american with minor changes
 793 ;;
 794 ;; Consider Dm6.  When we get here:
 795 ;;     tonic =  '(0 1 0) (note d=2)
 796 ;;     steps =  '((0 0 0) '(0 2 -1) (0 4 0) (0 5 0))
 797 ;;               steps are transposed for tonic c, octave 0,
 798 ;;               so (car steps) is always (0 0 0)
 799 ;;     except  = ("m")
 800 ;;               assuming that the exceptions-alist has an entry
 801 ;;               '(((0 . 0) (2 . -1)) . ("m"))
 802 ;;               (and NOT the full chord, like std jazz list, ugh)
 803 ;;     unmatch = '((0 0 0) (0 2 0) (0 4 0) (0 5 0))
 804 ;;     subtract= '()
 805 ;;
 806 ;; You can look very easily what happens, if you add some write-me calls,
 807 ;; and run lilypond on a simple file, eg, containing only the chord c:m6:
 808 ;;
 809 ;;   (let ((additions (write-me "adds: "
 810 ;;                 (chord::additions (write-me "unmatched:"
 811 ;;                 unmatched-steps))))
 812 ;;
 813 ;; If you set subtract #f, the chord::inner-name-jazz does not see any
 814 ;; subtractions, ever, so they don't turn up in the chord name.
 815 ;;
 816 (define (chord::name-jazz tonic exception-part unmatched-steps
 817                           bass-and-inversion steps)
 818   (let ((additions (chord::additions unmatched-steps))
 819         ;; get no 'omit' or 'no'
 820         ;; (subtractions #f))
 821         (subtractions (chord::subtractions unmatched-steps)))
 822     (chord::inner-name-jazz tonic exception-part additions subtractions
 823              bass-and-inversion steps)))
 824
 825 ;; wip (set! chord::names-alist-jazz
 826 (define chord::names-alist-jazz
 827       (append
 828       '(
 829         (((0 . 0) (2 . -1)) . ("m"))
 830         )
 831       '()))
 832       ;;chord::names-alist-american))