X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fchord-entry.scm;h=23601a8deaba4e54a3014c0b2fcdc8dd9c324dd1;hb=HEAD;hp=0ea8e032a0e774bb95265e15df406739979e40db;hpb=40aac0ae57ee113faa860ba221d83d9e6312173e;p=lilypond.git

diff --git a/scm/chord-entry.scm b/scm/chord-entry.scm
index 0ea8e032a0..23601a8dea 100644
--- a/scm/chord-entry.scm
+++ b/scm/chord-entry.scm
@@ -1,6 +1,6 @@
 ;;;; This file is part of LilyPond, the GNU music typesetter.
 ;;;;
-;;;; Copyright (C) 2004--2014 Han-Wen Nienhuys <hanwen@xs4all.nl>
+;;;; Copyright (C) 2004--2015 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
@@ -16,7 +16,9 @@
 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
 
 ;; for define-safe-public when byte-compiling using Guile V2
-(use-modules (scm safe-utility-defs))
+(use-modules (scm safe-utility-defs) (ice-9 receive))
+
+(define-session-public chordmodifiers '())
 
 (define-public (construct-chord-elements root duration modifications)
   "Build a chord on root using modifiers in @var{modifications}.
@@ -32,6 +34,8 @@ Entry point for the parser."
          (inversion #f)
          (lead-mod #f)
          (explicit-11 #f)
+         (explicit-2/4 #f)
+         (omit-3 #f)
          (start-additions #t))
 
     (define (interpret-inversion chord mods)
@@ -49,7 +53,8 @@ Entry point for the parser."
             (set! bass (cadr mods))
             (set! mods (cddr mods))))
       (if (pair? mods)
-          (ly:warning (_ "Spurious garbage following chord: ~A") mods))
+          (ly:parser-error
+           (format #f (_ "Spurious garbage following chord: ~A") mods)))
       chord)
 
     (define (interpret-removals  chord mods)
@@ -66,8 +71,10 @@ Entry point for the parser."
       "Interpret additions.  TODO: should restrict modifier use?"
       (cond ((null? mods) chord)
             ((ly:pitch? (car mods))
-             (if (= (pitch-step (car mods)) 11)
-                 (set! explicit-11 #t))
+             (case (pitch-step (car mods))
+               ((11) (set! explicit-11 #t))
+               ((2 4) (set! explicit-2/4 #t))
+               ((3) (set! omit-3 #f)))
              (interpret-additions (cons (car mods) (remove-step (pitch-step (car mods)) chord))
                                   (cdr mods)))
             ((procedure? (car mods))
@@ -129,8 +136,10 @@ the bass specified.
              (ly:pitch?  (car flat-mods))
              (not (eq? lead-mod sus-modifier)))
         (begin
-          (if (= (pitch-step (car flat-mods)) 11)
-              (set! explicit-11 #t))
+          (cond ((= (pitch-step (car flat-mods)) 11)
+                 (set! explicit-11 #t))
+                ((equal? (ly:make-pitch 0 4 0) (car flat-mods))
+                 (set! omit-3 #t)))
           (set! base-chord
                 (stack-thirds (car flat-mods) the-canonical-chord))
           (set! flat-mods (cdr flat-mods))))
@@ -141,6 +150,10 @@ the bass specified.
           (if start-additions
               (interpret-additions base-chord flat-mods)
               (interpret-removals base-chord flat-mods)))
+    ;; if sus has been given neither 2 or 4, we add 4.
+    (if (and (eq? lead-mod sus-modifier)
+             (not explicit-2/4))
+        (set! complete-chord (cons (ly:make-pitch 0 4 0) complete-chord)))
     (set! complete-chord (sort complete-chord ly:pitch<?))
     ;; If natural 11 + natural 3 is present, but not given explicitly,
     ;; we remove the 11.
@@ -150,6 +163,10 @@ the bass specified.
              (= 0 (ly:pitch-alteration (get-step 11 complete-chord)))
              (= 0 (ly:pitch-alteration (get-step 3 complete-chord))))
         (set! complete-chord (remove-step 11 complete-chord)))
+    ;; if omit-3 has been set (and not reset by an explicit 3
+    ;; somewhere), we remove the 3
+    (if omit-3
+        (set! complete-chord (remove-step 3 complete-chord)))
     ;; must do before processing inversion/bass, since they are
     ;; not relative to the root.
     (set! complete-chord (map (lambda (x) (ly:pitch-transpose x root))
@@ -174,26 +191,42 @@ the bass specified.
 
 (define (make-chord-elements pitches bass duration inversion original-inv-pitch)
   "Make EventChord with notes corresponding to PITCHES, BASS and
-DURATION, and INVERSION."
-  (define (make-note-ev pitch)
-    (make-music 'NoteEvent
-                'duration duration
-                'pitch pitch))
-  (let ((nots (map make-note-ev pitches))
-        (bass-note (if bass (make-note-ev bass) #f))
-        (inv-note (if inversion (make-note-ev inversion) #f)))
-    (if bass-note
-        (begin
-          (set! (ly:music-property bass-note 'bass) #t)
-          (set! nots (cons bass-note nots))))
-    (if inv-note
-        (begin
-          (set! (ly:music-property inv-note 'inversion) #t)
-          (set! (ly:music-property inv-note 'octavation)
-                (- (ly:pitch-octave inversion)
-                   (ly:pitch-octave original-inv-pitch)))
-          (set! nots (cons inv-note nots))))
-    nots))
+DURATION, and INVERSION.  Notes above INVERSION are transposed downward
+along with the inversion as long as they end up below at least one
+non-inverted note."
+  (define (make-note-ev pitch . rest)
+    (apply make-music 'NoteEvent
+           'duration duration
+           'pitch pitch
+           rest))
+  (cond (inversion
+         (let* ((octavation (- (ly:pitch-octave inversion)
+                               (ly:pitch-octave original-inv-pitch)))
+                (down (ly:make-pitch octavation 0 0)))
+           (define (invert p) (ly:pitch-transpose down p))
+           (define (make-inverted p . rest)
+             (apply make-note-ev (invert p) 'octavation octavation rest))
+           (receive (uninverted high)
+                    (span (lambda (p) (ly:pitch<? p original-inv-pitch))
+                          pitches)
+                    (receive (invertible rest)
+                             (if (null? uninverted)
+                                 ;; The following line caters for
+                                 ;; inversions "on the root", turning
+                                 ;; f/f into <f a' c''> rather than <f a c'>
+                                 ;; or <f' a' c''>
+                                 (values '() high)
+                                 (span (lambda (p)
+                                         (ly:pitch<? (invert p) (car uninverted)))
+                                       high))
+                             (cons (make-inverted original-inv-pitch 'inversion #t)
+                                   (append (if bass (list (make-note-ev bass 'bass #t)) '())
+                                           (map make-inverted invertible)
+                                           (map make-note-ev uninverted)
+                                           (map make-note-ev rest)))))))
+        (bass (cons (make-note-ev bass 'bass #t)
+                    (map make-note-ev pitches)))
+        (else (map make-note-ev pitches))))
 
 ;;;;;;;;;;;;;;;;
 ;; chord modifiers change the pitch list.