From: hanwen <hanwen>
Date: Sat, 15 Feb 2003 01:16:57 +0000 (+0000)
Subject: * scm/double-plus-new-chord-name.scm (ignatzek-chord-names):
X-Git-Tag: release/1.7.25~447
X-Git-Url: https://git.donarmstrong.com/?a=commitdiff_plain;h=c68429c7d2a25039af6cb86593b197392957933d;p=lilypond.git

* scm/double-plus-new-chord-name.scm (ignatzek-chord-names):
jazz chords.

* lily/pitch.cc (ly:pitch-diff): new function.

* input/regression/chords-ignatzek.ly: new file.
---

diff --git a/ChangeLog b/ChangeLog
index 174da66cfc..5f6277c422 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2003-02-15  Han-Wen Nienhuys  <hanwen@cs.uu.nl>
+
+	* input/regression/chords-funky-ignatzek.ly: new file.
+
+	* scm/double-plus-new-chord-name.scm (ignatzek-chord-names):
+	jazz chords.
+
+	* lily/pitch.cc (ly:pitch-diff): new function.
+
+	* input/regression/chords-ignatzek.ly: new file.
+
 2003-02-14  Han-Wen Nienhuys  <hanwen@cs.uu.nl>
 
 	* scm/double-plus-new-chord-name.scm (ignatzek-chord-names): classify
diff --git a/input/regression/chords-ignatzek.ly b/input/regression/chords-ignatzek.ly
new file mode 100644
index 0000000000..13cd194852
--- /dev/null
+++ b/input/regression/chords-ignatzek.ly
@@ -0,0 +1,69 @@
+\header {
+texidoc = "Jazz chords, following
+[Ignatzek1995], page 17 and 18."
+}
+
+chs = \notes 
+{
+<<c e g>>1
+<<c es g>>
+<<c e gis>>
+<<c es ges>> \break
+<<c e g bes>>
+<<c es g bes>>
+<<c e g b>>
+<<c es ges beses>> 
+<<c es ges b>> \break
+<<c e gis bes>>
+<<c es g b>>
+<<c e gis b>> 
+<<c es ges bes>>\break
+<<c e g a>>
+<<c es g a>>
+<<c e g bes d'>> % ?? 
+<<c es g bes d'>> \break
+<<c es g bes d' f' a' >>
+<<c es g bes d' f' >>
+<<c es ges bes d' >> 
+<<c e g bes des' >> \break
+<<c e g bes dis'>>
+<<c e g bes d' f'>>
+<<c e g bes d' fis'>>
+<<c e g bes d' f' a'>>\break
+<<c e g bes d' fis' as'>>
+<<c e gis bes dis'>>
+<<c e g bes dis' fis'>>
+<<c e g bes d' f' as'>>\break
+<<c e g bes des' f' as'>>
+<<c e g bes d' fis'>>
+<<c e g b d'>>
+<<c e g bes d' f' as'>>\break
+<<c e g bes des' f' as'>>
+<<c e g bes des' f' a'>>
+<<c e g b d'>>
+<<c e g b d' f' a'>>\break
+<<c e g b d' fis'>>
+<<c e g bes des' f ' a'>>
+<<c f g>>
+<<c f g bes>>\break
+<<c f g bes d'>>
+<<c e g d'>>
+<<c es g f'>>
+}
+
+
+\score{
+    <
+	\context ChordNames {
+	#(set-chord-name-style 'ignatzek)
+	\chs
+    }
+	\context Staff \notes \transpose c c' { \chs }
+    >
+    \paper{
+	\translator { 
+	    \ChordNamesContext
+	    ChordName \override #'word-space = #1 
+	}
+    }
+}
diff --git a/lily/pitch.cc b/lily/pitch.cc
index 4d1096fcc6..6b8bb17b7f 100644
--- a/lily/pitch.cc
+++ b/lily/pitch.cc
@@ -369,6 +369,24 @@ LY_DEFINE(pitch_less, "ly:pitch<?", 2,0,0, (SCM p1, SCM p2),
   return Pitch::less_p (ly_car (p1),  ly_car (p2));
 }
 
