\version "2.19.18"

% Scheme engraver to remove duplicate hairpins (e.g. caused by the partcombiner)
% author: Urs Liska
% source: http://lists.gnu.org/archive/html/lilypond-user/2015-04/msg00276.html
%         (Stub by David Nalesnik)

% String representation of a moment
#(define (moment->string mom)
   (let*
    ((num (ly:moment-main-numerator mom))
     (den (ly:moment-main-denominator mom)))
    (string-append
     (number->string num)
     "-"
     (number->string den))))

% Symbol representation of a moment, suitable as an alist key
#(define (moment->symbol mom)
   (string->symbol (moment->string mom)))

% Symbol representation of a starting point of a hairpin
#(define (hp-start-symbol hp)
   (moment->symbol
    (grob::when (ly:spanner-bound hp LEFT))))

% Symbol representation of a hairpin end
% This is suffixed with a direction indicator
#(define (hp-end-symbol hp)
   (string->symbol
    (string-append
     (moment->string
      (grob::when (ly:spanner-bound hp RIGHT)))
     "-"
     (number->string (ly:grob-property hp 'grow-direction)))))


removeDoubleHairpinsEngraver =
#(lambda (context)
   (let ((all-hairpins '())
         (simultaneous-hairpins '()))

     (make-engraver
      (acknowledgers
       ((hairpin-interface engraver grob source-engraver)
        (set! all-hairpins (cons grob all-hairpins))))

      ((finalize trans)
       (begin

        ;; generate an alist simultaneous-hairpins containing lists
        ;; with all hairpins starting at the same moment
        ;; This discerns between equal and different hairpins
        (for-each
         (lambda (hp)
           (let*
            ;; symbols to act as keys in alists
            ((start-symbol (hp-start-symbol hp))
             (end-symbol (hp-end-symbol hp))
             ;; list of hairpins with the same starting point as the current one
             (hp-siblings (assoc-ref simultaneous-hairpins start-symbol)))
            (if (not hp-siblings)
                ;; no hairpin with the current starting moment yet
                ;; -> initialize node
                (set! simultaneous-hairpins
                      (assoc-set! simultaneous-hairpins start-symbol
                        (list
                         (list end-symbol hp))))
                ;; There is already a hairpin starting at the current moment
                ;; -> check if we have an equal hairpin or not
                (let
                 ;; Equal hairpins are hairpins that also match the end-symbol
                 ((equal-hairpins (assoc-ref hp-siblings end-symbol)))
                 (if equal-hairpins
                     (set! simultaneous-hairpins
                           (assoc-set!
                            simultaneous-hairpins
                            start-symbol
                            (list (list end-symbol (append equal-hairpins (list hp)))))))))))
         all-hairpins)

        ;; Walk over the equal hairpins
        (for-each
         (lambda (moment)
           (let ((equal-hairpins (cadadr moment)))
             ;; non-equal hairpins are also passed into this function,
             ;; so we have to skip it
             (if (list? equal-hairpins)
                 (begin
                  ; temporarily color the kept hairpin red
                  (ly:grob-set-property! (car equal-hairpins) 'color red)
                  ;; remove the stencil for all subsequent hairpins
                  (for-each
                   (lambda (duplicate)
                     (ly:grob-set-property! duplicate 'stencil #f))
                   (cdr equal-hairpins))))))
         simultaneous-hairpins))))))


\layout {
  \context {
    \Score
    \consists \removeDoubleHairpinsEngraver
  }
}

music = {
  \partcombineApart
  c''1~\<
  c''1\!
  c''2.\< c''4\!
  c''1~\>
  \break
  c''2~ c''\!
}

\score {
  \new Staff {
    \partcombine
    {
      \music
      c''2 \< c''2 \!
      c''1 \>
      c''1 \>
      c''1 \!
    }
    \transpose c c, {
      \music
      c''1
      c''2 \> c''2 \!
      c''1 \<
      c''1 \!
    }
  }
  \layout {}
}