Am Mo., 21. Dez. 2020 um 20:41 Uhr schrieb Klaus Blum <benbigno...@gmx.de>:
>
> Hi Gilberto,
>
> Am 21.12.2020 um 17:51 schrieb lilypond-user-requ...@gnu.org:
>
> > Ideally, I think applying it to a chord (something like \cowellCluster
> > <c' a'>4) would be the ideal solution. It also does not handle whole
> > notes, as those do not have stems to be hacked. If I come up with
> > something interesting I will make sure to post it here.
>
> please have a look at the link to the German forum (the thread there
> continues in English):
> https://lilypondforum.de/index.php/topic,820.msg4546.html?PHPSESSID=6djk9rm3a7m81mmuqu25mjiehb#msg4546
>
> I've posted an improved version there, and Harm has an even more
> interesting solution.
>
> Cheers,
> Klaus
>
Hi Gilberto,
I reworked the code, see
https://lilypondforum.de/index.php/topic,820.msg4562.html#msg4562
You'll need an account there to get the files, thus I attach them here as well.
Cheers,
Harm
\version "2.20.0"
\include "cowell-clusters.ly"
\include "other-stuff.ly"
upI = {
\tempo "Allegro feroce"
r2 r8
<g! ais cis' fis'>\ff \repeat unfold 10 <g ais cis' fis'>
<a c' dis' gis'>^-\< <a c' dis' fisis' gis'>
<a c' dis' eis' gis'> <a c' dis' fis' gis'>
<a c' dis' gis'> <a c' e' gis'>
<a cis' gis'> <a c' gis'>
\break
\pseudoIndent 8.5
<>^\tweak padding #2
-\markup
\override #'(box-padding . 0.8)
\box
\fontsize #0
\italic
"For explanations and playing instructions also see inside back cover"
\voiceOne
<c' dis' fis' b'>--\!
\clef "bass"
<>-\tweak X-offset #-3
\mf
_\markup \fontsize #-1.2 \whiteout "Mit flacher Hand zu spielen"
\cluster { \repeat unfold 8 <c c'> }
\clef "treble"
<>-\tweak Y-offset #-4 -\tweak X-offset #-3 \ff
\repeat unfold 7 e''
e''4. e''8 c'''2
\oneVoice
r8\fermata
\override Slur.details.edge-attraction-factor = 200
\once \override Beam.positions = #'(-8 . -6)
ais''^>(
\change Staff = "down"
b'^> d''-\tweak avoid-slur #'inside ^>)
\change Staff = "up"
cis'''8.^>-\shape #'((0 . 0) (1.5 . 1.5) (-1 . 0) (0 . -3))-(
fis''16-\tweak avoid-slur #'inside ^>
\eraseShortInstrumentName
\change Staff = "down"
g'4)^>
\clef "bass"
\break
\change Staff = "up"
fis'''2->~ 8
\noBeam
<bes des' e' a'>-\f <bes gis' a'> <bes g' a'>
\override TupletBracket.bracket-visibility = ##t
\tuplet 5/4 {
<bes fis' a'> <bes gis' a'> <bes g' a'> <bes fis'? a'> <bes gis' a'>
}
\tuplet 5/4 {
<bes g' a'> <bes fis' a'> <bes gis' a'> <bes g' a'> <bes fis' a'>
}
\time 2/4
<bes gis' a'>[ <bes g' a'> <bes fis' a'> <bes gis' a'>]
}
downI = {
\clef "bass"
r2 r8 <e, a, dis> \repeat unfold 10 <e, a, dis>
<cis, fis, d!>_- \repeat unfold 7 <cis, fis, d>
<a, b, f>^- b,!^> gis,^> ais,^> e,^> fis,^> c,^> bes,,^>
a,,^>\noBeam -\tweak X-offset #2 -\tweak padding #5 _"C"
<>_\markup
\fontsize #-1.2
\whiteout
"Mit beiden Vorderarmen gleichzeitig zu"
_\markup \fontsize #-1.2 "spielen"
\cluster ##t {
\autoBeamOff
\repeat unfold 7 c,,
c,,4. c,,8
\once\override Score.NoteColumn.X-offset = 0.5
a,,2
}
\autoBeamOn
\clef "treble"
s1
\eraseShortInstrumentName
\once \override Staff.Clef.before-line-breaking =
#(lambda (grob)
(if (= (ly:item-break-dir grob) -1)
(ly:grob-set-property! grob 'X-extent '(-1.2 . 2))))
\clef "bass"
r2 r8
<fis, b, f!> \repeat unfold 2 q
<fis, b, f!> \repeat unfold 7 q
<fis, b, f!>[ \repeat unfold 2 q q]
}
upII = {
s1*3
R1*2
<>_\markup \fontsize #-1.2 \whiteout "Die Tasten lautlos niederzudrücken"
r2 r4
\set shapeNoteStyles = ##(do do do do do do do)
<gis ais cis' fis'>4~
-\tweak ParenthesesItem.font-size #0 \parenthesize ^\pp
q1\fermata
s1*2
s2
}
downII = {
\clef "bass"
s1*3
R1*2
\set shapeNoteStyles = ##(do do do do do do do)
r2 r4 <e, a, dis>~ q1_\fermata
s1*2
s2
}
pedal = {
\howellPedalStyle
s2 s8 s4.\sostenutoOn
s1
s1\sostenutoOff
s1
s8
\once \override Dynamics.PianoPedalBracket.shorten-pair = #'(0 . 1)
s2..\sostenutoOn
s1
s8\sostenutoOff
s2.. \sostenutoOn
s2 s8\sostenutoOff s4.
s1
s2
}
\paper {
indent = 19
short-indent = 4
ragged-last-bottom = ##f
top-markup-spacing.padding = 1
first-page-number = 20
print-first-page-number = ##t
top-margin = 20
bottom-margin = 8
last-bottom-spacing.padding = 8
tagline = \markup \fill-line { "AMP-95611" \null }
}
\header {
title = "8. Tiger"
composer = \markup \center-column { "Henry Cowell" "(1928)" }
}
\score {
\new GrandStaff
<<
\new Staff = "up"
\with {
shortInstrumentName =
\markup \hcenter-in #9 \center-column { "Rechte" "Hand" }
}
\upI
\new Staff = "down"
\with {
shortInstrumentName =
\markup \hcenter-in #9 \center-column { "Linke" "Hand" }
}
\downI
\new Staff = "upII"
\with { shortInstrumentName = \markup \hcenter-in #9 "Rechte" }
\upII
\new Staff = "downII"
\with { shortInstrumentName = \markup \hcenter-in #9 "Linke" }
\downII
\new Dynamics \pedal
>>
\layout {
\context {
\Voice
\override Stem.details.cluster-thick-short = 0.3
}
\context {
\Staff
\RemoveAllEmptyStaves
\numericTimeSignature
}
\context {
\GrandStaff
\consists #Cluster-span_stem_engraver
\omit SystemStartBrace
\override StaffGrouper.staff-staff-spacing.stretchability = 25
}
\context {
\Score
\omit BarNumber
}
}
}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% sometimes usefull for cross-staff stems and clusters
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
pushNC =
\once \override NoteColumn.X-offset =
#(lambda (grob)
(let* ((p-c (ly:grob-parent grob X))
(p-c-elts (ly:grob-object p-c 'elements))
(stems
(if (ly:grob-array? p-c-elts)
(filter
(lambda (elt)(grob::has-interface elt 'stem-interface))
(ly:grob-array->list p-c-elts))
#f))
(stems-x-exts
(if stems
(map
(lambda (stem)
(ly:grob-extent
stem
(ly:grob-common-refpoint grob stem X)
X))
stems)
'()))
(sane-ext
(filter interval-sane? stems-x-exts))
(cars (map car sane-ext)))
(if (pair? cars)
(abs (- (apply max cars) (apply min cars)))
0)))
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% erase a shortInstrumentName
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
eraseShortInstrumentName =
\context Staff
\applyContext
#(lambda (ctx)
(ly:context-set-property! ctx 'shortInstrumentName ""))
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% extract from LSR 1098 "Indenting individual systems"
%% http://lsr.di.unimi.it/LSR/Item?id=1098
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%% HEADER %%%%%%%%
%
% this code was prompted by
% https://lists.gnu.org/archive/html/lilypond-user/2019-07/msg00139.html
% and offers a pseudoIndent hack suitable for general use
% keywords:
% indent short-indent indentation system line
% mid-score temporarily arbitrary individual single just only once
% coda margin
% mouse's tale acrostic mesostic spine
%%%%%%%% PSEUDOINDENT FUNCTIONS %%%%%%%%
% these two functions are for indenting individual systems
% - to left-indent a system, apply \pseudoIndent before the music continues
% - \pseudoIndents is similar, but lets you also indent on the right
% - both provide an option for changing that system's instrument names
% N.B. these functions
% - assume application to non-ragged lines (generally the default)
% - include a manual \break to ensure application at line start
% - misbehave if called more than once at the same line start
% the parameters of the (full) pseudoIndents function are:
% 1: name-tweaks
% usually omitted; accepts replacement \markup for instrument names
% as an ordered list; starred elements leave their i-names unchanged.
% 2: left-indent
% additional left-indentation, in staff-space units; can be negative,
% but avoid a total indentation which implies (unsupported) stretching.
% 3: right-indent
% amount of right-indentation, in staff-space units; can be negative.
% - not offered by the (reduced) pseudoIndent function
pseudoIndents = % inline alternative to a new \score, also with right-indent
#(define-music-function (parser location name-tweaks left-indent right-indent)
((markup-list? '()) number? number?)
(define (warn-stretched p1 p2) (ly:input-warning location (_
" pseudoIndents ~s ~s is stretching staff; expect distorted layout") p1 p2))
(let* (
(narrowing (+ left-indent right-indent)) ; of staff implied by args
(set-staffsymbol! (lambda (staffsymbol-grob) ; change staff to new width
(let* (
(left-bound (ly:spanner-bound staffsymbol-grob LEFT))
(left-moment (ly:grob-property left-bound 'when))
(capo? (moment<=? left-moment ZERO-MOMENT)) ; in first system of score
(layout (ly:grob-layout staffsymbol-grob))
(lw (ly:output-def-lookup layout 'line-width)) ; debugging info
(indent (ly:output-def-lookup layout (if capo? 'indent 'short-indent)))
(old-stil (ly:staff-symbol::print staffsymbol-grob))
(staffsymbol-x-ext (ly:stencil-extent old-stil X))
;; >=2.19.16's first system has old-stil already narrowed [2]
;; compensate for this (ie being not pristine) when calculating
;; - old leftmost-x (its value is needed when setting so-called 'width)
;; - the new width and position (via local variable narrowing_)
(ss-t (ly:staff-symbol-line-thickness staffsymbol-grob))
(pristine? (<= 0 (car staffsymbol-x-ext) ss-t)) ; would expect half
(leftmost-x (+ indent (if pristine? 0 narrowing)))
(narrowing_ (if pristine? narrowing 0)) ; uses 0 if already narrowed
(old-width (+ (interval-length staffsymbol-x-ext) ss-t))
(new-width (- old-width narrowing_))
(new-rightmost-x (+ leftmost-x new-width)) ; and set! this immediately
(junk (ly:grob-set-property! staffsymbol-grob 'width new-rightmost-x))
(in-situ-stil (ly:staff-symbol::print staffsymbol-grob))
(new-stil (ly:stencil-translate-axis in-situ-stil narrowing_ X))
;(new-stil (stencil-with-color new-stil red)) ; for when debugging
(new-x-ext (ly:stencil-extent new-stil X)))
(ly:grob-set-property! staffsymbol-grob 'stencil new-stil)
(ly:grob-set-property! staffsymbol-grob 'X-extent new-x-ext)
)))
(set-X-offset! (lambda (margin-grob) ; move grob across to line start
(let* (
(old (ly:grob-property-data margin-grob 'X-offset))
(new (lambda (grob) (+ (if (procedure? old) (old grob) old) narrowing))))
(ly:grob-set-property! margin-grob 'X-offset new))))
(tweak-text! (lambda (i-name-grob mkup) ; tweak both instrumentname texts
(if (and (markup? mkup) (not (string=? (markup->string mkup) "*")))
(begin
(ly:grob-set-property! i-name-grob 'long-text mkup)
(ly:grob-set-property! i-name-grob 'text mkup)
)))) ; else retain existing text
(install-narrowing (lambda (leftedge-grob) ; on staves, + adapt left margin
(define (grob-name x) (assq-ref (ly:grob-property x 'meta) 'name))
(let* (
(sys (ly:grob-system leftedge-grob))
(all-grobs (ly:grob-array->list (ly:grob-object sys 'all-elements)))
(grobs-named (lambda (name)
(filter (lambda (x) (eq? name (grob-name x))) all-grobs)))
(first-leftedge-grob (list-ref (grobs-named 'LeftEdge) 0))
(relsys-x-of (lambda (g) (ly:grob-relative-coordinate g sys X)))
(leftedge-x (relsys-x-of first-leftedge-grob))
(leftedged? (lambda (g) (= (relsys-x-of g) leftedge-x)))
(leftedged-ss (filter leftedged? (grobs-named 'StaffSymbol))))
(if (eq? leftedge-grob first-leftedge-grob) ; ignore other leftedges [1]
(begin
(for-each set-staffsymbol! leftedged-ss)
(for-each set-X-offset! (grobs-named 'SystemStartBar))
(for-each set-X-offset! (grobs-named 'InstrumentName))
(for-each tweak-text! (grobs-named 'InstrumentName) name-tweaks)
))))))
(if (negative? narrowing) (warn-stretched left-indent right-indent))
#{ % and continue anyway
% ensure that these overrides are applied only at begin-of-line
\break % (but this does not exclude unsupported multiple application)
% give the spacing engine notice regarding the loss of width for music
\once \override Score.LeftEdge.X-extent = #(cons narrowing narrowing)
% discard line start region of staff and reassemble left-margin elements
\once \override Score.LeftEdge.after-line-breaking = #install-narrowing
% shift the system to partition the narrowing between left and right
\overrideProperty Score.NonMusicalPaperColumn.line-break-system-details
.X-offset #(- right-indent)
% prevent a leftmost barnumber entering a stretched staff
\once \override Score.BarNumber.horizon-padding = #(max 1 (- 1 narrowing))
#}))
pseudoIndent = % for changing just left-indent
#(define-music-function (parser location name-tweaks left-indent)
((markup-list? '()) number?)
#{
\pseudoIndents $name-tweaks $left-indent 0
#})
% [1] versions <2.19.1 can have end-of-line leftedges too
% - these were eliminated in issue 3761
% [2] versions >=2.19.16: the first system behaves differently from the rest
% - a side effect of issue 660 ?
%% [...] end LSR 1098
%%%%%%%%%%%%%%%%%%%%%%%%
%% from upcoming 2.23.0
%%%%%%%%%%%%%%%%%%%%%%%%
#(define spanner-bounds-break-status
(lambda (spanner)
(cons
(ly:item-break-dir (ly:spanner-bound spanner LEFT))
(ly:item-break-dir (ly:spanner-bound spanner RIGHT)))))
#(define-public unbroken-spanner?
(lambda (spanner) (equal? '(0 . 0) (spanner-bounds-break-status spanner))))
#(define-public first-broken-spanner?
(lambda (spanner) (equal? '(0 . -1) (spanner-bounds-break-status spanner))))
#(define-public middle-broken-spanner?
(lambda (spanner) (equal? '(1 . -1) (spanner-bounds-break-status spanner))))
#(define-public end-broken-spanner?
(lambda (spanner) (equal? '(1 . 0) (spanner-bounds-break-status spanner))))
#(define-public not-first-broken-spanner?
(lambda (spanner) (positive? (car (spanner-bounds-break-status spanner)))))
#(define-public not-last-broken-spanner?
(lambda (spanner) (negative? (cdr (spanner-bounds-break-status spanner)))))
#(define-public unbroken-or-last-broken-spanner?
(lambda (spanner) (zero? (cdr (spanner-bounds-break-status spanner)))))
#(define-public unbroken-or-first-broken-spanner?
(lambda (spanner) (zero? (car (spanner-bounds-break-status spanner)))))
%%%%%%%%%%%%%%%%%%%%%%%%
%% Tweak pedals
%%%%%%%%%%%%%%%%%%%%%%%%
%% AARGH!!
%% Is there no better method to get a pedal with a dashed line between the
%% glyphs "pedal.Ped" and "pedal.*"
howellPedalStyle = {
\override Dynamics.SostenutoPedal.stencil =
#(lambda (grob)
(grob-interpret-markup grob (make-musicglyph-markup "pedal.Ped")))
\override Dynamics.PianoPedalBracket.edge-height = #'(0 . 0)
\override Dynamics.PianoPedalBracket.style = #'dashed-line
\override Dynamics.PianoPedalBracket.after-line-breaking =
#(lambda (grob)
(if (unbroken-or-last-broken-spanner? grob)
(ly:grob-set-property! grob 'shorten-pair '(0 . 1.2))))
\override Dynamics.PianoPedalBracket.stencil =
#(grob-transformer 'stencil
(lambda (grob orig)
(if (unbroken-or-last-broken-spanner? grob)
(ly:stencil-combine-at-edge
orig
X
RIGHT
(grob-interpret-markup grob (make-musicglyph-markup "pedal.*"))
1)
orig)))
\override Dynamics.PianoPedalBracket.dash-fraction = 0.1
\override Dynamics.PianoPedalBracket.dash-period = 8
}
\version "2.20.0"
#(define (note-column::main-extent grob)
"Return extent of the noteheads in the 'main column', (i.e. excluding any
suspended noteheads), or extent of the rest (if there are no heads)."
(let* ((note-heads (ly:grob-object grob 'note-heads))
;; stem is currently not needed below, for now we let it in commented
;(stem (ly:grob-object grob 'stem))
(rest (ly:grob-object grob 'rest)))
(cond ((ly:grob-array? note-heads)
(let (;; get the cdr from all note-heads-extents, where the car
;; is zero
(n-h-right-coords
(filter-map
(lambda (n-h)
(let ((ext (ly:grob-extent n-h grob X)))
(and (= (car ext) 0) (cdr ext))))
(ly:grob-array->list note-heads))))
;; better be paranoid, find the max of n-h-right-coords and return
;; a pair with (cons 0 <max>)
(cons 0.0 (reduce max 0 n-h-right-coords))))
((ly:grob? rest)
(ly:grob-extent rest grob X))
;; better be paranoid again
(else '(0 . 0)))))
#(define note-column-cluster
(lambda (grob)
(let* ((nhds-array (ly:grob-object grob 'note-heads))
(nhds-list
(if (ly:grob-array? nhds-array)
(ly:grob-array->list nhds-array)
#f)))
(if nhds-list
(let* ((staff-pos-list
(map
(lambda (nhd) (ly:grob-property nhd 'staff-position))
nhds-list))
(staff-space (ly:staff-symbol-staff-space grob))
(bottom-pos
(/ (* (apply min staff-pos-list) staff-space) 2))
(top-pos
(/ (* (apply max staff-pos-list) staff-space) 2))
(nc-width (note-column::main-extent grob))
(mid-nc
(interval-center nc-width))
(stem (ly:grob-object grob 'stem))
(stem-details
(ly:grob-property stem 'details))
(cluster-thick-short
(* staff-space
(assoc-get 'cluster-thick-short stem-details 0.54)))
(stem-y-attach
(* staff-space
(cdr
(ly:grob-property (car nhds-list) 'stem-attachment))))
(stem-dir (ly:grob-property stem 'direction))
(dur-log (ly:grob-property stem 'duration-log))
(layout (ly:grob-layout grob))
(blot (ly:output-def-lookup layout 'blot-diameter))
(line-thick (ly:output-def-lookup layout 'line-thickness 0.1))
(stem-thick (ly:grob-property stem 'thickness 1.3))
(thick
(* (ly:grob-property
grob
'thickness
(* stem-thick line-thick))
staff-space)))
(ly:grob-set-property! stem 'avoid-note-head #t)
(ly:grob-set-property! grob 'stencil
(cond
((= dur-log 0)
(ly:stencil-add
(ly:round-filled-box
(cons 0 thick)
(cons bottom-pos top-pos)
blot)
(ly:round-filled-box
(cons (- (cdr nc-width) thick) (cdr nc-width))
(cons bottom-pos top-pos)
blot)))
((= dur-log 1)
(ly:stencil-add
(stencil-with-color
(ly:round-filled-box
(cons 0 thick)
(cons
(+ (/ staff-space 4) (- bottom-pos stem-y-attach))
(+ (/ staff-space 4) (- top-pos stem-y-attach)))
blot)
green)
(ly:round-filled-box
(cons (- (cdr nc-width) thick) (cdr nc-width))
(cons
(- (+ bottom-pos stem-y-attach) (/ staff-space 4))
(- (+ top-pos stem-y-attach) (/ staff-space 4)))
blot)))
(else
(let* ((x-left (- mid-nc (/ thick 2) cluster-thick-short))
(x-right (+ mid-nc (/ thick 2) cluster-thick-short))
(y-bottom-left
(+ (- bottom-pos thick stem-y-attach)
(/ staff-space 4)))
(y-bottom-right
(- (+ bottom-pos thick stem-y-attach)
(/ staff-space 4)))
(y-top-right
(- (+ top-pos thick stem-y-attach)
(/ staff-space 4)))
(y-top-left
(+ (- top-pos thick stem-y-attach)
(/ staff-space 4))))
(ly:make-stencil
`(polygon
;; with 2.20.0 use
',(list
;; with newer versions:
;,(list
x-left y-bottom-left
x-right y-bottom-right
x-right y-top-right
x-left y-top-left)
,blot
#t)
(cons x-left x-right)
(cons y-bottom-left y-top-right)))))))
;; else, do nothing
'()))))
#(define (close-enough? x y)
"Values are close enough to ignore the difference"
(< (abs (- x y)) 0.0001))
#(define (extent-combine extents)
"Combine a list of extents, return the minimum of the car and the maximum of
te cdr of all extents."
(reduce interval-union '() extents))
#(define ((cluster-stem-connectable? ref root) stem)
"Check if the @var{stem} is connectable to the @var{root}, done by comparing
their horizontal positions and their @code{direction} property.
For whole Notes fall back to compare the extent of the related @code{NoteColumn}
grobs."
(let* ((root-dur-log (ly:grob-property root 'duration-log))
(root-x-ext
(if (eqv? root-dur-log 0)
(ly:grob-extent (ly:grob-parent root X) ref X)
(ly:grob-extent root ref X)))
(stem-x-ext
(if (eqv? root-dur-log 0)
(ly:grob-extent (ly:grob-parent stem X) ref X)
(ly:grob-extent stem ref X))))
;; The root is always connectable to itself
(or (eq? root stem)
(and
;; Horizontal positions of the stems (or NoteColumns) must be almost the
;; same
(close-enough? (car root-x-ext) (car stem-x-ext))
;; The stem must be in the direction away from the root's notehead
;; Special case whole notes: always return #t
(if (eqv? root-dur-log 0)
#t
(positive? (* (ly:grob-property root 'direction)
(- (car (ly:grob-extent stem ref Y))
(car (ly:grob-extent root ref Y))))))))))
#(define (cluster-stem-span-stencil span)
"Connect stems if we have at least one stem connectable to the root.
@var{span} is the created target @code{grob}."
(let* ((system (ly:grob-system span))
(staff-space (ly:staff-symbol-staff-space span))
(root (ly:grob-parent span X))
(root-dir (ly:grob-property root 'direction 1))
(root-duration-log (ly:grob-property root 'duration-log))
(root-thick
(ly:grob-property root 'thickness 1.3))
(root-details
(ly:grob-property root 'details))
(cluster-thick-short
(assoc-get 'cluster-thick-short root-details 0.54))
(stems
(filter
(cluster-stem-connectable? system root)
(ly:grob-object span 'stems)))
(parent-ncs
(map
(lambda (stem)
(ly:grob-parent stem X))
stems))
(ncs-extents
(map
note-column::main-extent
parent-ncs))
;; Use half width for half notes and longer
(nc-x-width
(interval-center
(extent-combine ncs-extents)))
(layout (ly:grob-layout root))
(line-thick (ly:output-def-lookup layout 'line-thickness 0.1))
;(foo
; (pretty-print
; (list
; staff-space
; (ly:output-def-lookup layout 'staff-space)
; (ly:output-def-lookup layout 'output-scale)
; (ly:output-def-lookup (ly:grob-layout (car stems)) 'staff-space)
; )
; ))
(half-used-thick
(/ (* line-thick root-thick) 2))
(blot (ly:output-def-lookup layout 'blot-diameter))
)
(if (= 2 (length stems))
(let* (;; Get the Y-extents of all the original stems
;; For whole note stems fall back to Y-extents of their
;; NoteColumn
(y-extents
(cond ((< root-duration-log 1)
(map
(lambda (nc) (ly:grob-extent nc system Y))
parent-ncs))
(else
(map
(lambda (st)
(ly:grob-extent st system Y))
stems))))
;; For uppointing Stem accumulate their car, otherwise cdr,
;; for whole note stems use the center of their NoteColumn extent
;; to build a list. This list is used to determine bottom/top
;; values to print the cluster-stem lateron
(stem-starts-ls
(cond ((< root-duration-log 1)
(list (interval-center (car y-extents))
(interval-center (last y-extents))))
(else
(if (positive? root-dir)
(map car y-extents)
(map cdr y-extents)))))
(y-ext
(cons (car stem-starts-ls) (last stem-starts-ls)))
(raw-stencil
(ly:round-filled-box
(interval-scale (cons (- half-used-thick) half-used-thick) 1)
y-ext
blot))
(stem-attach
(ly:grob-property
(car
(ly:grob-array->list
(ly:grob-object root 'note-heads)))
'stem-attachment)))
;; Hide root stem, i.e. the stem of the lowest connected note
(set! (ly:grob-property root 'stencil) #f)
;; Draw a nice looking stem with rounded corners
(cond
;; whole notes
((= root-duration-log 0)
(ly:stencil-add
(ly:stencil-translate-axis
raw-stencil
(- half-used-thick nc-x-width)
X)
(ly:stencil-translate-axis
raw-stencil
(- nc-x-width half-used-thick)
X)
))
;; half notes
((= root-duration-log 1)
(ly:stencil-add
raw-stencil
(ly:round-filled-box
(coord-translate
(cons (- half-used-thick) half-used-thick)
(* 2 root-dir (- half-used-thick nc-x-width)))
(cons
(+ (car y-ext) (* -1 root-dir (cdr stem-attach)))
(+ (cdr y-ext) (* -1 root-dir (cdr stem-attach))))
blot)))
;; 4th and shorter
(else
(let* ((x-right (+ half-used-thick cluster-thick-short))
(x-left (- x-right))
(y-left-bottom
(+ (car y-ext)
(if (negative? root-dir)
0
(- (cdr stem-attach)))))
(y-right-bottom
(+ (car y-ext)
(if (negative? root-dir)
(cdr stem-attach)
0)))
(y-right-top
(+ (cdr y-ext)
(if (negative? root-dir)
(cdr stem-attach)
0)))
(y-left-top
(+ (cdr y-ext)
(if (negative? root-dir)
0
(- (cdr stem-attach))))))
(ly:stencil-translate-axis
(ly:make-stencil
`(polygon
;; with 2.20.0 use
',(list
;; with newer versions:
;,(list
x-left y-left-bottom
x-right y-right-bottom
x-right y-right-top
x-left y-left-top
)
,blot
#t)
(cons (- half-used-thick) half-used-thick)
y-ext
)
(* -1 root-dir (- nc-x-width half-used-thick))
X)
))))
;; Nothing to connect, don't draw the span
#f)))
#(define ((make-cluster-stem-span! stems trans) root)
"Create a stem span as a child of the cross-staff stem (the root)"
(let ((span (ly:engraver-make-grob trans 'Stem '())))
(ly:grob-set-parent! span X root)
(set! (ly:grob-object span 'stems) stems)
;; Suppress positioning, the stem code is confused by this weird stem
(set! (ly:grob-property span 'X-offset) 0)
(set! (ly:grob-property span 'stencil) cluster-stem-span-stencil)))
#(define-public (cross-staff-connect stem)
"Set cross-staff property of the stem to this function to connect it to
other stems automatically"
#t)
#(define (stem-is-root? stem)
"Check if automatic connecting of the stem was requested. Stems connected
to cross-staff beams are cross-staff, but they should not be connected to
other stems just because of that."
(eq? cross-staff-connect (ly:grob-property-data stem 'cross-staff)))
#(define (make-cluster-stem-spans! ctx stems trans)
"Create stem spans for cross-staff stems"
;; Cannot do extensive checks here, just make sure there are at least
;; two stems at this musical moment
(if (= 2 (length stems))
(let ((roots (filter stem-is-root? stems)))
(for-each (make-cluster-stem-span! stems trans) roots))))
#(define-public (Cluster-span_stem_engraver ctx)
"Connect cross-staff stems to the stems above in the system"
(let ((stems '()))
(make-engraver
;; Record all stems with note-heads for the given moment
(acknowledgers
((stem-interface trans grob source)
(if (ly:grob-array? (ly:grob-object grob 'note-heads))
(set! stems (cons grob stems)))))
;; Process stems and reset the stem list to empty
((process-acknowledged trans)
(make-cluster-stem-spans! ctx stems trans)
(set! stems '())))))
cluster =
#(define-music-function (cross-staff notes) ((boolean? #f) ly:music?)
(_i "Create cross-staff stems")
(if cross-staff
#{
\temporary \override Stem.cross-staff = #cross-staff-connect
\temporary \override Flag.style = #'no-flag
$notes
\revert Stem.cross-staff
\revert Flag.style
#}
#{
\temporary \override NoteColumn.before-line-breaking =
#note-column-cluster
$notes
\revert NoteColumn.before-line-breaking
#})
)
