From: fred Date: Thu, 16 Nov 2000 12:34:03 +0000 (+0000) Subject: lilypond-1.3.109 X-Git-Tag: release/1.5.59~5720 X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=921cfb4cd9aaf44e9f0e94a1a68f780251fadf09;p=lilypond.git lilypond-1.3.109 --- diff --git a/scm/chord-name.scm b/scm/chord-name.scm new file mode 100644 index 0000000000..d3ad48943c --- /dev/null +++ b/scm/chord-name.scm @@ -0,0 +1,525 @@ +;;; +;;; chord-name.scm -- Compile chord name +;;; +;;; source file of the GNU LilyPond music typesetter +;;; +;;; (c) 2000 Jan Nieuwenhuizen +;;; + + +(use-modules + (ice-9 debug) + ;; urg, these two only to guess if a '/' is needed to separate + ;; user-chord-name and additions/subtractions + (ice-9 format) + (ice-9 regex) + ) + +;; +;; (octave notename accidental) +;; + +;; +;; text: scm markup text -- see font.scm and input/test/markup.ly +;; + +;; TODO +;; +;; * clean split of base/banter/american stuff +;; * text definition is rather ad-hoc +;; * do without format module +;; * finish and check american names +;; * make notename (tonic) configurable from lilypond +;; * fix append/cons stuff in inner-name-banter +;; * doc strings. + +;;;;;;;;; +(define chord::names-alist-banter '()) +(set! chord::names-alist-banter + (append + '( + ; C iso C.no3.no5 + (((0 . 0)) . #f) + ; C iso C.no5 + (((0 . 0) (2 . 0)) . #f) + ; Cm iso Cm.no5 + (((0 . 0) (2 . -1)) . ("m")) + ; C2 iso C2.no3 + (((0 . 0) (1 . 0) (4 . 0)) . (super "2")) + ; C4 iso C4.no3 + (((0 . 0) (3 . 0) (4 . 0)) . (super "4")) + ; Cdim iso Cm5- + (((0 . 0) (2 . -1) (4 . -1)) . ("dim")) + ; Co iso Cm5-7- + ; urg + (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (super "o")) + ; Cdim9 + (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1)) . ("dim" (super "9"))) + (((0 . 0) (2 . -1) (4 . -1) (6 . -2) (1 . -1) (3 . -1)) . ("dim" (super "11"))) + ) + chord::names-alist-banter)) + + +;; NOTE: Duplicates of chord names defined elsewhere occur in this list +;; in order to prevent spurious superscripting of various chord names, +;; such as maj7, maj9, etc. +;; +;; See input/test/american-chords.ly +;; +;; James Hammons, +;; + +;; DONT use non-ascii characters, even if ``it works'' in Windows + +(define chord::names-alist-american '()) + +(set! chord::names-alist-american + (append + '( + (((0 . 0)) . #f) + (((0 . 0) (2 . 0)) . #f) + ;; Root-fifth chord + (((0 . 0) (4 . 0)) . ("5")) + ;; Common triads + (((0 . 0) (2 . -1)) . ("m")) + (((0 . 0) (3 . 0) (4 . 0)) . ("sus")) + (((0 . 0) (2 . -1) (4 . -1)) . ("dim")) +;Alternate: (((0 . 0) (2 . -1) (4 . -1)) . ((super "o"))) + (((0 . 0) (2 . 0) (4 . 1)) . ("aug")) +;Alternate: (((0 . 0) (2 . 0) (4 . 1)) . ("+")) + (((0 . 0) (1 . 0) (4 . 0)) . ("2")) + ;; Common seventh chords + (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (rows (super "o") "7")) + (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . ("maj7")) + (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . ("m7")) + (((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . ("7")) + (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . ("m(maj7)")) + ;jazz: the delta, see jazz-chords.ly + ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (super ((font-family . math) "N")) + ;; slashed o + (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (rows ((raise . 1) "o") ((raise . 0.5) ((kern . -0.5) ((font-relative-size . -3) "/"))) "7")) ; slashed o + (((0 . 0) (2 . 0) (4 . 1) (6 . -1)) . ("aug7")) + (((0 . 0) (2 . 0) (4 . -1) (6 . 0)) . (rows "maj7" ((font-relative-size . -2) ((raise . 0.2) (music (named "accidentals--1")))) "5")) + (((0 . 0) (2 . 0) (4 . -1) (6 . -1)) . (rows "7" ((font-relative-size . -2) ((raise . 0.2) (music (named "accidentals--1")))) "5")) + (((0 . 0) (3 . 0) (4 . 0) (6 . -1)) . ("7sus4")) + ;; Common ninth chords + (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) . ("6/9")) ;; we don't want the '/no7' + (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) . ("6")) + (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) . ("m6")) + (((0 . 0) (2 . 0) (4 . 0) (1 . 0)) . ("add9")) + (((0 . 0) (2 . 0) (4 . 0) (6 . 0) (1 . 0)) . ("maj9")) + (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0)) . ("9")) + (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) . ("m9")) + + ) + chord::names-alist-american)) + +;; Jazz chords, by Atte Andr'e Jensen +;; NBs: This uses the american list as a base. +;; Some defs take up more than one line, +;; be carefull when messing with ;'s!! + + +;; FIXME +;; +;; This is getting out-of hand? Only exceptional chord names that +;; cannot be generated should be here. +;; Maybe we should have inner-jazz-name and inner-american-name functions; +;; +;; +;; +;; DONT use non-ascii characters, even if ``it works'' in Windows + +(define chord::names-alist-jazz '()) +(set! chord::names-alist-jazz + (append + '( + ;; major chords + ; major sixth chord = 6 + (((0 . 0) (2 . 0) (4 . 0) (5 . 0)) . (((raise . 0.5) "6"))) + ; major seventh chord = triangle + (((0 . 0) (2 . 0) (4 . 0) (6 . 0)) . (((raise . 0.5)((font-family . "math") "M")))) + ; major chord add nine = add9 + (((0 . 0) (2 . 0) (4 . 0) (1 . 0)) . (((raise . 0.5) "add9"))) + ; major sixth chord with nine = 6/9 + (((0 . 0) (2 . 0) (4 . 0) (5 . 0) (1 . 0)) . (((raise . 0.5) "6/9"))) + + ;; minor chords + ; minor sixth chord = m6 + (((0 . 0) (2 . -1) (4 . 0) (5 . 0)) . (rows("m")((raise . 0.5) "6"))) + ; minor major seventh chord = m triangle + (((0 . 0) (2 . -1) (4 . 0) (6 . 0)) . (rows ("m") ((raise . 0.5)((font-family . "math") "M")))) + ; minor seventh chord = m7 + (((0 . 0) (2 . -1) (4 . 0) (6 . -1)) . (rows("m")((raise . 0.5) "7"))) + ; minor sixth nine chord = m6/9 + (((0 . 0) (2 . -1) (4 . 0) (5 . 0) (1 . 0)) . (rows("m")((raise . 0.5) "6/9"))) + ; minor with added nine chord = madd9 + (((0 . 0) (2 . -1) (4 . 0) (1 . 0)) . (rows("m")((raise . 0.5) "add9"))) + ; minor ninth chord = m9 + (((0 . 0) (2 . -1) (4 . 0) (6 . -1) (1 . 0)) . (rows("m")((raise . 0.5) "9"))) + + ;; dominant chords + ; dominant seventh = 7 + (((0 . 0) (2 . 0) (4 . 0) (6 . -1)) . (((raise . 0.5) "7"))) + ; augmented dominant = +7 + ;(((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (((raise . 0.5) "+7"))) ; +7 with both raised + (((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (rows("+")((raise . 0.5) "7"))) ; +7 with 7 raised + ;(((0 . 0) (2 . 0) (4 . +1) (6 . -1)) . (rows((raise . 0.5) "7(") + ; ((raise . 0.3)(music (named ("accidentals-1")))) + ; ((raise . 0.5) "5)"))); 7(#5) + ; dominant flat 5 = 7(b5) + (((0 . 0) (2 . 0) (4 . -1) (6 . -1)) . (rows((raise . 0.5) "7(") + ((raise . 0.3)(music (named ("accidentals--1")))) + ((raise . 0.5) "5)"))) + ; dominant 9 = 7(9) + (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0)) . (((raise . 0.8)"7(9)"))) + ; dominant flat 9 = 7(b9) + (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1)) . ( + ((raise . 0.8)"7(") + ((raise . 0.3)(music (named ("accidentals--1")))) + ((raise . 0.8)"9)"))) + ; dominant sharp 9 = 7(#9) + (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1)) . ( + ((raise . 0.8)"7(") + ((raise . 0.3)(music (named ("accidentals-1")))) + ((raise . 0.8)"9)"))) + ; dominant 13 = 7(13) + (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (5 . 0)) . (((raise . 0.8)"7(13)"))) + ; dominant flat 13 = 7(b13) + (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (5 . -1)) . ( + ((raise . 0.8)"7(") + ((raise . 0.3)(music (named ("accidentals--1")))) + ((raise . 0.8)"13)"))) + ; dominant 9, 13 = 7(9,13) + (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0) (5 . 0)) . (((raise . 0.8)"7(9, 13)"))) + ; dominant flat 9, 13 = 7(b9,13) + (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1) (5 . 0)) . ( + ((raise . 0.8)"7(") + ((raise . 0.3)(music (named ("accidentals--1")))) + ((raise . 0.8)"9, 13)"))) + ; dominant sharp 9, 13 = 7(#9,13) + (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1) (5 . 0)) . ( + ((raise . 0.8)"7(") + ((raise . 0.3)(music (named ("accidentals-1")))) + ((raise . 0.8)"9, 13)"))) + ; dominant 9, flat 13 = 7(9,b13) + (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . 0) (5 . -1)) . ( + ((raise . 0.8)"7(9, ") + ((raise . 0.3)(music (named ("accidentals--1")))) + ((raise . 0.8)"13)"))) + ; dominant flat 9, flat 13 = 7(b9,b13) + (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . -1) (5 . -1)) . ( + ((raise . 0.8)"7(") + ((raise . 0.3)(music (named ("accidentals--1")))) + ((raise . 0.8)"9, ") + ((raise . 0.3)(music (named ("accidentals--1")))) + ((raise . 0.8)"13)"))) + ; dominant sharp 9, flat 13 = 7(#9,b13) + (((0 . 0) (2 . 0) (4 . 0) (6 . -1) (1 . +1) (5 . -1)) . ( + ((raise . 0.8)"7(") + ((raise . 0.3)(music (named ("accidentals-1")))) + ((raise . 0.8)"9, ") + ((raise . 0.3)(music (named ("accidentals--1")))) + ((raise . 0.8)"13)"))) + + ;; diminished chord(s) + ; diminished seventh chord = o + + + ;; DONT use non-ascii characters, even if ``it works'' in Windows + + ;;(((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . (((raise . 0.8)"o"))); works, but "o" is a little big + (((0 . 0) (2 . -1) (4 . -1) (6 . -2)) . ((raise . 0.8) (size . -2) ("o"))) + + ;; half diminshed chords + ; half diminished seventh chord = slashed o + (((0 . 0) (2 . -1) (4 . -1) (6 . -1)) . (((raise . 0.8)"/o"))) + ; half diminished seventh chord with major 9 = slashed o cancelation 9 + (((0 . 0) (2 . -1) (4 . -1) (6 . -1) (1 . 0)) . ( + ((raise . 0.8)"/o(") + ((raise . 0.3)(music (named ("accidentals-0")))) + ((raise . 0.8)"9)"))); + +;; Missing jazz chord definitions go here (note new syntax: see american for hints) + + ) + chord::names-alist-american)) + +;;;;;;;;;; + + +(define (pitch->note-name pitch) + (cons (cadr pitch) (caddr pitch))) + +(define (pitch->text pitch) + (cons + (make-string 1 (integer->char (+ (modulo (+ (cadr pitch) 2) 7) 65))) + (if (= (caddr pitch) 0) + '() + (list + (append '(music) + (list + (append '(named) + (list + (append '((font-relative-size . -2)) + (list (append '((raise . 0.6)) + (list + (string-append "accidentals-" + (number->string (caddr pitch))))))))))))))) + +(define (step->text pitch) + (string-append + (number->string (+ (cadr pitch) (if (= (car pitch) 0) 1 8))) + (case (caddr pitch) + ((-2) "--") + ((-1) "-") + ((0) "") + ((1) "+") + ((2) "++")))) + +(define (pitch->text-banter pitch) + (pitch->text pitch)) + +(define (step->text-banter pitch) + (if (= (cadr pitch) 6) + (case (caddr pitch) + ((-2) "7-") + ((-1) "7") + ((0) "maj7") + ((1) "7+") + ((2) "7+")) + (step->text pitch))) + +(define pitch::semitone-vec (list->vector '(0 2 4 5 7 9 11))) + +(define (pitch::semitone pitch) + (+ (* (car pitch) 12) + (vector-ref pitch::semitone-vec (modulo (cadr pitch) 7)) + (caddr pitch))) + +(define (pitch::transpose pitch delta) + (let ((simple-octave (+ (car pitch) (car delta))) + (simple-notename (+ (cadr pitch) (cadr delta)))) + (let ((octave (+ simple-octave (quotient simple-notename 7))) + (notename (modulo simple-notename 7))) + (let ((accidental (- (+ (pitch::semitone pitch) (pitch::semitone delta)) + (pitch::semitone `(,octave ,notename 0))))) + `(,octave ,notename ,accidental))))) + +(define (pitch::diff pitch tonic) + (let ((simple-octave (- (car pitch) (car tonic))) + (simple-notename (- (cadr pitch) (cadr tonic)))) + (let ((octave (+ simple-octave (quotient simple-notename 7) + (if (< simple-notename 0) -1 0))) + (notename (modulo simple-notename 7))) + (let ((accidental (- (pitch::semitone pitch) + (pitch::semitone tonic) + (pitch::semitone `(,octave ,notename 0))))) + `(,octave ,notename ,accidental))))) + +(define (pitch::note-pitch pitch) + (+ (* (car pitch) 7) (cadr pitch))) + +(define (chord::step tonic pitch) + (- (pitch::note-pitch pitch) (pitch::note-pitch tonic))) + +;; text: list of word +;; word: string + optional list of property +;; property: align, kern, font (?), size + +(define chord::minor-major-vec (list->vector '(0 -1 -1 0 -1 -1 0))) + +;; compute the relative-to-tonic pitch that goes with 'step' +(define (chord::step-pitch tonic step) + ;; urg, we only do this for thirds + (if (= (modulo step 2) 0) + '(0 0 0) + (let loop ((i 1) (pitch tonic)) + (if (= i step) pitch + (loop (+ i 2) + (pitch::transpose + pitch `(0 2 ,(vector-ref chord::minor-major-vec + ;; -1 (step=1 -> vector=0) + 7 = 6 + (modulo (+ i 6) 7))))))))) + +;; find the pitches that are not part of `normal' chord +(define (chord::additions chord-pitches) + (let ((tonic (car chord-pitches))) + ;; walk the chord steps: 1, 3, 5 + (let loop ((step 1) (pitches chord-pitches) (additions '())) + (if (pair? pitches) + (let* ((pitch (car pitches)) + (p-step (+ (- (pitch::note-pitch pitch) + (pitch::note-pitch tonic)) + 1))) + ;; pitch is an addition if + (if (or + ;; it comes before this step or + (< p-step step) + ;; its step is even or + (= (modulo p-step 2) 0) + ;; has same step, but different accidental or + (and (= p-step step) + (not (equal? pitch (chord::step-pitch tonic step)))) + ;; is the last of the chord and not one of base thirds + (and (> p-step 5) + (= (length pitches) 1))) + (loop step (cdr pitches) (cons pitch additions)) + (if (= p-step step) + (loop step (cdr pitches) additions) + (loop (+ step 2) pitches additions)))) + (reverse additions))))) + +;; find the pitches that are missing from `normal' chord +(define (chord::subtractions chord-pitches) + (let ((tonic (car chord-pitches))) + (let loop ((step 1) (pitches chord-pitches) (subtractions '())) + (if (pair? pitches) + (let* ((pitch (car pitches)) + (p-step (+ (- (pitch::note-pitch pitch) + (pitch::note-pitch tonic)) + 1))) + ;; pitch is an subtraction if + ;; a step is missing or + (if (> p-step step) + (loop (+ step 2) pitches + (cons (chord::step-pitch tonic step) subtractions)) + ;; there are no pitches left, but base thirds are not yet done and + (if (and (<= step 5) + (= (length pitches) 1)) + ;; present pitch is not missing step + (if (= p-step step) + (loop (+ step 2) pitches subtractions) + (loop (+ step 2) pitches + (cons (chord::step-pitch tonic step) subtractions))) + (if (= p-step step) + (loop (+ step 2) (cdr pitches) subtractions) + (loop step (cdr pitches) subtractions))))) + (reverse subtractions))))) + +;; combine tonic, user-specified chordname, +;; additions, subtractions and base or inversion to chord name +;; +(define (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion) + (apply append + '(rows) + (pitch->text-banter tonic) + (if user-name user-name '()) + ;; why does list->string not work, format seems only hope... + (if (and (string-match "super" (format "~s" user-name)) + (or (pair? additions) + (pair? subtractions))) + '((super "/")) + '()) + (let loop ((from additions) (to '())) + (if (pair? from) + (let ((p (car from))) + (loop (cdr from) + (append to + (cons + (list 'super (step->text-banter p)) + (if (or (pair? (cdr from)) + (pair? subtractions)) + '((super "/")) + '()))))) + to)) + (let loop ((from subtractions) (to '())) + (if (pair? from) + (let ((p (car from))) + (loop (cdr from) + (append to + (cons '(super "no") + (cons + (list 'super (step->text-banter p)) + (if (pair? (cdr from)) + '((super "/")) + '())))))) ; nesting? + to)) + (if (and (pair? base-and-inversion) + (or (car base-and-inversion) + (cdr base-and-inversion))) + (cons "/" (append + (if (car base-and-inversion) + (pitch->text + (car base-and-inversion)) + (pitch->text + (cdr base-and-inversion))) + '())) + '()) + '())) + +(define (chord::name-banter tonic user-name pitches base-and-inversion) + (let ((additions (chord::additions pitches)) + (subtractions (chord::subtractions pitches))) + (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion))) + +;; american chordnames use no "no", +;; but otherwise very similar to banter for now +(define (chord::name-american tonic user-name pitches base-and-inversion) + (let ((additions (chord::additions pitches)) + (subtractions #f)) + (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion))) + +;; Jazz style--basically similar to american with minor changes +(define (chord::name-jazz tonic user-name pitches base-and-inversion) + (let ((additions (chord::additions pitches)) + (subtractions #f)) + (chord::inner-name-banter tonic user-name additions subtractions base-and-inversion))) + +(define (new-to-old-pitch p) + (if (pitch? p) + (list (pitch-octave p) (pitch-notename p) (pitch-alteration p)) + #f + )) + + + +;; C++ entry point +;; +;; Check for each subset of chord, full chord first, if there's a +;; user-override. Split the chord into user-overridden and to-be-done +;; parts, complete the missing user-override matched part with normal +;; chord to be name-calculated. +;; +;; CHORD: (pitches (base . inversion)) +(define (default-chord-name-function style chord) + (let* ((pitches (map new-to-old-pitch (car chord))) + (modifiers (cdr chord)) + (base-and-inversion (if (pair? modifiers) + (cons (new-to-old-pitch (car modifiers)) + (new-to-old-pitch (cdr modifiers))) + '(() . ()))) + (diff (pitch::diff '(0 0 0) (car pitches))) + (name-func + (ly-eval (string->symbol (string-append "chord::name-" style)))) + (names-alist + (ly-eval (string->symbol (string-append "chord::names-alist-" style))))) + (let loop ((note-names (reverse pitches)) + (chord '()) + (user-name #f)) + (if (pair? note-names) + (let ((entry (assoc + (reverse + (map (lambda (x) + (pitch->note-name (pitch::transpose x diff))) + note-names)) + names-alist))) + (if entry + ;; urg? found: break loop + (loop '() chord (cdr entry)) + (loop (cdr note-names) (cons (car note-names) chord) #f))) + (let* ((transposed (if pitches + (map (lambda (x) (pitch::transpose x diff)) chord) + '())) + (matched (if (= (length chord) 0) + 3 + (- (length pitches) (length chord)))) + (completed + (append (do ((i matched (- i 1)) + (base '() (cons `(0 ,(* (- i 1) 2) 0) base))) + ((= i 0) base) + ()) + transposed))) + (name-func (car pitches) user-name completed base-and-inversion)))))) + +