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