+
+LY_DEFINE(ly_pitch_diff, "ly:pitch-diff", 2 ,0 ,0,
+	  (SCM pitch, SCM  root),
+	  "Return pitch with value DELTA =  PITCH - ROOT, ie,
+ROOT == (ly:pitch-transpose root delta).")
+{
+  Pitch *p = unsmob_pitch (pitch);
+  Pitch *r = unsmob_pitch (root);
+  SCM_ASSERT_TYPE(p, pitch, SCM_ARG1, __FUNCTION__, "Pitch");
+  SCM_ASSERT_TYPE(r, root, SCM_ARG2, __FUNCTION__, "Pitch");
+
+  return interval (*p, *r ).smobbed_copy();
+}
+
+	  
+
+
+
 SCM
 Pitch::smobbed_copy ()const
 {
diff --git a/scm/double-plus-new-chord-name.scm b/scm/double-plus-new-chord-name.scm
index 342a315d71..1f317134a6 100644
--- a/scm/double-plus-new-chord-name.scm
+++ b/scm/double-plus-new-chord-name.scm
@@ -25,8 +25,8 @@
 
 (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)
+;;  (display message) (write x) (newline) x)
+  x)
 
 (define (tail lst)
   "Return tail element of LST."
@@ -42,6 +42,8 @@
 	  a)
       '()))
 
+
+
 (define (first-n n lst)
   "Return first N elements of LST"
   (if (and (pair? lst)
@@ -68,11 +70,45 @@
     (if entry (cdr entry) default)))
 
 
+(define (split-at predicate l)
+ "Split L = (a_1 a_2 ... a_k b_1 ... b_k)
+into L1 = (a_1 ... a_k ) and L2 =(b_1 .. b_k) 
+Such that (PREDICATE a_i a_{i+1}) and not (PREDICATE a_k b_1).
+L1 is copied, L2 not.
+
+(split-at (lambda (x y) (= (- y x) 2))  '(1 3 5 9 11) (cons '() '()))"
+;; "
+
+;; KUT EMACS MODE.
+
+  (define (inner-split predicate l acc)
+  (cond
+   ((null? l) acc)
+   ((null? (cdr l))
+    (set-car! acc (cons (car l) (car acc)))
+    acc)
+   ((predicate (car l) (cadr l))
+    (set-car! acc (cons (car l) (car acc)))
+    (inner-split predicate (cdr l) acc))
+   (else
+    (set-car! acc (cons (car l) (car acc)))
+    (set-cdr! acc (cdr l))
+    acc)
+
+  ))
+ (let*
+    ((c (cons '() '()))
+     )
+  (inner-split predicate l  c)
+  (set-car! c (reverse! (car c))) 
+  c)
+)
+
 ;; 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))
+      (make-line-markup (list-insert-separator markups sep))
       empty-markup))
 
 (define (markup-or-empty-markup markup)
@@ -86,7 +122,7 @@
 ROOT == (ly:pitch-transpose root delta)."
 
 
-  ;; a little kludgy? Do this in C++ ? --hwn
+  ;; kludgy. Do this in C++ ? --hwn
   
   (let ((simple-octave (- (ly:pitch-octave pitch) (ly:pitch-octave root)))
 	(simple-notename
@@ -100,13 +136,30 @@ ROOT == (ly:pitch-transpose root delta)."
 		(ly:pitch-semitones (ly:make-pitch octave notename 0)))))
 	(ly:make-pitch octave notename alteration)))))
 
