%% https://lists.gnu.org/archive/html/lilypond-user/2022-07/msg00353.html
%% by Lukas-Fabian Moser

%% Change-log Harm
%%   - drop support for guilev1
%%   - exclude NoteHeads with details.tie-me set to #f
%%   - move some definitions out of engraver
%%   - reformating

\version "2.23.9"

% TODO: Rename variables for clarity
% TODO: Turn re-implementations of C++ helper functions into exported callbacks

#(define (hash-non-empty? hash-table)
  (positive? (hash-count (const #t) hash-table)))

#(define (tie-column::add_tie tie-column tie)
;;; TODO: Make callback from C++
  (when (not (grob::has-interface (ly:grob-parent tie Y) 'tie-column-interface))
    (when (or (null? (ly:spanner-bound tie-column LEFT))
              (> (car (ly:grob-spanned-column-rank-interval tie-column))
                 ; THINK: is this exactly equivalent to the C++ original?
                 (car (ly:grob-spanned-column-rank-interval tie-column))))
      (ly:spanner-set-bound! tie-column LEFT (ly:spanner-bound tie LEFT))
      (ly:spanner-set-bound! tie-column RIGHT (ly:spanner-bound tie RIGHT)))

    (ly:grob-set-parent! tie Y tie-column)
    (ly:pointer-group-interface::add-grob tie-column 'ties tie)))

%{
head-event-alist has the fields:
   '((end-moment . #f)
     (tie-stream-event . #f)
     (tie-articulation-event . #f)
     (tie-from-chord-created . #f)
     (tie . #f)
   )
%}

#(define (ly:enharmonic-equivalent? p1 p2)
  (= (ly:pitch-tones p1) (ly:pitch-tones p2)))

#(define (ly:tie::head tie dir)
  (let ((it (ly:spanner-bound tie dir)))
    (if (grob::has-interface it 'note-head-interface)
        it #f)))

#(define (report-unterminated-tie notehead alist)
  ;; give notehead argument in order to simplify use of
  ;; report-unterminated-tie as a proc in hash-for-each
  (when (not (assq-ref alist 'tie-from-chord-created))
    (ly:warning (G_ "unterminated tie")) ; TODO: Warn with source position
    (ly:grob-suicide! (assq-ref alist 'tie))))

#(define (typeset-tie her)
  ;; this seems not to change anything for "her" if both bounds
  ;; are note heads ???
  (let ((left-head (ly:tie::head her LEFT))
        (right-head (ly:tie::head her RIGHT)))

    (when (not (and left-head right-head))
      (ly:warning "lonely tie")
      (if (not left-head)
          (set! left-head right-head)
          (set! right-head left-head)))
    (ly:spanner-set-bound! her LEFT left-head)
    (ly:spanner-set-bound! her RIGHT right-head)))


#(define-public (New_tie_engraver context)
  (let
   ((event-processed #f)
    (tie-stream-event #f)   ; corresponds to event_ in C++
    (tie-column #f)
    (now-heads '())
    (heads-to-tie (make-hash-table))
    (ties '())
    (target (ly:context-name context)))


   (define (tie-notehead engraver head enharmonic?)
     (let ((found #f))
       (hash-for-each
        (lambda (registered-head alist)
          (let* ((right-ev (event-cause head))
                 (left-head registered-head)
                 (left-ev (event-cause left-head)))
           (when (and (not found) left-ev right-ev)
             (let ((p1 (ly:event-property left-ev 'pitch))
                   (p2 (ly:event-property right-ev 'pitch))
                   (p-equal? (if enharmonic? ly:enharmonic-equivalent? equal?)))
               (when (and (p-equal? p1 p2)
                          ;; Do not create tie for events split by
                          ;; Completion_heads_engraver
                          (not (ly:event-property left-ev 'autosplit-end #f)))
                 (let* ((tie (assq-ref alist 'tie))
                        (end (assq-ref alist 'end-moment))
                        (tie-event (assq-ref alist 'tie-articulation-event))
                        (cause (if tie-event tie-event
                                   (assq-ref alist 'tie-stream-event)))
                        (cause-direction
                          (ly:event-property cause 'direction #f)))
                    (ly:engraver-announce-end-grob engraver tie cause)
                    (ly:spanner-set-bound! tie RIGHT head)
                    (ly:spanner-set-bound! tie LEFT left-head)
                    (if cause-direction
                        (ly:grob-set-property! tie 'direction cause-direction))
                    (set! ties (cons tie ties))
                    (set! found #t)
                    (hash-remove! heads-to-tie registered-head)

                    (hash-for-each
                     (lambda (other-head alist)
                       (if (equal? (assq-ref alist 'end-moment) end)
                           (hash-set!
                             heads-to-tie
                             other-head
                             (assq-set! alist 'tie-from-chord-created #t))))
                     heads-to-tie)))))))
        heads-to-tie)
       found))

   (make-engraver
    ((start-translation-timestep translator)
     (when (and (hash-non-empty? heads-to-tie)
                (not (ly:context-property context 'tieWaitForNote #f)))
       (let ((now (ly:context-current-moment context)))
         (hash-for-each
          (lambda (head-event alist)
            (if (ly:moment<? (assq-ref alist 'end-moment) now)
                (begin
                 (report-unterminated-tie head-event alist)
                 (hash-remove! heads-to-tie head-event))))
          heads-to-tie)))
     (ly:context-set-property!
       context 'tieMelismaBusy (hash-non-empty? heads-to-tie)))

    (listeners
     ((tie-event engraver event)
      (when (and (not (ly:context-property context 'skipTypesetting #f))
                 (eq? (ly:event-property event 'spanner-target 'Voice) target))
        (if (and tie-stream-event
                 (not (equal? tie-stream-event event)))
            (ly:warning "Conflict; discarding tie") ; improve (see stream-event.cc)
            (set! tie-stream-event event)))))

    (acknowledgers
     ((note-head-interface engraver grob source-engraver)
       (when (assoc-get 'tie-me (ly:grob-property grob 'details) #t)
         (set! now-heads (cons grob now-heads))
         (when (not (tie-notehead engraver grob #f))
           (tie-notehead engraver grob #t))
         (when (and (pair? ties) (not tie-column))
           (set! tie-column
                 (ly:engraver-make-spanner engraver 'TieColumn (last ties)))) ; is last correct?

         (when tie-column
           (for-each
             (lambda (tie) (tie-column::add_tie tie-column tie))
             ties)))))

    ((process-music engraver)
     (when (or tie-stream-event
               (positive?
                (hash-count
                 (lambda (head-event alist)
                   (or (assq-ref alist 'tie-articulation-event)
                       (assq-ref alist 'tie-stream-event)))
                 heads-to-tie)))
       (ly:context-set-property! context 'tieMelismaBusy #t)))

    ((process-acknowledged engraver)
     (let ((wait (ly:context-property context 'tieWaitForNote #f))
           (new-heads-to-tie '()))
       (when (pair? ties)
          (if (not wait)
              (begin
               (hash-for-each report-unterminated-tie heads-to-tie)
               (hash-clear! heads-to-tie)))
          (for-each typeset-tie ties)
          (set! ties '())
          (set! tie-column #f))
       (for-each
        (lambda (head)
          (let ((left-ev #f)
                (left-articulations #f)
                (tie-articulation-event #f))
            (set! left-ev (event-cause head))
            (when (and left-ev
                       ;; no left-ev: may happen for ambitus [?]
                       ;; not a note event: may happen for pitched trills [?]
                       (ly:in-event-class? left-ev 'note-event))
              (set! left-articulations
                    (ly:event-property left-ev 'articulations))
              (when (not tie-stream-event)
                (set! tie-articulation-event
                      (find
                       (lambda (ev)
                         (memq 'tie-event (ly:event-property ev 'class)))
                       left-articulations)))
              ;; TODO: taking the first tie articulation means that
              ;; there's trouble ahead if we have multiple tie articulations
              ;; on the same note, headed for different targets. Oh wow.
              (when (and tie-articulation-event
                         (not (eq? (ly:event-property
                                      tie-articulation-event
                                      'spanner-target
                                      'Voice)
                                   target)))
                (set! tie-articulation-event #f))

              (when (and left-ev
                         (or tie-stream-event tie-articulation-event)
                         ;; Do not create tie for events split by
                         ;; Completion_heads_engraver
                         (not (ly:event-property left-ev 'autosplit-end #f)))
                (let* ((new-tie (ly:engraver-make-spanner
                                 engraver
                                 'Tie
                                 (if tie-articulation-event
                                     tie-articulation-event
                                     tie-stream-event)))
                       (new-end-moment
                        (ly:moment-add
                         (ly:context-current-moment context)
                         (ly:event-property left-ev 'length (ly:make-moment 0))
                         ;; TODO: Care for grace
                         ;; (see translator.cc get_event_length)
                         ))
                       (new-head-alist
                        (list
                         ;; STRANGE: Doing this with quasiquoting
                         ;; and (tie-from-chord-created . #f)
                         ;; we have bleeding over from
                         ;; previous score causing
                         ;; tie-from-chord-created to be set to
                         ;; its value in a previous score ...
                         (cons 'tie-stream-event tie-stream-event)
                         (cons 'tie-articulation-event tie-articulation-event)
                         (cons 'end-moment new-end-moment)
                         (cons 'tie-from-chord-created #f)
                         (cons 'tie new-tie))))
                 (set! new-heads-to-tie
                       (cons (cons head new-head-alist)
                             new-heads-to-tie))
                 (set! event-processed #t))))))
        ;; reverse now-heads in order to process them
        ;; in the order of creation. This makes sure
        ;; double noteheads in ties get their ties
        ;; in the order requested in
        ;; input/regression/chord-X-align-on-main-noteheads.ly
        ;; e.g. for
        ;; {
        ;;   <e' e'>~ <e' e'>
        ;; }
        (reverse now-heads))

       (when (and (not wait) (pair? new-heads-to-tie))
         (hash-for-each report-unterminated-tie heads-to-tie)
         (hash-clear! heads-to-tie))

       (for-each
        (lambda (new-head-entry)
          (hash-set! heads-to-tie
                     (car new-head-entry)
                     (cdr new-head-entry)))
        new-heads-to-tie)

       (set! now-heads '())))
    ((stop-translation-timestep engraver)
     ;; Discard event only if it has been processed with at least one
     ;; appropriate note.
     (when event-processed
       (set! tie-stream-event #f))
     (set! event-processed #f)))))

to =
#(define-event-function (id event) (key? ly:event?)
   (set! (ly:music-property event 'spanner-target) id)
   event)

\layout {
  \context {
    \Voice
    \remove Tie_engraver
    \consists #New_tie_engraver
  }
}

skipMe = \once \override NoteHead.details.tie-me = ##f

% -------------------------------------------------------------------- %
% {
\new Staff \with { \consists #New_tie_engraver }
{
  <<
    \relative {
      <c''~ c,\to Staff~>4 c8 b a g~ 4
    }
    \\
    \relative {
      s4 c'2 e4
    }
  >>
}
%}



\new Staff \with { \consists #New_tie_engraver }
<<
   \relative {
     <%{ tie this %} c'\to Staff ~ c'>2
     \skipMe c8 b a g
   }
   \\
   \relative { s2 %{ to this %} c'2 }
   \\
   \relative { g16 a \skipMe c d e a g e f'4 d }
 >>