* input/test/chord-names-dpnj.ly: New file.

* scm/double-plus-new-chord-name.scm: Implement full and partial
exceptions.

* lily/lexer.ll: <markup>: Allow dash and hyphen in markup command.

* scm/double-plus-new-chord-name.scm
(double-plus-new-chord->markup): Fix sub->markup.

diff --git a/ChangeLog b/ChangeLog
index 556f19ed2d2ec3499b1eb8b5bb7df99034b79f79..de74412aa451c4e0f7d71fc16e0831498776074b 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,15 @@
+2003-01-07  Jan Nieuwenhuizen  <janneke@gnu.org>
+
+       * input/test/chord-names-dpnj.ly: New file.
+
+       * scm/double-plus-new-chord-name.scm: Implement full and partial
+       exceptions.
+
+       * lily/lexer.ll: <markup>: Allow dash and hyphen in markup command.
+
+       * scm/double-plus-new-chord-name.scm
+       (double-plus-new-chord->markup): Fix sub->markup.
+
 
 2003-01-07  Juergen Reuter  <reuter@ipd.uka.de>
 
@@ -48,11 +60,6 @@
 
        * scripts/convert-ly.py: add ly:pitch-transpose rule
 
-2003-01-07  Jan Nieuwenhuizen  <janneke@gnu.org>
-
-       * scm/double-plus-new-chord-name.scm
-       (double-plus-new-chord->markup): Fix sub->markup.
-
 2003-01-06  Jan Nieuwenhuizen  <janneke@gnu.org>
 
        * input/test/dpncnt.ly: New file.

