X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fchord-generic-names.scm;h=d1c8005c4a6dd583b45ddbc1a3d1646098eb34b0;hb=HEAD;hp=923cddd2cfa027d9be00302d9aeeb44e8ea37e04;hpb=d4ba37c298813e0f7008ef8388e126c34d8f8dd3;p=lilypond.git

diff --git a/scm/chord-generic-names.scm b/scm/chord-generic-names.scm
index 923cddd2cf..d1c8005c4a 100644
--- a/scm/chord-generic-names.scm
+++ b/scm/chord-generic-names.scm
@@ -1,8 +1,19 @@
-;;;; chord-generic-names.scm -- Compile chord names
+;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;
-;;;;  source file of the GNU LilyPond music typesetter
+;;;; Copyright (C) 2003--2015 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;;;
-;;;; (c) 2003--2007 Jan Nieuwenhuizen <janneke@gnu.org>
+;;;; LilyPond is free software: you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation, either version 3 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; LilyPond is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
 
 
 ;;;; NOTE: this is experimental code
@@ -10,6 +21,10 @@
 ;;;; Naming of the base chord (steps 1-5) is handled by exceptions only
 ;;;; see input/test/chord-names-dpnj.ly
 
+
+(define (default-note-namer pitch)
+  (note-name->markup pitch #f))
+
 (define (markup-or-empty-markup markup)
   "Return MARKUP if markup, else empty-markup"
   (if (markup? markup) markup empty-markup))
@@ -19,7 +34,7 @@
   (if bool
       (make-line-markup
        (list (make-hspace-markup amount)
-	     markup))
+             markup))
       markup))
 
 (define-public (banter-chord-names pitches bass inversion context)
@@ -31,47 +46,46 @@
    'jazz pitches bass inversion context '()))
 
 (define-public (ugh-compat-double-plus-new-chord->markup
-		style pitches bass inversion context options)
-  "Entry point for New_chord_name_engraver.
+                style pitches bass inversion context options)
+  "Entry point for @code{New_chord_name_engraver}.
 
 FIXME: func, options/context have changed
