Accidental adjustments for single-voice polyphony

LilyPond currently does not consider simultaneous notes to automatically determine the correct accidentals; it only looks at previous notes and key signatures. As a consequence, it is necessary to do some manual adjustments.

Unfortunately, these adjustments are quite complex. The Scheme code in this snippet provides a new engraver custom_accidental_placement_engraver that introduces a details subproperty flag called capture for the Accidental grob. If this flag is set, the current voice “captures” the accidental so that it is no longer aligned with the other accidentals in a note column. Together with other properties (force-hshift and ignore-collision) it is possible to achieve the desired result.

\version "2.24"

% written 2023 by Valentin Petzel
%
% https://lists.gnu.org/archive/html/lilypond-user/2023-06/msg00094.html

\version "2.24.0"

#(define (which lst)
   (define (impl lst count)
     (if (null? lst)
         #f
         (if (car lst)
             count
             (impl (cdr lst) (1+ count)))))
   (impl lst 0))


#(define (custom_accidental_placement_engraver context)
   (define (grob-array->list x)
     (if (ly:grob-array? x)
         (ly:grob-array->list x)
         '()))
   (let ((placement #f)
         (right-padding #f))
     (make-engraver
      (acknowledgers
       ((accidental-interface engraver grob source-engraver)
        (when (assoc-get 'capture (ly:grob-property grob 'details) #f)
          (when (not placement)
            (set! placement
                  (ly:engraver-make-grob engraver
                                         'AccidentalPlacement '()))
            (ly:grob-set-parent!
             placement X
             (ly:grob-parent (ly:grob-parent grob Y) X))
            (let ((padding (ly:grob-property-data placement
                                                  'right-padding)))
              (set!
               right-padding
               (lambda (grob)
                 (let*
                     ((grobs (ly:grob-object grob 'accidental-grobs))
                      (grobs (apply append (map cdr grobs)))
                      (heads (map (lambda (x)
                                    (ly:grob-parent x Y)) grobs))
                      (stems (map (lambda (x)
                                    (ly:grob-object x 'stem)) heads))
                      (cols (map (lambda (x)
                                   (ly:grob-parent x X)) heads))
                      (collisions (map (lambda (x)
                                         (ly:grob-parent x X)) cols))
                      (cols2
                       (apply append
                              (map
                               (lambda (x)
                                 (grob-array->list (ly:grob-object
                                                    x 'elements)))
                               collisions)))
                      (heads2
                       (apply append
                              (map
                               (lambda (x)
                                 (grob-array->list (ly:grob-object
                                                    x 'note-heads)))
                               cols2)))
                      (stems2 (map
                               (lambda (x)
                                 (ly:grob-object x 'stem)) heads))
                      (grob-set1 (ly:grob-list->grob-array
                                  (append heads stems)))
                      (grob-set2 (ly:grob-list->grob-array
                                  (append heads stems heads2 stems2)))
                      (refp (ly:grob-common-refpoint-of-array
                             grob grob-set1 X))
                      (refp2 (ly:grob-common-refpoint-of-array
                              grob grob-set2 X))
                      (ext (ly:grob-extent refp refp2 X))
                      (ext2 (ly:grob-extent refp2 refp2 X))
                      (offset (car ext))
                      (offset (- offset (car ext2))))
                   (- (if (procedure? padding) (padding grob) padding)
                      offset))))))
          (let* ((src-placement (ly:grob-parent grob X))
                 (grobs (ly:grob-object src-placement
                                        'accidental-grobs))
                 (has-grob? (map (lambda (pair)
                                   (memq grob (cdr pair))) grobs))
                 (pair (list-ref grobs (which has-grob?)))
                 (notename (car pair))
                 (groblist (cdr pair))
                 (new-grobs (ly:grob-object placement
                                            'accidental-grobs))
                 (new-groblist (assoc-get notename new-grobs '()))
                 (groblist (delete grob groblist eq?))
                 (new-groblist (cons grob new-groblist))
                 (grobs (assoc-set! grobs notename groblist))
                 (new-grobs
                  (assoc-set! new-grobs notename new-groblist)))
            (when (not (ly:grob-property
                        (ly:grob-parent (ly:grob-parent grob Y) X)
                        'ignore-collision #f))
              (ly:grob-set-property!
               placement 'right-padding right-padding))
            (ly:grob-set-object! src-placement 'accidental-grobs grobs)
            (ly:grob-set-object! placement 'accidental-grobs new-grobs)
            (ly:grob-set-parent! grob X placement)))))
      ((stop-translation-timestep engraver)
       (set! placement #f)))))


\layout {
  \context {
    \Voice
    \consists #custom_accidental_placement_engraver
    % Make `NoteColumn` use `force-hshift` even if `ignore-collision`
    % is `#t`.
    \override NoteColumn.X-offset =
    #(lambda (grob) (ly:grob-property grob 'force-hshift 0))
  }
}


<<
  \new Staff {
    <<
      \repeat unfold 4 { <b'! e''!>2. <c'' f''>4 }
      \\
      <<
        \repeat unfold 4 { bes'!8 a' g' f' bes' a' g' f' }
        {
          \textMark \markup \column { "force-hshift" }
          \once \override NoteColumn.force-hshift = #2.4
          s1

          \textMark \markup \column { "force-hshift"
				      "details.capture" }
          \once \override NoteColumn.force-hshift = #3.4
          \once \override Accidental.details.capture = ##t
          s1

          \textMark \markup \column { "force-hshift"
                                      "ignore-collision" }
          \once \override NoteColumn.force-hshift = #2.4
          \once \override NoteColumn.ignore-collision = ##t
          s1

          \textMark \markup \column { "force-hshift"
                                      "ignore-collision"
                                      "details.capture" }
          \once \override NoteColumn.force-hshift = #3.8
          \once \override NoteColumn.ignore-collision = ##t
          \once \override Accidental.details.capture = ##t
          s1
        }
      >>
    >>
  }
  \new Staff \with { \clef bass } \repeat unfold 8 { <a d'>2 }
>>

\new Staff <<
  \new Voice \relative c' {
    \autoBeamOff
    \voiceOne
    \textMark \markup \column { "default" }
    fis8 g s4
    \textMark \markup \column { "force-hshift"
				"details.capture" }
    \once \offset length 1 Stem
    fis8 g s4 }
  \new Voice \relative c' {
    \autoBeamOff
    \voiceTwo
    f!8 f s4
    \once \override NoteColumn.force-hshift = #2
    \once \override Accidental.details.capture = ##t
    f!8 \once \omit Accidental f s4
  }
>>