scm/chord-name.scm

   1 ;;;
   2 ;;; chord-name.scm -- Compile chord name
   3 ;;;
   4 ;;; source file of the GNU LilyPond music typesetter
   5 ;;;
   6 ;;; (c) 2000--2002 Jan Nieuwenhuizen <janneke@gnu.org>
   7 ;;;
   8
   9
  10 (use-modules
  11    (ice-9 debug)
  12    (ice-9 format)
  13    (ice-9 regex)
  14    (ice-9 string-fun)
  15    )
  16
  17
  18
  19 ;(define (dbg x) (write-me "" x))
  20 (define (dbg x) x)
  21
  22 ;;(define (write-me x) (write x) (newline) x)
  23 ;;(define (write-me-2 x y) (write "FOO") (write x) (write y) (newline) y)
  24
  25
  26 "
  27 TODO:
  28
  29   * Use lilypond Pitch objects -- SCM pitch objects lead to
  30     duplication. LilyPond pitch objects force meaningful names
  31     (i.e. (ly:pitch-octave PITCH) )
  32
  33   * Pitches are musical objects. The pitches -> markup step should
  34 happen earlier (during interpreting), brew-molecule () should only
  35 dump reinterpret the markup as a molecule.
  36
  37   *  chord:: prefix is a poor-man's namespace device.
  38   We have a module system to prevent export to userland.
  39   Nested functions can take care of many other clashes. --hwn.
  40
  41    * easier tweakability:
  42
  43     - split chord::names-alists up into logical bits,
  44       such as chord::exceptions-delta, exceptions-oslash
  45     - iso just the 'style parameter, use a list, eg:
  46       \property ChordNames.ChordName \set
  47         #'style = #'(jazz delta oslash german-tonic german-Bb)
  48
  49  * clean split/merge of bass/banter/american stuff.
  50    GET RID OF code duplication.
  51
  52  * fix FIXMEs
  53
  54  * doc strings
  55
  56 "
  57
  58 ;; " hey Emacs: string has ended
  59
  60
  61 ;; pitch = (octave notename alteration)
  62 ;;
  63 ;; note = (notename . alteration)
  64 ;;
  65 ;; markup = markup text -- see font.scm and input/test/markup.ly
  66
  67
  68 (define-public chord::exception-alist-banter
  69        `(
  70         ; C iso C.no3.no5
  71         (((0 . 0)) . ,empty-markup)
  72         ; C iso C.no5
  73         (((0 . 0) (2 . 0)) . ,empty-markup)
  74         ; Cm iso Cm.no5
  75         (((0 . 0) (2 . -1)) . ,(make-simple-markup "m"))
  76         ; C2 iso C2.no3
  77         (((0 . 0) (1 . 0) (4 . 0))
  78          . ,(make-normal-size-super-markup (make-simple-markup "2 ")))
  79         ; C4 iso C4.no3
  80         (((0 . 0) (3 . 0) (4 . 0))
  81          . ,(make-normal-size-super-markup (make-simple-markup "4 ")))
  82         ;; Cdim iso Cm5-
  83         (((0 . 0) (2 . -1) (4 . -1)) . ,(make-simple-markup "dim"))
  84         ; URG: Simply C:m5-/maj7 iso Cdim maj7
  85         (((0 . 0) (2 . -1) (4 . -1) (6 . 0))
  86          . ,(make-line-markup
  87              (list
  88               (make-simple-markup "m")
  89               (make-normal-size-super-markup (make-simple-markup "5-/maj7 ")))))
  90         ; URG: Simply C:m5-/7 iso Cdim7
  91         (((0 . 0) (2 . -1) (4 . -1) (6 . -1))
  92          . ,(make-line-markup
  93              (list
  94               (make-simple-markup "m")
  95               (make-normal-size-super-markup (make-simple-markup "5-/7 ")))))
  96         ; Co iso C:m5-/7-
  97         (((0 . 0) (2 . -1) (4 . -1) (6 . -2))
  98          . ,(make-super-markup (make-simple-markup "o")))
  99         ; Cdim9
 100         (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1))
 101          . ,(make-line-markup
 102              (list (make-simple-markup "dim")
 103                    (make-normal-size-super-markup (make-simple-markup "9 ")))))
 104         (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1) (3 . -1))
 105          . ,(make-line-markup
 106              (list (make-simple-markup "dim")
 107                                 (make-normal-size-super-markup
 108                                  (make-simple-markup "11 ")))))
 109
 110         ))
 111
 112 ; pitch->note-name: drops octave
 113 (define (pitch->note-name pitch)
 114   (cons (cadr pitch) (caddr pitch)))
 115
 116 (define (old-accidental->markup acc)
 117   "ACC is an int, return a markup making an accidental."
 118   (if (= acc 0)
 119       (make-line-markup (list empty-markup))
 120       (make-smaller-markup (make-musicglyph-markup
 121                             (string-append "accidentals-"
 122                                            (number->string acc))))))
 123
 124
 125 ; unused.
 126
 127 ;; FIXME: possibly to be used for american/jazz style
 128 ;; However, only pos == columns is used, which seems to do
 129 ;; exactly what old-accidental->markup does...
 130 (define (amy-accidental->text acc) (accidental->textp acc 'columns))
 131
 132
 133 ;; These not used
 134 ;;;(define (accidental->text-super acc) (accidental->textp acc 'simple-super))
 135 ;;(define (accidental->text-super acc) (accidental->textp acc 'super))
 136 ;;(define (accidental->text-sub acc) (accidental->textp acc 'sub))
 137
 138
 139 ;;
 140 ;; TODO: invent sensible way to make note name tweaking possible?
 141 ;;
 142 (define (old-pitch->markup pitch)
 143   (make-line-markup
 144    (list
 145     (make-simple-markup
 146      (vector-ref #("C" "D" "E" "F" "G" "A" "B")  (cadr pitch)))
 147     (make-normal-size-super-markup
 148      (old-accidental->markup (caddr pitch))))))
 149
 150 ;;; Hooks to override chord names and note names,
 151 ;;; see input/tricks/german-chords.ly
 152
 153 (define old-pitch->markup-banter old-pitch->markup)
 154
 155 ;; We need also steps, to allow for Cc name override,
 156 ;; see input/test/Cc-chords.ly
 157 (define (pitch->chord-name-markup-banter pitch steps)
 158   (old-pitch->markup-banter pitch))
 159
 160 (define pitch->note-name-markup-banter old-pitch->markup-banter)
 161
 162 (define (step->markup pitch)
 163   (string-append
 164    (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))
 165    (case (caddr pitch)
 166       ((-2) "--")
 167       ((-1) "-")
 168       ((0) "")
 169       ((1) "+")
 170       ((2) "++"))))
 171
 172 (define (step->markup-banter pitch)
 173   (make-simple-markup
 174    (if (= (cadr pitch) 6)
 175        (case (caddr pitch)
 176          ((-2)  "7-")
 177          ((-1) "7")
 178          ((0)  "maj7")
 179          ((1)  "7+")
 180          ((2)  "7+"))
 181        (step->markup pitch))))
 182
 183 (define (step->markup-previously-alternate-jazz pitch)
 184   (make-line-markup
 185    (list
 186     (old-accidental->markup (caddr pitch))
 187     (make-simple-markup
 188      (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))))))
 189
 190 (define (step->markup-previously-jazz pitch)
 191   (if (= (cadr pitch) 6)
 192       (case (caddr pitch)
 193         ;; sharp 7 only included for completeness?
 194         ((-2) (make-line-markup
 195                (list
 196                 (old-accidental->markup  -1)
 197                 (make-simple-markup "7"))))
 198         ((-1) (make-simple-markup "7"))
 199         ((0) (make-simple-markup "maj7"))
 200         ;;((0) (make-line-markup
 201         ;;      (list (make-simple-markup "maj7"))))
 202         ((1) (make-line-markup
 203               (list
 204                (old-accidental->markup 1) (make-simple-markup "7"))))
 205         ((2) (make-line-markup
 206               (list (old-accidental->markup 1)
 207                     (make-simple-markup "7")))))
 208       (step->markup-previously-alternate-jazz pitch)))
 209
 210
 211 (define pitch::semitone-vec #(0 2 4 5 7 9 11))
 212
 213 (define (pitch::semitone pitch)
 214   (+ (* (car pitch) 12)
 215      (vector-ref pitch::semitone-vec (modulo (cadr pitch) 7))
 216      (caddr pitch)))
 217
 218 (define (pitch::< l r)
 219   (< (pitch::semitone l) (pitch::semitone r)))
 220
 221 (define (pitch::transpose pitch delta)
 222   (let ((simple-octave (+ (car pitch) (car delta)))
 223         (simple-notename (+ (cadr pitch) (cadr delta))))
 224     (let ((octave (+ simple-octave (quotient simple-notename 7)))
 225            (notename (modulo simple-notename 7)))
 226       (let ((accidental (- (+ (pitch::semitone pitch) (pitch::semitone delta))
 227                            (pitch::semitone `(,octave ,notename 0)))))
 228         `(,octave ,notename ,accidental)))))
 229
 230 (define (pitch::diff pitch tonic)
 231   (let ((simple-octave (- (car pitch) (car tonic)))
 232         (simple-notename (- (cadr pitch) (cadr tonic))))
 233     (let ((octave (+ simple-octave (quotient simple-notename 7)
 234                      (if (< simple-notename 0) -1 0)))
 235           (notename (modulo simple-notename 7)))
 236       (let ((accidental (- (pitch::semitone pitch)
 237                           (pitch::semitone tonic)
 238                           (pitch::semitone `(,octave ,notename 0)))))
 239         `(,octave ,notename ,accidental)))))
 240
 241 (define (pitch::note-pitch pitch)
 242   (+ (* (car pitch) 7) (cadr pitch)))
 243
 244
 245 ; what's this?
 246 (define chord::minor-major-vec #(0 -1 -1 0 -1 -1 0))
 247
 248 ;; FIXME: unLOOP
 249 ;; compute the relative-to-tonic pitch that goes with 'step'
 250 (define (chord::step-pitch tonic step)
 251   ;; urg, we only do this for thirds
 252   (if (= (modulo step 2) 0)
 253     '(0 0 0)
 254     (let loop ((i 1) (pitch tonic))
 255       (if (= i step) pitch
 256         (loop (+ i 2)
 257               (pitch::transpose
 258                 pitch `(0 2 ,(vector-ref chord::minor-major-vec
 259                 ;; -1 (step=1 -> vector=0) + 7 = 6
 260                 (modulo (+ i 6) 7)))))))))
 261
 262 (define (chord::additions steps)
 263 " Return:
 264    * any even step (2, 4, 6)
 265    * any uneven step that is chromatically altered,
 266      (where 7-- == -1, 7- == 0, 7 == +1)
 267    * highest step
 268
 269 ?and jazz needs also:
 270
 271    * TODO: any uneven step that's lower than an uneven step which is
 272      chromatically altered
 273   "
 274   (let ((evens (filter-list (lambda (x) (!= 0 (modulo (cadr x) 2))) steps))
 275         (altered-unevens
 276          (filter-list (lambda (x)
 277                         (let ((n (cadr x)) (a (caddr x)))
 278                           (or (and (= 6 n) (!= -1 a))
 279                               (and (!= 6 n)
 280                                    (= 0 (modulo n 2))
 281                                    (!= 0 a)))))
 282                       steps))
 283         (highest (let ((h (car (last-pair steps))))
 284                    (if (and (not (null? h))
 285                             (or (> 4 (cadr h))
 286                                 (!= 0 (caddr h))))
 287                        (list (list h))
 288                        '()))))
 289     ;; Hmm, what if we have a step twice, can we ignore that?
 290     (uniq-list (sort (apply append evens altered-unevens highest)
 291                      pitch::<))))
 292
 293
 294 ;; FIXME: unLOOP, see ::additions
 295 ;; find the pitches that are missing from `normal' chord
 296 (define (chord::subtractions chord-pitches)
 297   (let ((tonic (car chord-pitches)))
 298     (let loop ((step 1) (pitches chord-pitches) (subtractions '()))
 299       (if (pair? pitches)
 300         (let* ((pitch (car pitches))
 301                (p-step (+ (- (pitch::note-pitch pitch)
 302                              (pitch::note-pitch tonic))
 303                           1)))
 304           ;; pitch is an subtraction if
 305           ;; a step is missing or
 306           (if (> p-step step)
 307             (loop (+ step 2) pitches
 308                 (cons (chord::step-pitch tonic step) subtractions))
 309           ;; there are no pitches left, but base thirds are not yet done and
 310           (if (and (<= step 5)
 311                    (= (length pitches) 1))
 312             ;; present pitch is not missing step
 313             (if (= p-step step)
 314               (loop (+ step 2) pitches subtractions)
 315               (loop (+ step 2) pitches
 316                     (cons (chord::step-pitch tonic step) subtractions)))
 317             (if (= p-step step)
 318               (loop (+ step 2) (cdr pitches) subtractions)
 319               (loop step (cdr pitches) subtractions)))))
 320         (reverse subtractions)))))
 321
 322 (define (chord::additions->markup-banter additions subtractions)
 323   (if (pair? additions)
 324       (make-line-markup
 325        (list
 326         (let ((step (step->markup-banter (car additions))))
 327           (if (or (pair? (cdr additions))
 328                   (pair? subtractions))
 329               (make-line-markup
 330                (list step (make-simple-markup "/")))
 331               step))
 332         (chord::additions->markup-banter (cdr additions) subtractions)))
 333       empty-markup))
 334
 335 (define (chord::subtractions->markup-banter subtractions)
 336   (if (pair? subtractions)
 337       (make-line-markup
 338        (list
 339         (make-simple-markup "no")
 340         (let ((step (step->markup-previously-jazz
 341                      (car subtractions))))
 342           (if (pair? (cdr subtractions))
 343               (make-line-markup
 344                (list step (make-simple-markup "/")))
 345               step))
 346         (chord::subtractions->markup-banter (cdr subtractions))))
 347       empty-markup))
 348
 349 (define (chord::bass-and-inversion->markup-banter bass-and-inversion)
 350   (if (and (pair? bass-and-inversion)
 351            (or (car bass-and-inversion)
 352                (cdr bass-and-inversion)))
 353       (make-line-markup
 354        (list
 355         (make-simple-markup "/")
 356         (pitch->note-name-markup-banter
 357          (if (car bass-and-inversion)
 358              (car bass-and-inversion)
 359              (cdr bass-and-inversion)))))
 360       empty-markup))
 361
 362 ;; FIXME: merge this function with inner-name-jazz, -american
 363 ;;        iso using chord::bass-and-inversion->markup-banter,
 364 ;;        See: chord::exceptions-lookup
 365 (define (chord::inner-name-banter tonic exception-part additions subtractions
 366                                   bass-and-inversion steps)
 367   "
 368
 369  Banter style
 370  Combine tonic, exception-part of chord name,
 371  additions, subtractions and bass or inversion into chord name
 372
 373 "
 374   (let* ((tonic-markup (pitch->chord-name-markup-banter tonic steps))
 375          (except-markup (if exception-part exception-part empty-markup))
 376          ;; UGR.  How do we know if we should add a separator or not?
 377          ;; maybe just add extra column to exception list?
 378          (sep-markup (if (and exception-part
 379                               (let ((s (format "~s" except-markup)))
 380                                 (and
 381                                  (string-match "super" s)
 382                                  ;; ugh ugh
 383                                  ;; python: `except_markup`[-5:] != '"o"))'
 384                                  (not (equal?
 385                                        "\"o\"))"
 386                                        (substring s
 387                                                   (- (string-length s) 5))))))
 388                               (or (pair? additions)
 389                                   (pair? subtractions)))
 390                          (make-super-markup (make-simple-markup "/"))
 391                          empty-markup))
 392          (adds-markup (chord::additions->markup-banter additions subtractions))
 393          (subs-markup (chord::subtractions->markup-banter subtractions))
 394          (b+i-markup (chord::bass-and-inversion->markup-banter
 395                       bass-and-inversion)))
 396
 397     (make-line-markup
 398      (list
 399       tonic-markup
 400       except-markup
 401       sep-markup
 402       (make-normal-size-super-markup
 403        (make-line-markup (list adds-markup subs-markup)))
 404       b+i-markup))))
 405
 406 (define (c++-pitch->scm p)
 407   (if (ly:pitch? p)
 408       (list (ly:pitch-octave p) (ly:pitch-notename p) (ly:pitch-alteration p))
 409       #f))
 410
 411 (define (chord::name-banter tonic exception-part unmatched-steps
 412                             bass-and-inversion steps)
 413   (let ((additions (chord::additions unmatched-steps))
 414         (subtractions (chord::subtractions unmatched-steps)))
 415
 416     (chord::inner-name-banter tonic exception-part additions subtractions
 417                               bass-and-inversion steps)))
 418
 419
 420 ;; see above.
 421 (define (chord::exceptions-lookup exceptions steps)
 422   "
 423    return (MATCHED-EXCEPTION . BASE-CHORD-WITH-UNMATCHED-STEPS)
 424    BASE-CHORD-WITH-UNMATCHED-STEPS always includes (tonic 3 5)
 425
 426 "
 427   ;; this is unintelligible.
 428   ;;
 429   (define (chord::exceptions-lookup-helper
 430            exception-alist try-steps unmatched-steps exception-part)
 431     "
 432
 433  check exception-alist for biggest matching part of try-steps
 434  return (MATCHED-EXCEPTION . UNMATCHED-STEPS)
 435
 436 "
 437     (if (pair? try-steps)
 438         ;; FIXME: junk '(0 . 0) from exceptions lists?
 439         ;;        if so: how to handle first '((0 . 0) . #f) entry?
 440         ;;
 441         ;; FIXME: either format exceptions list as real pitches, ie,
 442         ;;        including octave '((0 2 -1) ..), or drop octave
 443         ;;        from rest of calculations,
 444         (let ((entry (assoc
 445                       (map (lambda (x) (pitch->note-name x))
 446                            (append '((0 0 0)) try-steps))
 447                       exception-alist)))
 448           (if entry
 449               (chord::exceptions-lookup-helper
 450                #f '() unmatched-steps (cdr entry))
 451               (let ((r (reverse try-steps)))
 452                 (chord::exceptions-lookup-helper
 453                  exception-alist
 454                  (reverse (cdr r))
 455                  (cons (car r) unmatched-steps) #f))))
 456         (cons exception-part unmatched-steps)))
 457
 458   (let* ((result (chord::exceptions-lookup-helper
 459                   exceptions
 460                   steps '() #f))
 461            (exception-part (car result))
 462            (unmatched-steps (cdr result))
 463            (matched-steps (if (= (length unmatched-steps) 0)
 464                               3
 465                               (+ 1 (- (length steps)
 466                                       (length unmatched-steps)))))
 467            (unmatched-with-1-3-5
 468             (append (do ((i matched-steps (- i 1))
 469                          (base '() (cons `(0 ,(* (- i 1) 2) 0) base)))
 470                         ((= i 0) base)
 471                       ())
 472                     unmatched-steps)))
 473     (list exception-part unmatched-with-1-3-5)))
 474
 475
 476
 477 ;;; American style
 478 ;;;
 479
 480 ;; See input/test/american-chords.ly
 481 ;;
 482 ;; Original Version by James Hammons, <jlhamm@pacificnet.net>
 483 ;; Complete rewrite by Amelie Zapf, <amy@loueymoss.com>
 484
 485 ;; DONT use non-ascii characters, even if ``it works'' in Windows
 486
 487 ;;a white triangle
 488 (define mathm-markup-object
 489   (make-override-markup '(font-family . math) (make-simple-markup "M")))
 490
 491 ;a black triangle
 492 (define mathn-markup-object
 493   (make-override-markup '(font-family . math) (make-simple-markup "N")))
 494
 495 (define (step->markup-accidental pitch)
 496   (make-line-markup
 497    (list
 498     (case (caddr pitch)
 499       ((-2) (old-accidental->markup -2))
 500       ((-1) (old-accidental->markup -1))
 501       ((0) empty-markup)
 502       ((1) (old-accidental->markup 1))
 503       ((2) (old-accidental->markup 2)))
 504     (make-simple-markup (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))))))
 505
 506 (define-public chord::exception-alist-american
 507   `(
 508     (((0 . 0)) . ,empty-markup)
 509     (((0 . 0) (2 . -1)) . ,(make-simple-markup "m"))
 510
 511     ;; these should probably be normal-size?  --jcn
 512     ;;(((0 . 0) (4 . 0)) . ,(make-super-markup (make-simple-markup "5 ")))
 513     ;;(((0 . 0) (1 . 0) (4 . 0)) . ,(make-super-markup (make-simple-markup "2 ")))
 514
 515     (((0 . 0) (4 . 0)) . ,(make-normal-size-super-markup (make-simple-markup "5 ")))
 516     (((0 . 0) (1 . 0) (4 . 0)) . ,(make-normal-size-super-markup (make-simple-markup "2 ")))
 517
 518     ;;choose your symbol for the fully diminished chord
 519     (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ,(make-simple-markup "dim"))
 520     ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ,(make-line-markup (list empty-markup (make-super-markup (make-simple-markup "o")))))
 521     ))
 522
 523 (define (step->markup-american pitch)
 524   (case (cadr pitch)
 525     ((6) (case (caddr pitch)
 526            ((-2) (make-line-markup (list (old-accidental->markup -1) (make-simple-markup "7"))))
 527            ((-1) (make-simple-markup "7"))
 528            ((0) (make-simple-markup "maj7"))
 529            ((1) (make-line-markup (list (old-accidental->markup 1) (make-simple-markup "7"))))
 530            ((2) (make-line-markup (list (old-accidental->markup 2) (make-simple-markup "7"))))))
 531     ((4) (case (caddr pitch)
 532            ((-2) (make-line-markup (list (old-accidental->markup -2) (make-simple-markup "5"))))
 533            ;;choose your symbol for the diminished fifth
 534            ((-1) (make-simple-markup "-5"))
 535            ;;((-1) (make-line-markup (list (old-accidental->markup -1) (make-simple-markup "5")))))
 536            ((0) empty-markup)
 537            ;;choose your symbol for the augmented fifth
 538            ;;((1) (make-simple-markup "aug"))
 539            ;;((1) (make-line-markup (list (old-accidental->markup 1) (make-simple-markup "5")))))
 540            ((1) (make-simple-markup "+5"))
 541            ((2) (make-line-markup (list (old-accidental->markup 2) (make-simple-markup "5"))))))
 542     (else (if (and (= (car pitch) 0)
 543                    (= (cadr pitch) 3)
 544                    (= (caddr pitch) 0))
 545               (make-simple-markup "sus4")
 546               (step->markup-accidental pitch)))))
 547
 548 (define (chord::additions->markup-american additions subtractions)
 549   (if (pair? additions)
 550       ;; I don't like all this reasoning here, when we're actually typesetting.
 551       (if(and(pair? (cdr additions)) ;a further addition left over
 552              (or(and(= 0 (caddr(car additions))) ;this addition natural
 553                     (not(= 6 (cadr(car additions)))))
 554                 (and(= -1 (caddr(car additions)))
 555                     (= 6 (cadr(car additions)))))
 556              (or(and(= 0 (caddr(cadr additions))) ;the following addition natural
 557                     (not(= 6 (cadr(cadr additions)))))
 558                 (and(= -1 (caddr(cadr additions)))
 559                     (= 6 (cadr(cadr additions)))))
 560              (or(and(= (car(car additions)) (car(cadr additions))) ;both a third apart
 561                     (= 2 (- (cadr(cadr additions)) (cadr(car additions)))))
 562                 (and(= 1 (- (car(cadr additions)) (car(car additions))))
 563                     (= 5 (- (cadr(car additions)) (cadr(cadr additions))))))
 564              (or(null? subtractions) ;this or clause protects the "adds"
 565                 (and (pair? subtractions)
 566                      (or (< (car(cadr additions)) (car(car subtractions)))
 567                          (and(= (car(cadr additions)) (car(car subtractions)))
 568                              (< (cadr(cadr additions)) (cadr(car subtractions))))))))
 569          (chord::additions->markup-american (cdr additions) subtractions)
 570          (make-line-markup
 571           (list
 572            (let ((step (step->markup-american (car additions))))
 573              (if (or (pair? (cdr additions))
 574                      (pair? subtractions))
 575                  (if (and (pair? (cdr additions))
 576                           (or(< 3 (- (cadr(cadr additions)) (cadr(car additions))))
 577                              (and(< 0 (- (car(cadr additions)) (car(car additions))))
 578                                  (> 4 (- (cadr(car additions)) (cadr(cadr additions)))))))
 579                      (make-line-markup (list step (make-simple-markup " add")))
 580                      ;; tweak your favorite separator here
 581                      ;; (make-line-markup (list step (make-simple-markup "/")))
 582                      (make-line-markup (list step (make-simple-markup " "))))
 583                  step))
 584            (chord::additions->markup-american (cdr additions) subtractions))))
 585       empty-markup))
 586
 587 (define (chord::inner-name-american tonic exception-part additions subtractions
 588                                   bass-and-inversion steps)
 589   (let* ((tonic-markup (pitch->chord-name-markup-banter tonic steps))
 590          (except-markup (if exception-part exception-part empty-markup))
 591          ;; UGR.  How do we know if we should add a separator or not?
 592          ;; maybe just add extra column to exception list?
 593          (sep-markup (if (and exception-part
 594                               (let ((s (format "~s" except-markup)))
 595                                 (and
 596                                  (string-match "super" s)
 597                                  ;; ugh ugh
 598                                  ;; python: `except_markup`[-7:] != '"o"))'
 599                                  (not (equal?
 600                                        "\"o\"))))"
 601                                        (substring s
 602                                                   (- (string-length s) 7))))))
 603                               (or (pair? additions)
 604                                   (pair? subtractions)))
 605                          (make-super-markup (make-simple-markup "/"))
 606                          empty-markup))
 607          ;;this list contains all the additions that go "in line"
 608          (prefixes
 609           (filter-list
 610            (lambda (x)
 611              (let ((o (car x)) (n (cadr x)) (a (caddr x)))
 612                (and (not (and (= 0 o) (= 2 n))) ;gets rid of unwanted thirds
 613                     ;;change this if you want it differently
 614                     (not (and (= 0 o) (= 3 n) (= 0 a))) ;sus4
 615                     (not (and (= 0 o) (= 4 n) (!= 0 a)))))) ;alt5
 616            additions))
 617          ;;this list contains all the additions that are patched onto the end
 618          ;;of the chord symbol, usually sus4 and altered 5ths.
 619          (suffixes
 620           ;;take out the reverse if it bothers you in a pathological chord
 621           (reverse
 622            (filter-list
 623             (lambda (x)
 624               (let ((o (car x)) (n (cadr x)) (a (caddr x)))
 625                 (and(not (and (= 0 o) (= 2 n))) ;gets rid of unwanted thirds
 626                     ;;change this correspondingly
 627                     (or(and (= 0 o) (= 3 n) (= 0 a)) ;sus4
 628                        (and (= 0 o) (= 4 n) (!= 0 a)))))) ;alt5
 629             additions)))
 630          (relevant-subs (filter-list
 631                          (lambda (x) ;catches subtractions higher than 5th
 632                            (let((o (car x)) (n (cadr x)))
 633                              (or (> o 0)
 634                                  (> n 4))))
 635                          subtractions))
 636          (pref-markup (chord::additions->markup-american prefixes relevant-subs))
 637          (suff-markup (chord::additions->markup-american suffixes relevant-subs))
 638          (b+i-markup (chord::bass-and-inversion->markup-banter bass-and-inversion)))
 639     (make-line-markup
 640      (list
 641       tonic-markup except-markup sep-markup
 642       (make-normal-size-super-markup
 643        (make-line-markup (list pref-markup suff-markup)))
 644       b+i-markup))))
 645
 646 (define (chord::additions-american steps)
 647   (let ((evens (filter-list (lambda (x) (!= 0 (modulo (cadr x) 2))) steps))
 648         ;we let all the unevens pass for now, we'll fix that later.
 649         (unevens
 650          (filter-list (lambda (x)
 651                         (let ((n (cadr x)) (a (caddr x)))
 652                           (or (and (= 6 n) (!= -1 a))
 653                               (and (< 3 n)
 654                                    (= 0 (modulo n 2))))))
 655                       steps))
 656         (highest (let ((h (car (last-pair steps))))
 657                    (if (and (not (null? h))
 658                             (or (> 4 (cadr h))
 659                                 (!= 0 (caddr h))))
 660                        (list (list h))
 661                        '()))))
 662     (uniq-list (sort (apply append evens unevens highest)
 663                      pitch::<))))
 664
 665   ;; American style chordnames use no "no",
 666   ;; but otherwise very similar to banter for now
 667   (define-public (chord::name-american tonic exception-part unmatched-steps
 668                               bass-and-inversion steps)
 669   (let ((additions (chord::additions-american unmatched-steps))
 670         (subtractions (chord::subtractions unmatched-steps)))
 671     (chord::inner-name-american tonic exception-part additions subtractions
 672                               bass-and-inversion steps)))
 673
 674   ;;; Jazz style
 675   ;;;
 676 ;; Jazz chords, by Atte Andr'e Jensen <atte@post.com>
 677 ;; Complete rewrite by Amelie Zapf (amy@loueymoss.com)
 678
 679 ;; FIXME: identical to chord::exception-alist-american, apart from commented
 680 ;;        dim chord.  should merge.
 681 (define-public chord::exception-alist-jazz
 682   `(
 683     (((0 . 0)) . ,empty-markup)
 684     (((0 . 0) (2 . -1)) . ,(make-simple-markup "m"))
 685
 686     ;; these should probably be normal-size?  --jcn
 687     ;;(((0 . 0) (4 . 0)) . ,(make-super-markup (make-simple-markup "5 ")))
 688     ;;(((0 . 0) (1 . 0) (4 . 0)) . ,(make-super-markup (make-simple-markup "2 ")))
 689
 690     (((0 . 0) (4 . 0)) . ,(make-normal-size-super-markup (make-simple-markup "5 ")))
 691     (((0 . 0) (1 . 0) (4 . 0)) . ,(make-normal-size-super-markup (make-simple-markup "2 ")))
 692
 693     ;;choose your symbol for the fully diminished chord
 694     ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ,(make-simple-markup "dim"))
 695     (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ,(make-line-markup (list (make-simple-markup "") (make-super-markup (make-simple-markup "o")))))
 696     ))
 697
 698 ;; FIXME: rather similar to step->markup-american.  should merge.
 699 (define (step->markup-jazz pitch)
 700   (case (cadr pitch)
 701     ((6) (case (caddr pitch)
 702            ((-2) (make-line-markup (list (old-accidental->markup -1) (make-simple-markup "7"))))
 703            ((-1) (make-simple-markup "7"))
 704            ;;Pick your favorite maj7
 705            ((0) mathm-markup-object)  ;;a white triangle
 706            ;;((0) mathn-markup-object) ;;a black triangle
 707            ;;((0) (make-simple-markup "maj7")) ;;good old maj7
 708            ((1) (make-line-markup (list (old-accidental->markup 1) (make-simple-markup "7"))))
 709            ((2) (make-line-markup (list (old-accidental->markup 2) (make-simple-markup "7"))))))
 710     ((4) (case (caddr pitch)
 711            ((-2) (make-line-markup (list (old-accidental->markup -2) (make-simple-markup "5"))))
 712            ;;choose your symbol for the diminished fifth
 713            ;;((-1) (make-simple-markup "-5"))
 714            ((-1) (make-line-markup (list (old-accidental->markup -1) (make-simple-markup "5"))))
 715            ((0) empty-markup)
 716            ;;choose your symbol for the augmented fifth
 717            ;;((1) (make-simple-markup "aug"))
 718            ((1) (make-line-markup (list (old-accidental->markup 1) (make-simple-markup "5"))))
 719            ;;((1) (make-simple-markup "+5"))
 720            ((2) (make-line-markup (list (old-accidental->markup 2) (make-simple-markup "5"))))))
 721     (else (if (and (= (car pitch) 0)
 722                    (= (cadr pitch) 3)
 723                    (= (caddr pitch) 0))
 724               (make-simple-markup "sus4")
 725               (step->markup-accidental pitch)))))
 726
 727 ;; FIXME: identical to chord::additions->markup-american,
 728 ;; except for -jazz / -american suffixes on calls
 729 (define (chord::additions->markup-jazz additions subtractions)
 730   (if (pair? additions)
 731       ;; I don't like all this reasoning here, when we're actually typesetting.
 732       (if(and(pair? (cdr additions)) ;a further addition left over
 733              (or(and(= 0 (caddr(car additions))) ;this addition natural
 734                     (not(= 6 (cadr(car additions)))))
 735                 (and(= -1 (caddr(car additions)))
 736                     (= 6 (cadr(car additions)))))
 737              (or(and(= 0 (caddr(cadr additions))) ;the following addition natural
 738                     (not(= 6 (cadr(cadr additions)))))
 739                 (and(= -1 (caddr(cadr additions)))
 740                     (= 6 (cadr(cadr additions)))))
 741              (or(and(= (car(car additions)) (car(cadr additions))) ;both a third apart
 742                     (= 2 (- (cadr(cadr additions)) (cadr(car additions)))))
 743                 (and(= 1 (- (car(cadr additions)) (car(car additions))))
 744                     (= 5 (- (cadr(car additions)) (cadr(cadr additions))))))
 745              (or(null? subtractions) ;this or clause protects the "adds"
 746                 (and (pair? subtractions)
 747                      (or (< (car(cadr additions)) (car(car subtractions)))
 748                          (and(= (car(cadr additions)) (car(car subtractions)))
 749                              (< (cadr(cadr additions)) (cadr(car subtractions))))))))
 750          (chord::additions->markup-jazz (cdr additions) subtractions)
 751          (make-line-markup
 752           (list
 753            (let ((step (step->markup-jazz (car additions))))
 754              (if (or (pair? (cdr additions))
 755                      (pair? subtractions))
 756                  (if (and (pair? (cdr additions))
 757                           (or(< 3 (- (cadr(cadr additions)) (cadr(car additions))))
 758                              (and(< 0 (- (car(cadr additions)) (car(car additions))))
 759                                  (> 4 (- (cadr(car additions)) (cadr(cadr additions)))))))
 760                      (make-line-markup (list step (make-simple-markup " add")))
 761                      ;; tweak your favorite separator here
 762                      ;; (make-line-markup (list step (make-simple-markup "/")))
 763                      (make-line-markup (list step (make-simple-markup " "))))
 764                  step))
 765            (chord::additions->markup-jazz (cdr additions) subtractions))))
 766       empty-markup))
 767
 768 ;; FIXME: identical to chord::additions->markup-american.
 769 ;; except for -jazz / -american suffixes on calls
 770 (define (chord::inner-name-jazz tonic exception-part additions subtractions
 771                                 bass-and-inversion steps)
 772   (let* ((tonic-markup (pitch->chord-name-markup-banter tonic steps))
 773          (except-markup (if exception-part exception-part empty-markup))
 774          ;; UGR.  How do we know if we should add a separator or not?
 775          ;; maybe just add extra column to exception list?
 776          (sep-markup (if (and exception-part
 777                               (let ((s (format "~s" except-markup)))
 778                                 (and
 779                                  (string-match "super" s)
 780                                  ;; ugh ugh
 781                                  ;; python: `except_markup`[-7:] != '"o"))'
 782                                  (not (equal?
 783                                        "\"o\"))))"
 784                                        (substring s
 785                                                   (- (string-length s) 7))))))
 786                               (or (pair? additions)
 787                                   (pair? subtractions)))
 788                          (make-super-markup (make-simple-markup "/"))
 789                          empty-markup))
 790          ;;this list contains all the additions that go "in line"
 791          (prefixes
 792           (filter-list
 793            (lambda (x)
 794              (let ((o (car x)) (n (cadr x)) (a (caddr x)))
 795                (and (not (and (= 0 o) (= 2 n))) ;gets rid of unwanted thirds
 796                     ;;change this if you want it differently
 797                     (not (and (= 0 o) (= 3 n) (= 0 a))) ;sus4
 798                     (not (and (= 0 o) (= 4 n) (!= 0 a)))))) ;alt5
 799            additions))
 800          ;;this list contains all the additions that are patched onto the end
 801          ;;of the chord symbol, usually sus4 and altered 5ths.
 802          (suffixes
 803           ;;take out the reverse if it bothers you in a pathological chord
 804           (reverse
 805            (filter-list
 806             (lambda (x)
 807               (let ((o (car x)) (n (cadr x)) (a (caddr x)))
 808                 (and(not (and (= 0 o) (= 2 n))) ;gets rid of unwanted thirds
 809                     ;;change this correspondingly
 810                     (or(and (= 0 o) (= 3 n) (= 0 a)) ;sus4
 811                        (and (= 0 o) (= 4 n) (!= 0 a)))))) ;alt5
 812             additions)))
 813          (relevant-subs (filter-list
 814                          (lambda (x) ;catches subtractions higher than 5th
 815                            (let((o (car x)) (n (cadr x)))
 816                              (or (> o 0)
 817                                  (> n 4))))
 818                          subtractions))
 819          (pref-markup (chord::additions->markup-jazz prefixes relevant-subs))
 820          (suff-markup (chord::additions->markup-jazz suffixes relevant-subs))
 821          (b+i-markup (chord::bass-and-inversion->markup-banter bass-and-inversion)))
 822     (make-line-markup
 823      (list
 824       tonic-markup except-markup sep-markup
 825       (make-normal-size-super-markup
 826        (make-line-markup (list pref-markup suff-markup)))
 827       b+i-markup))))
 828
 829 (define (chord::name-jazz tonic exception-part unmatched-steps
 830                           bass-and-inversion steps)
 831   (let ((additions (chord::additions-american unmatched-steps))
 832         (subtractions (chord::subtractions unmatched-steps)))
 833     (chord::inner-name-jazz tonic exception-part additions subtractions
 834                             bass-and-inversion steps)))
 835
 836
 837 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 838
 839
 840 (define-public (new-chord->markup func ly-pitches bass inversion context)
 841   "Entry point for New_chord_name_engraver. See chord-name.scm for the
 842 signature of FUNC.  LY-PITCHES, BASS and INVERSION are lily
 843 pitches. EXCEPTIONS is an alist (see scm file).
 844  "
 845
 846   (let* ((pitches (map c++-pitch->scm ly-pitches))
 847          (exceptions (ly:get-context-property context 'chordNameExceptions))
 848          (bass-and-inversion
 849           (cons (c++-pitch->scm bass)
 850                 (c++-pitch->scm inversion)))
 851          (diff (pitch::diff '(0 0 0) (car pitches)))
 852          (steps (if (cdr pitches) (map (lambda (x)
 853                                          (pitch::transpose x diff))
 854                                        (cdr pitches))
 855                     '()))
 856          (lookup (dbg (chord::exceptions-lookup exceptions steps)))
 857          (exception-part (dbg (car lookup)))
 858          (unmatched-steps (cadr lookup))
 859          (tonic (car pitches))
 860          )
 861
 862       (func tonic exception-part unmatched-steps bass-and-inversion steps)
 863       ))
 864
 865 (define-public (chord->markup-jazz . args)
 866   (apply new-chord->markup (cons chord::name-jazz args))
 867   )
 868
 869 (define-public (chord->markup-american . args)
 870   (apply new-chord->markup (cons chord::name-american args))
 871   )
 872
 873 (define-public (chord->markup-banter . args)
 874   (apply new-chord->markup (cons chord::name-banter args))
 875   )
 876
 877 (define-public (new-chord-name-brew-molecule grob)
 878   (let*
 879       (
 880        (ws (ly:get-grob-property grob 'word-space))
 881        (markup (ly:get-grob-property grob 'text))
 882        (molecule (interpret-markup grob
 883                                    (cons '((word-space . 0.0))
 884                                          (Font_interface::get_property_alist_chain grob))
 885                                    markup))
 886        )
 887
 888     ;;
 889     ;; chord names aren't in staffs, so WS is in global staff space.
 890     (if (number? ws)
 891         (ly:combine-molecule-at-edge
 892          molecule
 893          X RIGHT (ly:make-molecule "" (cons 0 ws) '(-1 . 1) )
 894          0.0)
 895         molecule)
 896     ))
 897
 898 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 899
 900 (define-public (set-chord-name-style sym)
 901   "Return music expressions that set the chord naming style. For
 902 inline use in .ly file"
 903
 904   (define (chord-name-style-setter function exceptions)
 905     (context-spec-music
 906      (make-sequential-music
 907       (list (make-property-set 'chordNameFunction function)
 908             (make-property-set 'chordNameExceptions exceptions)))
 909      "ChordNames"
 910      )
 911     )
 912
 913   (ly:export
 914    (case sym
 915      ((jazz)
 916       (chord-name-style-setter chord->markup-jazz
 917                                chord::exception-alist-jazz))
 918      ((banter)
 919       (chord-name-style-setter chord->markup-banter
 920                                chord::exception-alist-banter))
 921      ((american)
 922       (chord-name-style-setter chord->markup-american
 923                                chord::exception-alist-american))
 924
 925      ((ignatzek)
 926       (chord-name-style-setter ignatzek-chord-names
 927                                '()))
 928      ((double-plus-new-banter)
 929       (chord-name-style-setter double-plus-new-chord->markup-banter
 930        chord::exception-alist-banter))
 931
 932      ((double-plus-new-jazz)
 933       (chord-name-style-setter double-plus-new-chord->markup-jazz
 934        chord::exception-alist-jazz))
 935      )))
 936
 937 ;; can't put this in double-plus-new-chord-name.scm, because we can't
 938 ;; ly:load that very easily.
 939 (define-public (set-double-plus-new-chord-name-style style options)
 940   "Return music expressions that set the chord naming style. For
 941 inline use in .ly file"
 942
 943   (define (chord-name-style-setter function)
 944     (context-spec-music
 945      (make-sequential-music
 946       (list (make-property-set 'chordNameFunction function)
 947
 948             ;; urg , misuse of chordNameExceptions function.
 949             (make-property-set 'chordNameExceptions options)))
 950      "ChordNames"))
 951
 952   (ly:export
 953    (case style
 954      ((banter)
 955       (chord-name-style-setter double-plus-new-chord->markup-banter))
 956
 957      ((jazz)
 958       (chord-name-style-setter double-plus-new-chord->markup-jazz)))))
 959