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