Tertio Idus Apriles MMXVIII scripsit Jérôme Plût :
> So before I waste too much time on this: given the number of geniuses
> on this mailing-list, certainly one of you already did write the
> relevant Scheme code, am I right?
Given the lack of answer, I did write some Scheme code, which you will
find attached.
This defines a function \transposeFigures, used in the following way:
#(load "transpose-figures.scm")
oldfigures = \figures { ... } % put something in here
oldbass = \relative { ... } % here too
\new FiguredBass { \transposeFigures c d \oldfigures \oldbass }
--
Jérôme
(define (moment-max a b) (if (ly:moment<? a b) b a))
(define (duration-rat d) (ly:moment-main (ly:duration-length d)))
; raw-notes;{{{
; returns a pair (list of all music events) . (end position)
; where each (music event) is a list of (time, pitch, duration)
(define (raw-notes music) (car (raw-note-rec music (ly:make-moment 0 1 0 0))))
(define (raw-note-rec music start) (let* (
(name (ly:music-property music 'name))
(proc (primitive-eval (assoc-ref raw-note-proc name)))
)
(if proc (proc music start) (cons '() start))
))
(define raw-note-proc '(
(RelativeOctaveMusic . raw-note-descend-element)
(SequentialMusic . raw-note-sequential)
(EventChord . raw-note-simultaneous)
(SimultaneousMusic . raw-note-simultaneous)
(NoteEvent . raw-note-duration)
(RestEvent . raw-note-duration)
(SkipEvent . raw-note-duration)
))
(define (raw-note-descend-element music start)
(raw-note-rec (ly:music-property music 'element) start))
; (define (raw-note-ignore music start) (cons '() start))
(define (raw-note-sequential music start) (let* (
(F (lambda (m ret) (let (
(R (raw-note-rec m (cdr ret))))
(cons (append (car R) (car ret)) (cdr R)))))
)
(fold F (cons '() start) (ly:music-property music 'elements))
))
(define (raw-note-simultaneous music start) (let* (
(F (lambda (ret m) (let R (raw-note-rec m start)
(cons (append (car R) (car ret)) (moment-max (cdr R) (cdr ret))))))
)
(fold F (cons '() start) (ly:music-property music 'elements))
))
(define (raw-note-duration music start) (let* (
(prop (lambda (x) (ly:music-property music x)))
(duration (prop 'duration))
)
(cons (list (list start (prop 'pitch) duration))
(ly:moment-add start (ly:duration-length duration)))
))
;}}}
; bass-line;{{{
; 0. get raw notes (cf. supra)
; 1. sort them by (increasing time position, increasing pitch,
; decreasing duration)
; 1.5 initialize B = '()
; 2. for each note X in this list:
; if (null? B)
; or (X starts after the end of (car B))
; or (X is lower in pitch than (car B))
; then B ← X::B
; 3. return (reverse B)
;
; then we modify step 3 by computing the duration of each note as the
; difference between its position and the next one
; (this allows rests in the bass to be interpreted as a prolongation
; of the previous note)
(define (bass-line music) (car (fold
(lambda (x r)
(cons
(cons (list (list-ref x 0) (list-ref x 1) (- (cdr r) (list-ref x 0)))
(car r))
(list-ref x 0))) (cons '() 10000)
(fold bass-line-rec '() (sort (raw-notes music) (lambda (x y) (or
(ly:moment<? (list-ref x 0) (list-ref y 0))
(ly:pitch<? (list-ref x 1) (list-ref y 1))
(ly:duration<? (list-ref y 2) (list-ref x 2)))))))))
; (define (bass-note-end x) (ly:moment-add (list-ref x 0) (list-ref x 2)))
(define (bass-line-rec x b) (let* (
(m (ly:moment-main (list-ref x 0)))
(p (list-ref x 1))
(d (duration-rat (list-ref x 2)))
; (_ (print "m p d = " m " " p " " d ", " b))
) (if (null? b) (list (list m p d))
(if (or
(>= m (+ (list-ref (car b) 0) (list-ref (car b) 2)))
(ly:pitch<? p (list-ref (car b) 1))
) (cons (list m p d) b) b))
))
;}}}
; transpose-figures-event;{{{
; transposes a single BassFigureEvent object.
; figure (as a BassFigureEvent)
; delta (as a Pitch)
; bass (as a Pitch)
(define (transpose-figures-event delta figure bass) (let* (
(prop (lambda (x) (ly:music-property figure x)))
(f1 (prop 'figure))
(f (if (null? f1) 3 f1)) ; 3 is the default (unnamed) interval
(p (ly:make-pitch 0 (+ (ly:pitch-notename bass) f -1)))
(q (ly:pitch-transpose p delta))
(l1 (list 'duration (prop 'duration)))
(l (if (null? f1) l1 (append l1 (list 'figure f))))
; (_ (print "f1 = " f1 ", f = " f ", q = " q "l = " l))
(a (prop 'alteration))
)
; (print "a:" (rational? a) a (if (rational? a) (+ a (ly:pitch-alteration q))
a))
(if (not (null? a)) (set! l (cons 'alteration (cons
(if (rational? a) (+ a (ly:pitch-alteration q)) a) l))))
; (print "now l = " l)
(apply make-music (cons 'BassFigureEvent l))
))
;}}}
; transpose-figures-chord;{{{
(define (transpose-figures-chord delta chord bass)
(if (and (not (null? bass))
(equal? (ly:music-property chord 'name) 'EventChord))
(make-music 'EventChord 'elements (map
(lambda (e) (transpose-figures-event delta e bass))
(ly:music-property chord 'elements)))
chord))
; delta: pitch of transposition
; figures: list of BassFigureEvent
; bass: list of bass notes (as produced by bass-line)
; current: current bass note
; ttl: (rational) duration remaining on current bass note
(define (chord-duration chord)
(if (equal? (ly:music-property chord 'name) 'EventChord)
(fold max 0 (map
(lambda(x) (duration-rat (ly:music-property x 'duration)))
(ly:music-property chord 'elements)))
0))
(define (transpose-figures-rec delta figures bass current ttl)
; (print "#figures = " (length figures))
; (print "figures0 = ") (display-scheme-music (list-ref figures 0)) (print
"--")
(if (null? figures) '() (if (<= ttl 0)
(transpose-figures-rec delta figures
(cdr bass) (list-ref (car bass) 1) (+ ttl (list-ref (car bass) 2)))
(cons
(transpose-figures-chord delta (car figures) current)
(transpose-figures-rec delta (cdr figures) bass current
(- ttl (chord-duration (car figures)))))
))
)
;}}}
;
(define (transpose-figures delta figures bass) (let* (
(bass1 (bass-line bass))
(fig1 (ly:music-property (ly:music-property figures 'element) 'elements))
) (transpose-figures-rec delta fig1 bass1 (list-ref (car bass1) 1) 0)
))
(define transposeFigures (define-music-function (parser location
p1 p2 figures bass) (ly:pitch? ly:pitch? ly:music? ly:music?)
(make-music 'ContextSpeccedMusic 'create-new #t
'property-operations '() 'context-type 'FiguredBass 'element
(make-music 'SequentialMusic 'elements
(transpose-figures (ly:pitch-diff p2 p1) figures bass))))
)
_______________________________________________
lilypond-user mailing list
lilypond-user@gnu.org
https://lists.gnu.org/mailman/listinfo/lilypond-user
