Hi Paul,
On Wed, Aug 19, 2015 at 8:56 PM, Paul Morris <p...@paulwmorris.com> wrote:
> On Aug 18, 2015, at 9:20 AM, David Nalesnik <david.nales...@gmail.com>
> wrote:
>
> In the attached file, I've recoded the print routine in Scheme
>
>
> The attached file contains David’s Scheme recoding with the original C++
> code inserted line by line as comments. This helped me to understand how
> he did it by seeing the two versions back to back. I thought I’d share it
> in case anyone else is interested. (This is the first version that follows
> the C++ more closely than the second.)
>
>
Thanks for doing this! (I should have thought to write it this way in the
first place!)
By the way, later in the thread I posted a correction of the version you're
commenting, which makes the spacing of naturals tally with the original.
There's a parens error: should be an extra parens in line 136 to close the
inner loop and one fewer in line 191. (I also moved a variable into a
named let, but that's just cosmetic.)
By the way, I've also recoded hairpin::print in Scheme, and I'm attaching
that to this email in case you're interested. Hairpins are another popular
candidate for customizations and this should make it easier--changing the
size of the circled-tip, some sort of "shorten-pair," easy addition of
circles to Ferneyhough hairpins, etc.
Best,
David
\version "2.19.23"
#(define broken-right-neighbor
(lambda (grob)
(let* ((pieces (ly:spanner-broken-into (ly:grob-original grob)))
(me-list (member grob pieces)))
(if (> (length me-list) 1)
(cadr me-list)
'()))))
#(define (interval-dir-set i val dir)
(cond ((= dir LEFT) (set-car! i val))
((= dir RIGHT) (set-cdr! i val))
(else (ly:error "dir must be LEFT or RIGHT"))))
#(define (other-dir dir) (- dir))
#(define hairpin::print-scheme
(lambda (grob)
(let ((grow-dir (ly:grob-property grob 'grow-direction)))
(if (not (ly:dir? grow-dir))
(begin
(ly:grob-suicide! grob)
'()))
(let* ((padding (ly:grob-property grob 'bound-padding 0.5))
(bounds (cons (ly:spanner-bound grob LEFT)
(ly:spanner-bound grob RIGHT)))
(broken (cons
(not (= (ly:item-break-dir (car bounds)) CENTER))
(not (= (ly:item-break-dir (cdr bounds)) CENTER)))))
(if (cdr broken)
(let ((next (broken-right-neighbor grob)))
(if (ly:spanner? next)
(begin
(ly:grob-property next 'after-line-breaking)
(set-cdr! broken (grob::is-live? next)))
(set-cdr! broken #f))))
(let* ((common
(ly:grob-common-refpoint (car bounds) (cdr bounds) X))
(x-points (cons 0 0))
(circled-tip (ly:grob-property grob 'circled-tip))
(height (* (ly:grob-property grob 'height 0.2)
(ly:staff-symbol-staff-space grob)))
(rad (* 0.525 height))
; commented out is directly from C++, but it leads to think lines when
; no circled tip!
;(thick 1.0)
;(thick (if circled-tip
;(* (ly:grob-property grob 'thickness 1.0)
;(ly:staff-symbol-line-thickness grob))
;thick))
(thick (* (ly:grob-property grob 'thickness 1.0)
(ly:staff-symbol-line-thickness grob))))
(define (inner dir)
(let* ((b (interval-bound bounds dir))
(e (ly:generic-bound-extent b common))) ; X-AXIS assumed
(interval-dir-set
x-points (ly:grob-relative-coordinate b common X) dir)
(if (interval-bound broken dir)
(if (= dir LEFT)
(interval-dir-set
x-points (interval-bound e (other-dir dir)) dir)
(let* ((broken-bound-padding
(ly:grob-property grob 'broken-bound-padding 0.0))
(chp (ly:grob-object grob 'concurrent-hairpins)))
(let loop ((i 0))
(if (and (ly:grob-array? chp) ; hmm...why no test in C++ needed?
(< i (ly:grob-array-length chp)))
(let ((span-elt (ly:grob-array-ref chp i)))
(if (= (ly:item-break-dir (ly:spanner-bound span-elt RIGHT))
LEFT)
(set! broken-bound-padding
(max broken-bound-padding
(ly:grob-property span-elt 'broken-bound-padding 0.0))))
(loop (1+ i)))))
(interval-dir-set
x-points
(- (interval-bound x-points dir)
(* dir broken-bound-padding))
dir)))
(if (grob::has-interface b 'text-interface)
(if (not (interval-empty? e))
(interval-dir-set x-points
(- (interval-bound e (other-dir dir))
(* dir padding))
dir))
(let* ((neighbor-found #f)
(adjacent '()) ; spanner
(neighbors (ly:grob-object grob 'adjacent-spanners))
(neighbors-len (if (ly:grob-array? neighbors)
(ly:grob-array-length neighbors)
0))) ; this shouldn't be necessary -- see comment above
(let inner-two ((i 0))
(if (and (< i neighbors-len)
(not neighbor-found))
(begin
(set! adjacent (ly:grob-array-ref neighbors i))
(if (and (ly:spanner? adjacent)
(eq? (ly:item-get-column (ly:spanner-bound adjacent (other-dir dir)))
(ly:item-get-column b)))
(set! neighbor-found #t))
(inner-two (1+ i)))))
(if neighbor-found
(if (grob::has-interface adjacent 'hairpin-interface)
(if (and circled-tip (not (eq? grow-dir dir)))
(interval-dir-set x-points
(+ (interval-center e)
(* dir
(- rad (/ thick 2.0))))
dir)
(interval-dir-set x-points
(- (interval-center e)
(/ (* dir padding) 3.0))
dir))
(if (= dir RIGHT)
(interval-dir-set x-points
(- (interval-bound e (other-dir dir))
(* dir padding))
dir)))
(begin
(if (and (= dir RIGHT)
(grob::has-interface b 'note-column-interface)
(ly:grob-array? (ly:grob-object b 'rest)))
(interval-dir-set x-points
(interval-bound e (other-dir dir))
dir)
(interval-dir-set x-points
(interval-bound e dir)
dir))
(if (eq? (ly:grob-property b 'non-musical) #t)
(interval-dir-set x-points
(- (interval-bound x-points dir)
(* dir padding))
dir)))))))))
(inner LEFT)
(inner RIGHT)
(let* ((width (- (interval-bound x-points RIGHT)
(interval-bound x-points LEFT)))
(width (if (< width 0)
(begin
(ly:warning
(if (< grow-dir 0)
"decrescendo too small"
"crescendo too small"))
0)
width))
(continued (interval-bound broken (other-dir grow-dir)))
(continuing (interval-bound broken grow-dir))
(starth (if (< grow-dir 0)
(if continuing
(* 2 (/ height 3))
height)
(if continued
(/ height 3)
0.0)))
(endh (if (< grow-dir 0)
(if continued
(/ height 3)
0.0)
(if continuing
(* 2 (/ height 3))
height)))
(mol empty-stencil)
(x 0.0)
(tip-dir (other-dir grow-dir)))
(if (and circled-tip
(not (interval-bound broken tip-dir)))
(if (> grow-dir 0)
(set! x (* rad 2.0))
(if (< grow-dir 0)
(set! width (- width (* rad 2.0))))))
(set! mol (make-line-stencil thick x starth width endh))
(set! mol
(ly:stencil-add
mol
(make-line-stencil thick x (- starth) width (- endh))))
(if circled-tip
(let ((circle (make-circle-stencil rad thick #f)))
(if (not (interval-bound broken tip-dir))
(set! mol
(ly:stencil-combine-at-edge mol X tip-dir circle 0)))))
(set! mol
(ly:stencil-translate-axis mol
(- (interval-bound x-points LEFT)
(ly:grob-relative-coordinate (interval-bound bounds LEFT) common X))
X))
mol))))))
music =
{
c'1\<
c'2\! c'2~\>
c'2~ c'2\!
c'2\> c'2\< c'1
c''1\<
c''4 a' c''\< a'
c''4 a' c''\! a'\<
c''4 a' c'' a'\!
c''1~\<
c''1~
\break
c''1\!
c'1\!\<
\break
c'1
\break
c'2 c'2\!
c''1\<
c''4 a' c''\mf a'
c''1\<
c''4 a' c''\ffff a'
c''4\< c''\! d''\> e''\!
<<
f''1
{ s4 s4\< s4\> s4\! }
>>
\override Hairpin.to-barline = ##f
c''1\<
c''1\!
}
\markup \huge \bold "DEFAULT"
{
\music
\override Hairpin.circled-tip = ##t
\music
}
\markup \huge \bold "SCHEME REWRITE"
{
\override Hairpin.stencil = #hairpin::print-scheme
\music
\override Hairpin.circled-tip = ##t
\music
}
\layout {
ragged-right = ##t
}
_______________________________________________
lilypond-user mailing list
lilypond-user@gnu.org
https://lists.gnu.org/mailman/listinfo/lilypond-user