diff --git a/input/test/chord-names-dpnj.ly b/input/test/chord-names-dpnj.ly
new file mode 100644 (file)
index 0000000..e22b284
--- /dev/null
+++ b/input/test/chord-names-dpnj.ly
@@ -0,0 +1,107 @@
+\header {
+    texidoc = "Chord name scheme test -- double-plus-new-chord-name jazz"
+}
+
+\version "1.7.11"
+
+
+
+%% This should only be necessary if your kpathsea setup is broken
+%
+% Make sure the correct msamxx.tfm is where lily can find it
+% (ie cwd or lily's tfm dir).
+%
+% For normal (20pt) paper, do
+%
+%   cp $(locate msam9.tfm) $LILYPONDPREFIX/fonts/tfm
+%
+
+scheme = \chords {
+  % major chords
+  c
+  c:6          % 6 = major triad with added sixth
+  c:maj                % triangle = maj
+  c:6.9^7      % 6/9 
+  c:9^7                % add9
+
+  % minor chords
+  c:m          % m = minor triad
+  c:m.6                % m6 = minor triad with added sixth
+  c:m.7+       % m triangle = minor major seventh chord
+  c:3-.6.9^7   % m6/9 
+  c:m.7                % m7
+  c:3-.9       % m9
+  c:3-.9^7     % madd9
+
+  % dominant chords
+  c:7          % 7 = dominant
+  c:7.5+       % +7 = augmented dominant
+  c:7.5-       % 7b5 = hard diminished dominant
+  c:9          % 7(9)
+  c:9-         % 7(b9)
+  c:9+         % 7(#9)
+  c:13^9.11    % 7(13)
+  c:13-^9.11   % 7(b13)
+  c:13^11      % 7(9,13)
+  c:13.9-^11   % 7(b9,13)
+  c:13.9+^11   % 7(#9,13)
+  c:13-^11     % 7(9,b13)
+  c:13-.9-^11  % 7(b9,b13)
+  c:13-.9+^11  % 7(#9,b13)
+
+  % half diminished chords
+  c:m5-.7              % slashed o = m7b5
+  c:9.3-.5-    % o/7(pure 9)
+
+  % diminished chords
+  c:m5-.7-     % o = diminished seventh chord
+}
+
+efull = \chordnames {
+
+    %% ? what 'bout maj7?
+    %% c:7 = \markup { \normal-size-super "maj7" }
+
+    %% Choose your symbol for the fully diminished chord
+    %% American:
+    %% c:3-.5-.7- = \markup { "dim" }
+    %% Jazz:
+    c:3-.5-.7- = \markup { \super " o" }
+
+    %% Hmm
+    %%            ;;Pick your favorite maj7
+    %%    ((0) mathm-markup-object)  ;;a white triangle
+    %%    ;;((0) mathn-markup-object) ;;a black triangle
+    %% ;;((0) (make-simple-markup "maj7")) ;;good old maj7
+
+    %% This ok?
+    c:7+ = \markup { \normal-size-super \override #'(font-family . math) "N" }
+    %%c:3.5.7 = \markup { \override #'(font-family . math) "M" }
+    %%c:3.5.7 = \markup { \normal-size-super "maj7" }
+}
+
+epartial = \chordnames {
+    c:2^3 = \markup { \normal-size-super "2" }
+    c:3-  = \markup { "m" }
+    c:4   = \markup { \normal-size-super "sus4" }
+    c:5^3 = \markup { \normal-size-super "5" }
+}
+
+\score {
+  \notes <
+    \context ChordNames {
+       
+       %#(set-double-plus-new-chord-name-style 'banter
+       %   `((separator . ,(make-simple-markup ":"))
+       %     (full-exceptions . ,efull)
+       %     (partial-exceptions . ,epartial)))
+       
+       #(set-double-plus-new-chord-name-style 'jazz
+          `((separator . ,(make-simple-markup ":"))
+            (full-exceptions . ,efull)
+            (partial-exceptions . ,epartial)))
+       \scheme }
+    \context Staff \transpose c c' \scheme
+  >
+}
+%% new-chords-done %%

diff --git a/input/test/dpncnt.ly b/input/test/dpncnt.ly
index fbdf2696b118986dc84a9b1ba557dd926429ed88..f4aa954596738326e0f89ebfcf18980ad919ef95 100644 (file)
--- a/input/test/dpncnt.ly
+++ b/input/test/dpncnt.ly
@@ -1,13 +1,38 @@
+\header {
+1    texidoc = "test file for new-new-chord names, ie, double-plus-new-chord-name"
+}
 
 efull = \chordnames {
-    c:3-.5-.7- = \markup { \super "didem" }
-    c:7+ = \markup { \super "maj7" }
+
+    %% ? what 'bout maj7?
+    %% c:7 = \markup { \normal-size-super "maj7" }
+
+    %% Choose your symbol for the fully diminished chord
+    %% American:
+    %% c:3-.5-.7- = \markup { "dim" }
+    %% Jazz:
+    c:3-.5-.7- = \markup { \super " o" }
+
+    %% Hmm
+    %%            ;;Pick your favorite maj7
+    %%    ((0) mathm-markup-object)  ;;a white triangle
+    %%    ;;((0) mathn-markup-object) ;;a black triangle
+    %% ;;((0) (make-simple-markup "maj7")) ;;good old maj7
+
+    %% This ok?
+    c:7+ = \markup { \normal-size-super \override #'(font-family . math) "N" }
+    %%c:3.5.7 = \markup { \override #'(font-family . math) "M" }
+    %%c:3.5.7 = \markup { \normal-size-super "maj7" }
 }
 
 epartial = \chordnames {
-    c:3- = \markup { "dim" }
+    c:2^3 = \markup { \normal-size-super "2" }
+    c:3-  = \markup { "m" }
+    c:4   = \markup { \normal-size-super "sus4" }
+    c:5^3 = \markup { \normal-size-super "5" }
 }
 
+
 xch = \chords { c:7+.9-^3.5 c:dim }
 
 xch = \chords { c:13-.9+^11 }
@@ -34,6 +59,7 @@ ch = \chords { c c:m c:7 c:7.9 c:7+.9 c:7.9+ c:9^7 c:3.11^7 }
 
 %ch = \chords { c:9^7 c:5^3}
 
+ch = \chords { c:3- c:3 c:2 c:7+ c:3-.5-.7- c:6.9^7 }
 
 \score{
     <

diff --git a/lily/lexer.ll b/lily/lexer.ll
index 8661688a36d0aa98ef49168468aac9b61ace2a6d..91b25c1b393086bf603b783ad6250a0610a32736 100644 (file)
--- a/lily/lexer.ll
+++ b/lily/lexer.ll
@@ -124,6 +124,7 @@ HORIZONTALWHITE             [ \t]
 BLACK          [^ \n\t\f\r]
 RESTNAME       [rs]
 NOTECOMMAND    \\{A}+
+MARKUPCOMMAND  \\({A}|[-_])+
 LYRICS         ({AA}|{TEX})[^0-9 \t\n\f]*
 ESCAPED                [nt\\'"]
 EXTENDER       __
@@ -441,7 +442,7 @@ HYPHEN              --
        \" {
                start_quote ();
        }
-       {NOTECOMMAND} {
+       {MARKUPCOMMAND} {
                String str (YYText() + 1);
                SCM s = lookup_markup_command (str);
 

diff --git a/scm/chord-name.scm b/scm/chord-name.scm
index 3f48cc88b5b1af816a1d6383c45e36eb7382d4bd..cb364402b55a10fd53d69a5fd09674e31485c6eb 100644 (file)
--- a/scm/chord-name.scm
+++ b/scm/chord-name.scm
@@ -15,7 +15,7 @@
    )
 
 
-(define-public (write-me x)
+(define (write-me x)
   "Write and return X. For debugging purposes. "
   (write x) (newline) x)
 

diff --git a/scm/double-plus-new-chord-name.scm b/scm/double-plus-new-chord-name.scm
index 11c2e71850303425c6bbb1a6e5c41e32bd36005b..a5c9836a8e881a0e1dc8e09db937aca734d3a585 100644 (file)
--- a/scm/double-plus-new-chord-name.scm
+++ b/scm/double-plus-new-chord-name.scm
@@ -5,9 +5,9 @@
 ;;;; (c) 2003 Jan Nieuwenhuizen <janneke@gnu.org>
 
 ;;;; NOTE: this is experimental code
-;;;; It only handles naming for steps 5 and up
-;;;; There's no code for naming the base chord (steps 1-5)
-;;;; or exceptions.
+;;;; Base and inversion are ignored.
+;;;; Naming of the base chord (steps 1-5) is handled by exceptions only
+;;;; see input/test/chord-names-dpnj.ly
 
 
 (define-module (scm double-plus-new-chord-name))
@@ -20,10 +20,20 @@
 
 (define this-module (current-module))
 
-(define (tail x)
-  (car (reverse x)))
+
+;; SCM utilily functions
+
+(define (write-me message x)
+  "Return X.  Display MESSAGE and write X.  Handy for debugging, possibly turned off."
+;;  (display message) (write x) (newline) x)
+  x)
+
+(define (tail lst)
+  "Return tail element of LST."
+  (car (reverse lst)))
 
 (define (list-minus a b)
+  "Return list of elements in A that are not in B."
   (if (pair? a)
       (if (pair? b)
          (if (member (car a) b)
@@ -32,17 +42,48 @@
          a)
       '()))
 
-(define (assoc-default key alist default)
-  (let ((value (assoc key alist)))
-    (if value (cdr value) default)))
-        
+(define (first-n n lst)
+  "Return first N elements of LST"
+  (if (and (pair? lst)
+          (> n 0))
+      (cons (car lst) (first-n (- n 1) (cdr lst)))
+      '()))
+
+(define (butfirst-n n lst)
+  "Return all but first N entries of LST"
+  (if (pair? lst)
+      (if (> n 0)
+         (butfirst-n (- n 1) (cdr lst))
+         lst)
+      '()))
+  
+(define (assoc-get key alist)
+  "Return value if KEY in ALIST, else #f."
+  (let ((entry (assoc key alist)))
+    (if entry (cdr entry) #f)))
+  
+(define (assoc-get-default key alist default)
+  "Return value if KEY in ALIST, else DEFAULT."
+  (let ((entry (assoc key alist)))
+    (if entry (cdr entry) default)))
+
+
+;; MARKUP functions
 (define (markup-join markups sep)
   "Return line-markup of MARKUPS, joining them with markup SEP"
   (if (pair? markups)
       (make-line-markup (reduce-list markups sep))
       empty-markup))
 
+(define (markup-or-empty-markup markup)
+  "Return MARKUP if markup, else empty-markup"
+  (if (markup? markup) markup empty-markup))
+
+
+;; Generic PITCH/MARKUP functions
 (define (ly:pitch-diff pitch tonic)
+  "Return pitch with value PITCH - TONIC, ie,
+TONIC == (ly:pitch-transpose tonic delta)."
   (let ((simple-octave (- (ly:pitch-octave pitch) (ly:pitch-octave tonic)))
        (simple-notename
         (- (ly:pitch-notename pitch) (ly:pitch-notename tonic))))
@@ -64,6 +105,7 @@
        (string-append "accidentals-" (number->string alteration))))))
 
 (define (pitch->markup pitch)
+  "Return pitch markup for PITCH."
   (make-line-markup
    (list
     (make-simple-markup
@@ -71,15 +113,14 @@
     (make-normal-size-super-markup
      (accidental->markup (ly:pitch-alteration pitch))))))
 
-(define-public (write-me message x)
-  (write message) (write x) (newline) x)
-
 (define-public (double-plus-new-chord->markup-banter . args)
   (apply double-plus-new-chord->markup (cons 'banter args)))
 
 (define-public (double-plus-new-chord->markup-jazz . args)
   (apply double-plus-new-chord->markup (cons 'jazz args)))
 
+;; FIXME: if/when double-plus-new-chord->markup get installed
+;; setting and calling can be done a bit handier.
 (define-public (double-plus-new-chord->markup
                func pitches bass inversion options)
   "Entry point for New_chord_name_engraver.  See
@@ -149,7 +190,7 @@ input/test/dpncnt.ly).
     (make-line-markup (list (make-simple-markup "no") (step->markup pitch))))
                         
   (define (get-full-list pitch)
-    (if (< (step-nr pitch) (step-nr (tail pitches)))
+    (if (<= (step-nr pitch) (step-nr (tail pitches)))
        (cons pitch (get-full-list (next-third pitch)))
        '()))
 
@@ -162,25 +203,62 @@ input/test/dpncnt.ly).
              '()))
        '()))
 
-  (let* ((all 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))))
+       '(())))
+
+  (define (partial-match exceptions)
+    (if (pair? exceptions)
+       (let* ((e (car exceptions))
+              (e-pitches (car e)))
+         (if (equal? e-pitches (first-n (length e-pitches) pitches))
+             e
+             (partial-match (cdr exceptions))))
+       '(())))
+
+  (write-me "options: " options)
+  (write-me "pitches: " pitches)
+  (let* ((full-exceptions (assoc-get 'full-exceptions options))
+        (full-exception (full-match full-exceptions))
+        (full-markup (cdr full-exception))
+        
+        (partial-exceptions (assoc-get 'partial-exceptions options))
+        (partial-exception (partial-match partial-exceptions))
+        (partial-pitches (car partial-exception))
+        (partial-markup (markup-or-empty-markup (cdr partial-exception)))
+
+        (tonic (car pitches))
+        (full (get-full-list tonic))
+        ;; kludge alert: replace partial matched lower part of all with
+        ;; 'normal' pitches from full
+        ;; (all pitches)
+        (all (append (first-n (length partial-pitches) full)
+                     (butfirst-n (length partial-pitches) pitches)))
+             
         (highest (tail all))
-        (full (get-full-list (car all)))
         (missing (list-minus full (map pitch-unalter all)))
         (consecutive (get-consecutive 1 all))
         (rest (list-minus all consecutive))
         (altered (filter-list step-even-or-altered? all))
         (cons-alt (filter-list step-even-or-altered? consecutive))
-        (base (list-minus consecutive altered))
+        (base (list-minus consecutive altered)))
         
-        (full-exceptions (assoc 'full-exceptions options))
-        (partial-exceptions (assoc 'partial-exceptions options)))
 
-    ;;(newline)
-    ;;(write-me "pitches" pitches)
-    ;;(write-me "altered:" altered)
-    ;;(write-me "missing:" missing)
-    ;;(write-me "consecutive:" consecutive)
-    ;;(write-me "rest:" rest)
+    (write-me "full:" full)
+    ;; (write-me "partial-pitches:" partial-pitches)
+    (write-me "full-markup:" full-markup)
+    (write-me "partial-markup:" partial-markup)
+    (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 func
       ((banter)
@@ -188,62 +266,86 @@ input/test/dpncnt.ly).
        ;;    + steps:altered + (highest all -- if not altered)
        ;;    + subs:missing
        
-       (let* ((tonic->markup
-              (assoc-default 'tonic->markup options pitch->markup))
-             (step->markup
-              (assoc-default 'step->markup options step->markup-plusminus))
-             (sub->markup
-              (assoc-default
-               'sub->markup options
-               (lambda (x) (step-based-sub->markup step->markup x))))
-             (sep
-              (assoc-default 'separator options (make-simple-markup "/"))))
+       (let* ((tonic->markup (assoc-get-default
+                             'tonic->markup options pitch->markup))
+             (step->markup (assoc-get-default
+                            'step->markup options step->markup-plusminus))
+             (sub->markup (assoc-get-default
+                           'sub->markup options
+                           (lambda (x)
+                             (step-based-sub->markup step->markup x))))
+             (sep (assoc-get-default
+                   'separator options (make-simple-markup "/"))))
         
-        (make-line-markup
-         (list
-          (tonic->markup (car pitches))
-
-          (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 (map sub->markup missing)))
-            sep))))))
-
+        (if
+         (pair? full-markup)
+         (make-line-markup (list (tonic->markup tonic) full-markup))
+           
+         (make-line-markup
+          (list
+           (tonic->markup tonic)
+           partial-markup
+           (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 (map sub->markup missing)))
+             sep)))))))
+       
       
       ((jazz)
        ;;    tonic
        ;;    + steps:(highest base) + cons-alt
        ;;    + 'add'
        ;;    + steps:rest
-       (let* ((tonic->markup
-              (assoc-default 'tonic->markup options pitch->markup))
-             (step->markup
-              (assoc-default 'step->markup options step->markup-accidental))
-             (sep
-              (assoc-default 'separator options (make-simple-markup " ")))
-             (add-prefix
-              (assoc-default 'add-prefix options
-                             (make-simple-markup " add"))))
+       (let* ((tonic->markup (assoc-get-default
+                             'tonic->markup options pitch->markup))
+             (step->markup (assoc-get-default
+                            'step->markup options step->markup-accidental))
+             (sep (assoc-get-default
+                   'separator options (make-simple-markup " ")))
+             (add-prefix (assoc-get-default 'add-prefix options
+                                            (make-simple-markup " add"))))
         
-        (make-line-markup
-         (list
-          (tonic->markup (car pitches))
-          
-          (make-normal-size-super-markup
-           (make-line-markup
-            (list
-             (markup-join (map step->markup (cons (tail base) cons-alt)) sep)
-             (if (pair? rest)
-                 add-prefix
-                 empty-markup)
-             (markup-join (map step->markup rest) sep))))))))
-      
-      (else empty-markup))))
+        (if
+         (pair? full-markup)
+         (make-line-markup (list (tonic->markup tonic) full-markup))
+         
+         (make-line-markup
+          (list
+           (tonic->markup tonic)
+           partial-markup
+           (make-normal-size-super-markup
+            (make-line-markup
+             (list
+              
+              ;; kludge alert: omit <= 5
+              ;;(markup-join (map step->markup
+              ;;                        (cons (tail 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 (tail 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)))))))))
+       
+       (else empty-markup))))
+