#(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)
   (let ((placement #f))
     (make-engraver
      (acknowledgers
       ((accidental-interface engraver grob source-engraver)
        (if (assoc-get 'capture (ly:grob-property grob 'details) #f)
            (begin
              (if (not placement)
                  (begin
                   (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)))
                     (ly:grob-set-property!
                      placement
                      'right-padding
                      (lambda (grob)
                        (let* ((grobs (ly:grob-object placement '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)
                                                (ly:grob-array->list (ly:grob-object x 'elements)))
                                              collisions)))
                               (heads2 (apply append
                                              (map
                                               (lambda (x)
                                                 (ly: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)))
                (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))))))
      ((finish-timestep engraver)
       (set! placement #f)))))

\layout {
  \context {
    \Voice
    \consists #custom_accidental_placement_engraver
  }
}

{
  << { <b'! e''!>4. <b'! e''!>4. } \\
     { \once \override NoteColumn.force-hshift = #3.4
       bes'!8 s4
       \once \override NoteColumn.force-hshift = #3.4
       \once\override Accidental.details.capture = ##t bes'!8 } >>
}