\version "2.18"
#(begin

(define (create-articulation . l);<<<
  "creates an articulation with invisible output and specified properties"
  (define-event-function () ()
  (apply make-music (append (list 'TextScriptEvent 'text "") l)))
);>>>
(define (voicelead-find-articulation-prop m p);<<<
  "returns the first value found for property p in an articulation of m"
  " (or #f if not found)"
  (let* (
  (a (ly:music-property m 'articulations '()))
  (b (map (lambda (x) (ly:music-property x p #f)) a))
  )
  (find (lambda (x) x) b)
));>>>
(define (voicelead-duration-to d x);<<<
  "converts duration d to a duration (x 0 y) with same length"
  (let* (
    (q (ly:moment-main (ly:duration-length d)))
    ; arriver à q en partant de 2^(-x)
    (y (/ q (expt 2 (- x))))
  )
  (ly:make-duration x 0 y)
));>>>
(define (voicelead-note-heads! m);<<<
  "keep only note heads in the melody m, according to the voicelead-head
  property"
  (cond
  ((ly:music-property m 'elements #f)
    (map voicelead-note-heads! (ly:music-property m 'elements)))
  ((ly:music-property m 'element #f)
    (voicelead-note-heads! (ly:music-property m 'element)))
  ((eq? (ly:music-property m 'name) 'NoteEvent) (let* (
    (h (voicelead-find-articulation-prop m 'voicelead-head))
    )
    (cond
    ((eq? h 'white)
      (ly:music-set-property! m 'duration
        (voicelead-duration-to (ly:music-property m 'duration) 1)))
    ((eq? h 'black)
      (ly:music-set-property! m 'duration
        (voicelead-duration-to (ly:music-property m 'duration) 2)))
    ; if no head defined and has a beam, then white head
    ((voicelead-find-articulation-prop m 'voicelead-beam)
      (ly:music-set-property! m 'duration
        (voicelead-duration-to (ly:music-property m 'duration) 1)))
    ; if no head defined and has a slur, then black head
    ((voicelead-find-articulation-prop m 'voicelead-slur)
      (ly:music-set-property! m 'duration
        (voicelead-duration-to (ly:music-property m 'duration) 2)))
    (else  (ly:music-set-property! m 'name 'SkipEvent))
    )
    (ly:music-set-property! m 'articulations '())
  m ))
  (else m)
) m);>>>
(define (voicelead-note-beams! m);<<<
  "keep only note beams in the melody m, according to the voicelead-stem
  property"
  (cond
  ((ly:music-property m 'elements #f)
    (map voicelead-note-beams! (ly:music-property m 'elements)))
  ((ly:music-property m 'element #f)
    (voicelead-note-beams! (ly:music-property m 'element)))
  ((eq? (ly:music-property m 'name) 'NoteEvent) (let* (
    (h (voicelead-find-articulation-prop m 'voicelead-beam))
    )
    (ly:music-set-property! m 'articulations '())
    (if h
      (ly:music-set-property! m 'duration
        (voicelead-duration-to (ly:music-property m 'duration) 3))
      (ly:music-set-property! m 'name 'SkipEvent))
    (if (or (eq? h -1) (eq? h 1))
      (ly:music-set-property! m 'articulations (list
        (make-music 'BeamEvent 'span-direction h))))
  m ))
  (else m)
) m);>>>
(define (voicelead-note-slurs! m x);<<<
  "keep only note beams in the melody m, according to the voicelead-stem
  property"
  (cond
  ((ly:music-property m 'elements #f)
    (map (lambda (y) (voicelead-note-slurs! y x))
        (ly:music-property m 'elements)))
  ((ly:music-property m 'element #f)
    (voicelead-note-slurs! (ly:music-property m 'element) x))
  ((eq? (ly:music-property m 'name) 'NoteEvent) (let* (
    (h (voicelead-find-articulation-prop m 'voicelead-slur))
    )
    (ly:music-set-property! m 'articulations '())
    (ly:music-set-property! m 'duration
       (voicelead-duration-to (ly:music-property m 'duration) 0))
    (if (eq? h x)
      (ly:music-set-property! m 'articulations (list
        (make-music 'SlurEvent 'span-direction 1))))
    (if (eq? h (- x))
      (ly:music-set-property! m 'articulations (list
        (make-music 'SlurEvent 'span-direction -1))))
  m ))
  (else m)
) m);>>>
(define voiceLeadDiagram (define-music-function;<<<
   (parser location music) (ly:music?)
  #{ <<
  {
    \override NoteColumn.ignore-collision = ##t
    \omit Stem \omit Flag
    #(voicelead-note-heads! (ly:music-deep-copy music))
  } \\
  {
    \override NoteColumn.ignore-collision = ##t
    \omit NoteHead
    #(voicelead-note-beams! (ly:music-deep-copy music))
  } \\
  {
    \hideNotes
    \slurUp
    #(voicelead-note-slurs! (ly:music-deep-copy music) 1)
  } \\
  {
    \hideNotes
    \slurDown
    #(voicelead-note-slurs! (ly:music-deep-copy music) 2)
  }
  >> #}
));>>>

)% begin

% Definition of custom articulations%<<<
%  + use a black head if no head defined *and* a slur is defined;
%  + use a white head if no head defined *and* a beam is defined
white = #(create-articulation 'voicelead-head 'white)
black = #(create-articulation 'voicelead-head 'black)
beam = #(create-articulation 'voicelead-beam #t)
beamR = #(create-articulation 'voicelead-beam -1)
beamL = #(create-articulation 'voicelead-beam 1)
% slurs A, C up; B, D down
slurAR = #(create-articulation 'voicelead-slur -1)
slurAL = #(create-articulation 'voicelead-slur  1)
slurBR = #(create-articulation 'voicelead-slur -2)
slurBL = #(create-articulation 'voicelead-slur  2)
%>>>

% qux = \relative { a8\beamR\slurAR[( b\black] c) d\beamL\slurAL  }
qux = \relative {
   c'8\beamR d\slurAR\slurBR e\white f\black g\beam\slurAL
   a b\slurBR
   c\beamL\slurBL }

\paper { ragged-bottom = ##t }
\score { \new StaffGroup <<
  \new Staff { \qux }
  \new Staff { \voiceLeadDiagram \qux }
>> }

% \score { a8-* b c-[ d-] }