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