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 ;;
  18 ;; (octave notename accidental)
  19 ;;
  20
  21 ;;
  22 ;; text: scm markup text -- see font.scm and input/test/markup.ly
  23 ;;
  24
  25 ;; TODO
  26 ;;
  27 ;; * clean split of base/banter/american stuff
  28 ;; * text definition is rather ad-hoc
  29 ;; * do without format module
  30 ;; * finish and check american names
  31 ;; * make notename (tonic) configurable from lilypond
  32 ;; * fix append/cons stuff in inner-name-banter
  33 ;; * doc strings.
  34
  35 ;;;;;;;;;
  36 (define chord::names-alist-banter '())
  37 (set! chord::names-alist-banter
  38       (append
  39         '(
  40         ; C iso C.no3.no5
  41         (((0 . 0)) . #f)
  42         ; C iso C.no5
  43         (((0 . 0) (2 . 0)) . #f)
  44         ; Cm iso Cm.no5
  45         (((0 . 0) (2 . -1)) . ("m"))
  46         ; C2 iso C2.no3
  47         (((0 . 0) (1 . 0) (4 . 0)) . ("" (super "2")))
  48         ; C4 iso C4.no3
  49         (((0 . 0) (3 . 0) (4 . 0)) . ("" (super "4")))
  50         ;; Cdim iso Cm5-
  51         (((0 . 0) (2 . -1) (4 . -1)) . ("dim"))
  52         ; Co iso Cm5-7-
  53         (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ("" (super "o")))
  54         ; Cdim9
  55         (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1)) . ("dim" (super "9")))
  56         (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1) (3 . -1)) . ("dim" (super "11")))
  57         )
  58       chord::names-alist-banter))
  59
  60
  61 ;; NOTE: Duplicates of chord names defined elsewhere occur in this list
  62 ;; in order to prevent spurious superscripting of various chord names,
  63 ;; such as maj7, maj9, etc.
  64 ;;
  65 ;; See input/test/american-chords.ly
  66 ;;
  67 ;; James Hammons, <jlhamm@pacificnet.net>
  68 ;;
  69
  70 ;; DONT use non-ascii characters, even if ``it works'' in Windows
  71
  72 (define chord::names-alist-american '())
  73
  74 (set! chord::names-alist-american
  75       (append
  76        '(
  77          (((0 . 0)) . #f)
  78          (((0 . 0) (2 . 0)) . #f)
  79          ;; Root-fifth chord
  80          (((0 . 0) (4 . 0)) . ("5"))
  81          ;; Common triads
  82          (((0 . 0) (2 . -1)) . ("m"))
  83          (((0 . 0) (3 . 0) (4 . 0)) . ("sus"))
  84          (((0 . 0) (2 . -1) (4 . -1)) . ("dim"))
  85 ;Alternate:      (((0 . 0) (2 . -1) (4 . -1)) . ("" (super "o")))
  86          (((0 . 0) (2 . 0) (4 . 1)) . ("aug"))
  87 ;Alternate:      (((0 . 0) (2 . 0) (4 . 1)) . ("+"))
  88          (((0 . 0) (1 . 0) (4 . 0)) . ("2"))
  89          ;; Common seventh chords
  90          (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ("" (super "o") "7"))
  91          (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . ("maj7"))
  92          (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . ("m7"))
  93          (((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . ("7"))
  94          (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . ("m(maj7)"))
  95          ;jazz: the delta, see jazz-chords.ly
  96          ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) .  (super ((font-family . math) "N"))
  97          ;; ugh, kludge slashed o
  98          ;; (((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
  99          (((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
 100
 101          (((0 . 0) (2 . 0) (4 . 1) (6 . -1)) . ("aug7"))
 102          (((0 . 0) (2 . 0) (4 . -1) (6 . 0)) . (rows "maj7" ((font-relative-size . -2) ((raise . 0.2) (music (named "accidentals--1")))) "5"))
 103          (((0 . 0) (2 . 0) (4 . -1) (6 . -1)) . (rows "7" ((font-relative-size . -2) ((raise . 0.2) (music (named "accidentals--1")))) "5"))
 104          (((0 . 0) (3 . 0) (4 . 0) (6 . -1)) . ("7sus4"))
 105          ;; Common ninth chords
 106          (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) . ("6/9")) ;; we don't want the '/no7'
 107          (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) . ("6"))
 108          (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) . ("m6"))
 109          (((0 . 0) (2 . 0) (4 . 0) (1 . 0)) . ("add9"))
 110          (((0 . 0) (2 . 0) (4 . 0) (6 . 0) (1 . 0)) . ("maj9"))
 111          (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0)) . ("9"))
 112          (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) . ("m9"))
 113
 114          )
 115       chord::names-alist-american))
 116
 117 ;; Jazz chords, by Atte Andr'e Jensen <atte@post.com>
 118 ;; NBs: This uses the american list as a base.
 119 ;;      Some defs take up more than one line,
 120 ;; be carefull when messing with ;'s!!
 121
 122
 123 ;; FIXME
 124 ;;
 125 ;; This is getting out-of hand?  Only exceptional chord names that
 126 ;; cannot be generated should be here.
 127 ;; Maybe we should have inner-jazz-name and inner-american-name functions;
 128 ;;
 129 ;;
 130 ;;
 131 ;; DONT use non-ascii characters, even if ``it works'' in Windows
 132
 133 (define chord::names-alist-jazz '())
 134 (set! chord::names-alist-jazz
 135       (append
 136       '(
 137         ;; major chords
 138         ; major sixth chord = 6
 139         (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) . (((raise . 0.5) "6")))
 140         ; major seventh chord = triangle
 141         ;; shouldn't this be a filled black triange, like this:  ? --jcn
 142         ;; (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) .  (((raise . 0.5)((font-family . math) "N"))))
 143         (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) .  (((raise . 0.5)((font-family . math) "M"))))
 144         ; major chord add nine = add9
 145         (((0 . 0) (2 . 0) (4 . 0) (1 . 0)) . (((raise . 0.5) "add9")))
 146         ; major sixth chord with nine = 6/9
 147         (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) . (((raise . 0.5) "6/9")))
 148
 149         ;; minor chords
 150         ; minor sixth chord = m6
 151         (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) . (rows("m")((raise . 0.5) "6")))
 152         ;; minor major seventh chord = m triangle
 153         ;; shouldn't this be a filled black triange, like this:  ? --jcn
 154         ;;(((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (rows ("m") ((raise . 0.5)((font-family . math) "N"))))
 155         (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (rows ("m") ((raise . 0.5)((font-family . math) "M"))))
 156         ; minor seventh chord = m7
 157         (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . (rows("m")((raise . 0.5) "7")))
 158         ; minor sixth nine chord = m6/9
 159         (((0 . 0) (2 . -1) (4 . 0) (5 . 0) (1 . 0)) . (rows("m")((raise . 0.5) "6/9")))
 160         ; minor with added nine chord = madd9
 161         (((0 . 0) (2 . -1) (4 . 0) (1 . 0)) . (rows("m")((raise . 0.5) "add9")))
 162         ; minor ninth chord = m9
 163         (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) . (rows("m")((raise . 0.5) "9")))
 164
 165         ;; dominant chords
 166         ; dominant seventh = 7
 167         (((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . (((raise . 0.5) "7")))
 168         ; augmented dominant = +7
 169         ;(((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (((raise . 0.5) "+7"))) ; +7 with both raised
 170         (((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (rows("+")((raise . 0.5) "7"))) ; +7 with 7 raised
 171         ;(((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (rows((raise . 0.5) "7(")
 172         ;       ((raise . 0.3)(music (named ("accidentals-1"))))
 173         ;       ((raise . 0.5) "5)"))); 7(#5)
 174         ; dominant flat 5 = 7(b5)
 175         (((0 . 0) (2 . 0) (4 . -1) (6 . -1)) . (rows((raise . 0.5) "7(")
 176                 ((raise . 0.3)(music (named ("accidentals--1"))))
 177                 ((raise . 0.5) "5)")))
 178         ; dominant 9 = 7(9)
 179         (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0)) . (((raise . 0.8)"7(9)")))
 180         ; dominant flat 9 = 7(b9)
 181         (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1)) . (
 182                 ((raise . 0.8)"7(")
 183                 ((raise . 0.3)(music (named ("accidentals--1"))))
 184                 ((raise . 0.8)"9)")))
 185         ; dominant sharp 9 = 7(#9)
 186         (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1)) . (
 187                 ((raise . 0.8)"7(")
 188                 ((raise . 0.3)(music (named ("accidentals-1"))))
 189                 ((raise . 0.8)"9)")))
 190         ; dominant 13 = 7(13)
 191         (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (5 . 0)) . (((raise . 0.8)"7(13)")))
 192         ; dominant flat 13 = 7(b13)
 193         (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (5 . -1)) . (
 194                 ((raise . 0.8)"7(")
 195                 ((raise . 0.3)(music (named ("accidentals--1"))))
 196                 ((raise . 0.8)"13)")))
 197         ; dominant 9, 13 = 7(9,13)
 198         (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0) (5 . 0)) . (((raise . 0.8)"7(9, 13)")))
 199         ; dominant flat 9, 13 = 7(b9,13)
 200         (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1) (5 . 0)) . (
 201                 ((raise . 0.8)"7(")
 202                 ((raise . 0.3)(music (named ("accidentals--1"))))
 203                 ((raise . 0.8)"9, 13)")))
 204         ; dominant sharp 9, 13 = 7(#9,13)
 205         (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1) (5 . 0)) . (
 206                 ((raise . 0.8)"7(")
 207                 ((raise . 0.3)(music (named ("accidentals-1"))))
 208                 ((raise . 0.8)"9, 13)")))
 209         ; dominant 9, flat 13 = 7(9,b13)
 210         (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0) (5 . -1)) . (
 211                 ((raise . 0.8)"7(9, ")
 212                 ((raise . 0.3)(music (named ("accidentals--1"))))
 213                 ((raise . 0.8)"13)")))
 214         ; dominant flat 9, flat 13 = 7(b9,b13)
 215         (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1) (5 . -1)) . (
 216                 ((raise . 0.8)"7(")
 217                 ((raise . 0.3)(music (named ("accidentals--1"))))
 218                 ((raise . 0.8)"9, ")
 219                 ((raise . 0.3)(music (named ("accidentals--1"))))
 220                 ((raise . 0.8)"13)")))
 221         ; dominant sharp 9, flat 13 = 7(#9,b13)
 222         (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1) (5 . -1)) . (
 223                 ((raise . 0.8)"7(")
 224                 ((raise . 0.3)(music (named ("accidentals-1"))))
 225                 ((raise . 0.8)"9, ")
 226                 ((raise . 0.3)(music (named ("accidentals--1"))))
 227                 ((raise . 0.8)"13)")))
 228
 229         ;; diminished chord(s)
 230         ; diminished seventh chord =  o
 231
 232
 233         ;; DONT use non-ascii characters, even if ``it works'' in Windows
 234
 235         ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ((raise . 0.8) (size . -2) ("o")))
 236         (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ("" (super "o")))
 237
 238         ;; half diminshed chords
 239         ;; half diminished seventh chord = slashed o
 240         ;; (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (((raise . 0.8) "/o")))
 241         (((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
 242
 243         ; half diminished seventh chord  with major 9 = slashed o cancelation 9
 244         (((0 . 0) (2 . -1) (4 . -1) (6 . -1) (1 . 0)) . (
 245                 ((raise . 0.8)"/o(")
 246                 ((raise . 0.3)(music (named ("accidentals-0"))))
 247                 ((raise . 0.8)"9)")));
 248
 249 ;; Missing jazz chord definitions go here (note new syntax: see american for hints)
 250
 251         )
 252       chord::names-alist-american))
 253
 254 ;;;;;;;;;;
 255
 256
 257 (define (pitch->note-name pitch)
 258   (cons (cadr pitch) (caddr pitch)))
 259
 260
 261 (define (accidental->text acc)
 262     (if (= acc 0)
 263       '()
 264       (list
 265        (append '(music)
 266                (list
 267                 (append '(named)
 268                         (list
 269                           (append '((font-relative-size . -2))
 270                                 (list (append '((raise . 0.6))
 271                                   (list
 272                                    (string-append "accidentals-"
 273                                                  (number->string acc))))))))))))
 274 )
 275
 276 (define (pitch->text pitch)
 277   (cons
 278     (make-string 1 (integer->char (+ (modulo (+ (cadr pitch) 2) 7) 65)))
 279     (accidental->text (caddr pitch))
 280   )
 281 )
 282
 283 ;;; Hooks to override chord names and note names,
 284 ;;; see input/tricks/german-chords.ly
 285
 286 (define (pitch->text-banter pitch)
 287   (pitch->text pitch))
 288
 289 (define (pitch->chord-name-text-banter pitch)
 290   (pitch->text-banter pitch))
 291
 292 (define (pitch->note-name-text-banter pitch)
 293   (pitch->text-banter pitch))
 294
 295 (define (step->text pitch)
 296   (string-append
 297     (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))
 298     (case (caddr pitch)
 299       ((-2) "--")
 300       ((-1) "-")
 301       ((0) "")
 302       ((1) "+")
 303       ((2) "++"))))
 304
 305 (define (step->text-banter pitch)
 306   (if (= (cadr pitch) 6)
 307       (case (caddr pitch)
 308         ((-2) "7-")
 309         ((-1) "7")
 310         ((0) "maj7")
 311         ((1) "7+")
 312         ((2) "7+"))
 313       (step->text pitch)))
 314
 315 (define pitch::semitone-vec (list->vector '(0 2 4 5 7 9 11)))
 316
 317 (define (pitch::semitone pitch)
 318   (+ (* (car pitch) 12)
 319      (vector-ref pitch::semitone-vec (modulo (cadr pitch) 7))
 320      (caddr pitch)))
 321
 322 (define (pitch::transpose pitch delta)
 323   (let ((simple-octave (+ (car pitch) (car delta)))
 324         (simple-notename (+ (cadr pitch) (cadr delta))))
 325     (let ((octave (+ simple-octave (quotient simple-notename 7)))
 326            (notename (modulo simple-notename 7)))
 327       (let ((accidental (- (+ (pitch::semitone pitch) (pitch::semitone delta))
 328                            (pitch::semitone `(,octave ,notename 0)))))
 329         `(,octave ,notename ,accidental)))))
 330
 331 (define (pitch::diff pitch tonic)
 332   (let ((simple-octave (- (car pitch) (car tonic)))
 333         (simple-notename (- (cadr pitch) (cadr tonic))))
 334     (let ((octave (+ simple-octave (quotient simple-notename 7)
 335                      (if (< simple-notename 0) -1 0)))
 336           (notename (modulo simple-notename 7)))
 337       (let ((accidental (- (pitch::semitone pitch)
 338                           (pitch::semitone tonic)
 339                           (pitch::semitone `(,octave ,notename 0)))))
 340         `(,octave ,notename ,accidental)))))
 341
 342 (define (pitch::note-pitch pitch)
 343   (+ (* (car pitch) 7) (cadr pitch)))
 344
 345 (define (chord::step tonic pitch)
 346  (- (pitch::note-pitch pitch) (pitch::note-pitch tonic)))
 347
 348 ;; text: list of word
 349 ;; word: string + optional list of property
 350 ;; property: align, kern, font (?), size
 351
 352 (define chord::minor-major-vec (list->vector '(0 -1 -1 0 -1 -1 0)))
 353
 354 ;; compute the relative-to-tonic pitch that goes with 'step'
 355 (define (chord::step-pitch tonic step)
 356   ;; urg, we only do this for thirds
 357   (if (= (modulo step 2) 0)
 358     '(0 0 0)
 359     (let loop ((i 1) (pitch tonic))
 360       (if (= i step) pitch
 361         (loop (+ i 2)
 362               (pitch::transpose
 363                 pitch `(0 2 ,(vector-ref chord::minor-major-vec
 364                 ;; -1 (step=1 -> vector=0) + 7 = 6
 365                 (modulo (+ i 6) 7)))))))))
 366
 367 ;; find the pitches that are not part of `normal' chord
 368 (define (chord::additions chord-pitches)
 369   (let ((tonic (car chord-pitches)))
 370     ;; walk the chord steps: 1, 3, 5
 371     (let loop ((step 1) (pitches chord-pitches) (additions '()))
 372       (if (pair? pitches)
 373         (let* ((pitch (car pitches))
 374                (p-step (+ (- (pitch::note-pitch pitch)
 375                              (pitch::note-pitch tonic))
 376                           1)))
 377           ;; pitch is an addition if
 378           (if (or
 379                 ;; it comes before this step or
 380                 (< p-step step)
 381                 ;; its step is even or
 382                 (= (modulo p-step 2) 0)
 383                 ;; has same step, but different accidental or
 384                 (and (= p-step step)
 385                      (not (equal? pitch (chord::step-pitch tonic step))))
 386                 ;; is the last of the chord and not one of base thirds
 387                 (and (> p-step  5)
 388                      (= (length pitches) 1)))
 389             (loop step (cdr pitches) (cons pitch additions))
 390           (if (= p-step step)
 391             (loop step (cdr pitches) additions)
 392             (loop (+ step 2) pitches additions))))
 393       (reverse additions)))))
 394
 395 ;; find the pitches that are missing from `normal' chord
 396 (define (chord::subtractions chord-pitches)
 397   (let ((tonic (car chord-pitches)))
 398     (let loop ((step 1) (pitches chord-pitches) (subtractions '()))
 399       (if (pair? pitches)
 400         (let* ((pitch (car pitches))
 401                (p-step (+ (- (pitch::note-pitch pitch)
 402                              (pitch::note-pitch tonic))
 403                           1)))
 404           ;; pitch is an subtraction if
 405           ;; a step is missing or
 406           (if (> p-step step)
 407             (loop (+ step 2) pitches
 408                 (cons (chord::step-pitch tonic step) subtractions))
 409           ;; there are no pitches left, but base thirds are not yet done and
 410           (if (and (<= step 5)
 411                    (= (length pitches) 1))
 412             ;; present pitch is not missing step
 413             (if (= p-step step)
 414               (loop (+ step 2) pitches subtractions)
 415               (loop (+ step 2) pitches
 416                     (cons (chord::step-pitch tonic step) subtractions)))
 417             (if (= p-step step)
 418               (loop (+ step 2) (cdr pitches) subtractions)
 419               (loop step (cdr pitches) subtractions)))))
 420         (reverse subtractions)))))
 421
 422 ;; combine tonic, user-specified chordname,
 423 ;; additions, subtractions and base or inversion to chord name
 424 ;;
 425 (define (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)
 426   (apply append
 427          '(rows)
 428          (pitch->chord-name-text-banter tonic)
 429          (if user-name user-name '())
 430          ;; why does list->string not work, format seems only hope...
 431          (if (and (string-match "super" (format "~s" user-name))
 432                   (or (pair? additions)
 433                       (pair? subtractions)))
 434              '((super "/"))
 435              '())
 436          (let loop ((from additions) (to '()))
 437            (if (pair? from)
 438                (let ((p (car from)))
 439                  (loop (cdr from)
 440                        (append to
 441                                (cons
 442                                 (list 'super (step->text-banter p))
 443                                 (if (or (pair? (cdr from))
 444                                         (pair? subtractions))
 445                                     '((super "/"))
 446                                     '())))))
 447                to))
 448          (let loop ((from subtractions) (to '()))
 449            (if (pair? from)
 450                  (let ((p (car from)))
 451                    (loop (cdr from)
 452                          (append to
 453                                  (cons '(super "no")
 454                                        (cons
 455                                         (list 'super (step->text-banter p))
 456                                         (if (pair? (cdr from))
 457                                             '((super "/"))
 458                                             '())))))) ; nesting?
 459                  to))
 460          (if (and (pair? base-and-inversion)
 461                   (or (car base-and-inversion)
 462                       (cdr base-and-inversion)))
 463              (cons "/" (append
 464                         (if (car base-and-inversion)
 465                             (pitch->note-name-text-banter
 466                              (car base-and-inversion))
 467                             (pitch->note-name-text-banter
 468                              (cdr base-and-inversion)))
 469                         '()))
 470              '())
 471          '()))
 472
 473 (define (chord::name-banter tonic user-name pitches base-and-inversion)
 474   (let ((additions (chord::additions pitches))
 475         (subtractions (chord::subtractions pitches)))
 476     (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)))
 477
 478 ;; american chordnames use no "no",
 479 ;; but otherwise very similar to banter for now
 480 (define (chord::name-american tonic user-name pitches base-and-inversion)
 481   (let ((additions (chord::additions pitches))
 482         (subtractions #f))
 483     (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)))
 484
 485 ;; Jazz style--basically similar to american with minor changes
 486 (define (chord::name-jazz tonic user-name pitches base-and-inversion)
 487   (let ((additions (chord::additions pitches))
 488         (subtractions #f))
 489     (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)))
 490
 491 (define (new-to-old-pitch p)
 492   (if (pitch? p)
 493       (list (pitch-octave p) (pitch-notename p) (pitch-alteration p))
 494       #f
 495   ))
 496
 497
 498
 499 ;; C++ entry point
 500 ;;
 501 ;; Check for each subset of chord, full chord first, if there's a
 502 ;; user-override.  Split the chord into user-overridden and to-be-done
 503 ;; parts, complete the missing user-override matched part with normal
 504 ;; chord to be name-calculated.
 505 ;;
 506 ;; CHORD: (pitches (base . inversion))
 507 (define (default-chord-name-function style chord)
 508   (let* ((style-string (symbol->string style))
 509          (pitches (map new-to-old-pitch (car chord)))
 510          (modifiers (cdr chord))
 511          (base-and-inversion (if (pair? modifiers)
 512                                  (cons (new-to-old-pitch (car modifiers))
 513                                        (new-to-old-pitch (cdr modifiers)))
 514                                  '(() . ())))
 515          (diff (pitch::diff '(0 0 0) (car pitches)))
 516          (name-func
 517           (ly-eval (string->symbol (string-append "chord::name-" style-string))))
 518          (names-alist
 519           (ly-eval (string->symbol (string-append "chord::names-alist-" style-string)))))
 520   (let loop ((note-names (reverse pitches))
 521              (chord '())
 522              (user-name #f))
 523     (if (pair? note-names)
 524       (let ((entry (assoc
 525                      (reverse
 526                        (map (lambda (x)
 527                               (pitch->note-name (pitch::transpose x diff)))
 528                             note-names))
 529                      names-alist)))
 530         (if entry
 531           ;; urg? found: break loop
 532           (loop '() chord (cdr entry))
 533           (loop (cdr note-names) (cons (car note-names) chord) #f)))
 534       (let* ((transposed (if pitches
 535                            (map (lambda (x) (pitch::transpose x diff)) chord)
 536                            '()))
 537              (matched (if (= (length chord) 0)
 538                           3
 539                           (- (length pitches) (length chord))))
 540              (completed
 541               (append (do ((i matched (- i 1))
 542                            (base '() (cons `(0 ,(* (- i 1) 2) 0) base)))
 543                            ((= i 0) base)
 544                            ())
 545                   transposed)))
 546       (name-func (car pitches) user-name completed base-and-inversion))))))
 547
 548