3 (define (make-chord pitches bass duration)
4 "Make EventChord with notes corresponding to PITCHES, BASS and DURATION. "
5 (define (make-note-ev pitch)
8 (ev (make-music-by-name 'NoteEvent))
11 (ly:set-mus-property! ev 'duration duration)
12 (ly:set-mus-property! ev 'pitch pitch)
18 (nots (map make-note-ev pitches))
19 (bass-note (if bass (make-note-ev bass) #f))
24 (ly:set-mus-property! bass-note 'bass #t)
25 (set! nots (cons bass-note nots))))
27 (make-event-chord nots)
31 (define (aug-modifier root pitches)
32 (set! pitches (replace-step (ly:pitch-transpose (ly:make-pitch 0 4 1) root) pitches))
33 (replace-step (ly:pitch-transpose (ly:make-pitch 0 2 0) root) pitches)
37 (define (minor-modifier root pitches)
38 (replace-step (ly:pitch-transpose (ly:make-pitch 0 2 -1) root) pitches)
41 (define (maj7-modifier root pitches)
42 (set! pitches (remove-step 7 pitches))
43 (cons (ly:pitch-transpose (ly:make-pitch 0 6 0) root) pitches)
46 (define (dim-modifier root pitches)
47 (set! pitches (replace-step (ly:pitch-transpose (ly:make-pitch 0 2 -1) root) pitches))
48 (set! pitches (replace-step (ly:pitch-transpose (ly:make-pitch 0 4 -1) root) pitches))
49 (set! pitches (replace-step (ly:pitch-transpose (ly:make-pitch 0 6 -2) root) pitches))
54 (define (sus2-modifier root pitches)
55 (set! pitches (remove-step (pitch-step (ly:pitch-transpose (ly:make-pitch 0 2 0) root)) pitches))
56 (set! pitches (remove-step (pitch-step (ly:pitch-transpose (ly:make-pitch 0 3 0) root)) pitches))
57 (cons (ly:pitch-transpose (ly:make-pitch 0 1 0) root) pitches)
60 (define (sus4-modifier root pitches)
61 (set! pitches (remove-step (pitch-step (ly:pitch-transpose (ly:make-pitch 0 2 0) root)) pitches))
62 (set! pitches (remove-step (pitch-step (ly:pitch-transpose (ly:make-pitch 0 3 0) root)) pitches))
63 (cons (ly:pitch-transpose (ly:make-pitch 0 3 0) root) pitches)
66 (define-public default-chord-modifier-list
67 `((m . ,minor-modifier)
68 (min . ,minor-modifier)
69 (aug . , aug-modifier)
70 (dim . , dim-modifier)
71 (maj . , maj7-modifier)
72 (sus . , sus4-modifier)
75 (define (gobble-pitches lst)
78 (if (ly:pitch? (car lst))
79 (gobble-pitches (cdr lst))
84 ;; ? should remove 3 if sus2 or sus4 found?
85 (define (add-pitches root pitches to-add)
87 (or (null? to-add) (not (ly:pitch? (car to-add))))
91 (p (ly:pitch-transpose (car to-add) root))
94 (if (get-step step pitches)
95 (set! pitches (remove-step step pitches)))
96 (add-pitches root (cons p pitches) (cdr to-add)))))
98 (define (rm-pitches root pitches to-add)
100 (or (null? to-add) (not (ly:pitch? (car to-add))))
104 (p (ly:pitch-transpose (car to-add) root))
105 (step (pitch-step p))
107 (rm-pitches root (remove-step step pitches) (cdr to-add)))))
110 (define-public (construct-chord root duration modifications)
113 (flat-mods (flatten-list modifications))
114 (base-chord (list root
115 (ly:pitch-transpose (ly:make-pitch 0 2 0) root)
116 (ly:pitch-transpose (ly:make-pitch 0 4 0) root)))
122 (define (process-inversion note-evs inversion)
125 ;; Transpose the inversion down, and remember its original octave.
129 (define (interpret-chord root chord mods)
130 "Walk MODS, and apply each mod to CHORD in turn.
132 Side-effect: set BASS and INVERSION in containing body
134 ;; the recursion makes this into a loop. Perhaps its better to
135 ;; to do the different types of modifiers in order, so that
136 ;; addition _always_ precedes removal.
145 (interpret-chord root
148 ((equal? tag 'chord-colon)
149 (interpret-chord root
150 (add-pitches root chord tail)
151 (gobble-pitches tail)))
152 ((equal? tag 'chord-caret)
153 (interpret-chord root
154 (rm-pitches root chord tail)
155 (gobble-pitches tail)))
157 ((equal? tag 'chord-slash)
158 (set! inversion (car tail))
159 (interpret-chord root
161 (gobble-pitches tail)))
162 ((equal? tag 'chord-bass)
163 (set! bass (car tail))
164 (interpret-chord root
166 (gobble-pitches tail)))
168 ;; ugh. Simply add isolated pitches. This will give
169 ;; unexpected results.
171 (interpret-chord root
172 (add-pitches root chord tail)
173 (gobble-pitches tail)))
174 (else (scm-error 'chord-entry 'interpret-chord "Unknown chord instructions ~S." (list mods) #f))
179 (write-me "*******\n" flat-mods)
180 (set! complete-chord (interpret-chord root base-chord flat-mods))
181 (write-me "pitches: " complete-chord)
182 (write-me "bass: " bass)
183 (process-inversion (make-chord complete-chord bass duration) inversion)