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