Re: shifting accidentals horizontally

[Werner LEMBERG]

> @Werner I’ve added a small fix concerning the case when there is no
> NoteCollision grob (in which case this should not be relevant in the
> first place).

Thanks a lot!  I think this would be a great snippet for the
LSR.

Note, however, that there are alignment problems with other staves,
see below.  For this particular case I can fix it by using
`NoteColumn.X-offset`, but this isn't a sustainable solution.


    Werner


======================================================================


#(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))
     (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)
                                                (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)))
                (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
  }
}

<<
  \new Staff {
    << { <b'! e''!>2. <c'' f''>4 |
         <b'! e''!>2. <c'' f''>4 } \\
       { \once \override NoteColumn.force-hshift = #2.4
         bes'!8 a' g' f' bes' a' g' f' |
         \once \override NoteColumn.force-hshift = #3.4
         \once \override Accidental.details.capture = ##t
         bes'!8 a' g' f' bes' a' g' f' } >>
  }
  \new Staff {
    \clef bass
    <a d'>2 q |
    % \once \override NoteColumn.X-offset = #0.8
    q2 q |
  }
>>