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 ((family . "math") "N"))
  91          (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (rows (super "o") ((kern . -0.5) ((size . "-3") "/")) "7")) ; slashed o
  92          (((0 . 0) (2 . 0) (4 . 1) (6 . -1)) . ("aug7"))
  93          (((0 . 0) (2 . 0) (4 . -1) (6 . 0)) . (rows "maj7" (music (named ("accidentals--1"))) "5"))
  94          (((0 . 0) (3 . 0) (4 . 0) (6 . -1)) . ("7sus4"))
  95          ;; Common ninth chords
  96          (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) . ("6/9")) ;; we don't want the '/no7'
  97          (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) . ("maj6"))
  98          (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) . ("m6"))
  99          (((0 . 0) (2 . 0) (4 . 0) (1 . 0)) . ("add9"))
 100          (((0 . 0) (2 . 0) (4 . 0) (6 . 0) (1 . 0)) . ("maj9"))
 101          (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0)) . ("9"))
 102          (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) . ("m9"))
 103
 104          )
 105       chord::names-alist-american))
 106
 107 ;;;;;;;;;;
 108
 109
 110 (define (pitch->note-name pitch)
 111   (cons (cadr pitch) (caddr pitch)))
 112
 113 (define (pitch->text pitch)
 114   (cons
 115     (make-string 1 (integer->char (+ (modulo (+ (cadr pitch) 2) 7) 65)))
 116     (if (= (caddr pitch) 0)
 117       '()
 118       (list
 119        (append '(music)
 120                (list
 121                 (append '(named)
 122                         (list
 123                          (string-append "accidentals-"
 124                                         (number->string (caddr pitch)))))))))))
 125
 126
 127 (define (step->text pitch)
 128   (string-append
 129     (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8)))
 130     (case (caddr pitch)
 131       ((-2) "--")
 132       ((-1) "-")
 133       ((0) "")
 134       ((1) "+")
 135       ((2) "++"))))
 136
 137 (define (pitch->text-banter pitch)
 138   (pitch->text pitch))
 139
 140 (define (step->text-banter pitch)
 141   (if (= (cadr pitch) 6)
 142       (case (caddr pitch)
 143         ((-2) "7-")
 144         ((-1) "7")
 145         ((0) "maj7")
 146         ((1) "7+")
 147         ((2) "7+"))
 148       (step->text pitch)))
 149
 150 (define pitch::semitone-vec (list->vector '(0 2 4 5 7 9 11)))
 151
 152 (define (pitch::semitone pitch)
 153   (+ (* (car pitch) 12)
 154      (vector-ref pitch::semitone-vec (modulo (cadr pitch) 7))
 155      (caddr pitch)))
 156
 157 (define (pitch::transpose pitch delta)
 158   (let ((simple-octave (+ (car pitch) (car delta)))
 159         (simple-notename (+ (cadr pitch) (cadr delta))))
 160     (let ((octave (+ simple-octave (quotient simple-notename 7)))
 161            (notename (modulo simple-notename 7)))
 162       (let ((accidental (- (+ (pitch::semitone pitch) (pitch::semitone delta))
 163                            (pitch::semitone `(,octave ,notename 0)))))
 164         `(,octave ,notename ,accidental)))))
 165
 166 (define (pitch::diff pitch tonic)
 167   (let ((simple-octave (- (car pitch) (car tonic)))
 168         (simple-notename (- (cadr pitch) (cadr tonic))))
 169     (let ((octave (+ simple-octave (quotient simple-notename 7)
 170                      (if (< simple-notename 0) -1 0)))
 171           (notename (modulo simple-notename 7)))
 172       (let ((accidental (- (pitch::semitone pitch)
 173                           (pitch::semitone tonic)
 174                           (pitch::semitone `(,octave ,notename 0)))))
 175         `(,octave ,notename ,accidental)))))
 176
 177 (define (pitch::note-pitch pitch)
 178   (+ (* (car pitch) 7) (cadr pitch)))
 179
 180 (define (chord::step tonic pitch)
 181  (- (pitch::note-pitch pitch) (pitch::note-pitch tonic)))
 182
 183 ;; text: list of word
 184 ;; word: string + optional list of property
 185 ;; property: align, kern, font (?), size
 186
 187 (define chord::minor-major-vec (list->vector '(0 -1 -1 0 -1 -1 0)))
 188
 189 ;; compute the relative-to-tonic pitch that goes with 'step'
 190 (define (chord::step-pitch tonic step)
 191   ;; urg, we only do this for thirds
 192   (if (= (modulo step 2) 0)
 193     '(0 0 0)
 194     (let loop ((i 1) (pitch tonic))
 195       (if (= i step) pitch
 196         (loop (+ i 2)
 197               (pitch::transpose
 198                 pitch `(0 2 ,(vector-ref chord::minor-major-vec
 199                 ;; -1 (step=1 -> vector=0) + 7 = 6
 200                 (modulo (+ i 6) 7)))))))))
 201
 202 ;; find the pitches that are not part of `normal' chord
 203 (define (chord::additions chord-pitches)
 204   (let ((tonic (car chord-pitches)))
 205     ;; walk the chord steps: 1, 3, 5
 206     (let loop ((step 1) (pitches chord-pitches) (additions '()))
 207       (if (pair? pitches)
 208         (let* ((pitch (car pitches))
 209                (p-step (+ (- (pitch::note-pitch pitch)
 210                              (pitch::note-pitch tonic))
 211                           1)))
 212           ;; pitch is an addition if
 213           (if (or
 214                 ;; it comes before this step or
 215                 (< p-step step)
 216                 ;; its step is even or
 217                 (= (modulo p-step 2) 0)
 218                 ;; has same step, but different accidental or
 219                 (and (= p-step step)
 220                      (not (equal? pitch (chord::step-pitch tonic step))))
 221                 ;; is the last of the chord and not one of base thirds
 222                 (and (> p-step  5)
 223                      (= (length pitches) 1)))
 224             (loop step (cdr pitches) (cons pitch additions))
 225           (if (= p-step step)
 226             (loop step (cdr pitches) additions)
 227             (loop (+ step 2) pitches additions))))
 228       (reverse additions)))))
 229
 230 ;; find the pitches that are missing from `normal' chord
 231 (define (chord::subtractions chord-pitches)
 232   (let ((tonic (car chord-pitches)))
 233     (let loop ((step 1) (pitches chord-pitches) (subtractions '()))
 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 subtraction if
 240           ;; a step is missing or
 241           (if (> p-step step)
 242             (loop (+ step 2) pitches
 243                 (cons (chord::step-pitch tonic step) subtractions))
 244           ;; there are no pitches left, but base thirds are not yet done and
 245           (if (and (<= step 5)
 246                    (= (length pitches) 1))
 247             ;; present pitch is not missing step
 248             (if (= p-step step)
 249               (loop (+ step 2) pitches subtractions)
 250               (loop (+ step 2) pitches
 251                     (cons (chord::step-pitch tonic step) subtractions)))
 252             (if (= p-step step)
 253               (loop (+ step 2) (cdr pitches) subtractions)
 254               (loop step (cdr pitches) subtractions)))))
 255         (reverse subtractions)))))
 256
 257 ;; combine tonic, user-specified chordname,
 258 ;; additions, subtractions and base or inversion to chord name
 259 ;;
 260 (define (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)
 261   (apply append
 262          '(rows)
 263          (pitch->text-banter tonic)
 264          (if user-name user-name '())
 265          ;; why does list->string not work, format seems only hope...
 266          (if (and (string-match "super" (format "~s" user-name))
 267                   (or (pair? additions)
 268                       (pair? subtractions)))
 269              '((super "/"))
 270              '())
 271          (let loop ((from additions) (to '()))
 272            (if (pair? from)
 273                (let ((p (car from)))
 274                  (loop (cdr from)
 275                        (append to
 276                                (cons
 277                                 (list 'super (step->text-banter p))
 278                                 (if (or (pair? (cdr from))
 279                                         (pair? subtractions))
 280                                     '((super "/"))
 281                                     '())))))
 282                to))
 283          (let loop ((from subtractions) (to '()))
 284            (if (pair? from)
 285                  (let ((p (car from)))
 286                    (loop (cdr from)
 287                          (append to
 288                                  (cons '(super "no")
 289                                        (cons
 290                                         (list 'super (step->text-banter p))
 291                                         (if (pair? (cdr from))
 292                                             '((super "/"))
 293                                             '()))))))
 294                  to))
 295          (if (and (pair? base-and-inversion)
 296                   (or (car base-and-inversion)
 297                       (cdr base-and-inversion)))
 298              (cons "/" (append
 299                         (if (car base-and-inversion)
 300                             (pitch->text
 301                              (car base-and-inversion))
 302                             (pitch->text
 303                              (cdr base-and-inversion)))
 304                         '()))
 305              '())
 306          '()))
 307
 308 (define (chord::name-banter tonic user-name pitches base-and-inversion)
 309   (let ((additions (chord::additions pitches))
 310         (subtractions (chord::subtractions pitches)))
 311     (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)))
 312
 313 ;; american chordnames use no "no",
 314 ;; but otherwise very similar to banter for now
 315 (define (chord::name-american tonic user-name pitches base-and-inversion)
 316   (let ((additions (chord::additions pitches))
 317         (subtractions #f))
 318     (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion)))
 319
 320 ;; C++ entry point
 321 ;;
 322 ;; Check for each subset of chord, full chord first, if there's a
 323 ;; user-override.  Split the chord into user-overridden and to-be-done
 324 ;; parts, complete the missing user-override matched part with normal
 325 ;; chord to be name-calculated.
 326 ;;
 327 (define (default-chord-name-function style pitches base-and-inversion)
 328   ;(display "pitches:") (display  pitches) (newline)
 329   ;(display "style:") (display  style) (newline)
 330   ;(display "b&i:") (display  base-and-inversion) (newline)
 331   (let ((diff (pitch::diff '(0 0 0) (car pitches)))
 332         (name-func
 333           (ly-eval (string->symbol (string-append "chord::name-" style))))
 334         (names-alist
 335           (ly-eval (string->symbol (string-append "chord::names-alist-" style)))))
 336   (let loop ((note-names (reverse pitches))
 337              (chord '())
 338              (user-name #f))
 339     (if (pair? note-names)
 340       (let ((entry (assoc
 341                      (reverse
 342                        (map (lambda (x)
 343                               (pitch->note-name (pitch::transpose x diff)))
 344                             note-names))
 345                      names-alist)))
 346         (if entry
 347           ;; urg? found: break loop
 348           (loop '() chord (cdr entry))
 349           (loop (cdr note-names) (cons (car note-names) chord) #f)))
 350       (let* ((transposed (if pitches
 351                            (map (lambda (x) (pitch::transpose x diff)) chord)
 352                            '()))
 353              (matched (if (= (length chord) 0)
 354                           3
 355                           (- (length pitches) (length chord))))
 356              (completed
 357               (append (do ((i matched (- i 1))
 358                            (base '() (cons `(0 ,(* (- i 1) 2) 0) base)))
 359                            ((= i 0) base)
 360                            ())
 361                   transposed)))
 362       (name-func (car pitches) user-name completed base-and-inversion))))))
 363
 364