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