Hi Stefano,
On Thu, Feb 8, 2018 at 4:43 PM, Stefano Troncaro
<stefanotronc...@gmail.com> wrote:
> Hello again!
>
> I managed to modify David's translation of ly:hairpin::print to have it use
> two properties, Hairpin.rotate and Hairpin.straight-end, to achieve almost
> all the results I wanted.
Glad you got some use out of this! I like the look of the
straight-edged hairpins.
>
> The idea is that Hairpin.rotate can be either a numerical value,
> representing the angle of rotation, or a procedure that returns the angle of
> rotation. In one of the examples I used the function discussed earlier in
> this thread to have it automatically detect the angle of a beam. However, I
> can't manage to make this idea work when the procedure given to
> Hairpin.rotate requires more than one variable. This is very inconvenient
> because for some cases the procedure would need to calculate again a lot of
> things that are already calculated in the process of making the stencil.
First of all, calling ly:grob-property calls any procedure the
property is set to. The function ly:grob-property-data won't.
I don't know of any way in Scheme to overload functions or to count
arguments. If you name your function, however, you can use
procedure-name. (See the attached.)
HTH,
David
\version "2.19.80"
#(define (proc-number-or-false? obj)
(or (procedure? obj)
(number? obj)
(eq? obj #f)))
#(define (define-grob-property symbol type? description)
(if (not (equal? (object-property symbol 'backend-doc) #f))
(ly:error (_ "symbol ~S redefined") symbol))
(set-object-property! symbol 'backend-type? type?)
(set-object-property! symbol 'backend-doc description)
symbol)
#(map
(lambda (x)
(apply define-grob-property x))
`(
(circled-tip-radius ,number? "Radius for hairpin circled tip")
(rotate ,proc-number-or-false? "Custom rotation: a number specifies angle in degrees, a procedure will receive the grob and return an angle, #f deactivates rotation")
(straight-end ,boolean? "Straighten the end of the hairpin when it's rotated?")
))
#(define broken-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-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 (ly:grob-property grob 'circled-tip-radius (* 0.525 height)))
(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)))
(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)
(< 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 '())
(neighbors (ly:grob-object grob 'adjacent-spanners))
(neighbors-len (if (ly:grob-array? neighbors)
(ly:grob-array-length neighbors)
0)))
(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))))))
;add support for rotation and straightened end-points
(let* ((rotate (ly:grob-property-data grob 'rotate))
(straighten (ly:grob-property grob 'straight-end #f))
(ang (cond
((number? rotate) rotate)
((procedure? rotate)
(if (eq? (procedure-name rotate) 'hairpin-follow-beam)
(rotate grob)
(rotate grob width starth endh)))
(else 0)))
(offset (if (or (= ang 0) (not straighten))
0
(let* ((adj-hgt (- starth endh))
(def-ang (atan (/ adj-hgt width)))
(and-rad (degrees->radians ang))
(tot-ang (+ def-ang and-rad)))
(- (* width (tan tot-ang)) adj-hgt)))))
(set! mol (make-line-stencil thick x starth width (+ endh offset)))
(set! mol
(ly:stencil-add
mol
(make-line-stencil thick x (- starth) width (- offset endh))))
;TODO: circle on the right end of the object should be placed with the offset. How?
(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)))))
;if straight end-points are not needed, just rotate the stencil
(if (and (not straighten) (not (= ang 0)))
(set! mol (ly:stencil-rotate mol ang CENTER CENTER)))
(set! mol
(ly:stencil-translate-axis mol
(- (interval-bound x-points LEFT)
(ly:grob-relative-coordinate (interval-bound bounds LEFT) common X))
X))
mol)))))))
#(define hairpin-follow-beam
(lambda (grob)
(let* ((lb (ly:spanner-bound grob LEFT))
(rb (ly:spanner-bound grob RIGHT))
(bound
(find (lambda (b)
(grob::has-interface b 'note-column-interface))
(list lb rb)))
(beam
(if bound
(ly:grob-object (ly:grob-object bound 'stem) 'beam)
(let* ((col (ly:item-get-column lb))
(elts (ly:grob-array->list
(ly:grob-object col 'bounded-by-me))))
(find (lambda (e) (grob::has-interface e 'beam-interface))
elts)))))
(if (ly:grob? beam)
(let* ((X-pos (ly:grob-property beam 'X-positions))
(Y-pos (ly:grob-property beam 'positions))
(ang (ly:angle (- (cdr X-pos) (car X-pos))
(- (cdr Y-pos) (car Y-pos)))))
ang)
0))))
% The following doesn't work because of the following error when Hairpin.rotate has a lambda that requires more than one variable.
% 226:29: Wrong number of arguments to #<procedure hairpin-upper-with-staff (grob width starth endh)>
#(define hairpin-upper-with-staff
(lambda (grob width starth endh)
(let* ((adj-hgt (- endh starth))
(def-ang (atan (/ adj-hgt width)))
(def-ang-degrees (* def-ang (/ 180 PI))))
(- def-ang-degrees))))
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\! }
>>
\once \override Hairpin.to-barline = ##f
c''1\<
c''1\!
c'8\< e' g' b'\! d''\> b' g' e'\!
<< f''1 { s4 s\< s\> s\! } >>
\override Hairpin.minimum-length = #5
<< f''1 { s4 s\< s\> s\! } >>
\revert Hairpin.minimum-length
}
\markup \huge \bold "DEFAULT"
{
\music
\override Hairpin.circled-tip = ##t
\music
}
\markup \huge \bold "ANGLE REWRITE"
{
\override Hairpin.stencil = #hairpin::print-scheme
\music
\override Hairpin.rotate = 10
\override Hairpin.straight-end = ##f
\music
\override Hairpin.rotate = -15
\override Hairpin.straight-end = ##t
\music
%\override Hairpin.circled-tip = ##t %can't properly position circled-tip
\override Hairpin.rotate = #hairpin-follow-beam
\override Hairpin.straight-end = ##t
\music
\override Hairpin.rotate = #hairpin-upper-with-staff
\override Hairpin.straight-end = ##t
\music
}
\layout {
ragged-right = ##t
}_______________________________________________
lilypond-user mailing list
lilypond-user@gnu.org
https://lists.gnu.org/mailman/listinfo/lilypond-user
