Merging simultaneous voices into shared note heads

This snippet defines \combineVoices, a music function that takes any number of rhythmically identical voices written inside << ... >> and merges them into a single voice under one stem. Wherever two or more of the voices share the same pitch at a given moment, only one note head is printed; wherever the pitches differ, a chord containing all of the distinct pitches is printed instead.

This differs from the default functionality, where double note heads are printed in case of shared pitches.

\version "2.24"

% Return a list 0, 1, ..., n - 1.
#(define (int-range n)
   (let loop ((i 0) (acc '()))
     (if (= i n)
         (reverse acc)
         (loop (+ i 1) (cons i acc)))))

% Drill through any single-child wrapper node (as introduced by, e.g.,
% \relative) until a music object with a real, non-empty 'elements
% list is reached, and return that list.
#(define (music-elements m)
   (let ((elts (ly:music-property m 'elements)))
     (if (and (list? elts) (pair? elts))
         elts
         (let ((child (ly:music-property m 'element)))
           (if (ly:music? child)
               (music-elements child)
               '())))))

% Return the NoteEvents contained in a single moment of music.  A
% plain note is a bare NoteEvent; an explicit chord <...> is an
% EventChord wrapping one NoteEvent per pitch.  Rests and skips
% contain no pitch and contribute nothing.
#(define (note-events moment)
   (cond
    ((eq? (ly:music-property moment 'name) 'NoteEvent)
     (list moment))
    ((eq? (ly:music-property moment 'name) 'EventChord)
     (filter (lambda (e) (eq? (ly:music-property e 'name) 'NoteEvent))
             (ly:music-property moment 'elements)))
    (else '())))

% A comparable key for a pitch, since pitch objects do not compare
% correctly with equal?.
#(define (pitch-key p)
   (list (ly:pitch-notename p) (ly:pitch-alteration p) (ly:pitch-octave p)))

% Merge one moment's worth of notes, taken from several voices, into
% a single EventChord with duplicate pitches removed.
#(define (merge-chords moments)
   (let ((seen '())
         (notes '()))
     (for-each
      (lambda (moment)
        (for-each
         (lambda (note)
           (let ((key (pitch-key (ly:music-property note 'pitch))))
             (if (not (member key seen))
                 (begin
                   (set! seen (cons key seen))
                   (set! notes (cons note notes))))))
         (note-events moment)))
      moments)
     (if (null? notes)
         (car moments)  ; every voice rests here: keep a rest
         (make-music 'EventChord 'elements (reverse notes)))))

combineVoices =
#(define-music-function (music) (ly:music?)
   (let* ((voices (ly:music-property music 'elements))
          (seqs (map music-elements voices))
          (lens (map length seqs)))
     (make-music 'SequentialMusic 'elements
       (map (lambda (i) (merge-chords (map (lambda (s) (list-ref s i)) seqs)))
            (int-range (apply min lens))))))

\new Voice \combineVoices <<
  \relative { c''4 f8 d e16 f g8 d4 }
  \relative { c''4 d8 b c16 d e8 b4 }
>>