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