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