X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fchord-generic-names.scm;h=9ee26dee584fff50df16c5f48d9ca809863e14c9;hb=5b4b0d6e9a197e8f9eb085b7c2ad78b8be3e5cfc;hp=8caaa4c8d0ea304f56c923a574e93f565be19c24;hpb=9f8e04c4008b5f50ee2f771568d18df50764e0f5;p=lilypond.git diff --git a/scm/chord-generic-names.scm b/scm/chord-generic-names.scm index 8caaa4c8d0..9ee26dee58 100644 --- a/scm/chord-generic-names.scm +++ b/scm/chord-generic-names.scm @@ -1,8 +1,8 @@ -;;;; double-plus-new-chord-name.scm -- Compile chord names +;;;; chord-generic-names.scm -- Compile chord names ;;;; ;;;; source file of the GNU LilyPond music typesetter -;;;; -;;;; (c) 2003 Jan Nieuwenhuizen +;;;; +;;;; (c) 2003--2008 Jan Nieuwenhuizen ;;;; NOTE: this is experimental code @@ -24,15 +24,11 @@ (define-public (banter-chord-names pitches bass inversion context) (ugh-compat-double-plus-new-chord->markup - 'banter pitches bass inversion context '()) - ) - + 'banter pitches bass inversion context '())) (define-public (jazz-chord-names pitches bass inversion context) (ugh-compat-double-plus-new-chord->markup - 'jazz pitches bass inversion context '()) - ) - + 'jazz pitches bass inversion context '())) (define-public (ugh-compat-double-plus-new-chord->markup style pitches bass inversion context options) @@ -45,26 +41,25 @@ BASS and INVERSION are lily pitches. OPTIONS is an alist-alist (see input/test/dpncnt.ly). " - (define (step-nr pitch) (let* ((pitch-nr (+ (* 7 (ly:pitch-octave pitch)) (ly:pitch-notename pitch))) (root-nr (+ (* 7 (ly:pitch-octave (car pitches))) (ly:pitch-notename (car pitches))))) (+ 1 (- pitch-nr root-nr)))) - + (define (next-third pitch) (ly:pitch-transpose pitch (ly:make-pitch 0 2 (if (or (= (step-nr pitch) 3) (= (step-nr pitch) 5)) - -1 0)))) + FLAT 0)))) (define (step-alteration pitch) (let* ((diff (ly:pitch-diff (ly:make-pitch 0 0 0) (car pitches))) (normalized-pitch (ly:pitch-transpose pitch diff)) (alteration (ly:pitch-alteration normalized-pitch))) - (if (= (step-nr pitch) 7) (+ alteration 1) alteration))) - + (if (= (step-nr pitch) 7) (+ alteration SEMI-TONE) alteration))) + (define (pitch-unalter pitch) (let ((alteration (step-alteration pitch))) (if (= alteration 0) @@ -84,12 +79,12 @@ input/test/dpncnt.ly). (make-simple-markup (number->string (step-nr pitch))) (make-simple-markup (case (step-alteration pitch) - ((-2) "--") - ((-1) "-") - ((0) "") - ((1) "+") - ((2) "++")))))) - + ((DOUBLE-FLAT) "--") + ((FLAT) "-") + ((NATURAL) "") + ((SHARP) "+") + ((DOUBLE-SHARP) "++")))))) + (define (step->markup-accidental pitch) (make-line-markup (list (accidental->markup (step-alteration pitch)) @@ -99,19 +94,19 @@ input/test/dpncnt.ly). (make-line-markup (if (and (= (step-nr pitch) 7) (= (step-alteration pitch) 1)) - (list (ly:get-context-property context 'majorSevenSymbol)) + (list (ly:context-property context 'majorSevenSymbol)) (list (accidental->markup (step-alteration pitch)) (make-simple-markup (number->string (step-nr pitch))))))) - + ;; tja, kennok (define (make-sub->markup step->markup) (lambda (pitch) (make-line-markup (list (make-simple-markup "no") (step->markup pitch))))) - + (define (step-based-sub->markup step->markup pitch) (make-line-markup (list (make-simple-markup "no") (step->markup pitch)))) - + (define (get-full-list pitch) (if (<= (step-nr pitch) (step-nr (last pitches))) (cons pitch (get-full-list (next-third pitch))) @@ -139,19 +134,19 @@ input/test/dpncnt.ly). (if (pair? exceptions) (let* ((e (car exceptions)) (e-pitches (car e))) - (if (equal? e-pitches (take pitches (length e-pitches) )) + (if (equal? e-pitches (take pitches (length e-pitches))) e (partial-match (cdr exceptions)))) #f)) - (if #f (begin + (if #f (begin (write-me "pitches: " pitches))) (let* ((full-exceptions - (ly:get-context-property context 'chordNameExceptionsFull)) + (ly:context-property context 'chordNameExceptionsFull)) (full-exception (full-match full-exceptions)) (full-markup (if full-exception (cadr full-exception) '())) (partial-exceptions - (ly:get-context-property context 'chordNameExceptionsPartial)) + (ly:context-property context 'chordNameExceptionsPartial)) (partial-exception (partial-match partial-exceptions)) (partial-pitches (if partial-exception (car partial-exception) '())) (partial-markup-prefix @@ -165,9 +160,9 @@ input/test/dpncnt.ly). ;; kludge alert: replace partial matched lower part of all with ;; 'normal' pitches from full ;; (all pitches) - (all (append (take full (length partial-pitches) ) - (drop pitches (length partial-pitches) ))) - + (all (append (take full (length partial-pitches)) + (drop pitches (length partial-pitches)))) + (highest (last all)) (missing (list-minus full (map pitch-unalter all))) (consecutive (get-consecutive 1 all)) @@ -175,7 +170,7 @@ input/test/dpncnt.ly). (altered (filter step-even-or-altered? all)) (cons-alt (filter step-even-or-altered? consecutive)) (base (list-minus consecutive altered))) - + (if #f (begin (write-me "full:" full) @@ -195,22 +190,22 @@ input/test/dpncnt.ly). ;; root ;; + steps:altered + (highest all -- if not altered) ;; + subs:missing - - (let* ((root->markup (assoc-get-default + + (let* ((root->markup (assoc-get 'root->markup options note-name->markup)) - (step->markup (assoc-get-default + (step->markup (assoc-get 'step->markup options step->markup-plusminus)) - (sub->markup (assoc-get-default + (sub->markup (assoc-get 'sub->markup options (lambda (x) (step-based-sub->markup step->markup x)))) - (sep (assoc-get-default + (sep (assoc-get 'separator options (make-simple-markup "/")))) - + (if (pair? full-markup) (make-line-markup (list (root->markup root) full-markup)) - + (make-line-markup (list (root->markup root) @@ -227,29 +222,29 @@ input/test/dpncnt.ly). (list partial-markup-suffix) (list (map sub->markup missing))) sep))))))) - - + + ((jazz) ;; root ;; + steps:(highest base) + cons-alt ;; + 'add' ;; + steps:rest - (let* ((root->markup (assoc-get-default + (let* ((root->markup (assoc-get 'root->markup options note-name->markup)) (step->markup - (assoc-get-default + (assoc-get ;; FIXME: ignatzek ;;'step->markup options step->markup-accidental)) 'step->markup options step->markup-ignatzek)) - (sep (assoc-get-default + (sep (assoc-get 'separator options (make-simple-markup " "))) - (add-prefix (assoc-get-default 'add-prefix options + (add-prefix (assoc-get 'add-prefix options (make-simple-markup " add")))) - + (if (pair? full-markup) (make-line-markup (list (root->markup root) full-markup)) - + (make-line-markup (list (root->markup root) @@ -257,11 +252,11 @@ input/test/dpncnt.ly). (make-normal-size-super-markup (make-line-markup (list - + ;; kludge alert: omit <= 5 ;;(markup-join (map step->markup ;; (cons (last base) cons-alt)) sep) - + ;; This fixes: ;; c C5 -> C ;; c:2 C5 2 -> C2 @@ -273,11 +268,11 @@ input/test/dpncnt.ly). (if (> (step-nr tb) 5) (cons tb cons-alt) cons-alt))) sep) - + (if (pair? rest) add-prefix empty-markup) (markup-join (map step->markup rest) sep) partial-markup-suffix)))))))) - + (else empty-markup))))