% 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
  }
>>

\paper { tagline = ##f }