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