scm/chord-names.scm

   1 ;;; chord.scm -- to be included in/to replace chord-name.scm
   2 ;;; 2000 janneke@gnu.org
   3 ;;;
   4
   5 (use-modules
   6    (ice-9 debug)
   7    ;; urg, these two only to guess if a '/' is needed to separate
   8    ;; user-chord-name and additions/subtractions
   9    (ice-9 format)
  10    (ice-9 regex)
  11    )
  12
  13 ;;
  14 ;; (octave notename accidental)
  15 ;;
  16
  17 ;;
  18 ;; text: scm markup text -- see font.scm and input/test/markup.ly
  19 ;;
  20
  21 ;; TODO
  22 ;;
  23 ;; * clean split of base/banter/american stuff
  24 ;; * text definition is rather ad-hoc
  25 ;; * do without format module
  26 ;; * finish and check american names
  27 ;; * make notename (tonic) configurable from mudela
  28 ;; * fix append/cons stuff in inner-name-banter
  29 ;;
  30
  31
  32 ;;;;;;;;;
  33 (define chord::names-alist-banter '())
  34 (set! chord::names-alist-banter
  35       (append
  36         '(
  37         ; C iso C.no3.no5
  38         (((0 . 0)) . #f)
  39         ; C iso C.no5
  40         (((0 . 0) (2 . 0)) . #f)
  41         ; Cm iso Cm.no5
  42         (((0 . 0) (2 . -1)) . ("m"))
  43         ; C2 iso C2.no3
  44         (((0 . 0) (1 . 0) (4 . 0)) . (super "2"))
  45         ; C4 iso C4.no3
  46         (((0 . 0) (3 . 0) (4 . 0)) . (super "4"))
  47         ; Cdim iso Cm5-
  48         (((0 . 0) (2 . -1) (4 . -1)) . ("dim"))
  49         ; Co iso Cm5-7-
  50         ; urg
  51         (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (super "o"))
  52         ; Cdim9
  53         (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1)) . ("dim" (super "9")))
  54         (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1) (3 . -1)) . ("dim" (super "11")))
  55         )
  56       chord::names-alist-banter))
  57
  58
  59 ;; NOTE: Duplicates of chord names defined elsewhere occur in this list
  60 ;; in order to prevent spurious superscripting of various chord names,
  61 ;; such as maj7, maj9, etc.
  62 ;;
  63 ;; See input/test/american-chords.ly
  64 ;;
  65 ;; James Hammons, <jlhamm@pacificnet.net>
  66
  67 (define chord::names-alist-american '())
  68 (set! chord::names-alist-american
  69       (append
  70        '(
  71          (((0 . 0)) . #f)
  72          (((0 . 0) (2 . 0)) . #f)
  73          ;; Root-fifth chord
  74          (((0 . 0) (4 . 0)) . ("5"))
  75          ;; Common triads
  76          (((0 . 0) (2 . -1)) . ("m"))
  77          (((0 . 0) (3 . 0) (4 . 0)) . ("sus"))
  78          (((0 . 0) (2 . -1) (4 . -1)) . ("dim"))
  79 ;Alternate:      (((0 . 0) (2 . -1) (4 . -1)) . ((super "o")))
  80          (((0 . 0) (2 . 0) (4 . 1)) . ("aug"))
  81 ;Alternate:      (((0 . 0) (2 . 0) (4 . 1)) . ("+"))
  82          (((0 . 0) (1 . 0) (4 . 0)) . ("2"))
  83          ;; Common seventh chords
  84          (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (rows (super "o") "7"))
  85          (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . ("maj7"))
  86          (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . ("m7"))
  87          (((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . ("7"))
  88          (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . ("m(maj7)"))
  89          ;jazz: the delta, see jazz-chords.ly
  90          ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) .  (super ((font-family . "math") "N"))
  91          ;; slashed o
  92          (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (rows ((raise . 1) "o") ((raise . 0.5) ((kern . -0.5) ((font-relative-size . -3) "/"))) "7")) ; slashed o
  93          (((0 . 0) (2 . 0) (4 . 1) (6 . -1)) . ("aug7"))
  94          (((0 . 0) (2 . 0) (4 . -1) (6 . 0)) . (rows "maj7" ((font-relative-size . -2) ((raise . 0.2) (music (named "accidentals--1")))) "5"))
  95          (((0 . 0) (2 . 0) (4 . -1) (6 . -1)) . (rows "7" ((font-relative-size . -2) ((raise . 0.2) (music (named "accidentals--1")))) "5"))
  96          (((0 . 0) (3 . 0) (4 . 0) (6 . -1)) . ("7sus4"))
  97          ;; Common ninth chords
  98          (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) . ("6/9")) ;; we don't want the '/no7'
  99          (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) . ("6"))
 100          (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) . ("m6"))
 101          (((0 . 0) (2 . 0) (4 . 0) (1 . 0)) . ("add9"))
 102          (((0 . 0) (2 . 0) (4 . 0) (6 . 0) (1 . 0)) . ("maj9"))
 103          (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0)) . ("9"))
 104          (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) . ("m9"))
 105
 106          )
 107       chord::names-alist-american))
 108
 109 ;; Jazz chords, by Atte André Jensen
 110 ;; Note: This uses the american list as a base
 111
 112 (define chord::names-alist-jazz '())
 113 (set! chord::names-alist-jazz
 114       (append
 115       '(
 116          ; half diminished seventh chord = slashed o
 117          (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (("o" (type . "super")) ("/" (size . -2) (offset . (-0.58 . 0.5))) ))
 118          ; diminished seventh chord =  o
 119          (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (("o" (type . "super"))))
 120          ; major seventh chord = triangle
 121          (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) .  ((super ((font-family . "math") "N")) (size . -3)))
 122          ; minor major seventh chord = m triangle
 123          (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) .  (("m") ((super ((font-family . math) "N")) (size . -3))))
 124          ; augmented dominant = +7
 125          (((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (super "+7"))
 126
 127 ;; Missing jazz chord definitions go here (note new syntax: see american for hints)
 128
 129         )
 130       chord::names-alist-american))
 131
 132 ;;;;;;;;;;
 133
 134
 135 (define (pitch->note-name pitch)
 136   (cons (cadr pitch) (caddr pitch)))
 137
 138 (define (pitch->text pitch)
 139   (cons
 140     (make-string 1 (integer->char (+ (modulo (+ (cadr pitch) 2) 7) 65)))
 141     (if (= (caddr pitch) 0)
 142       '()
 143       (list
 144        (append '(music)
 145                (list
 146                 (append '(named)
 147                         (list
 148                           (append '((font-relative-size . -2))
 149                                 (list (append '((raise . 0.6))
 150                                   (list
 151                                    (string-append "accidentals-"
 152                                                   (number->string (caddr pitch)))))))))))))))
 153
 154 (define (step->text pitch)
 155   (string-append
 156     (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))
 157     (case (caddr pitch)
 158       ((-2) "--")
 159       ((-1) "-")
 160       ((0) "")
 161       ((1) "+")
 162       ((2) "++"))))
 163
 164 (define (pitch->text-banter pitch)
 165   (pitch->text pitch))
 166
 167 (define (step->text-banter pitch)
 168   (if (= (cadr pitch) 6)
 169       (case (caddr pitch)
 170         ((-2) "7-")
 171         ((-1) "7")
 172         ((0) "maj7")
 173         ((1) "7+")
 174         ((2) "7+"))
 175       (step->text pitch)))
 176
 177 (define pitch::semitone-vec (list->vector '(0 2 4 5 7 9 11)))
 178
 179 (define (pitch::semitone pitch)
 180   (+ (* (car pitch) 12)
 181      (vector-ref pitch::semitone-vec (modulo (cadr pitch) 7))
 182      (caddr pitch)))
 183
 184 (define (pitch::transpose pitch delta)
 185   (let ((simple-octave (+ (car pitch) (car delta)))
 186         (simple-notename (+ (cadr pitch) (cadr delta))))
 187     (let ((octave (+ simple-octave (quotient simple-notename 7)))
 188            (notename (modulo simple-notename 7)))
 189       (let ((accidental (- (+ (pitch::semitone pitch) (pitch::semitone delta))
 190                            (pitch::semitone `(,octave ,notename 0)))))
 191         `(,octave ,notename ,accidental)))))
 192
 193 (define (pitch::diff pitch tonic)
 194   (let ((simple-octave (- (car pitch) (car tonic)))
 195         (simple-notename (- (cadr pitch) (cadr tonic))))
 196     (let ((octave (+ simple-octave (quotient simple-notename 7)
 197                      (if (< simple-notename 0) -1 0)))
 198           (notename (modulo simple-notename 7)))
 199       (let ((accidental (- (pitch::semitone pitch)
 200                           (pitch::semitone tonic)
 201                           (pitch::semitone `(,octave ,notename 0)))))
 202         `(,octave ,notename ,accidental)))))
 203
 204 (define (pitch::note-pitch pitch)
 205   (+ (* (car pitch) 7) (cadr pitch)))
 206
 207 (define (chord::step tonic pitch)
 208  (- (pitch::note-pitch pitch) (pitch::note-pitch tonic)))
 209
 210 ;; text: list of word
 211 ;; word: string + optional list of property
 212 ;; property: align, kern, font (?), size
 213
 214 (define chord::minor-major-vec (list->vector '(0 -1 -1 0 -1 -1 0)))
 215
 216 ;; compute the relative-to-tonic pitch that goes with 'step'
 217 (define (chord::step-pitch tonic step)
 218   ;; urg, we only do this for thirds
 219   (if (= (modulo step 2) 0)
 220     '(0 0 0)
 221     (let loop ((i 1) (pitch tonic))
 222       (if (= i step) pitch
 223         (loop (+ i 2)
 224               (pitch::transpose
 225                 pitch `(0 2 ,(vector-ref chord::minor-major-vec
 226                 ;; -1 (step=1 -> vector=0) + 7 = 6
 227                 (modulo (+ i 6) 7)))))))))
 228
 229 ;; find the pitches that are not part of `normal' chord
 230 (define (chord::additions chord-pitches)
 231   (let ((tonic (car chord-pitches)))
 232     ;; walk the chord steps: 1, 3, 5
 233     (let loop ((step 1) (pitches chord-pitches) (additions '()))
 234       (if (pair? pitches)
 235         (let* ((pitch (car pitches))
 236                (p-step (+ (- (pitch::note-pitch pitch)
 237                              (pitch::note-pitch tonic))
 238                           1)))
 239           ;; pitch is an addition if
 240           (if (or
 241                 ;; it comes before this step or
 242                 (< p-step step)
 243                 ;; its step is even or
 244                 (= (modulo p-step 2) 0)
 245                 ;; has same step, but different accidental or
 246                 (and (= p-step step)
 247                      (not (equal? pitch (chord::step-pitch tonic step))))
 248                 ;; is the last of the chord and not one of base thirds
 249                 (and (> p-step  5)
 250                      (= (length pitches) 1)))
 251             (loop step (cdr pitches) (cons pitch additions))
 252           (if (= p-step step)
 253             (loop step (cdr pitches) additions)
 254             (loop (+ step 2) pitches additions))))
 255       (reverse additions)))))
 256
 257 ;; find the pitches that are missing from `normal' chord
 258 (define (chord::subtractions chord-pitches)
 259   (let ((tonic (car chord-pitches)))
 260     (let loop ((step 1) (pitches chord-pitches) (subtractions '()))
 261       (if (pair? pitches)
 262         (let* ((pitch (car pitches))
 263                (p-step (+ (- (pitch::note-pitch pitch)
 264                              (pitch::note-pitch tonic))
 265                           1)))
 266           ;; pitch is an subtraction if
 267           ;; a step is missing or
 268           (if (> p-step step)
 269             (loop (+ step 2) pitches
 270                 (cons (chord::step-pitch tonic step) subtractions))
 271           ;; there are no pitches left, but base thirds are not yet done and
 272           (if (and (<= step 5)
 273                    (= (length pitches) 1))
 274             ;; present pitch is not missing step
 275             (if (= p-step step)
 276               (loop (+ step 2) pitches subtractions)
 277               (loop (+ step 2) pitches
 278                     (cons (chord::step-pitch tonic step) subtractions)))
 279             (if (= p-step step)
 280               (loop (+ step 2) (cdr pitches) subtractions)
 281               (loop step (cdr pitches) subtractions)))))
 282         (reverse subtractions)))))
 283
 284 ;; combine tonic, user-specified chordname,
 285 ;; additions, subtractions and base or inversion to chord name
 286 ;;
 287 (define (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)
 288   (apply append
 289          '(rows)
 290          (pitch->text-banter tonic)
 291          (if user-name user-name '())
 292          ;; why does list->string not work, format seems only hope...
 293          (if (and (string-match "super" (format "~s" user-name))
 294                   (or (pair? additions)
 295                       (pair? subtractions)))
 296              '((super "/"))
 297              '())
 298          (let loop ((from additions) (to '()))
 299            (if (pair? from)
 300                (let ((p (car from)))
 301                  (loop (cdr from)
 302                        (append to
 303                                (cons
 304                                 (list 'super (step->text-banter p))
 305                                 (if (or (pair? (cdr from))
 306                                         (pair? subtractions))
 307                                     '((super "/"))
 308                                     '())))))
 309                to))
 310          (let loop ((from subtractions) (to '()))
 311            (if (pair? from)
 312                  (let ((p (car from)))
 313                    (loop (cdr from)
 314                          (append to
 315                                  (cons '(super "no")
 316                                        (cons
 317                                         (list 'super (step->text-banter p))
 318                                         (if (pair? (cdr from))
 319                                             '((super "/"))
 320                                             '()))))))
 321                  to))
 322          (if (and (pair? base-and-inversion)
 323                   (or (car base-and-inversion)
 324                       (cdr base-and-inversion)))
 325              (cons "/" (append
 326                         (if (car base-and-inversion)
 327                             (pitch->text
 328                              (car base-and-inversion))
 329                             (pitch->text
 330                              (cdr base-and-inversion)))
 331                         '()))
 332              '())
 333          '()))
 334
 335 (define (chord::name-banter tonic user-name pitches base-and-inversion)
 336   (let ((additions (chord::additions pitches))
 337         (subtractions (chord::subtractions pitches)))
 338     (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)))
 339
 340 ;; american chordnames use no "no",
 341 ;; but otherwise very similar to banter for now
 342 (define (chord::name-american tonic user-name pitches base-and-inversion)
 343   (let ((additions (chord::additions pitches))
 344         (subtractions #f))
 345     (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)))
 346
 347 ;; Jazz style--basically similar to american with minor changes
 348 (define (chord::name-jazz tonic user-name pitches base-and-inversion)
 349   (let ((additions (chord::additions pitches))
 350         (subtractions #f))
 351     (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)))
 352
 353 ;; C++ entry point
 354 ;;
 355 ;; Check for each subset of chord, full chord first, if there's a
 356 ;; user-override.  Split the chord into user-overridden and to-be-done
 357 ;; parts, complete the missing user-override matched part with normal
 358 ;; chord to be name-calculated.
 359 ;;
 360 (define (default-chord-name-function style pitches base-and-inversion)
 361   ;(display "pitches:") (display  pitches) (newline)
 362   ;(display "style:") (display  style) (newline)
 363   ;(display "b&i:") (display  base-and-inversion) (newline)
 364   (let ((diff (pitch::diff '(0 0 0) (car pitches)))
 365         (name-func
 366           (ly-eval (string->symbol (string-append "chord::name-" style))))
 367         (names-alist
 368           (ly-eval (string->symbol (string-append "chord::names-alist-" style)))))
 369   (let loop ((note-names (reverse pitches))
 370              (chord '())
 371              (user-name #f))
 372     (if (pair? note-names)
 373       (let ((entry (assoc
 374                      (reverse
 375                        (map (lambda (x)
 376                               (pitch->note-name (pitch::transpose x diff)))
 377                             note-names))
 378                      names-alist)))
 379         (if entry
 380           ;; urg? found: break loop
 381           (loop '() chord (cdr entry))
 382           (loop (cdr note-names) (cons (car note-names) chord) #f)))
 383       (let* ((transposed (if pitches
 384                            (map (lambda (x) (pitch::transpose x diff)) chord)
 385                            '()))
 386              (matched (if (= (length chord) 0)
 387                           3
 388                           (- (length pitches) (length chord))))
 389              (completed
 390               (append (do ((i matched (- i 1))
 391                            (base '() (cons `(0 ,(* (- i 1) 2) 0) base)))
 392                            ((= i 0) base)
 393                            ())
 394                   transposed)))
 395       (name-func (car pitches) user-name completed base-and-inversion))))))
 396
 397