\version "2.22.0"

#(use-modules (srfi srfi-26))

#(define-macro (prepend! thing lst)
   `(set! ,lst (cons ,thing ,lst)))

#(define (make-mark ctx engraver event)
   (let* ((mark-grob
           (ly:engraver-make-grob engraver 'RehearsalMark event))
          (ev-label (ly:event-property event 'label))
          (actual-label (if (null? ev-label)
                            (ly:context-property ctx 'rehearsalMark)
                            ev-label))
          (formatter (ly:context-property ctx 'markFormatter))
          (label
            (cond
              ((markup? actual-label)
               actual-label)
              ((not (procedure? formatter))
               (ly:warning "markFormatter must be a procedure")
               empty-markup)
              ((integer? actual-label)
               (formatter actual-label ctx))
              (else
                (ly:warning "rehearsal mark label must be markup, number or \\default")
                empty-markup))))
     (if (integer? actual-label)
         (ly:context-set-property! ctx 'rehearsalMark (1+ actual-label)))
     (ly:grob-set-property! mark-grob 'text label)
     mark-grob))

#(define (Multi_mark_engraver ctx)
   (let ((texts '())
         (final-texts '())
         (events '()))
     (make-engraver
       ((start-translation-timestep engraver)
          (set! final-texts '()))
       (listeners
         ((mark-event engraver event)
            (prepend! event events)))
       ((process-music engraver)
          (for-each (lambda (event)
                      (prepend! (make-mark ctx engraver event)
                                texts))
                    (reverse! events)))
       ((stop-translation-timestep engraver)
          (let ((staves (ly:context-property ctx 'stavesFound)))
            (let loop ((remaining-texts (reverse texts))
                       (i 0))
              (if (not (null? remaining-texts))
                  (let* ((grob (car remaining-texts))
                         (my-found-priority
                          (ly:grob-property grob 'outside-staff-priority))
                         (my-priority (if (or (not my-found-priority)
                                              (null? my-found-priority))
                                          1500
                                          my-found-priority)))
                    (for-each
                      (cute ly:pointer-group-interface::add-grob
                            grob
                            'side-support-elements
                            <>)
                      staves)
                    (ly:grob-set-property! grob
                                           'outside-staff-priority
                                           (+ my-priority i))
                    (prepend! grob final-texts)
                    (loop (cdr remaining-texts)
                          (1+ i))))))
          (set! texts '())
          (set! events '()))
        ((finalize engraver)
           (for-each
             (cute ly:grob-set-property! <> 'break-visibility end-of-line-visible)
             final-texts)))))


#(ly:register-translator
   Multi_mark_engraver
   'Multi_mark_engraver
   '((grobs-created . (RehearsalMark))
     (events-accepted . (mark-event))
     (properties-read . (markFormatter
                         rehearsalMark
                         stavesFound))
     (properties-written . (rehearsalMark))
     (description . "\
An alternative to the Mark_engraver that accepts several marks at the
same moment.")))


\layout {
  \context {
    \Score
    \remove "Mark_engraver"
    \consists "Multi_mark_engraver"
  }
}