+
+(define (conditional-kern-before markup bool amount)
+  "Add AMOUNT of space before MARKUP if BOOL is true."
+  (if bool
+      (make-line-markup
+       (list (make-hspace-markup amount)
+	     markup))
+      markup
+      ))
+  
 (define (accidental->markup alteration)
   "Return accidental markup for ALTERATION."
   (if (= alteration 0)
       (make-line-markup (list empty-markup))
-      (make-smaller-markup
-       (make-musicglyph-markup
-	(string-append "accidentals-" (number->string alteration))))))
+      (conditional-kern-before
+       (make-smaller-markup
+	(make-raise-markup
+	(if (= alteration -1)
+	    0.3
+	    0.6)
+	(make-musicglyph-markup
+	 (string-append "accidentals-" (number->string alteration)))))
+       (= alteration -1) 0.2
+       )))
 
 (define (pitch->markup pitch)
   "Return pitch markup for PITCH."
@@ -361,7 +414,14 @@ input/test/dpncnt.ly).
 ;;
 ;; after Klaus Ignatzek,   Die Jazzmethode fuer Klavier 1.
 ;; 
-
+;; The idea is: split chords into
+;;  
+;;  ROOT PREFIXES MAIN-NAME ALTERATIONS SUFFIXES ADDITIONS
+;;
+;; and put that through a layout routine.
+;; 
+;; the split is a procedural process , with lots of set!. 
+;;
 
 (define natural-chord-alterations
   '(
@@ -380,22 +440,14 @@ input/test/dpncnt.ly).
 (define natural-7-up-alterations
   (butfirst-n 5 natural-chord-alterations) )
 
