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