- See
-double-plus-new-chord-name.scm for the signature of STYLE.  PITCHES,
-BASS and INVERSION are lily pitches.  OPTIONS is an alist-alist (see
-input/test/dpncnt.ly).
- "
+
+See @file{double-plus-new-chord-name.scm} for the signature of @var{style}.
+@var{pitches}, @var{bass}, and @var{inversion} are lily pitches.
+@var{options} is an alist-alist (see @file{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)))))
+                        (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))
-					       FLAT 0))))
+                        (ly:make-pitch 0 2 (if (or (= (step-nr pitch) 3)
+                                                   (= (step-nr pitch) 5))
+                                               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)))
+           (normalized-pitch (ly:pitch-transpose pitch diff))
+           (alteration (ly:pitch-alteration normalized-pitch)))
       (if (= (step-nr pitch) 7) (+ alteration SEMI-TONE) alteration)))
 
   (define (pitch-unalter pitch)
     (let ((alteration (step-alteration pitch)))
       (if (= alteration 0)
-	  pitch
-	  (ly:make-pitch (ly:pitch-octave pitch) (ly:pitch-notename pitch)
-			 (- (ly:pitch-alteration pitch) alteration)))))
+          pitch
+          (ly:make-pitch (ly:pitch-octave pitch) (ly:pitch-notename pitch)
+                         (- (ly:pitch-alteration pitch) alteration)))))
 
   (define (step-even-or-altered? pitch)
     (let ((nr (step-nr pitch)))
       (if (!= (modulo nr 2) 0)
-	  (!= (step-alteration pitch) 0)
-	  #t)))
+          (!= (step-alteration pitch) 0)
+          #t)))
 
   (define (step->markup-plusminus pitch)
     (make-line-markup
@@ -79,111 +93,111 @@ input/test/dpncnt.ly).
       (make-simple-markup (number->string (step-nr pitch)))
       (make-simple-markup
        (case (step-alteration pitch)
-	 ((DOUBLE-FLAT) "--")
-	 ((FLAT) "-")
-	 ((NATURAL) "")
-	 ((SHARP) "+")
-	 ((DOUBLE-SHARP) "++"))))))
+         ((DOUBLE-FLAT) "--")
+         ((FLAT) "-")
+         ((NATURAL) "")
+         ((SHARP) "+")
+         ((DOUBLE-SHARP) "++"))))))
 
   (define (step->markup-accidental pitch)
     (make-line-markup
      (list (accidental->markup (step-alteration pitch))
-	   (make-simple-markup (number->string (step-nr pitch))))))
+           (make-simple-markup (number->string (step-nr pitch))))))
 
   (define (step->markup-ignatzek pitch)
     (make-line-markup
      (if (and (= (step-nr pitch) 7)
-	      (= (step-alteration pitch) 1))
-	 (list (ly:context-property context 'majorSevenSymbol))
-	 (list (accidental->markup (step-alteration pitch))
-	       (make-simple-markup (number->string (step-nr pitch)))))))
-	
+              (= (step-alteration pitch) 1))
+         (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)))))
-			
+                              (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)))
-	'()))
+        (cons pitch (get-full-list (next-third pitch)))
+        '()))
 
   (define (get-consecutive nr pitches)
     (if (pair? pitches)
-	(let* ((pitch-nr (step-nr (car pitches)))
-	       (next-nr (if (!= (modulo pitch-nr 2) 0) (+ pitch-nr 2) nr)))
-	  (if (<= pitch-nr nr)
-	      (cons (car pitches) (get-consecutive next-nr (cdr pitches)))
-	      '()))
-	'()))
+        (let* ((pitch-nr (step-nr (car pitches)))
+               (next-nr (if (!= (modulo pitch-nr 2) 0) (+ pitch-nr 2) nr)))
+          (if (<= pitch-nr nr)
+              (cons (car pitches) (get-consecutive next-nr (cdr pitches)))
+              '()))
+        '()))
 
   (define (full-match exceptions)
     (if (pair? exceptions)
-	(let* ((e (car exceptions))
-	       (e-pitches (car e)))
-	  (if (equal? e-pitches pitches)
-	      e
-	      (full-match (cdr exceptions))))
-	#f))
+        (let* ((e (car exceptions))
+               (e-pitches (car e)))
+          (if (equal? e-pitches pitches)
+              e
+              (full-match (cdr exceptions))))
+        #f))
 
   (define (partial-match exceptions)
     (if (pair? exceptions)
-	(let* ((e (car exceptions))
-	       (e-pitches (car e)))
-	  (if (equal? e-pitches (take pitches (length e-pitches)))
-	      e
-	      (partial-match (cdr exceptions))))
-	#f))
+        (let* ((e (car exceptions))
+               (e-pitches (car e)))
+          (if (equal? e-pitches (take pitches (length e-pitches)))
+              e
+              (partial-match (cdr exceptions))))
+        #f))
 
   (if #f (begin
-	   (write-me "pitches: " pitches)))
+           (write-me "pitches: " pitches)))
   (let* ((full-exceptions
-	  (ly:context-property context 'chordNameExceptionsFull))
-	 (full-exception (full-match full-exceptions))
-	 (full-markup (if full-exception (cadr full-exception) '()))
-	 (partial-exceptions
-	  (ly:context-property context 'chordNameExceptionsPartial))
-	 (partial-exception (partial-match partial-exceptions))
-	 (partial-pitches (if partial-exception (car partial-exception) '()))
-	 (partial-markup-prefix
-	  (if partial-exception (markup-or-empty-markup
-				 (cadr partial-exception)) empty-markup))
-	 (partial-markup-suffix
-	  (if (and partial-exception (pair? (cddr partial-exception)))
-	      (markup-or-empty-markup (caddr partial-exception)) empty-markup))
-	 (root (car pitches))
-	 (full (get-full-list root))
-	 ;; 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))))
-	
-	 (highest (last all))
-	 (missing (list-minus full (map pitch-unalter all)))
-	 (consecutive (get-consecutive 1 all))
-	 (rest (list-minus all consecutive))
-	 (altered (filter step-even-or-altered? all))
-	 (cons-alt (filter step-even-or-altered? consecutive))
-	 (base (list-minus consecutive altered)))
-	
+          (ly:context-property context 'chordNameExceptionsFull))
+         (full-exception (full-match full-exceptions))
+         (full-markup (if full-exception (cadr full-exception) '()))
+         (partial-exceptions
+          (ly:context-property context 'chordNameExceptionsPartial))
+         (partial-exception (partial-match partial-exceptions))
+         (partial-pitches (if partial-exception (car partial-exception) '()))
+         (partial-markup-prefix
+          (if partial-exception (markup-or-empty-markup
+                                 (cadr partial-exception)) empty-markup))
+         (partial-markup-suffix
+          (if (and partial-exception (pair? (cddr partial-exception)))
+              (markup-or-empty-markup (caddr partial-exception)) empty-markup))
+         (root (car pitches))
+         (full (get-full-list root))
+         ;; 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))))
+
+         (highest (last all))
+         (missing (list-minus full (map pitch-unalter all)))
+         (consecutive (get-consecutive 1 all))
+         (rest (list-minus all consecutive))
+         (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)
-	      ;; (write-me "partial-pitches:" partial-pitches)
-	      (write-me "full-markup:" full-markup)
-	      (write-me "partial-markup-perfix:" partial-markup-prefix)
-	      (write-me "partial-markup-suffix:" partial-markup-suffix)
-	      (write-me "all:" all)
-	      (write-me "altered:" altered)
-	      (write-me "missing:" missing)
-	      (write-me "consecutive:" consecutive)
-	      (write-me "rest:" rest)
-	      (write-me "base:" base)))
+             (write-me "full:" full)
+             ;; (write-me "partial-pitches:" partial-pitches)
+             (write-me "full-markup:" full-markup)
+             (write-me "partial-markup-perfix:" partial-markup-prefix)
+             (write-me "partial-markup-suffix:" partial-markup-suffix)
+             (write-me "all:" all)
+             (write-me "altered:" altered)
+             (write-me "missing:" missing)
+             (write-me "consecutive:" consecutive)
+             (write-me "rest:" rest)
+             (write-me "base:" base)))
 
     (case style
       ((banter)
@@ -192,36 +206,36 @@ input/test/dpncnt.ly).
        ;;    + subs:missing
 
        (let* ((root->markup (assoc-get
-			      'root->markup options note-name->markup))
-	      (step->markup (assoc-get
-			     'step->markup options step->markup-plusminus))
-	      (sub->markup (assoc-get
-			    'sub->markup options
-			    (lambda (x)
-			      (step-based-sub->markup step->markup x))))
-	      (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)
-	    partial-markup-prefix
-	    (make-normal-size-super-markup
-	     (markup-join
-	      (apply append
-		     (map step->markup
-			  (append altered
-				  (if (and (> (step-nr highest) 5)
-					   (not
-					    (step-even-or-altered? highest)))
-				      (list highest) '())))
-		      (list partial-markup-suffix)
-		     (list (map sub->markup missing)))
-	      sep)))))))
+                             'root->markup options default-note-namer))
+              (step->markup (assoc-get
+                             'step->markup options step->markup-plusminus))
+              (sub->markup (assoc-get
+                            'sub->markup options
+                            (lambda (x)
+                              (step-based-sub->markup step->markup x))))
+              (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)
+            partial-markup-prefix
+            (make-normal-size-super-markup
+             (markup-join
+              (append
+               (map step->markup
+                    (append altered
+                            (if (and (> (step-nr highest) 5)
+                                     (not
+                                      (step-even-or-altered? highest)))
+                                (list highest) '())))
+               (list partial-markup-suffix)
+               (map sub->markup missing))
+              sep)))))))
 
 
       ((jazz)
@@ -230,49 +244,49 @@ input/test/dpncnt.ly).
        ;;    + 'add'
        ;;    + steps:rest
        (let* ((root->markup (assoc-get
-			      'root->markup options note-name->markup))
-	      (step->markup
-	       (assoc-get
-		;; FIXME: ignatzek
-		;;'step->markup options step->markup-accidental))
-		'step->markup options step->markup-ignatzek))
-	      (sep (assoc-get
-		    'separator options (make-simple-markup " ")))
-	      (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)
-	    partial-markup-prefix
-	    (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
-	       ;;  c:3-  Cm5      -> Cm
-	       ;;  c:6.9 C5 6add9 -> C6 add 9 (add?)
-	       ;;  ch = \chords { c c:2 c:3- c:6.9^7 }
-	       (markup-join (map step->markup
-  				 (let ((tb (last base)))
-  				   (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))))
+                             'root->markup options default-note-namer))
+              (step->markup
+               (assoc-get
+                ;; FIXME: ignatzek
+                ;;'step->markup options step->markup-accidental))
+                'step->markup options step->markup-ignatzek))
+              (sep (assoc-get
+                    'separator options (make-simple-markup " ")))
+              (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)
+            partial-markup-prefix
+            (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
+               ;;  c:3-  Cm5      -> Cm
+               ;;  c:6.9 C5 6add9 -> C6 add 9 (add?)
+               ;;  ch = \chords { c c:2 c:3- c:6.9^7 }
+               (markup-join (map step->markup
+                                 (let ((tb (last base)))
+                                   (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))))