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