;;;; 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
;;;; 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}.
(inversion #f)
(lead-mod #f)
(explicit-11 #f)
+ (explicit-2/4 #f)
+ (omit-3 #f)
(start-additions #t))
(define (interpret-inversion chord mods)
(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)
"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))
(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))))
(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.
(= 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))
(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.
projects / lilypond.git / blobdiff