Hi Andrew,
Am 23.07.22 um 03:49 schrieb Andrew Bernard:
I know that we can't natively make ties between notes in different
voices. I know that there was a Google Summer of Code task that could
not be completed.
A few weeks ago, I sent you the following privately (I was too timid to
post in on the list):
My idea was to \consist the Tie_engraver to the Staff context not
_instead_ of to the Voice context, but _in addition_. Then we have two
Tie engravers and need a mechanism by which to tell if a given tie
should be collected by the Voice-level Tie_engraver or at Staff level
(in order to connect ties between different voices).
During my experiments I re-implemented the Tie_engraver in Scheme;
although it turned out that (contrary to my expectations) the necessary
adjustments could just as easily have been made in C++, the advantage is
that we can test this approach without the need to re-compile a custom
LilyPond build.
The attached file (requiring 2.23.6 and above) generates
as easily as:
\new Staff \with { \consists #New_tie_engraver }
{
<<
\relative {
<c''~ c,\to Staff~>4 c8 b a g~ 4
}
\\
\relative {
s4 c'2 e4
}
>>
}
Of course the same mechanism might be implemented for, e.g., the
Slur_engraver. But this requires additional work, as the slur
positioning mechanism is not quite up to positioning Staff-level slurs
correctly.
The attached Scheme Tie_engraver may be used as a drop-in replacement
for the standard C++ Tie_engraver; in my local branch, it compiles the
full regression test suite without causing differences.)
Lukas
\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
}
>>
}
