\version "2.23.6"

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

% Not in guile core for 1.8 (remove for Guile2)
#(define (hash-count pred table)
   (count identity (hash-map->list pred table)))

#
(define (hash-non-empty? hash-table)
  ;; For Guile2, simplfy to
  ;; (positive? (hash-count (const #t) hash-table)))
  (pair? (hash-map->list (lambda (key handle) '()) hash-table)))

#
(define (tie-column::add_tie tie-column tie)
;;; TODO: Make callback from C++
  (if (not (grob::has-interface (ly:grob-parent tie Y) 'tie-column-interface))
      (begin
       (if
        (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))))
        (begin
         (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-public (New_tie_engraver context)
  (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
    (if (not (assq-ref alist 'tie-from-chord-created))
        (begin
         (ly:warning (G_ "unterminated tie")) ; TODO: Warn with source position
         (ly:grob-suicide! (assq-ref alist 'tie)))))
  (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 (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)))

       (if (not (and left-head right-head))
           (begin
            (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 (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)))
           (if (and (not found) left-ev right-ev)
               (let ((p1 (ly:event-property left-ev 'pitch))
                     (p2 (ly:event-property right-ev 'pitch)))
                 (if (and
                      ((if enharmonic? ly:enharmonic-equivalent? 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)
     (if (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)
      (if (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)
      (set! now-heads (cons grob now-heads))
      (if (not (tie-notehead engraver grob #f))
          (tie-notehead engraver grob #t))
      (if (and (pair? ties) (not tie-column))
          (set! tie-column
                (ly:engraver-make-spanner engraver 'TieColumn (last ties)))) ; is last correct?

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

    ((process-music engraver)
     (if (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 '()))
       (if (pair? ties)
           (begin
            (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))
            (if (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))
                (begin
                 (set! left-articulations (ly:event-property left-ev 'articulations))
                 (if (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.
                 (if
                  (and tie-articulation-event
                       (not (eq? (ly:event-property tie-articulation-event
                                                    'spanner-target 'Voice)
                                 target)))
                  (set! tie-articulation-event #f))

                 (if (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))

       (if (and (not wait) (pair? new-heads-to-tie))
           (begin
            (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.
     (if 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
  }
}

% -------------------------------------------------------------------- %

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