+ "Make a circle of radius @var{radius} and thickness @var{thickness}."
+ (let*
+ ((out-radius (+ radius (/ thickness 2.0))))
+
+ (ly:make-stencil
+ (list 'circle radius thickness fill)
+ (cons (- out-radius) out-radius)
+ (cons (- out-radius) out-radius))))
+
+(define-public (make-oval-stencil x-radius y-radius thickness fill)
+ "Make an oval from two Bezier curves, of x@tie{}radius @var{x-radius},
+y@tie{}radius @code{y-radius}, and thickness @var{thickness} with fill
+defined by @code{fill}."
+ (let*
+ ((x-out-radius (+ x-radius (/ thickness 2.0)))
+ (y-out-radius (+ y-radius (/ thickness 2.0)))
+ (x-max x-radius)
+ (x-min (- x-radius))
+ (y-max y-radius)
+ (y-min (- y-radius))
+ (commands `(,(list 'moveto x-max 0)
+ ,(list 'curveto x-max y-max x-min y-max x-min 0)
+ ,(list 'curveto x-min y-min x-max y-min x-max 0)
+ ,(list 'closepath)))
+ (command-list (fold-right append '() commands)))
+ (ly:make-stencil
+ `(path ,thickness `(,@',command-list) 'round 'round ,fill)
+ (cons (- x-out-radius) x-out-radius)
+ (cons (- y-out-radius) y-out-radius))))
+
+(define-public
+ (make-partial-ellipse-stencil
+ x-radius y-radius start-angle end-angle thick connect fill)
+ "Create an elliptical arc
+@var{x-radius} is the X radius of the arc.
+@var{y-radius} is the Y radius of the arc.
+@var{start-angle} is the starting angle of the arc in degrees.
+@var{end-angle} is the ending angle of the arc in degrees.
+@var{thick} is the thickness of the line.
+@var{connect} is a boolean flag indicating if the end should
+be connected to the start by a line.
+@var{fill} is a boolean flag indicating if the shape should be filled."
+ (define (make-radius-list x-radius y-radius)
+ "Makes a list of angle/radius pairs at intervals of PI/2 for
+the partial ellipse until 7*PI/2. For example, in pseudo-code:
+> (make-radius-list 2 3)\
+\n((0.0 . 2) (PI/2 . 3) (PI . -2) (3*PI/2 . -3)\
+\n(2*PI . 2) (5*PI/2 . 3) (3*PI . -2) (7*PI/2 . -3))
+"
+ (append-map
+ (lambda (adder)
+ (map (lambda (quadrant)
+ (cons (+ adder (car quadrant))
+ (cdr quadrant)))
+ `((0.0 . (,x-radius . 0.0))
+ (,PI-OVER-TWO . (0.0 . ,y-radius))
+ (,PI . (,(- x-radius) . 0.0))
+ (,THREE-PI-OVER-TWO . (0.0 . ,(- y-radius))))))
+ `(0.0 ,TWO-PI)))
+
+ (define
+ (insert-in-ordered-list ordering-function value inlist cutl? cutr?)
+ "Insert @var{value} in ordered list @var{inlist}. If @var{cutl?}, we
+cut away any parts of @var{inlist} before @var{value}. @var{cutr?} works
+the same way but for the right side. For example:
+> (insert-in-ordered-list < 4 '(1 2 3 6 7) #f #f)
+'(1 2 3 4 6 7)
+> (insert-in-ordered-list < 4 '(1 2 3 6 7) #t #f)
+'(4 6 7)
+> (insert-in-ordered-list < 4 '(1 2 3 6 7) #f #t)
+'(1 2 3 4)
+"
+ (define
+ (helper ordering-function value left-list right-list cutl? cutr?)
+ (if (null? right-list)
+ (append
+ (if cutl? '() left-list)
+ (list value)
+ (if cutr? '() right-list))
+ (if (ordering-function value (car right-list))
+ (append
+ (if cutl? '() left-list)
+ (list value)
+ (if cutr? '() right-list))
+ (helper
+ ordering-function
+ value
+ (append left-list (list (car right-list)))
+ (cdr right-list)
+ cutl?
+ cutr?))))
+ (helper ordering-function value '() inlist cutl? cutr?))
+
+ (define (ordering-function-1 a b) (car< a b))
+
+ (define (ordering-function-2 a b) (car<= a b))
+
+ (define (min-max-crawler min-max side l)
+ "Apply function @var{side} to each member of list and
+then reduce using @var{min-max}:
+> (min-max-crawler min car '((0 . 3) (-1 . 4) (1 . 2)))
+-1
+> (min-max-crawler min cdr '((0 . 3) (-1 . 4) (1 . 2)))
+2
+"
+ (reduce min-max
+ (if (eq? min-max min) 100000 -100000)
+ (map side l)))
+
+ (let*
+ (;; the outside limit of the x-radius
+ (x-out-radius (+ x-radius (/ thick 2.0)))
+ ;; the outside limit of the y-radius
+ (y-out-radius (+ y-radius (/ thick 2.0)))
+ ;; end angle to radians
+ (new-end-angle (angle-0-2pi (degrees->radians end-angle)))
+ ;; length of the radius at the end angle
+ (end-radius (ellipse-radius x-out-radius y-out-radius new-end-angle))
+ ;; start angle to radians
+ (new-start-angle (angle-0-2pi (degrees->radians start-angle)))
+ ;; length of the radius at the start angle
+ (start-radius (ellipse-radius x-out-radius y-out-radius new-start-angle))
+ ;; points that the arc passes through at 90 degree intervals
+ (radius-list (make-radius-list x-out-radius y-out-radius))
+ ;; rectangular coordinates of arc endpoint
+ (rectangular-end-radius (polar->rectangular end-radius end-angle))
+ ;; rectangular coordinates of arc begin point
+ (rectangular-start-radius (polar->rectangular start-radius start-angle))
+ ;; we want the end angle to always be bigger than the start angle
+ ;; so we redefine it here just in case it is less
+ (new-end-angle
+ (if (<= new-end-angle new-start-angle)
+ (+ TWO-PI new-end-angle)
+ new-end-angle))
+ ;; all the points that may be extrema of the arc
+ ;; this is the 90 degree points plus the beginning and end points
+ ;; we use this to calculate extents
+ (possible-extrema
+ (insert-in-ordered-list
+ ordering-function-2
+ (cons new-end-angle rectangular-end-radius)
+ (insert-in-ordered-list
+ ordering-function-1
+ (cons new-start-angle rectangular-start-radius)
+ radius-list
+ #t
+ #f)
+ #f
+ #t)))
+ (ly:make-stencil
+ (list
+ 'partial-ellipse
+ x-radius
+ y-radius
+ start-angle
+ end-angle
+ thick
+ connect
+ fill)
+ ;; we know the extrema points by crawling through the
+ ;; list of possible extrema and finding the min and max
+ ;; for x and y
+ (cons (min-max-crawler min cadr possible-extrema)
+ (min-max-crawler max cadr possible-extrema))
+ (cons (min-max-crawler min cddr possible-extrema)
+ (min-max-crawler max cddr possible-extrema)))))
+
+(define (line-part-min-max x1 x2)
+ (list (min x1 x2) (max x1 x2)))
+
+(define (bezier-part-min-max x1 x2 x3 x4)
+ ((lambda (x) (list (reduce min 10000 x) (reduce max -10000 x)))
+ (map
+ (lambda (x)
+ (+ (* x1 (expt (- 1 x) 3))
+ (+ (* 3 (* x2 (* (expt (- 1 x) 2) x)))
+ (+ (* 3 (* x3 (* (- 1 x) (expt x 2))))
+ (* x4 (expt x 3))))))
+ (if (< (+ (expt x2 2) (+ (expt x3 2) (* x1 x4)))
+ (+ (* x1 x3) (+ (* x2 x4) (* x2 x3))))
+ (list 0.0 1.0)
+ (filter
+ (lambda (x) (and (>= x 0) (<= x 1)))
+ (append
+ (list 0.0 1.0)
+ (map (lambda (op)
+ (if (not (eqv? 0.0
+ (exact->inexact (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2))))))
+ ;; Zeros of the bezier curve
+ (/ (+ (- x1 (* 2 x2))
+ (op x3
+ (sqrt (- (+ (expt x2 2)
+ (+ (expt x3 2) (* x1 x4)))
+ (+ (* x1 x3)
+ (+ (* x2 x4) (* x2 x3)))))))
+ (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2))))
+ ;; Apply L'hopital's rule to get the zeros if 0/0
+ (* (op 0 1)
+ (/ (/ (- x4 x3) 2)
+ (sqrt (- (+ (* x2 x2)
+ (+ (* x3 x3) (* x1 x4)))
+ (+ (* x1 x3)
+ (+ (* x2 x4) (* x2 x3)))))))))
+ (list + -))))))))
+
+(define (bezier-min-max x1 y1 x2 y2 x3 y3 x4 y4)
+ (map (lambda (x)
+ (apply bezier-part-min-max x))
+ `((,x1 ,x2 ,x3 ,x4) (,y1 ,y2 ,y3 ,y4))))
+
+(define (line-min-max x1 y1 x2 y2)
+ (map (lambda (x)
+ (apply line-part-min-max x))
+ `((,x1 ,x2) (,y1 ,y2))))
+
+(define (path-min-max origin pointlist)
+
+ ((lambda (x)
+ (list
+ (reduce min +inf.0 (map caar x))
+ (reduce max -inf.0 (map cadar x))
+ (reduce min +inf.0 (map caadr x))
+ (reduce max -inf.0 (map cadadr x))))
+ (map (lambda (x)
+ (if (= (length x) 8)
+ (apply bezier-min-max x)
+ (apply line-min-max x)))
+ (map (lambda (x y)
+ (append (list (cadr (reverse x)) (car (reverse x))) y))
+ (append (list origin)
+ (reverse (cdr (reverse pointlist)))) pointlist))))
+
+(define-public (make-path-stencil path thickness x-scale y-scale fill)
+ "Make a stencil based on the path described by the list @var{path},
+with thickness @var{thickness}, and scaled by @var{x-scale} in the X
+direction and @var{y-scale} in the Y direction. @var{fill} is a boolean
+argument that specifies if the path should be filled. Valid path
+commands are: moveto rmoveto lineto rlineto curveto rcurveto closepath,
+and their standard SVG single letter equivalents: M m L l C c Z z."
+
+ (define (convert-path path origin previous-point)
+ "Recursive function to standardize command names and
+convert any relative path expressions (in @var{path}) to absolute
+values. Returns a list of lists. @var{origin} is a pair of x and y
+coordinates for the origin point of the path (used for closepath and
+reset by moveto commands). @var{previous-point} is a pair of x and y
+coordinates for the previous point in the path."
+ (if (pair? path)
+ (let*
+ ((head-raw (car path))
+ (rest (cdr path))
+ (head (cond
+ ((memq head-raw '(rmoveto M m)) 'moveto)
+ ((memq head-raw '(rlineto L l)) 'lineto)
+ ((memq head-raw '(rcurveto C c)) 'curveto)
+ ((memq head-raw '(Z z)) 'closepath)
+ (else head-raw)))
+ (arity (cond
+ ((memq head '(lineto moveto)) 2)
+ ((eq? head 'curveto) 6)
+ (else 0)))
+ (coordinates-raw (take rest arity))
+ (is-absolute (if (memq head-raw
+ '(rmoveto m rlineto l rcurveto c)) #f #t))
+ (coordinates (if is-absolute
+ coordinates-raw
+ ;; convert relative coordinates to absolute by
+ ;; adding them to previous point values
+ (map (lambda (c n)
+ (if (even? n)
+ (+ c (car previous-point))
+ (+ c (cdr previous-point))))
+ coordinates-raw
+ (iota arity))))
+ (new-point (if (eq? head 'closepath)
+ origin
+ (cons
+ (list-ref coordinates (- arity 2))
+ (list-ref coordinates (- arity 1)))))
+ (new-origin (if (eq? head 'moveto)
+ new-point
+ origin)))
+ (cons (cons head coordinates)
+ (convert-path (drop rest arity) new-origin new-point)))
+ '()))
+
+ (let* ((path-absolute (convert-path path (cons 0 0) (cons 0 0)))
+ ;; scale coordinates
+ (path-scaled (if (and (= 1 x-scale) (= 1 y-scale))
+ path-absolute
+ (map (lambda (path-unit)
+ (map (lambda (c n)
+ (cond
+ ((= 0 n) c)
+ ((odd? n) (* c x-scale))
+ (else (* c y-scale))))
+ path-unit
+ (iota (length path-unit))))
+ path-absolute)))
+ ;; a path must begin with a 'moveto'
+ (path-final (if (eq? 'moveto (car (car path-scaled)))
+ path-scaled
+ (append (list (list 'moveto 0 0)) path-scaled)))
+ ;; remove all commands in order to calculate bounds
+ (path-headless (map cdr (delete (list 'closepath) path-final)))
+ (bound-list (path-min-max
+ (car path-headless)
+ (cdr path-headless))))
+ (ly:make-stencil
+ `(path ,thickness
+ `(,@',(concatenate path-final))
+ 'round
+ 'round
+ ,(if fill #t #f))
+ (coord-translate
+ ((if (< x-scale 0) reverse-interval identity)
+ (cons
+ (list-ref bound-list 0)
+ (list-ref bound-list 1)))
+ `(,(/ thickness -2) . ,(/ thickness 2)))
+ (coord-translate
+ ((if (< y-scale 0) reverse-interval identity)
+ (cons
+ (list-ref bound-list 2)
+ (list-ref bound-list 3)))
+ `(,(/ thickness -2) . ,(/ thickness 2))))))
+
+(define-public (make-connected-path-stencil pointlist thickness
+ x-scale y-scale connect fill)
+ "Make a connected path described by the list @var{pointlist}, beginning
+at point '(0 . 0), with thickness @var{thickness}, and scaled by
+@var{x-scale} in the X direction and @var{y-scale} in the Y direction.
+@var{connect} and @var{fill} are boolean arguments that specify if the
+path should be connected or filled, respectively."
+ (make-path-stencil
+ (concatenate
+ (append
+ (map (lambda (path-unit)
+ (case (length path-unit)
+ ((2) (append (list 'lineto) path-unit))
+ ((6) (append (list 'curveto) path-unit))))
+ pointlist)
+ ;; if this path is connected, add closepath to the end
+ (if connect (list '(closepath)) '())))
+ thickness x-scale y-scale fill))
+
+(define-public (make-ellipse-stencil x-radius y-radius thickness fill)
+ "Make an ellipse of x@tie{}radius @var{x-radius}, y@tie{}radius
+@code{y-radius}, and thickness @var{thickness} with fill defined by
+@code{fill}."
+ (let*
+ ((x-out-radius (+ x-radius (/ thickness 2.0)))
+ (y-out-radius (+ y-radius (/ thickness 2.0))) )
+
+ (ly:make-stencil
+ (list 'ellipse x-radius y-radius thickness fill)
+ (cons (- x-out-radius) x-out-radius)
+ (cons (- y-out-radius) y-out-radius))))