(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))))
)