X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fchord-ignatzek-names.scm;h=22f54fec85e523adde58e5715ebd9bee0d6947a1;hb=0b544cfb7332615ef809b71b57ab656741311ae1;hp=696d02fc7af43ab3ae2383f670a51ecc98afde9d;hpb=2613eed0a13ce118cb11f83057d9d79fc6973a4e;p=lilypond.git

diff --git a/scm/chord-ignatzek-names.scm b/scm/chord-ignatzek-names.scm
index 696d02fc7a..22f54fec85 100644
--- a/scm/chord-ignatzek-names.scm
+++ b/scm/chord-ignatzek-names.scm
@@ -1,6 +1,6 @@
 ;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;
-;;;; Copyright (C) 2000--2011  Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;; Copyright (C) 2000--2014  Han-Wen Nienhuys <hanwen@xs4all.nl>
 ;;;;
 ;;;; LilyPond is free software: you can redistribute it and/or modify
 ;;;; it under the terms of the GNU General Public License as published by
@@ -44,63 +44,63 @@
   (if (null? ps)
       #f
       (if (= (- x 1) (ly:pitch-steps (car ps)))
-	  (car ps)
-	  (get-step x (cdr ps)))))
+          (car ps)
+          (get-step x (cdr ps)))))
 
 (define (replace-step p ps)
   "Copy PS, but replace the step of P in PS."
   (if (null? ps)
       '()
       (let* ((t (replace-step p (cdr ps))))
-	(if (= (ly:pitch-steps p) (ly:pitch-steps (car ps)))
-	    (cons p t)
-	    (cons (car ps) t)))))
+        (if (= (ly:pitch-steps p) (ly:pitch-steps (car ps)))
+            (cons p t)
+            (cons (car ps) t)))))
 
 (define (remove-step x ps)
   "Copy PS, but leave out the Xth step."
   (if (null? ps)
       '()
       (let* ((t (remove-step x (cdr ps))))
-	(if (= (- x 1) (ly:pitch-steps (car ps)))
-	    t
-	    (cons (car ps) t)))))
+        (if (= (- x 1) (ly:pitch-steps (car ps)))
+            t
+            (cons (car ps) t)))))
 
 
 (define-public (ignatzek-chord-names
-		in-pitches bass inversion
-		context)
+                in-pitches bass inversion
+                context)
 
   (define (remove-uptil-step x ps)
     "Copy PS, but leave out everything below the Xth step."
     (if (null? ps)
-	'()
-	(if (< (ly:pitch-steps (car ps)) (- x 1))
-	    (remove-uptil-step x (cdr ps))
-	    ps)))
+        '()
+        (if (< (ly:pitch-steps (car ps)) (- x 1))
+            (remove-uptil-step x (cdr ps))
+            ps)))
 
   (define name-root (ly:context-property context 'chordRootNamer))
   (define name-note
     (let ((nn (ly:context-property context 'chordNoteNamer)))
       (if (eq? nn '())
-	  ;; replacing the next line with name-root gives guile-error...? -rz
+          ;; replacing the next line with name-root gives guile-error...? -rz
 
-	  ;; apparently sequence of defines is equivalent to let, not let* ? -hwn
-	  (ly:context-property context 'chordRootNamer)
-	  ;; name-root
-	  nn)))
+          ;; apparently sequence of defines is equivalent to let, not let* ? -hwn
+          (ly:context-property context 'chordRootNamer)
+          ;; name-root
+          nn)))
 
   (define (is-natural-alteration? p)
     (= (natural-chord-alteration p) (ly:pitch-alteration p)))
 
   (define (ignatzek-format-chord-name
-	   root
-	   prefix-modifiers
-	   main-name
-	   alteration-pitches
-	   addition-pitches
-	   suffix-modifiers
-	   bass-pitch
-	   lowercase-root?)
+           root
+           prefix-modifiers
+           main-name
+           alteration-pitches
+           addition-pitches
+           suffix-modifiers
+           bass-pitch
+           lowercase-root?)
 
     "Format for the given (lists of) pitches.  This is actually more
 work than classifying the pitches."
@@ -109,99 +109,103 @@ work than classifying the pitches."
       "The main name: don't print anything for natural 5 or 3."
       (if
        (or (not (ly:pitch? p))
-	   (and (is-natural-alteration? p)
-		(or (= (pitch-step p) 5)
-		    (= (pitch-step p) 3))))
+           (and (is-natural-alteration? p)
+                (or (= (pitch-step p) 5)
+                    (= (pitch-step p) 3))))
        '()
        (list (name-step p))))
 
     (define (glue-word-to-step word x)
       (make-line-markup
        (list
-	(make-simple-markup word)
-	(name-step x))))
+        (make-simple-markup word)
+        (name-step x))))
 
     (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)))
