%% http://lsr.di.unimi.it/LSR/Item?id=654

%% version 2013/05/11
%% for lilypond 2.18 or higher
%% last changes : - \changePitch : a single s as the last event of newnotes parameter
%%                   will give you the ending rests of the pattern (if there), and two s
%%                   also the beginning ones. If pattern ends with a note, a single 
%%                   ending s will have no effects.
%%                - Is now \language independant (no more #{ c #})
%%                - new algorithm for make-notes-list, change-pitch
%%                  and has-notes? (shorter and safer)
%%
%%%%%%%%%%%%%%%%%%%%%%%%% some utility functions %%%%%%%%%%%%%%%%%%%%%

\paper { tagline = ##f }

#(define (name-of music)
 (ly:music-property music 'name))

#(define (has-notes? music)
"Return true if there is at least one note in `music, false otherwise."
 (or (eq? (name-of music) 'NoteEvent)
     (let ((e (ly:music-property music 'element)))
        (and (ly:music? e) 
             (has-notes? e)))
     (let loop ((es (ly:music-property music 'elements)))
        (and (pair? es)
             (or (has-notes? (car es))
                 (loop (cdr es)))))))
 
%% An EventChord is sometimes used as a wrapper in Lilypond, so we have to check
%% if a chord is a standard chord with notes. We could have used has-notes? but
%% this version is perhaps more efficient. 
%% Optional events name like 'RestEvent can be included.
#(define (note-or-chord? music . otherEvent)
"Is music a note or a chord with notes ?"
(let ((name (name-of music)))
 (or (memq name (cons 'NoteEvent otherEvent))
     (and (eq? name 'EventChord)  ; have this chord at least one note ? 
          (let loop ((es (ly:music-property music 'elements)))
             (and (pair? es)
                  (or (eq? (name-of (car es)) 'NoteEvent)
                      (loop (cdr es)))))))))

#(define (expand-q-chords music); for q chords : see chord-repetition-init.ly
(expand-repeat-chords! (list 'rhythmic-event) music))

#(define (clean-music mus)
"Try to reduce the number of sequential music"
(let ((name (ly:music-property mus 'name)))
  (cond
    ((eq? name 'SequentialMusic)
       (ly:music-set-property! mus 'elements (fold-right
          (lambda (evt prev-list)
            (if (eq? (name-of evt) 'SequentialMusic)
              (append (ly:music-property (clean-music evt) 'elements) prev-list)
              (cons (clean-music evt) prev-list)))
          '()
          (ly:music-property mus 'elements))))
    ((eq? name 'SimultaneousMusic)
       (ly:music-set-property! mus 'elements
                (map clean-music (ly:music-property mus 'elements))))
    ((memq name (list 'RelativeOctaveMusic 'UnrelativableMusic))
         (ly:music-set-property! mus 'element (clean-music
                  (ly:music-property mus 'element)))))
 mus))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%% changePitch %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
#(define cPInsertInPattern (gensym))
#(define cPSamePitch (gensym))
#(define cPSamePitchEnd (gensym))
#(define cPPatternEnd (gensym))

#(define (make-notes-list music)
"Make a list with each element will be of one of these types :
  1- a note, a chord, a rest
  2- an integer, indicating the number of notes to skip in pattern ( The user will
     indicate that, by a corresponding number of skips (s or \\skip) in `newnotes 
     parameter of \\changePitch )
  3- a list of musics, to be inserted between 2 notes of pattern, and added with
     the \\insert function, inside `newnotes"
(let ((res '())     ; the list to fill
      (prev #f))
  (define (fill-notes-list evt)
    (let ((tags (ly:music-property evt 'tags))
          (name (name-of evt)))
      (cond
        ((memq cPInsertInPattern tags)             ; a music added by \insert
            (ly:music-set-property! evt 'tags
                          (delq cPInsertInPattern tags))     ; remove the tag
            (if (integer? prev)(set! res (cons prev res)))
            (set! prev (if (pair? prev)(cons evt prev)(list evt))))  ; a list
         ((memq name (list 'SkipEvent 'SkipMusic))
            (if (pair? prev)(set! res (cons prev res))) ; keep the reverse order
            (set! prev (if (integer? prev) (1+ prev) 1)))
       ; ((memq name (list 'EventChord 'NoteEvent 'RestEvent))
         ((note-or-chord? evt 'RestEvent) ; a note, a chord, or a rest
            (if (or (pair? prev)(integer? prev))(set! res (cons prev res)))
            (set! prev evt)
            (set! res (cons evt res)))
         (else
          (let ((elt (ly:music-property evt 'element))
                (elts (ly:music-property evt 'elements)))
            (if (ly:music? elt) (fill-notes-list elt))
            (if (pair? elts)(for-each fill-notes-list elts)))))))
(fill-notes-list music)
(if (or (pair? prev)(integer? prev))(set! res (cons prev res)))
(reverse res)))

%%%%%%%%%%%%  used inside the inner function change-one-note
#(define (copy-duration from to)  ; from and to as EventChord or NoteEvent
(let ((max-dur #f)); in theory, 2 notes in a chord can have a different duration
  (music-map (lambda (x)            ; get main duration from `from
              (let ((dur (ly:music-property x 'duration)))
               (if (and (ly:duration? dur)
                        (or (not max-dur)
                            (ly:duration<? max-dur dur))); take the greater
                 (set! max-dur dur))
                 x))
              from)
  (music-map (lambda (x)            ; set duration to duration of `to
               (if (ly:duration? (ly:music-property x 'duration))
                  (ly:music-set-property! x 'duration max-dur))
               x)
             to)))

#(define (copy-arti from to) ; from and to as EventChord or NoteEvent
(let* ((es-from (ly:music-property from 'elements))
       (es-to (ly:music-property to 'elements))
       (arti-from (if (null? es-from) 
                    (ly:music-property from 'articulations)
                    (filter 
                      (lambda(x)
                        (not (ly:duration? (ly:music-property x 'duration))))
                      es-from))))
  (if (null? es-to)                       ; NoteEvent
    (ly:music-set-property! to 'articulations  
              (append (ly:music-property to 'articulations) arti-from))
    (ly:music-set-property! to 'elements  ; EventChord
              (append es-to arti-from)))
  ; copy also 'tags and 'to-relative-callback            
  (ly:music-set-property! to 'tags 
    (append (ly:music-property from 'tags)(ly:music-property to 'tags)))
   (if (null? es-to) 
      (ly:music-set-property! to 'to-relative-callback 
          (ly:music-property from 'to-relative-callback))
      (begin
        (ly:music-set-property! to 'to-relative-callback 
            ly:music-sequence::event-chord-relative-callback)
        (ly:music-set-property! (car es-to) 'to-relative-callback
            (ly:music-property from 'to-relative-callback))))
    ))

%% del-arti is called for all notes but the first of a \samePitch section. 
#(define (del-arti note-or-chord)
(ly:music-set-property! note-or-chord 'articulations '())
(ly:music-set-property! note-or-chord 'elements 
  (filter (lambda(x) 
              (and (ly:duration? (ly:music-property x 'duration))
                   (ly:music-set-property! x 'articulations '())))
          (ly:music-property note-or-chord 'elements))) ; can be empty
(music-map  ;; del all caution accidentals
  (lambda(x)(if (eq? (name-of x) 'NoteEvent) (begin
               (ly:music-set-property! x 'force-accidental #f)
               (ly:music-set-property! x 'cautionary #f)))
             x)
  note-or-chord))

#(define (change-pitch pattern newnotes)
"The scheme function of \\changePitch, `pattern and `newnotes as music."
(let ((seq-list '())           ; list of transformed patterns
      (skip-notnote-event? #f) ; #t if a \skip or an \insert is found in newnotes
      (same-pitch-section? #f) ; #t if we are in the 2nd pattern note of a\samePitch section
      ;(dummy-note #{ c4 #})    ; \language dependant -:(
      (dummy-note (make-music 'NoteEvent ; to avoid pbs with pattern without any notes
                              'duration (ly:make-duration 2 0 1) ;
                              'pitch (ly:make-pitch -1 0 0))) ;
      (pattern2 #{ $pattern \tag #cPPatternEnd s4 #}) ; to detect the end of pattern
      (last-notes-list #f))    ; buffer 
 (set! seq-list (cdr  ; skip dummy notes
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; loop ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (let loop ((notes-list (cons dummy-note (make-notes-list newnotes))); see make-notes-list
             (pat-list (cons dummy-note (circular-list pattern2)))
             (res '())) ; the list to fill
    (if (or (null? notes-list)(null? pat-list)) ; pat-list may be a regular list in the loop
      (reverse res)               ;;;;;; return the list in the right order
      (let ((x (car notes-list))  ;;;;;; go deeper, taking 1st elt of each lists
            (evt (ly:music-deep-copy (car pat-list))))
       (cond
       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
        ((pair? x)                   ; x is a list of musics, added with \insert in newnotes
          (set! skip-notnote-event? #t)      ; for events between 2 pattern notes
          (set! last-notes-list notes-list)  ; for section "else" of this cond statement
          (loop (cdr notes-list) pat-list (append x res))) ; append x to res
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        ((note-or-chord? evt)         ; evt in pattern is a note or a chord (with notes)
          (set! last-notes-list notes-list)  ; for section "else" later
          (cond
            ((ly:music? x)  ;;;;;; the elt of notes-list is a note or a chord
               (if same-pitch-section? ; x is used several times. Copy arti of x only to the
                 (set! x (del-arti (ly:music-deep-copy x)))) ; 1st note of \samePitch section
               (copy-duration evt x)  ; evt = from, x = to
               (copy-arti evt x)
               (let ((tags (ly:music-property x 'tags)))
                 (cond               ; are we in a \samePitch section ?
                   ((memq cPSamePitch tags)    ; yes, first,remove the tag
                      (ly:music-set-property! x 'tags (delq cPSamePitch tags))
                      (set! same-pitch-section? #t)) ; then set the flag        
                   ((memq cPSamePitchEnd tags) ; last note of \samePitch
                      (ly:music-set-property! x 'tags (delq cPSamePitchEnd tags))
                      (set! same-pitch-section? #f))))      ; unset the flag
               (set! skip-notnote-event? #f); stop deletion of not-notes event.
               (if same-pitch-section?
                   (loop notes-list (cdr pat-list)(cons x res))    
                   (loop (cdr notes-list)(cdr pat-list)(cons x res)))) ; next new note              
            ((integer? x)   ;;;;;; user want to skip over the current evt note. We also
               (set! skip-notnote-event? x) ; don't add any events bis next pattern note
               ;; (format #t "x : ~a\n" x)  ; for testing
               (cond ((= x 1)                                      ; only one s
                        (loop (cdr notes-list)(cdr pat-list) res)) ; next notes-list elt
                     (else                                         ; several successive s
                        (set-car! notes-list (1- x))               ; for the next loop
                        (loop notes-list (cdr pat-list) res))))))  ; the next evt only
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;        
        ((or (ly:music-property evt 'duration #f)  ; current evt in pattern is not a note
             (not (has-notes? evt)))
           (cond ((memq cPPatternEnd (ly:music-property evt 'tags)) ; last evt of pattern
                    (let ((x (car notes-list)))
                      (if (and (integer? x)
                                (or (null? (cdr notes-list))        ; last elt ?
                                    (and (null? (cddr notes-list))  ; 2nd to last and last is
                                         (pair? (car (cdr notes-list)))))) ; a \insert section
                        (cond 
                           ((= x 1)
                              (set! skip-notnote-event? x)
                              (loop (cdr notes-list) (cdr pat-list) res))
                           (else 
                              (set-car! notes-list (1- x))
                              (loop notes-list (cdr pat-list) res))))
                        (loop notes-list (cdr pat-list) res))) ;; ignores evt
                  (skip-notnote-event? (loop notes-list (cdr pat-list) res))
                  (else (loop notes-list (cdr pat-list)(cons evt res)))))
        ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        (else
          (let ((e (ly:music-property evt 'element))
                (es (ly:music-property evt 'elements))
                (empty? #f)) ; don't add to res if #t
           (if (ly:music? e)
             (let ((new-e (loop notes-list (list e) '())))
               (ly:music-set-property! evt 'element
                 (case (length new-e)
                   ((0) (set! empty? #t)
                        new-e)
                   ((1)(car new-e))
                   (else (make-sequential-music new-e))))))
           (if (pair? es)
             (let ((new-es (loop notes-list es '())))
               (ly:music-set-property! evt 'elements new-es)
               (set! empty? (and empty? (null! new-es))))) ; #t if both empty 
           
           (let ((next-new-notes (if (or same-pitch-section? 
                                         (and (integer? skip-notnote-event?)
                                              (> skip-notnote-event? 1)))
                                    last-notes-list 
                                    (cdr last-notes-list))))
              (if empty? (loop next-new-notes (cdr pat-list) res)
                         (loop next-new-notes (cdr pat-list) (cons evt res))))))))))))
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; end loop ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  
 (let ((relativize (lambda(m)
        (let* ((clean-newnotes (clean-music newnotes))
               (name (name-of clean-newnotes)))
            (if (memq name (list 'RelativeOctaveMusic 'UnrelativableMusic))
               (make-music name 'element m)
               m)))))
     (case (length seq-list)
        ((0) (make-music 'Music 'void #t))
        ((1) (relativize (car seq-list)))
        (else (relativize (clean-music (make-sequential-music seq-list))))))))
        
changePitch = #(define-music-function (pattern newnotes)
                                                          (ly:music? ly:music?)
"Change each notes in `pattern by the notes (or rests) given in `newnotes.
If count of events doesn't match, pattern is duplicated repeatedly or truncate."
(let* ((expand-q (lambda (music) (expand-repeat-chords!
			    (cons 'rhythmic-event (ly:parser-lookup '$chord-repeat-events))
			    music)))
       (pattern (expand-q pattern))
       (newnotes (expand-q newnotes)))
 (change-pitch pattern newnotes)))

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% enhancement functions, working with \changePitch pattern newnotes

samePitch = #(define-music-function (music) (ly:music?)
"Inside the `pattern parameter of the \\changePitch function, all notes grouped 
by this function will have the same pitch, according to the current note of
`newnotes parameter of \\changePitch."
(let((not-first? #f)
     (last-note #f))
  (map-some-music
    (lambda (x)
      (cond
        ((note-or-chord? x)
           (if not-first?     ; set all pitches to the pitch of the first note
             (ly:music-set-property! x 'to-relative-callback 
                (lambda (x p)                    ; set pitch to the prev value
                    (ly:prob-set-property! x 'pitch p)
                    p))
             (set! not-first? x)) ; do nothing for first note
           (ly:music-set-property! x 'tags (cons
                   cPSamePitch  ; add tag cPSamePitch to x
                   (ly:music-property x 'tags)))
           (set! last-note x)   ; save the note x
           x)
        (else #f)))
    music)
  (if last-note              ; the last saved EventChord
     (ly:music-set-property! last-note 'tags (cons
           cPSamePitchEnd    ; add cPSamePitchEnd tag, delete cPSamePitch tag
           (delq cPSamePitch (ly:music-property last-note 'tags)))))
  music))

%% this function should be no more needed, as copy-arti should avoid pbs
%% in relative mode and \samePitch
absolute = #(define-music-function (music) (ly:music?)
"Make `music unrelativable. To use inside a \\samePitch function in relative
mode."
(make-music 'UnrelativableMusic 'element music))

insert = #(define-music-function (music) (ly:music?)
"Using this function inside the `newnotes parameter of the \\changePitch
function, allow you to insert and remplace by `music, all music between one note
and his following, in the `pattern parameter of \\changePitch, ."
#{ \tag #cPInsertInPattern $music #})

%%%%%%%
#(define (n-copy n music)
(cond
  ((> n 1)(make-sequential-music 
            (map (lambda (x)(ly:music-deep-copy music))
                 (make-list n))))
  ((= n 1) music)
  (else (make-music 'Music 'void #t))))

nCopy = #(define-music-function (n music)(integer? ly:music?)
(n-copy n music))

%% same effect as { \repeat unfold n s } but \nSkip works inside the `newnotes
%% parameter of \changePitch.
nSkip = #(define-music-function (n)(integer?)
"Return \\skip \\skip \\skip ... n times."
#{ \nCopy #n s #})
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% shortcuts
% default values for patI and patII, if the user do not define
% them, before using \cPI and \cPII
% patI ={ c8. c16 }      % not \language independant
patI = #(make-music 'SequentialMusic 'elements (list  
          (make-music 'NoteEvent 'duration (ly:make-duration 3 1 1) 
                                 'pitch (ly:make-pitch -1 0 0))
          (make-music 'NoteEvent 'duration (ly:make-duration 4 0 1)
                                 'pitch (ly:make-pitch -1 0 0)))) 
% patII = { c4. c8 }
patII = #(make-music 'SequentialMusic 'elements (list  
          (make-music 'NoteEvent 'duration (ly:make-duration 2 1 1) 
                                 'pitch (ly:make-pitch -1 0 0))
          (make-music 'NoteEvent 'duration (ly:make-duration 3 0 1)
                                 'pitch (ly:make-pitch -1 0 0)))) 


cPI = #(define-music-function (newnotes) (ly:music?)
#{ \changePitch \patI $newnotes #})

cPII = #(define-music-function (newnotes) (ly:music?)
#{ \changePitch \patII $newnotes #})

#(define cP changePitch)

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% The example %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

testMusic = { c d e f g f e d <c e> <d f> <e g> <d f> }
fillerChord = { <c e>2 }

\relative c' {
  \override  Score.RehearsalMark.self-alignment-X = #LEFT
  
  \mark "pattern = { c8.-> c16-. }"
  
  \changePitch { c8.-> c16-. } {
    \testMusic
  }
  \fillerChord
  \break
  
  \mark "pattern = { c8 c16( c) }"
  
  \changePitch { c8 c16( c) } {
    \testMusic
  }
  \fillerChord
  \fillerChord
  \break

  \time 6/8
  \mark "pattern = { c4( c8) c8.( c16) c8-. }"
  \changePitch { c4( c8) c8.( c16) c8-. } {
    \testMusic
  }
  <c e>4.
}