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