\version "2.12.3"

#(define (transposer-factory scale)
    ;; Returns a transposer for the specified scale
    ;; It is an error if either argument to a transposer
    ;; is not in the scale it was created with.
   
    (define (index item lis) 
        (list-index (lambda (x) (equal? item x)) lis))

    (lambda (root-pitch new-root p) 
        (if (not (member root-pitch scale)) 
            (error "Root pitch not in scale!"))
            
        (if (not (member p scale)) 
            (error "Pitch, p, not in scale!"))
        (display (index p scale)) (display "  ")
        (display (index root-pitch scale)) (newline)
        (list-ref scale 
            (modulo 
                (+ (index p scale) 
                    (- (index new-root scale) 
                       (index root-pitch scale))) 
                (length scale)))))


#(define (alter-pitches music transposer)
  ;; Recurse through music, applying transposer to pitches.
  ;; The transposer function must take a single pitch as its
  ;; argument and return a new pitch.  These are LilyPond
  ;; scheme pitches, e.g. (ly:make-pitch 0 2 0)

  (let ((es (ly:music-property music 'elements))
        (e (ly:music-property music 'element))
        (p (ly:music-property music 'pitch)))

    (cond
        ((ly:pitch? p)
            (display-scheme-music p)
            (ly:music-set-property! music 'pitch (transposer p))
            (display-scheme-music (ly:music-property music 'pitch)))

        ((pair? es)
            (map (lambda (x) (alter-pitches x transposer)) es))

        ((ly:music? e)
            (alter-pitches e transposer)))))


#(define (extract-pitch-sequence music)
  ;; Recurse through music, extracting pitches.
  ;; Returns a list of pitch objects, e.g
  ;; '((ly:make-pitch 0 2 0) (ly:make-pitch 0 4 0) ... )
  ;; Typically used to construct a scale for input to
  ;; transposer-factory (see above in this file).

  (let ((es (ly:music-property music 'elements))
        (e (ly:music-property music 'element))
        (p (ly:music-property music 'pitch)))

    (cond
        ((ly:pitch? p)  p)

        ((pair? es)
            (map (lambda (x) (extract-pitch-sequence x)) es))

        ((ly:music? e)
            (extract-pitch-sequence e)))))

#(define (make-scale music)
    (map car (extract-pitch-sequence music)))

#(define (replicate-modify lis n mod-proc)
    ;; apply (mod-proc lis n) to list and
    ;; concatenate.
    (cond 
        ((< n 0) (error "Whoops, negative replication count!"))
        ((= n 0) '())
        ((= n 1) (mod-proc lis 1))
        ((= n 2) (append (mod-proc lis 1) (mod-proc lis 2)))
        ((> n 2) (append 
            (replicate-modify lis (- n 1) mod-proc) 
            (mod-proc lis n))))) 

#(define (make-extended-scale music)
    ;; extend scale by 5 octaves up and down
    (define extender  
        (lambda (lis n)
            (display n) (newline)
            (map (lambda (i) 
                (display i) (newline)
                (ly:make-pitch 
                    (+ (- n 6) (ly:pitch-octave i))
                    (ly:pitch-notename i)
                    (ly:pitch-alteration i))) lis)))

    (let ((scale (make-scale music)))
        (display-scheme-music scale)
        (replicate-modify scale 11 extender)))
       

#(define (make-modal-transposer root-pitch new-root scale)
    ;;wrapper function for transposer-factory
    (let ((transposer (transposer-factory 
            (make-extended-scale scale)))
          (root 
            (car (extract-pitch-sequence root-pitch)))
          (new 
            (car (extract-pitch-sequence new-root))))
        (lambda (p)
            (transposer root new p))))
            

%% Music function for modal transposition
modalTranspose = 
#(define-music-function (parser location from to scale music) 
    (ly:music? ly:music? ly:music? ly:music?)
       (let ((transposer 
                (make-modal-transposer from to scale)))
        (alter-pitches music transposer)
        music))

%% ---------- Demo ------------------------------

%% Just to show it works with transposed music :-)
dPentScale =  \transpose c d { c'4 d' e' g' a'1 }
mymotive = \transpose c d { c'4 c' e' d' c'1}

%% And here's an octatonic example
cOctatonicScale = {c'4 d' ees' f' ges' aes' a' b'}
octamotive = {c'4 ees' ges' a' b' aes' f' d' }

\score {
     \new Staff {
        \tempo "" 2=120
        \mark "Pentatonic"
        \dPentScale
        \mymotive
        \modalTranspose d' e' \dPentScale \mymotive
        \mymotive
        \break
        \mark "Octatonic"
        \cOctatonicScale
        \octamotive
        \modalTranspose c' a' \cOctatonicScale \octamotive
        \octamotive
        {ees'1} %% Can't stand not resolving :-)
     }

    \layout {}
    \midi {}
}