;;;; You should have received a copy of the GNU General Public License
;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
-(define (make-bezier-sandwich-stencil coords thick xext yext)
- (let* ((command-list `(moveto
- ,(car (list-ref coords 3))
- ,(cdr (list-ref coords 3))
- curveto
- ,(car (list-ref coords 0))
- ,(cdr (list-ref coords 0))
- ,(car (list-ref coords 1))
- ,(cdr (list-ref coords 1))
- ,(car (list-ref coords 2))
- ,(cdr (list-ref coords 2))
- curveto
- ,(car (list-ref coords 4))
- ,(cdr (list-ref coords 4))
- ,(car (list-ref coords 5))
- ,(cdr (list-ref coords 5))
- ,(car (list-ref coords 6))
- ,(cdr (list-ref coords 6))
- closepath)))
- (ly:make-stencil
- `(path ,thick `(,@' ,command-list) 'round 'round #t)
- xext
- yext)))
+(define (make-bezier-sandwich-stencil coords thick)
+ (make-path-stencil
+ `(moveto
+ ,(car (list-ref coords 0))
+ ,(cdr (list-ref coords 0))
+ curveto
+ ,(car (list-ref coords 1))
+ ,(cdr (list-ref coords 1))
+ ,(car (list-ref coords 2))
+ ,(cdr (list-ref coords 2))
+ ,(car (list-ref coords 3))
+ ,(cdr (list-ref coords 3))
+ curveto
+ ,(car (list-ref coords 4))
+ ,(cdr (list-ref coords 4))
+ ,(car (list-ref coords 5))
+ ,(cdr (list-ref coords 5))
+ ,(car (list-ref coords 0))
+ ,(cdr (list-ref coords 0))
+ closepath)
+ thick
+ 1
+ 1
+ #t))
+
+(define-public (make-bow-stencil
+ start stop thickness angularity bow-height orientation)
+ "Create a bow stencil.
+It starts at point @var{start}, ends at point @var{stop}.
+@var{thickness} is the thickness of the bow.
+The higher the value of number @var{angularity}, the more angular the shape of
+the bow.
+@var{bow-height} determines the height of the bow.
+@var{orientation} determines, whether the bow is concave or convex.
+@var{orientation} should be set to @val{-1} or @val{1}, other values are
+possible but will affect the bow's height as well.
+Both variables are supplied to support independent usage.
+
+Done by calculating a horizontal unit-bow first, then moving all control-points
+to the correct positions.
+Limitation: s-curves are currently not supported.
+"
+
+;;;; Coding steps:
+;;;; (1) calculate control-points for a "unit"-bow from '(0 . 0) to '(1 . 0)
+;;;; user settable `bow-height' and `thickness' are scaled down.
+;;;; (2) move control-points to match `start' and `stop'
+
+ (let* (;; we use a fixed line-width as border for different behaviour
+ ;; for larger and (very) small lengths
+ (line-width 0.1)
+ ;; `start'-`stop' distances
+ (dx (- (car stop) (car start)))
+ (dy (- (cdr stop) (cdr start)))
+ (length-to-print (magnitude (make-rectangular dx dy))))
+
+ (if (= 0 length-to-print)
+ empty-stencil
+ (let* (
+ ;;;; (1) calculate control-points for the horizontal unit-bow,
+ ;; y-values for 2nd/3rd control-points
+ (outer-control
+ (* 4/3 orientation (/ bow-height length-to-print)))
+ (inner-control
+ (* orientation
+ (- (abs outer-control) (/ thickness length-to-print))))
+ ;; x-values for 2nd/3rd control-points depending on `angularity'
+ (offset-index
+ (- (* 0.6 angularity) 0.8))
+ (left-control
+ (+ 0.1 (* 0.3 angularity)))
+ (right-control
+ (- 1 left-control))
+ ;; defining 2nd and 3rd outer control-points
+ (left-outer-control-point
+ (cons left-control outer-control))
+ (right-outer-control-point
+ (cons right-control outer-control))
+ ;; defining 2nd and 3rd inner control-points
+ (left-inner-control-point
+ (cons left-control inner-control))
+ (right-inner-control-point
+ (cons right-control inner-control))
+ (coord-list
+ (list
+ '(0 . 0)
+ left-outer-control-point
+ right-outer-control-point
+ '(1 . 0)
+ right-inner-control-point
+ left-inner-control-point))
+ ;;;; (2) move control-points to match `start' and `stop'
+ (moved-coord-list
+ (map
+ (lambda (p)
+ (cons
+ (+ (car start) (- (* (car p) dx) (* (cdr p) dy)))
+ (+ (cdr start) (+ (* (car p) dy) (* (cdr p) dx)))))
+ coord-list)))
+
+ ;; final stencil
+ (make-bezier-sandwich-stencil
+ moved-coord-list
+ (min (* 2 thickness) line-width))))))
+
+(define-public (make-tie-stencil start stop thickness orientation)
+ (let* (;; For usage in text we choose a little less `height-limit'
+ ;; than the default for `Tie'
+ (height-limit 0.7)
+ (ratio 0.33)
+ ;; taken from bezier-bow.cc
+ (F0_1
+ (lambda (x) (* (/ 2 PI) (atan (* PI x 0.5)))))
+ (slur-height
+ (lambda (w h_inf r_0) (F0_1 (* (/ (* w r_0) h_inf) h_inf))))
+ (width (abs (- (car start) (car stop))))
+ (angularity 0.5)
+ (height (slur-height width height-limit ratio)))
+ (make-bow-stencil start stop thickness angularity height orientation)))
(define-public (stack-stencils axis dir padding stils)
"Stack stencils @var{stils} in direction @var{axis}, @var{dir}, using
(cons inner-control-x upper-control-y))
(lower-inner-control-point
(cons inner-control-x lower-control-y)))
-
- (make-bezier-sandwich-stencil
- (list
- ;; Step 4: curve through inner control points
- ;; to lower end point.
- upper-inner-control-point
- lower-inner-control-point
- lower-end-point
- ;; Step 3: move to upper end point.
- upper-end-point
- ;; Step 2: curve through outer control points
- ;; to upper end point.
- lower-outer-control-point
- upper-outer-control-point
- upper-end-point
- ;; Step 1: move to lower end point.
- lower-end-point)
- (min (* 2 half-thickness) line-width)
- (interval-widen x-extent (/ line-width 2))
- (interval-widen y-extent (/ line-width 2)))))
+ (ly:make-stencil
+ (ly:stencil-expr
+ (make-bezier-sandwich-stencil
+ (list
+ ;; Step 1: move to lower end point.
+ lower-end-point
+ ;; Step 2: curve through outer control points
+ ;; to upper end point.
+ lower-outer-control-point
+ upper-outer-control-point
+ upper-end-point
+ ;; Step 3: curve through inner control points
+ ;; to lower end point.
+ upper-inner-control-point
+ lower-inner-control-point)
+ (min (* 2 half-thickness) line-width)))
+ (interval-widen x-extent (/ line-width 2))
+ (interval-widen y-extent (/ line-width 2)))))
(define-public (parenthesize-stencil
stencil half-thickness width angularity padding)
(ly:stencil-extent stencil X)
(ly:stencil-extent stencil Y)))
-(define*-public (stencil-whiteout
+(define*-public (stencil-whiteout-outline
stil #:optional (thickness 0.3) (color white)
(angle-increments 16) (radial-increments 1))
"This function works by creating a series of white or @var{color}
stencils radially offset from the original stencil with angles from
0 to 2*pi, at an increment of @code{angle-inc}, and with radii
from @code{radial-inc} to @var{thickness}. @var{thickness} is how big
-the white outline is in staff-spaces. @var{radial-increments} is how
-many copies of the white stencil we make on our way out to thickness.
-@var{angle-increments} is how many copies of the white stencil
-we make between 0 and 2*pi."
+the white outline is, as a multiple of line-thickness.
+@var{radial-increments} is how many copies of the white stencil we make
+on our way out to thickness. @var{angle-increments} is how many copies
+of the white stencil we make between 0 and 2*pi."
(if (or (not (positive? angle-increments))
(not (positive? radial-increments)))
(begin
`(delay-stencil-evaluation ,(delay whiteout-expr)))
stil)))))
-(define*-public (stencil-whiteout-box stencil
+(define*-public (stencil-whiteout-box stil
#:optional (thickness 0) (blot 0) (color white))
- "@var{thickness} is how far in staff-spaces the white outline
-extends past the extents of @var{stencil}."
+ "@var{thickness} is how far, as a multiple of line-thickness,
+the white outline extends past the extents of stencil @var{stil}."
(let*
- ((x-ext (interval-widen (ly:stencil-extent stencil X) thickness))
- (y-ext (interval-widen (ly:stencil-extent stencil Y) thickness)))
+ ((x-ext (interval-widen (ly:stencil-extent stil X) thickness))
+ (y-ext (interval-widen (ly:stencil-extent stil Y) thickness)))
(ly:stencil-add
(stencil-with-color (ly:round-filled-box x-ext y-ext blot) color)
- stencil)))
+ stil)))
+
+(define-public (stencil-whiteout stil style thickness line-thickness)
+ "@var{style} is a symbol that determines the shape of the white
+background. @var{thickness} is how far, as a multiple of
+@var{line-thickness}, the white background extends past the extents
+of stencil @var{stil}. If @var{thickness} has not been specified
+by the user, an appropriate default is chosen based on @var{style}."
+ (let ((thick (* line-thickness
+ (if (number? thickness)
+ thickness
+ (if (eq? style 'outline) 3 0)))))
+ (if (eq? style 'outline)
+ (stencil-whiteout-outline stil thick)
+ (stencil-whiteout-box stil thick))))
(define-public (arrow-stencil-maker start? end?)
"Return a function drawing a line from current point to @code{destination},
(make-simple-markup (simple-format #f "~a: NaN/inf" name))))
(let ((text-stencil (interpret-markup
layout text-props
- (markup #:whiteout-box #:simple name)))
+ (markup #:whiteout #:simple name)))
(dim-stencil (interpret-markup
layout text-props
- (markup #:whiteout-box
+ (markup #:whiteout
#:simple (cond
((interval-empty? extent)
"empty")