2015-03-17 15:52 GMT+01:00 Kevin Barry <barr...@gmail.com>:
> Just as a follow up to Stephen's question: for analytic examples I have to
> draw curved lines all the time, usually with arrow-heads attached at the
> end, so I made a function to do it given just the coordinates of the
> desired destination. Using curveto is very slow because of all the trial
> and error with control points, and if you do this often it becomes draining
> (rather like fixing slurs before the awesome \shape function was
> introduced).
>
> The code with some examples is at the end of this mail. If I knew more
> about mathematics I might know how to calculate the tangent to a bezier
> curve at the end point (to know how much to rotate the arrowhead) and the
> function wouldn't be such a hack.
>
I attach my approach to create arrowed slurs.
It's hackish as well, though maybe helpful.
Cheers,
Harm
\version "2.18.0"
% #(use-modules (ice-9 pretty-print))
% #(use-modules (srfi srfi-1))
#(define grob-name
(lambda (x)
(if (ly:grob? x)
(assq-ref (ly:grob-property x 'meta) 'name)
(ly:error "~a is not a grob" x))))
#(define (add-arrow-head-to-curve control-points)
(lambda (grob)
(let* ((orig (if (ly:spanner? grob)
(ly:grob-original grob)
#f))
(siblings (if (ly:grob? orig)
(ly:spanner-broken-into orig)
'()))
(function (assoc-get 'stencil
(reverse (ly:grob-basic-properties grob))))
(stil ;; Ugh, is there no better way to test that a grob has no
;; 'stencil and that no other previous procedure assigned
;; a stencil-value to said grob?
(if (and (procedure? function)
(not (eq? (procedure-name function)
'add-arrow-head-to-curve)))
(function grob)
(begin
(ly:warning "~a has no stencil. Ignoring." grob)
#f))))
(if (or (null? siblings)
(equal? grob (car (last-pair siblings))))
(let* ((default-stil-lngth
(interval-length (ly:stencil-extent stil X)))
(frst (car control-points))
(thrd (caddr control-points))
(frth (cadddr control-points))
(delta-x-cps (- (car frth) (car frst)))
;; Get the difference between stil-length and the distance
;; of first-to-last control-point
(diff (- default-stil-lngth delta-x-cps))
;; Get the legs of the triangle at third/fourth control-
;; point.
(delta-iv
(cons (- (car frth) (car thrd)) (- (cdr frth) (cdr thrd))))
(radians->degree (lambda (radians) (/ (* radians 180) PI)))
(angl (radians->degree (atan (cdr delta-iv) (car delta-iv))))
;; Ties seems to need a lower angle
(ang (if (member (grob-name grob)
'(Tie RepeatTie LaissezVibrerTie))
(* angl 0.75)
angl))
(arrowhead-stil (ly:font-get-glyph (ly:grob-default-font grob)
"arrowheads.open.01"))
;; The arrowhead is too small for Tie
(arrowhead (if (eq? 'Tie (grob-name grob))
(ly:stencil-scale arrowhead-stil 1.7 1.7)
arrowhead-stil))
(rotated-arrowhead (ly:stencil-rotate arrowhead ang 0 0))
(arrowhead-lngth
(interval-length (ly:stencil-extent rotated-arrowhead X))))
(ly:stencil-add
stil
(ly:stencil-translate
rotated-arrowhead
;; Ugh, 3.8 found by trial and error
(cons (+ diff (/ arrowhead-lngth 3.8) (car frth))
(+ (cdr frth) 0)))))
stil))))
#(define arrowed-curve
(lambda (grob)
(let* ((curve-dir (ly:grob-property grob 'direction))
(right-bound (if (ly:spanner? grob)
(ly:spanner-bound grob RIGHT)
#f))
(right-bound-stem (if (ly:grob? right-bound)
(ly:grob-object right-bound 'stem)
#f))
(right-bound-stem-dir
(if (ly:grob? right-bound-stem)
(ly:grob-property right-bound-stem 'direction)
#f))
(c-ps (ly:grob-property grob 'control-points))
;(function (assoc-get 'control-points
; (reverse (ly:grob-basic-properties grob))))
;(c-pss (function grob))
(frst (car c-ps))
(thrd (caddr c-ps))
;; corr-values are my choice.
;; A little space is needed to make room for the arrowhead
(corr (cond ((eq? (grob-name grob) 'RepeatTie)
(cons -0.25 (* 0.3 curve-dir)))
((not right-bound-stem-dir)
'(0 . 0))
((eq? (grob-name grob) 'Tie)
(cons -0.4 (* 0.3 curve-dir)))
(else (cons -0.4 (* 0.3 curve-dir)))))
(frth (offset-add (cadddr c-ps) corr))
(changed-cps (append (list-head c-ps 3) (list frth))))
(ly:grob-set-property! grob 'control-points changed-cps)
((add-arrow-head-to-curve changed-cps) grob))))
#(define outside-staff-curve
;; prints the curve outside the staff
(lambda (grob)
(let* ((function (assoc-get 'control-points
(reverse (ly:grob-basic-properties grob))))
(c-ps (function grob))
(frst (car c-ps))
(scnd (cadr c-ps))
(thrd (caddr c-ps))
(frth (cadddr c-ps))
(curve-dir (ly:grob-property grob 'direction))
(curve-up? (= 1 curve-dir))
(right-bound (ly:spanner-bound grob RIGHT))
(right-bound-stem (ly:grob-object right-bound 'stem))
(right-bound-stem-dir
(if (ly:grob? right-bound-stem)
(ly:grob-property right-bound-stem 'direction)
#f))
(right-bound-beam
(if (ly:grob? right-bound-stem)
(ly:grob-object right-bound-stem 'beam)
#f))
(left-bound (ly:spanner-bound grob LEFT))
(left-bound-stem (ly:grob-object left-bound 'stem))
(left-bound-stem-dir
(if (ly:grob? left-bound-stem)
(ly:grob-property left-bound-stem 'direction)
#f))
(left-bound-beam
(if (ly:grob? left-bound-stem)
(ly:grob-object left-bound-stem 'beam)
#f))
;; If Stem and Slur have same direction, more distance is needed
;; But not if a beam is present
(crr
(if (and right-bound-stem-dir
left-bound-stem-dir
(or (= right-bound-stem-dir curve-dir)
(= left-bound-stem-dir curve-dir))
(not (null? (ly:grob-property left-bound-stem 'stencil)))
(not (null? (ly:grob-property right-bound-stem 'stencil)))
(null? right-bound-beam)
(null? left-bound-beam)
(or (> (max (cdr frst) (cdr frth)) 2.551)
(< (min (cdr frst) (cdr frth)) -2.551)))
(* 1.2 curve-dir)
0))
;; Ensure first and fourth control-points have the same value to
;; creat a "flat" curve
;; Set second and third appropriate
;; The numeric values are my choice.
(new-cps
(map
(lambda (cp)
(if (or (eq? cp frst) (eq? cp frth))
(cons
(car cp)
;; For first and fourth control-point, choose the highest
;; y-value, 2.551 at least.
;; Similiar if the curve is below.
(+ crr
(if curve-up?
(max (cdr frst) (cdr frth) 2.551)
(min (cdr frst) (cdr frth) -2.551))))
(cons
(car cp)
;; For second and third control-point, choose an
;; appropiate y-value, 4.235 at least.
;; Similiar if the curve is below.
(+ crr
(if curve-up?
(max
4.235
(cdr scnd)
(cdr thrd)
(+ (max (cdr frst) (cdr frth)) 1.2))
(min
-4.235
(cdr scnd)
(cdr thrd)
(- (min (cdr frst) (cdr frth)) 1.2)))))))
c-ps)))
new-cps)))
%
%slurArrow =
% \override Slur #'stencil = #arrowed-curve
%
%print-slur-outside-staff =
% \override Slur #'control-points = #outside-staff-curve
%
curve-arrow =
#(define-music-function (parser location curve outside-staff-slur?)
(string? boolean?)
"
Prints a curve with an arrowhead at right end.
If wanted, Slurs and PhrasingSlurs are printed outside staff.
"
#{
\override $curve . stencil = #arrowed-curve
#(if (or outside-staff-slur?
(not (member (string->symbol curve)
'(Ties RepeatTies LaissezVibrerTies))))
#{
\override $curve . control-points =
#outside-staff-curve
#}
#{#})
#})
arrowed-slur-outside-staff = \curve-arrow Slur ##t
neutral-slur = {
\override Slur.stencil = #ly:slur::print
%% Why does a simple revert not work?
%\revert Slur #'stencil
\revert Slur.control-points
\slurNeutral
}
arrowed-phrasing-slur-outside-staff = \curve-arrow PhrasingSlur ##t
neutral-phrasing-slur = {
\revert PhrasingSlur #'stencil
\revert PhrasingSlur.control-points
}
arrowed-tie = \curve-arrow Tie ##f
neutral-tie = {
\revert Tie #'stencil
\revert Tie.control-points
}
arrowed-repeat-tie = \curve-arrow RepeatTie ##f
neutral-repeat-tie = {
\revert RepeatTie #'stencil
\revert RepeatTie.control-points
}
arrowed-laissez-vibrer-tie = \curve-arrow LaissezVibrerTie ##f
neutral-laissez-vibrer-tie = {
\revert LaissezVibrerTie #'stencil
\revert LaissezVibrerTie.control-points
}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% EXAMPLES
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\relative c'' {
\arrowed-slur-outside-staff
c'( c \bar "" \break c c)
\slurDown
c( c c c)
<>^\markup \with-color #red "How should it look?"
\stemUp
\slurUp
c,,4( c c c'')
<>^"default"
\neutral-slur
c( c c c)
}
m = { c4( d e f e d des c) }
testI = {
\relative c \m
\relative c' \m
\relative c'' \m
\relative c''' \m
}
\new Staff \with { \arrowed-slur-outside-staff instrumentName = "Slurs" }
{
<>^"no Slur-Stem-direction"
\testI
\break
<>^"Slur down, Stem up"
\slurDown
\stemUp
\testI
\break
<>^"Slur up, Stem down"
\slurUp
\stemDown
\testI
\break
<>^"Slur up, Stem up"
\slurUp
\stemUp
\testI
\break
<>^"Slur down, Stem down"
\slurDown
\stemDown
\testI
\break
<>^"default"
\stemNeutral
\neutral-slur
\testI
\break
}
\new Staff \with { instrumentName = "Ties" }
\relative c' {
\arrowed-tie
<c e g c>1~ q
<>^"default"
\neutral-tie
<c e g c>1~ q
}
\new Staff \with { instrumentName = "PhrasingSlur" }
\relative c' {
<>^\markup \with-color #red"How should it look?"
\arrowed-phrasing-slur-outside-staff
<c e g c>1^\( q q <g d' g b g'>\)
<>^"default"
\neutral-phrasing-slur
<c e g c>1^\( q q <g d' g b g'>\)
}
\new Staff \with { instrumentName = "RepeatTie" }
\relative c' {
<>_\markup \fontsize #-2 \with-color #red \column {
"TODO: Better output" "for RepeatTie"
}
\arrowed-repeat-tie
c2\repeatTie
<>^"default"
\neutral-repeat-tie
c2\repeatTie
}
\new Staff \with { instrumentName = "LaissezVibrerTie" }
\relative c' {
\arrowed-laissez-vibrer-tie
c1\laissezVibrer
<>^"default"
\neutral-laissez-vibrer-tie
c1\laissezVibrer
}
\paper { indent = 30 }
#(set-global-staff-size 19)
_______________________________________________
lilypond-user mailing list
lilypond-user@gnu.org
https://lists.gnu.org/mailman/listinfo/lilypond-user
