Hi David, thank you for your suggestions, this is almost done!
I decided to pass an alist to the function instead of changing the amount
of arguments based on the procedure name, mainly because if I write more
angle functions in the future I want to be able to do so without having to
temper with the stencil definition. That is however a useful idea that I
would have never thought about, and I may find it useful in the future.
I have a few doubts if you don't mind.
1) At first I couldn't make the alist approach work because for some reason
I can't define one in a let or let* block. Do you know why? I googled and I
couldn't find an explanation.
2) Is there a way to define an alist different than a succession of acons?
I thought I would be able to create it with a syntax like '((k1 . v1) (k2 .
v2) ... etc) but in the end I had to settle for (acons k1 v1 (acons k2 v2
... (acons kn vn '()))).
3) I made the following function to make it so that the upper line of the
hairpin runs parallel with the staff lines. It does so by finding the angle
that is formed between the "zero-point" of the hairpin (the point where it
begins to open) and the ending point of the higher hairpin line, that is in
(width, height). The function takes into account that the lines of hairpins
that go through a system break have different starting and ending heights,
this is called "adjusted height" here. With all this in mind, the function
finds the angle of the upper line of the hairpin, and returns the negative
of that angle, which ideally would result in that angle being 0 degrees,
making it so that the upper line is parallel to the staff. But the end
result is slightly off (see image). I don't know if the math is wrong or if
this problem arises from rounding differences. If it is the later I may
need to formulate another approach entirely. Any insight on this?
> #(define hairpin-upper-with-staff
> (lambda (prop-alist)
> (let* ((starth (assq-ref prop-alist 'starth))
> (endh (assq-ref prop-alist 'endh))
> (width (assq-ref prop-alist 'width))
> (adj-hgt (- endh starth))
> (def-ang (ly:angle width adj-hgt)) )
> (- def-ang))))
>
>
Thank you for all the help!!
2018-02-08 21:50 GMT-03:00 David Nalesnik <david.nales...@gmail.com>:
> 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)
(rotate (acons 'grob grob
(acons 'width width
(acons 'starth starth
(acons 'endh endh '()))))))
;(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 (prop-alist)
(let* ((grob (assq-ref prop-alist 'grob))
(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))))
#(define hairpin-upper-with-staff
(lambda (prop-alist)
(let* ((starth (assq-ref prop-alist 'starth))
(endh (assq-ref prop-alist 'endh))
(width (assq-ref prop-alist 'width))
(adj-hgt (- endh starth))
(def-ang (ly:angle width adj-hgt)) )
(- def-ang))))
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
