\version "2.18.0"

% http://lsr.dsi.unimi.it/LSR/Item?id=465


%LSR This snippet was contributed by Jay Anderson


#(define (nondestructive-music-map fn mus)
 (music-map fn (ly:music-deep-copy mus)))

#(define (create-note pitch duration)
 (make-music 'NoteEvent
   'duration duration
   'pitch pitch))

#(define (make-chord chord-pitches chordevent)
 (let* ((skip (car (ly:music-property chordevent 'elements)))
        (rest (cdr (ly:music-property chordevent 'elements)))
        (duration (ly:music-property skip 'duration)))
   (if (eq? (ly:music-property skip 'name) 'SkipEvent)
     (make-music 'EventChord
       'elements (append
                   (map (lambda (x) (create-note x duration))
(pick-pitches chord-pitches))
                   rest))
     chordevent)))

#(define (apply-chord mus pitches)
 (if (eq? (ly:music-property mus 'name) 'EventChord)
   (make-chord pitches mus)
   mus))

% Returns two pitches from the input:
%  <The original pitch(es)>
%  <The pitch(es) in octave '-1'>
% This makes the function work in \relative sections.
% A flag is included to mark which marks if the first pitches need to be used or
% not.
#(define (get-pitches mus)
 (let* ((p (map
            (lambda (x) (ly:music-property x 'pitch))
            (ly:music-property mus 'elements)))
       (first-p (car p))
       (pitch (ly:pitch-notename first-p))
       (alteration (ly:pitch-alteration first-p))
       (octave -1)
       (px (ly:make-pitch octave pitch alteration)))
  (list #t p (cons px (cdr p)))))

% Return the first set of pitches if the flag is true else return the second
% set. Always set the flag to false before returning.
#(define (pick-pitches pitches)
 (let* ((first (car pitches))
        (native-octave (cadr pitches))
        (relative-octave (caddr pitches))
        (return (if first native-octave relative-octave)))
   (set-car! pitches #f)
   return))

#(define (rhythm-template template)
 (define-music-function (parser location mus) (ly:music?)
   (let ((pitches (get-pitches (event-chord-wrap! mus))))
     (nondestructive-music-map (lambda (mus) (apply-chord (event-chord-wrap! mus)
pitches)) template))))

%Example usage:
%These methods should only be used within a \relative section.
rhya = #(rhythm-template #{s8.-> s16 s8#} )
rhyb = #(rhythm-template #{s8[ r16 s16 s8]#} )
rhyc = #(rhythm-template #{s16 s~ s4#} )

rhyd = #(rhythm-template #{ \times 2/3 { s8 s8 s8 } s4 s4 s8 s8 s4 #} )
rhye = #(rhythm-template #{ \times 2/3 { s8---\pp s8-- s8-- } s4--
s4-- s8-- s8-- s4-- #} )
rhyf = #(rhythm-template #{ \times 2/3 { s4 \times 2/3 { s8 s-> s } s4 } #} )

\score
{
 \new Staff \relative c'
 {
  \time 6/8
  \rhya c \rhyb c' |
  \rhya <c, e> \rhyb <c f> |
  \rhyc <c e> \rhyc <c d> |
  \time 5/4
  \rhyd c
  \rhyd e
  \rhye <c e g>
  \time 4/4
  \rhyf c \rhyf d
  }
}