+              (= 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))
-	       (= FLAT (ly:pitch-alteration mod)))
-	  (make-simple-markup (if lowercase-root? "" "m"))
-	  (make-simple-markup "huh")))
+               (= FLAT (ly:pitch-alteration mod)))
+          (if lowercase-root?
+              empty-markup
+              (ly:context-property context 'minorChordModifier))
+          (make-simple-markup "huh")))
 
     (define (filter-alterations alters)
       "Filter out uninteresting (natural) pitches from ALTERS."
 
       (define (altered? p)
-	(not (is-natural-alteration? p)))
+        (not (is-natural-alteration? p)))
 
       (if
        (null? alters)
        '()
        (let* ((lst (filter altered? alters))
-	      (lp (last-pair alters)))
+              (lp (last-pair alters)))
 
-	 ;; we want the highest also if unaltered
-	 (if (and (not (altered? (car lp)))
-		  (> (pitch-step (car lp)) 5))
-	     (append lst (last-pair alters))
-	     lst))))
+         ;; we want the highest also if unaltered
+         (if (and (not (altered? (car lp)))
+                  (> (pitch-step (car lp)) 5))
+             (append lst (last-pair alters))
+             lst))))
 
     (define (name-step pitch)
       (define (step-alteration pitch)
-	(- (ly:pitch-alteration pitch)
-	   (natural-chord-alteration pitch)))
+        (- (ly:pitch-alteration pitch)
+           (natural-chord-alteration pitch)))
 
       (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 (ly:context-property context 'majorSevenSymbol))
-			    args)
-			(cons (accidental->markup (step-alteration pitch)) args))))
+                          (number->string (pitch-step pitch))))
+             (args (list num-markup))
+             (total (if (= (ly:pitch-alteration pitch) 0)
+                        (if (= (pitch-step pitch) 7)
+                            (list (ly:context-property context 'majorSevenSymbol))
+                            args)
+                        (cons (accidental->markup (step-alteration pitch)) args))))
 
-	(make-line-markup total)))
+        (make-line-markup total)))
 
     (let* ((sep (ly:context-property context 'chordNameSeparator))
-	   (root-markup (name-root root lowercase-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))
-	   (main-markups (filter-main-name main-name))
-	   (to-be-raised-stuff (markup-join
-				(append
-				 main-markups
-				 alterations
-				 suffixes
-				 add-markups) sep))
-	   (base-stuff (if (ly:pitch? bass-pitch)
-			   (list sep (name-note bass-pitch #f))
-			   '())))
+           (slashsep (ly:context-property context 'slashChordSeparator))
+           (root-markup (name-root root lowercase-root?))
+           (add-pitch-prefix (ly:context-property context 'additionalPitchPrefix))
+           (add-markups (map (lambda (x) (glue-word-to-step add-pitch-prefix 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))
+           (main-markups (filter-main-name main-name))
+           (to-be-raised-stuff (markup-join
+                                (append
+                                 main-markups
+                                 alterations
+                                 suffixes
+                                 add-markups) sep))
+           (base-stuff (if (ly:pitch? bass-pitch)
+                           (list slashsep (name-note bass-pitch #f))
+                           '())))
 
       (set! base-stuff
-	    (append
-	     (list root-markup
-		   (conditional-kern-before (markup-join prefixes sep)
-					    (and (not (null? prefixes))
-						 (= (ly:pitch-alteration root) NATURAL))
-					    (ly:context-property context 'chordPrefixSpacer))
-		   (make-super-markup to-be-raised-stuff))
-	     base-stuff))
+            (append
+             (list root-markup
+                   (conditional-kern-before (markup-join prefixes sep)
+                                            (and (not (null? prefixes))
+                                                 (= (ly:pitch-alteration root) NATURAL))
+                                            (ly:context-property context 'chordPrefixSpacer))
+                   (make-super-markup to-be-raised-stuff))
+             base-stuff))
       (make-line-markup base-stuff)))
 
   (define (ignatzek-format-exception
-	   root
-	   exception-markup
-	   bass-pitch
-	   lowercase-root?)
+           root
+           exception-markup
+           bass-pitch
+           lowercase-root?)
 
     (make-line-markup
      `(
@@ -209,83 +213,82 @@ work than classifying the pitches."
        ,exception-markup
        .
        ,(if (ly:pitch? bass-pitch)
-	    (list (ly:context-property context 'chordNameSeparator)
-		  (name-note bass-pitch #f))
-	    '()))))
+            (list (ly:context-property context 'slashChordSeparator)
+                  (name-note bass-pitch #f))
+            '()))))
 
   (let* ((root (car in-pitches))
-	 (pitches (map (lambda (x) (ly:pitch-diff x root)) (cdr in-pitches)))
-	 (lowercase-root?
-	  (and (ly:context-property context 'chordNameLowercaseMinor)
-       (let ((third (get-step 3 pitches)))
-	    (and third (= (ly:pitch-alteration third) FLAT)))))
-	 (exceptions (ly:context-property context 'chordNameExceptions))
-	 (exception (assoc-get pitches exceptions))
-	 (prefixes '())
-	 (suffixes '())
-	 (add-steps '())
-	 (main-name #f)
-	 (bass-note
-	  (if (ly:pitch? inversion)
-	      inversion
-	      bass))
-	 (alterations '()))
+         (pitches (map (lambda (x) (ly:pitch-diff x root)) (cdr in-pitches)))
+         (lowercase-root?
+          (and (ly:context-property context 'chordNameLowercaseMinor)
+               (let ((third (get-step 3 pitches)))
+                 (and third (= (ly:pitch-alteration third) FLAT)))))
+         (exceptions (ly:context-property context 'chordNameExceptions))
+         (exception (assoc-get pitches exceptions))
+         (prefixes '())
+         (suffixes '())
+         (add-steps '())
+         (main-name #f)
+         (bass-note
+          (if (ly:pitch? inversion)
+              inversion
+              bass))
+         (alterations '()))
 
     (if exception
-	(ignatzek-format-exception root exception bass-note lowercase-root?)
-
-	(begin
-	  ;; no exception.
-	  ;; handle sus4 and sus2 suffix: if there is a 3 together with
-	  ;; sus2 or sus4, then we explicitly say add3.
-	  (map
-	   (lambda (j)
-	     (if (get-step j pitches)
-		 (begin
-		   (if (get-step 3 pitches)
-		       (begin
-			 (set! add-steps (cons (get-step 3 pitches) add-steps))
-			 (set! pitches (remove-step 3 pitches))))
-		   (set! suffixes (cons (get-step j pitches) suffixes)))))
-	   '(2 4))
-
-	  ;; do minor-3rd modifier.
-	  (if (and (get-step 3 pitches)
-		   (= (ly:pitch-alteration (get-step 3 pitches)) FLAT))
-	      (set! prefixes (cons (get-step 3 pitches) prefixes)))
-
-	  ;; 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))))
-
-	  (let* ((3-diff? (lambda (x y)
-			    (= (- (pitch-step y) (pitch-step x)) 2)))
-		 (split (split-at-predicate
-			 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))
-
-
-	    ;; chords with natural (5 7 9 11 13) or leading subsequence.
-	    ;; etc. are named by the top pitch, without any further
-	    ;; alterations.
-	    (if (and
-		 (ly:pitch? main-name)
-		 (= 7 (pitch-step main-name))
-		 (is-natural-alteration? main-name)
-		 (pair? (remove-uptil-step 7 alterations))
-		 (reduce (lambda (x y) (and x y)) #t
-			 (map is-natural-alteration? alterations)))
-		(begin
-		  (set! main-name (last alterations))
-		  (set! alterations '())))
-
-	    (ignatzek-format-chord-name
-	     root prefixes main-name alterations add-steps suffixes bass-note
-	     lowercase-root?))))))
+        (ignatzek-format-exception root exception bass-note lowercase-root?)
+
+        (begin
+          ;; no exception.
+          ;; handle sus4 and sus2 suffix: if there is a 3 together with
+          ;; sus2 or sus4, then we explicitly say add3.
+          (for-each
+           (lambda (j)
+             (if (get-step j pitches)
+                 (begin
+                   (if (get-step 3 pitches)
+                       (begin
+                         (set! add-steps (cons (get-step 3 pitches) add-steps))
+                         (set! pitches (remove-step 3 pitches))))
+                   (set! suffixes (cons (get-step j pitches) suffixes)))))
+           '(2 4))
+
+          ;; do minor-3rd modifier.
+          (if (and (get-step 3 pitches)
+                   (= (ly:pitch-alteration (get-step 3 pitches)) FLAT))
+              (set! prefixes (cons (get-step 3 pitches) prefixes)))
+
+          ;; 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))))
+
+          (let* ((3-diff? (lambda (x y)
+                            (= (- (pitch-step y) (pitch-step x)) 2)))
+                 (split (split-at-predicate
+                         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))
+
+
+            ;; chords with natural (5 7 9 11 13) or leading subsequence.
+            ;; etc. are named by the top pitch, without any further
+            ;; alterations.
+            (if (and
+                 (ly:pitch? main-name)
+                 (= 7 (pitch-step main-name))
+                 (is-natural-alteration? main-name)
+                 (pair? (remove-uptil-step 7 alterations))
+                 (every is-natural-alteration? alterations))
+                (begin
+                  (set! main-name (last alterations))
+                  (set! alterations '())))
+
+            (ignatzek-format-chord-name
+             root prefixes main-name alterations add-steps suffixes bass-note
+             lowercase-root?))))))