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