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 Jan Nieuwenhuizen <janneke@gnu.org>
   7 ;;;
   8
   9
  10 (use-modules
  11    (ice-9 debug)
  12    ;; urg, these two only to guess if a '/' is needed to separate
  13    ;; user-chord-name and additions/subtractions
  14    (ice-9 format)
  15    (ice-9 regex)
  16    )
  17
  18 ;;
  19 ;; (octave notename accidental)
  20 ;;
  21
  22 ;;
  23 ;; text: scm markup text -- see font.scm and input/test/markup.ly
  24 ;;
  25
  26 ;; TODO
  27 ;;
  28 ;; * clean split of base/banter/american stuff
  29 ;; * text definition is rather ad-hoc
  30 ;; * do without format module
  31 ;; * finish and check american names
  32 ;; * make notename (tonic) configurable from lilypond
  33 ;; * fix append/cons stuff in inner-name-banter
  34 ;; * doc strings.
  35
  36 ;;;;;;;;;
  37 (define chord::names-alist-banter '())
  38 (set! chord::names-alist-banter
  39       (append
  40         '(
  41         ; C iso C.no3.no5
  42         (((0 . 0)) . #f)
  43         ; C iso C.no5
  44         (((0 . 0) (2 . 0)) . #f)
  45         ; Cm iso Cm.no5
  46         (((0 . 0) (2 . -1)) . ("m"))
  47         ; C2 iso C2.no3
  48         (((0 . 0) (1 . 0) (4 . 0)) . (super "2"))
  49         ; C4 iso C4.no3
  50         (((0 . 0) (3 . 0) (4 . 0)) . (super "4"))
  51         ; Cdim iso Cm5-
  52         (((0 . 0) (2 . -1) (4 . -1)) . ("dim"))
  53         ; Co iso Cm5-7-
  54         ; urg
  55         (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (super "o"))
  56         ; Cdim9
  57         (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1)) . ("dim" (super "9")))
  58         (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1) (3 . -1)) . ("dim" (super "11")))
  59         )
  60       chord::names-alist-banter))
  61
  62
  63 ;; NOTE: Duplicates of chord names defined elsewhere occur in this list
  64 ;; in order to prevent spurious superscripting of various chord names,
  65 ;; such as maj7, maj9, etc.
  66 ;;
  67 ;; See input/test/american-chords.ly
  68 ;;
  69 ;; James Hammons, <jlhamm@pacificnet.net>
  70 ;;
  71
  72 ;; DONT use non-ascii characters, even if ``it works'' in Windows
  73
  74 (define chord::names-alist-american '())
  75
  76 (set! chord::names-alist-american
  77       (append
  78        '(
  79          (((0 . 0)) . #f)
  80          (((0 . 0) (2 . 0)) . #f)
  81          ;; Root-fifth chord
  82          (((0 . 0) (4 . 0)) . ("5"))
  83          ;; Common triads
  84          (((0 . 0) (2 . -1)) . ("m"))
  85          (((0 . 0) (3 . 0) (4 . 0)) . ("sus"))
  86          (((0 . 0) (2 . -1) (4 . -1)) . ("dim"))
  87 ;Alternate:      (((0 . 0) (2 . -1) (4 . -1)) . ((super "o")))
  88          (((0 . 0) (2 . 0) (4 . 1)) . ("aug"))
  89 ;Alternate:      (((0 . 0) (2 . 0) (4 . 1)) . ("+"))
  90          (((0 . 0) (1 . 0) (4 . 0)) . ("2"))
  91          ;; Common seventh chords
  92          (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (rows (super "o") "7"))
  93          (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . ("maj7"))
  94          (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . ("m7"))
  95          (((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . ("7"))
  96          (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . ("m(maj7)"))
  97          ;jazz: the delta, see jazz-chords.ly
  98          ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) .  (super ((font-family . math) "N"))
  99          ;; ugh, kludge slashed o
 100          (((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
 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)"o"))); works, but "o" is a little big
 236         (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ((raise . 0.8) (size . -2) ("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         ; half diminished seventh chord  with major 9 = slashed o cancelation 9
 242         (((0 . 0) (2 . -1) (4 . -1) (6 . -1) (1 . 0)) . (
 243                 ((raise . 0.8)"/o(")
 244                 ((raise . 0.3)(music (named ("accidentals-0"))))
 245                 ((raise . 0.8)"9)")));
 246
 247 ;; Missing jazz chord definitions go here (note new syntax: see american for hints)
 248
 249         )
 250       chord::names-alist-american))
 251
 252 ;;;;;;;;;;
 253
 254
 255 (define (pitch->note-name pitch)
 256   (cons (cadr pitch) (caddr pitch)))
 257
 258 (define (pitch->text pitch)
 259   (cons
 260     (make-string 1 (integer->char (+ (modulo (+ (cadr pitch) 2) 7) 65)))
 261     (if (= (caddr pitch) 0)
 262       '()
 263       (list
 264        (append '(music)
 265                (list
 266                 (append '(named)
 267                         (list
 268                           (append '((font-relative-size . -2))
 269                                 (list (append '((raise . 0.6))
 270                                   (list
 271                                    (string-append "accidentals-"
 272                                                   (number->string (caddr pitch)))))))))))))))
 273
 274 ;;; Hooks to override chord names and note names,
 275 ;;; see input/tricks/german-chords.ly
 276
 277 (define (pitch->text-banter pitch)
 278   (pitch->text pitch))
 279
 280 (define (pitch->chord-name-text-banter pitch)
 281   (pitch->text-banter))
 282
 283 (define (pitch->note-name-text-banter pitch)
 284   (pitch->text-banter))
 285
 286 (define (step->text pitch)
 287   (string-append
 288     (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))
 289     (case (caddr pitch)
 290       ((-2) "--")
 291       ((-1) "-")
 292       ((0) "")
 293       ((1) "+")
 294       ((2) "++"))))
 295
 296 (define (step->text-banter pitch)
 297   (if (= (cadr pitch) 6)
 298       (case (caddr pitch)
 299         ((-2) "7-")
 300         ((-1) "7")
 301         ((0) "maj7")
 302         ((1) "7+")
 303         ((2) "7+"))
 304       (step->text pitch)))
 305
 306 (define pitch::semitone-vec (list->vector '(0 2 4 5 7 9 11)))
 307
 308 (define (pitch::semitone pitch)
 309   (+ (* (car pitch) 12)
 310      (vector-ref pitch::semitone-vec (modulo (cadr pitch) 7))
 311      (caddr pitch)))
 312
 313 (define (pitch::transpose pitch delta)
 314   (let ((simple-octave (+ (car pitch) (car delta)))
 315         (simple-notename (+ (cadr pitch) (cadr delta))))
 316     (let ((octave (+ simple-octave (quotient simple-notename 7)))
 317            (notename (modulo simple-notename 7)))
 318       (let ((accidental (- (+ (pitch::semitone pitch) (pitch::semitone delta))
 319                            (pitch::semitone `(,octave ,notename 0)))))
 320         `(,octave ,notename ,accidental)))))
 321
 322 (define (pitch::diff pitch tonic)
 323   (let ((simple-octave (- (car pitch) (car tonic)))
 324         (simple-notename (- (cadr pitch) (cadr tonic))))
 325     (let ((octave (+ simple-octave (quotient simple-notename 7)
 326                      (if (< simple-notename 0) -1 0)))
 327           (notename (modulo simple-notename 7)))
 328       (let ((accidental (- (pitch::semitone pitch)
 329                           (pitch::semitone tonic)
 330                           (pitch::semitone `(,octave ,notename 0)))))
 331         `(,octave ,notename ,accidental)))))
 332
 333 (define (pitch::note-pitch pitch)
 334   (+ (* (car pitch) 7) (cadr pitch)))
 335
 336 (define (chord::step tonic pitch)
 337  (- (pitch::note-pitch pitch) (pitch::note-pitch tonic)))
 338
 339 ;; text: list of word
 340 ;; word: string + optional list of property
 341 ;; property: align, kern, font (?), size
 342
 343 (define chord::minor-major-vec (list->vector '(0 -1 -1 0 -1 -1 0)))
 344
 345 ;; compute the relative-to-tonic pitch that goes with 'step'
 346 (define (chord::step-pitch tonic step)
 347   ;; urg, we only do this for thirds
 348   (if (= (modulo step 2) 0)
 349     '(0 0 0)
 350     (let loop ((i 1) (pitch tonic))
 351       (if (= i step) pitch
 352         (loop (+ i 2)
 353               (pitch::transpose
 354                 pitch `(0 2 ,(vector-ref chord::minor-major-vec
 355                 ;; -1 (step=1 -> vector=0) + 7 = 6
 356                 (modulo (+ i 6) 7)))))))))
 357
 358 ;; find the pitches that are not part of `normal' chord
 359 (define (chord::additions chord-pitches)
 360   (let ((tonic (car chord-pitches)))
 361     ;; walk the chord steps: 1, 3, 5
 362     (let loop ((step 1) (pitches chord-pitches) (additions '()))
 363       (if (pair? pitches)
 364         (let* ((pitch (car pitches))
 365                (p-step (+ (- (pitch::note-pitch pitch)
 366                              (pitch::note-pitch tonic))
 367                           1)))
 368           ;; pitch is an addition if
 369           (if (or
 370                 ;; it comes before this step or
 371                 (< p-step step)
 372                 ;; its step is even or
 373                 (= (modulo p-step 2) 0)
 374                 ;; has same step, but different accidental or
 375                 (and (= p-step step)
 376                      (not (equal? pitch (chord::step-pitch tonic step))))
 377                 ;; is the last of the chord and not one of base thirds
 378                 (and (> p-step  5)
 379                      (= (length pitches) 1)))
 380             (loop step (cdr pitches) (cons pitch additions))
 381           (if (= p-step step)
 382             (loop step (cdr pitches) additions)
 383             (loop (+ step 2) pitches additions))))
 384       (reverse additions)))))
 385
 386 ;; find the pitches that are missing from `normal' chord
 387 (define (chord::subtractions chord-pitches)
 388   (let ((tonic (car chord-pitches)))
 389     (let loop ((step 1) (pitches chord-pitches) (subtractions '()))
 390       (if (pair? pitches)
 391         (let* ((pitch (car pitches))
 392                (p-step (+ (- (pitch::note-pitch pitch)
 393                              (pitch::note-pitch tonic))
 394                           1)))
 395           ;; pitch is an subtraction if
 396           ;; a step is missing or
 397           (if (> p-step step)
 398             (loop (+ step 2) pitches
 399                 (cons (chord::step-pitch tonic step) subtractions))
 400           ;; there are no pitches left, but base thirds are not yet done and
 401           (if (and (<= step 5)
 402                    (= (length pitches) 1))
 403             ;; present pitch is not missing step
 404             (if (= p-step step)
 405               (loop (+ step 2) pitches subtractions)
 406               (loop (+ step 2) pitches
 407                     (cons (chord::step-pitch tonic step) subtractions)))
 408             (if (= p-step step)
 409               (loop (+ step 2) (cdr pitches) subtractions)
 410               (loop step (cdr pitches) subtractions)))))
 411         (reverse subtractions)))))
 412
 413 ;; combine tonic, user-specified chordname,
 414 ;; additions, subtractions and base or inversion to chord name
 415 ;;
 416 (define (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)
 417   (apply append
 418          '(rows)
 419          (pitch->chord-name-text-banter tonic)
 420          (if user-name user-name '())
 421          ;; why does list->string not work, format seems only hope...
 422          (if (and (string-match "super" (format "~s" user-name))
 423                   (or (pair? additions)
 424                       (pair? subtractions)))
 425              '((super "/"))
 426              '())
 427          (let loop ((from additions) (to '()))
 428            (if (pair? from)
 429                (let ((p (car from)))
 430                  (loop (cdr from)
 431                        (append to
 432                                (cons
 433                                 (list 'super (step->text-banter p))
 434                                 (if (or (pair? (cdr from))
 435                                         (pair? subtractions))
 436                                     '((super "/"))
 437                                     '())))))
 438                to))
 439          (let loop ((from subtractions) (to '()))
 440            (if (pair? from)
 441                  (let ((p (car from)))
 442                    (loop (cdr from)
 443                          (append to
 444                                  (cons '(super "no")
 445                                        (cons
 446                                         (list 'super (step->text-banter p))
 447                                         (if (pair? (cdr from))
 448                                             '((super "/"))
 449                                             '())))))) ; nesting?
 450                  to))
 451          (if (and (pair? base-and-inversion)
 452                   (or (car base-and-inversion)
 453                       (cdr base-and-inversion)))
 454              (cons "/" (append
 455                         (if (car base-and-inversion)
 456                             (pitch->note-name-text-banter
 457                              (car base-and-inversion))
 458                             (pitch->note-name-text-banter
 459                              (cdr base-and-inversion)))
 460                         '()))
 461              '())
 462          '()))
 463
 464 (define (chord::name-banter tonic user-name pitches base-and-inversion)
 465   (let ((additions (chord::additions pitches))
 466         (subtractions (chord::subtractions pitches)))
 467     (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)))
 468
 469 ;; american chordnames use no "no",
 470 ;; but otherwise very similar to banter for now
 471 (define (chord::name-american tonic user-name pitches base-and-inversion)
 472   (let ((additions (chord::additions pitches))
 473         (subtractions #f))
 474     (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)))
 475
 476 ;; Jazz style--basically similar to american with minor changes
 477 (define (chord::name-jazz tonic user-name pitches base-and-inversion)
 478   (let ((additions (chord::additions pitches))
 479         (subtractions #f))
 480     (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)))
 481
 482 (define (new-to-old-pitch p)
 483   (if (pitch? p)
 484       (list (pitch-octave p) (pitch-notename p) (pitch-alteration p))
 485       #f
 486   ))
 487
 488
 489
 490 ;; C++ entry point
 491 ;;
 492 ;; Check for each subset of chord, full chord first, if there's a
 493 ;; user-override.  Split the chord into user-overridden and to-be-done
 494 ;; parts, complete the missing user-override matched part with normal
 495 ;; chord to be name-calculated.
 496 ;;
 497 ;; CHORD: (pitches (base . inversion))
 498 (define (default-chord-name-function style chord)
 499   (let* ((style-string (symbol->string style))
 500          (pitches (map new-to-old-pitch (car chord)))
 501          (modifiers (cdr chord))
 502          (base-and-inversion (if (pair? modifiers)
 503                                  (cons (new-to-old-pitch (car modifiers))
 504                                        (new-to-old-pitch (cdr modifiers)))
 505                                  '(() . ())))
 506          (diff (pitch::diff '(0 0 0) (car pitches)))
 507          (name-func
 508           (ly-eval (string->symbol (string-append "chord::name-" style-string))))
 509          (names-alist
 510           (ly-eval (string->symbol (string-append "chord::names-alist-" style-string)))))
 511   (let loop ((note-names (reverse pitches))
 512              (chord '())
 513              (user-name #f))
 514     (if (pair? note-names)
 515       (let ((entry (assoc
 516                      (reverse
 517                        (map (lambda (x)
 518                               (pitch->note-name (pitch::transpose x diff)))
 519                             note-names))
 520                      names-alist)))
 521         (if entry
 522           ;; urg? found: break loop
 523           (loop '() chord (cdr entry))
 524           (loop (cdr note-names) (cons (car note-names) chord) #f)))
 525       (let* ((transposed (if pitches
 526                            (map (lambda (x) (pitch::transpose x diff)) chord)
 527                            '()))
 528              (matched (if (= (length chord) 0)
 529                           3
 530                           (- (length pitches) (length chord))))
 531              (completed
 532               (append (do ((i matched (- i 1))
 533                            (base '() (cons `(0 ,(* (- i 1) 2) 0) base)))
 534                            ((= i 0) base)
 535                            ())
 536                   transposed)))
 537       (name-func (car pitches) user-name completed base-and-inversion))))))
 538
 539