+
+
 (define-public (ignatzek-chord-names
 		in-pitches bass inversion options)
 
-  (let*
-     (
-      (root (car in-pitches))
-      (pitches (map (lambda (x) (ly:pitch-diff x root)) (cdr in-pitches)))
-      (suffixes '())
-      (add-steps '())
-      (body '())
-      (7-and-up '())
-      (sequential-7-to-13 '())
-      (sequential-count 0)
-      (alterations '())
-      (unaltered-count 0)
-      )
+  (define maj7-markup
+    (make-simple-markup "maj7")
+    )
   
   (define (get-step x ps)
     "Does PS have the X step? Return that step if it does."
@@ -411,21 +463,21 @@ input/test/dpncnt.ly).
       (- (ly:pitch-alteration pitch)
 	 (assoc-get-default (+ 1  (ly:pitch-steps pitch)) natural-chord-alterations 0))
       )
+    (let*
+	(
+	 (num-markup (make-simple-markup
+		      (number->string (pitch-step pitch))))
+	 (args (list num-markup))
+	 (total (if (= (ly:pitch-alteration pitch) 0)
+		    (if (= (pitch-step pitch) 7)
+			(list maj7-markup)
+			args)
+		    (cons (accidental->markup (step-alteration pitch)) args)
+		    ))
+	 
+	 )
       
-    (make-line-markup
-     (list
-      (accidental->markup (step-alteration pitch))
-      (make-simple-markup (number->string (+ 1 (ly:pitch-steps pitch)))))))
-
-  
-  (define (count-leading-true bs)
-    "For the list of booleans BS, count with how many #t's it starts."
-    (if (null? bs)
-	0
-	(if (car bs)
-	    (+ 1 (count-leading-true (cdr bs)))
-	    0)
-    ))
+    (make-line-markup total)))
 
   (define (remove-step x ps)
     "Copy PS, but leave out the Xth step."
@@ -453,10 +505,116 @@ input/test/dpncnt.ly).
 	)
     )
 
+  (define (pitch-step p)
+    "Musicological notation for an interval. Eg. C to D is 2."
+    (+ 1 (ly:pitch-steps p)))
+  
+  (define (glue-word-to-step word x)
+    (make-line-markup 
+     (list
+      (make-simple-markup word)
+      (name-step x)))
+    )
+
+  (define (is-natural-alteration? p)
+    (= (assoc-get-default (pitch-step p) natural-chord-alterations 0) (ly:pitch-alteration p))
+    )
+  
+  (define (filter-main-name p)
+    "The main name: don't print anything for natural 5 or 3."
+    (if
+     (and (is-natural-alteration? p)
+	  (or (= (pitch-step p) 5)
+	      (= (pitch-step p) 3)))
+     '()
+     (list (name-step p))
+    ))
 
 
-  (write-me "*****************\nchord " in-pitches)
+  (define (ignatzek-format-chord-name
+	   root
+	   prefix-modifiers
+	   main-name
+	   alteration-pitches
+	   addition-pitches
+	   suffix-modifiers
+	   )
+
+    
+    (define (suffix-modifier->markup mod)
+      (if (or (= 4 (pitch-step mod))
+	      (= 2 (pitch-step mod)))
+	  (glue-word-to-step "sus" mod)
+	  (glue-word-to-step "huh" mod)
+	  ))
+    
+    (define (prefix-modifier->markup mod)
+      (if (and (= 3 (pitch-step mod))
+	       (= -1 (ly:pitch-alteration mod)))
+	  (make-simple-markup "m")
+	  (make-simple-markup "huh")
+	  ))
+
+    
+    (define (filter-alterations alters)
+      (define (altered? p)
+	(not (is-natural-alteration? p)))
+      
+      (if
+       (null? alters)
+       '()
+       (let*
+	   (
+	    (l (filter-list altered? alters))
+	    (lp (last-pair alters))
+	    )
+
+	 ;; we want the highest also if unaltered
+	 (if (and (not (altered? (car lp)))
+		  (> (pitch-step (car lp)) 5))
+	     (append l (last-pair alters))
+	     l)
+	 )))
+    
+    (let*
+	(
+	 (sep (make-simple-markup "/"))
+	 (root-markup (pitch->markup root))
+	 (add-markups (map (lambda (x)
+			     (glue-word-to-step "add" x))
+			   addition-pitches))
+	 (filtered-alterations (filter-alterations alteration-pitches))
+	 (alterations (map name-step filtered-alterations))
+	 (suffixes (map suffix-modifier->markup suffix-modifiers))
+	 (prefixes (map prefix-modifier->markup prefix-modifiers))
+	 (prefix-markup (markup-join prefixes sep))
+	 (main-markups (filter-main-name main-name))
+	 (to-be-raised-stuff (markup-join
+			      (append
+			       main-markups
+			       alterations
+			       suffixes
+			       add-markups) sep))
+	 )
+      (make-line-markup
+       (list
+	root-markup
+	prefix-markup
+	(make-super-markup to-be-raised-stuff))
+       )))
+  
 
+  (let*
+     (
+      (root (car in-pitches))
+      (pitches (map (lambda (x) (ly:pitch-diff x root)) (cdr in-pitches)))
+      (prefixes '())
+      (suffixes '())
+      (add-steps '())
+      (main-name #f)
+      (alterations '())
+      )
+   
   ;; handle sus4 suffix.
   (if (get-step 4 pitches)
       (begin
@@ -465,11 +623,12 @@ input/test/dpncnt.ly).
 	      (set! add-steps (cons (get-step 3 pitches) add-steps))
 	      (set! pitches (remove-step 3 pitches))
 	    ))
-	(set! suffixes  (cons "sus4" suffixes))
+	(set! suffixes  (cons (get-step 4 pitches) suffixes))
       )
   )
 
   ;; handle sus2 suffix.
+  ;; ugh - dup, should use loop.
   (if (get-step 2 pitches)
       (begin
 	(if (get-step 3 pitches)
@@ -477,64 +636,55 @@ input/test/dpncnt.ly).
 	      (set! add-steps (cons (get-step 3 pitches) add-steps))
 	      (set! pitches (remove-step 3 pitches))
 	    ))
-	(set! suffixes  (cons "sus2" suffixes))
+	(set! suffixes  (cons (get-step 2 pitches) suffixes))
       )
   )
 
   (if (and (get-step 3 pitches)
 	   (= (ly:pitch-alteration (get-step 3 pitches)) -1))
-      (set! body (cons "m" body))
-      )
-
-  (if (get-step 6 pitches)
-      (set! body (cons "6" body ))
+      (set! prefixes (cons (get-step 3 pitches) prefixes))
       )
 
-  (if (>= (ly:pitch-steps (tail pitches))  6)
-      (begin
-
-	;; TODO: filter 6, 8, 10, 12, 14
-	(set! 7-and-up (remove-uptil-step 7 pitches))
-	(set! sequential-count
-	      (count-leading-true
-	       (map
-		(lambda (x)
-		  (get-step (car x) 7-and-up))
-		natural-7-up-alterations
-		)
-	       ))
-
-	(set! sequential-7-to-13
-	      (first-n sequential-count  7-and-up))
-
-	(set! add-steps (append add-steps
-				(butfirst-n sequential-count 7-and-up)))
-
-	(set! unaltered-count    
-	      (count-leading-true
-	       (map (lambda (x)
-		      (= (ly:pitch-alteration (get-step (car x) sequential-7-to-13))
-			 (cdr x)))
-		    (first-n (length sequential-7-to-13) natural-7-up-alterations)
-		    )))
 
-	(write-me "sequential-7-to-13 " sequential-7-to-13)
-	(if (pair? sequential-7-to-13)
-	    (set! body
-		  (cons (name-step
-			 (list-ref sequential-7-to-13 (max 0 (- unaltered-count 1))))
-			body)))
+  ;; lazy bum. Should write loop.
+  (cond
+   ((get-step 7 pitches) (set! main-name (get-step 7 pitches)))
+   ((get-step 6 pitches) (set! main-name (get-step 6 pitches)))
+   ((get-step 5 pitches) (set! main-name (get-step 5 pitches)))
+   ((get-step 4 pitches) (set! main-name (get-step 4 pitches)))
+   ((get-step 3 pitches) (set! main-name (get-step 3 pitches)))
+   )
 
-	(set! alterations (butfirst-n unaltered-count sequential-7-to-13))
+  (let*
+     (
+      (3-diff? (lambda (x y)
+		 (= (- (pitch-step y) (pitch-step x)) 2)))
+      (split (split-at 3-diff? (remove-uptil-step 5 pitches)))
+      )
+    (set! alterations (append alterations (car split)))
+    (set! add-steps (append add-steps (cdr split)))
+    
+    (set! alterations (delq main-name alterations))
+    (set! add-steps (delq main-name add-steps))
+
+
+    ;; natural 5 7 9 11 13 etc. are named by the top pitch, without 
+    ;; any alterations.
+    (if (and
+	 (= 7 (pitch-step main-name))
+	 (is-natural-alteration? main-name)
+	 (pair? (remove-uptil-step 7 alterations))
+	 (reduce (lambda (x y) (and x y))
+		      (map is-natural-alteration? alterations)))
+	(begin
+	  (set! main-name (tail alterations))
+	  (set! alterations '())
 	))
-  
-  (write-me "alterations " alterations)
-  (write-me "add-steps " add-steps)
-  (write-me "body " body)
-  (write-me "suffixes " suffixes)
 
-  
-  (make-simple-markup "bla")
+    
+    (ignatzek-format-chord-name root prefixes main-name alterations add-steps suffixes)
+
+    )
   
   ))
 
diff --git a/scm/lily.scm b/scm/lily.scm
index 2d957ae64d..194c649bb3 100644
--- a/scm/lily.scm
+++ b/scm/lily.scm
@@ -111,20 +111,20 @@ is the  first to satisfy CRIT
   ))
 
 ;; rare naam.  voorstel: reduce-add-infix
-(define-public (reduce-list list between)
+(define-public (list-insert-separator list between)
   "Create new list, inserting BETWEEN between elements of LIST"
   (if (null? list)
       '()
       (if (null? (cdr list))
 	  list
 	  (cons (car list)
-		(cons between (reduce-list (cdr list) between)))
+		(cons between (list-insert-separator (cdr list) between)))
   
   )))
 
 (define-public (string-join str-list sep)
   "append the list of strings in STR-LIST, joining them with SEP"
-  (apply string-append (reduce-list str-list sep))
+  (apply string-append (list-insert-separator str-list sep))
   )