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