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