1 ;;; modal-transforms.scm --- Modal transposition, inversion, and retrograde.
3 ;; Copyright (C) 2011--2015 Ellis & Grant, Inc.
5 ;; Author: Michael Ellis <michael.f.ellis@gmail.com>
9 ;; This program is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2 of the License, or
12 ;; (at your option) any later version.
14 ;; This program is distributed in the hope that it will be useful, but
15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
16 ;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with this program; if not, write to the Free Software
21 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.
24 (define (transposer-factory scale)
25 "Returns a transposer for the specified @var{scale}.
26 It is an error if either argument to a transposer is not in the scale
27 it was created with. A transposer knows nothing about LilyPond
28 internals. It treats scales as an ordered list of arbitrary items and
29 pitches as members of a scale.
32 (define (index item lis)
33 (list-index (lambda (x) (equal? item x)) lis))
35 (lambda (from-pitch to-pitch pitch)
37 ((not (member from-pitch scale))
38 (ly:warning (_i "'from' pitch not in scale; ignoring"))
41 ((not (member to-pitch scale))
42 (ly:warning (_i "'to' pitch not in scale; ignoring"))
45 ((not (member pitch scale))
46 (ly:warning (_i "pitch to be transposed not in scale; ignoring"))
52 (+ (index pitch scale)
53 (- (index to-pitch scale)
54 (index from-pitch scale)))
57 (define (inverter-factory scale)
58 "Returns an inverter for the specified @var{scale}.
59 It is an error if either argument to an inverter
60 is not in the scale it was created with. An inverter knows nothing
61 about LilyPond internals. It treats scales as an ordered list of
62 arbitrary items and pitches as members of a scale.
65 (define (index item lis)
66 (list-index (lambda (x) (equal? item x)) lis))
68 (lambda (around-pitch to-pitch pitch)
70 ((not (member around-pitch scale))
71 (ly:warning (_i "'around' pitch not in scale; ignoring"))
74 ((not (member to-pitch scale))
75 (ly:warning (_i "'to' pitch not in scale; ignoring"))
78 ((not (member pitch scale))
79 (ly:warning (_i "pitch to be inverted not in scale; ignoring"))
85 (+ (index to-pitch scale)
86 (- (index around-pitch scale)
90 (define (replicate-modify lis n mod-proc)
91 "Apply @code{(mod-proc lis n)} to each element of a list and
92 concatenate the results. Knows nothing of LilyPond internals."
95 (ly:warning (_i "negative replication count; ignoring")))
102 (replicate-modify lis (- n 1) mod-proc)
107 (define-public (change-pitches music converter)
108 "Recurse through @var{music}, applying @var{converter} to pitches.
109 Converter is typically a transposer or an inverter as defined above in
110 this module, but may be user-defined. The converter function must take
111 a single pitch as its argument and return a new pitch. These are
112 LilyPond scheme pitches, e.g. @code{(ly:make-pitch 0 2 0)}
114 (let ((elements (ly:music-property music 'elements))
115 (element (ly:music-property music 'element))
116 (pitch (ly:music-property music 'pitch)))
120 (ly:music-set-property! music 'pitch (converter pitch)))
123 (for-each (lambda (x) (change-pitches x converter)) elements))
126 (change-pitches element converter)))))
129 (define (make-scale music)
130 "Recurse through @var{music}, extracting pitches.
131 Returns a list of pitch objects, e.g
132 @code{'((ly:make-pitch 0 2 0) (ly:make-pitch 0 4 0) ... )}
133 Typically used to construct a scale for input to
134 @code{transposer-factory}."
136 (let ((elements (ly:music-property music 'elements))
137 (element (ly:music-property music 'element))
138 (pitch (ly:music-property music 'pitch)))
146 (lambda (x) (make-scale x))
150 (make-scale element)))))
152 (define (make-extended-scale music)
153 "Extend scale given by @var{music} by 5 octaves up and down."
154 ;; This is a bit of a hack since, in theory, someone might want to
155 ;; transpose further than 5 octaves from the original scale
156 ;; definition. In practice this seems unlikely to occur very often.
162 (+ (- n 6) (ly:pitch-octave i))
163 (ly:pitch-notename i)
164 (ly:pitch-alteration i)))
167 (let ((scale (make-scale music)))
168 (replicate-modify scale 11 extender)))
171 ;; ------------- PUBLIC FUNCTIONS -----------------------------
173 (define-public (make-modal-transposer from to scale)
174 "Wrapper function for transposer-factory."
175 (let ((transposer (transposer-factory (make-extended-scale scale))))
177 (transposer from to p))))
179 (define-public (make-modal-inverter around to scale)
180 "Wrapper function for inverter-factory"
181 (let ((inverter (inverter-factory (make-extended-scale scale))))
183 (inverter around to p))))
186 (define-public (retrograde-music music)
187 "Returns @var{music} in retrograde (reversed) order."
188 ;; Included here to allow this module to provide a complete set of
189 ;; common formal operations on motives, i.e transposition,
190 ;; inversion and retrograding.
192 (define (reverse-span! m)
193 ;; invert direction of two-sided spanners
194 (let ((spd (ly:music-property m 'span-direction)))
197 (set! (ly:music-property m 'span-direction) (- spd))
198 (case (ly:music-property m 'name)
200 (make-music 'DecrescendoEvent m))
202 (make-music 'CrescendoEvent m))
206 ;; carryover is a possible list of tie events, the loop returns any
207 ;; such trailing list from the given expression
208 (define (loop m carryover)
209 (define (filter-ties! m carryover field)
210 (let ((vals (ly:music-property m field)))
214 (partition! (music-type-predicate
215 '(tie-event glissando-event)) vals))
216 (lambda (ties no-ties)
217 (set! (ly:music-property m field)
218 (append! (map! reverse-span! no-ties) carryover))
221 (if (pair? carryover)
222 (set! (ly:music-property m field) carryover))
225 ;; The reversal will let some prefatory material stay in front of
226 ;; the following element. Most prominently single
227 ;; overrides/reverts/sets/unsets and applyContext. This does not
228 ;; change the position of a clef (which will generally be useless
229 ;; after retrograding) but it does not jumble the clef change
230 ;; command internals. Also, stuff like \once\override stays at
231 ;; the affected element.
233 (define (prefatory? m)
234 (or ((music-type-predicate
235 '(apply-context apply-output-event layout-instruction-event)) m)
237 (music-is-of-type? m 'music-wrapper-music)
238 (prefatory? (ly:music-property m 'element)))))
240 (define (musiclistreverse lst)
241 (let loop ((lst lst) (res '()) (zeros '()))
242 (cond ((null? lst) (reverse! zeros res))
243 ((prefatory? (car lst))
244 (loop (cdr lst) res (cons (car lst) zeros)))
246 (loop (cdr lst) (reverse! zeros (cons (car lst) res)) '())))))
248 (cond ((music-is-of-type? m 'event-chord)
251 (filter-ties! m carryover 'elements)
252 ;; articulations on an event-chord do not occur
253 ;; "naturally" but are supported when user-generated
254 ;; elsewhere, so we treat them properly
255 (filter-ties! m '() 'articulations)))
256 ;; in-chord ties are converted to per-chord ties.
257 ;; This is less than optimal but pretty much the
258 ;; best we can hope to achieve with this approach.
261 (lambda (m) (filter-ties! m '() 'articulations))
262 (ly:music-property m 'elements))))
263 (append! chord-ties element-ties)))
265 ((music-is-of-type? m 'rhythmic-event)
266 (filter-ties! m carryover 'articulations))
268 ;; The following is hardly correct but tieing inside of
269 ;; <<...>> is really beyond our pay grade.
270 ((music-is-of-type? m 'simultaneous-music)
271 (append-map! (lambda (m) (loop m (ly:music-deep-copy carryover)))
272 (ly:music-property m 'elements)))
274 (let ((elt (ly:music-property m 'element))
275 (elts (ly:music-property m 'elements)))
278 (if (ly:music? elt) (loop elt carryover) carryover)
281 (set! (ly:music-property m 'element)
282 (reverse-span! elt)))
284 (set! (ly:music-property m 'elements)
285 (map! reverse-span! (musiclistreverse elts))))
286 (append! res (filter-ties! m '() 'articulations)))))))
287 (let ((dangling (loop music '())))
289 (lambda (t) (ly:music-warning t (_ "Dangling tie in \\retrograde")))
293 (define-public (pitch-invert around to music)
294 "If @var{music} is a single pitch, inverts it about @var{around}
295 and transposes from @var{around} to @var{to}."
296 (let ((p (ly:music-property music 'pitch)))
298 (ly:music-set-property!
300 (ly:pitch-transpose to (ly:pitch-diff around p))))
303 (define-public (music-invert around to music)
304 "Applies pitch-invert to all pitches in @var{music}."
305 (music-map (lambda (x) (pitch-invert around to x)) music))