1 ;;;; This file is part of LilyPond, the GNU music typesetter.
3 ;;;; Copyright (C) 2003--2015 Han-Wen Nienhuys <hanwen@xs4all.nl>
5 ;;;; LilyPond is free software: you can redistribute it and/or modify
6 ;;;; it under the terms of the GNU General Public License as published by
7 ;;;; the Free Software Foundation, either version 3 of the License, or
8 ;;;; (at your option) any later version.
10 ;;;; LilyPond is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;;;; GNU General Public License for more details.
15 ;;;; You should have received a copy of the GNU General Public License
16 ;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
18 (define (make-bezier-sandwich-stencil coords thick)
21 ,(car (list-ref coords 0))
22 ,(cdr (list-ref coords 0))
24 ,(car (list-ref coords 1))
25 ,(cdr (list-ref coords 1))
26 ,(car (list-ref coords 2))
27 ,(cdr (list-ref coords 2))
28 ,(car (list-ref coords 3))
29 ,(cdr (list-ref coords 3))
31 ,(car (list-ref coords 4))
32 ,(cdr (list-ref coords 4))
33 ,(car (list-ref coords 5))
34 ,(cdr (list-ref coords 5))
35 ,(car (list-ref coords 0))
36 ,(cdr (list-ref coords 0))
43 (define-public (stack-stencils axis dir padding stils)
44 "Stack stencils @var{stils} in direction @var{axis}, @var{dir}, using
48 (ly:stencil-stack front axis dir next padding))
52 (define-public (stack-stencils-padding-list axis dir paddings stils)
53 "Stack stencils @var{stils} in direction @var{axis}, @var{dir}, using
54 a list of @var{paddings}."
58 (lambda (next padding front)
59 (let ((offset (+ (- (interval-end (ly:stencil-extent front axis))
60 (interval-start (ly:stencil-extent next axis)))
64 (ly:stencil-translate-axis next offset axis))))
69 (define-public (centered-stencil stencil)
70 "Center stencil @var{stencil} in both the X and Y directions."
71 (ly:stencil-aligned-to (ly:stencil-aligned-to stencil X CENTER) Y CENTER))
73 (define-public (stack-lines dir padding baseline stils)
74 "Stack vertically with a baseline skip."
76 (lambda (next back) (ly:stencil-stack next Y dir back padding baseline))
80 ;; X-empty stencils may add vertical space. A stencil that is
81 ;; merely Y-empty counts as horizontal spacing. Since we want
82 ;; those to register as lines of their own (is this a good
83 ;; idea?), we make them a separately visible line.
84 (if (and (ly:stencil-empty? s Y)
85 (not (ly:stencil-empty? s X)))
86 (ly:make-stencil (ly:stencil-expr s) (ly:stencil-extent s X) '(0 . 0))
90 (define-public (bracketify-stencil stil axis thick protrusion padding)
91 "Add brackets around @var{stil}, producing a new stencil."
93 (let* ((ext (ly:stencil-extent stil axis))
94 (lb (ly:bracket axis ext thick protrusion))
95 (rb (ly:bracket axis ext thick (- protrusion))))
97 (ly:stencil-combine-at-edge stil (other-axis axis) 1 rb padding))
99 (ly:stencil-combine-at-edge stil (other-axis axis) -1 lb padding))
102 (define (make-parenthesis-stencil
103 y-extent half-thickness width angularity)
104 "Create a parenthesis stencil.
105 @var{y-extent} is the Y extent of the markup inside the parenthesis.
106 @var{half-thickness} is the half thickness of the parenthesis.
107 @var{width} is the width of a parenthesis.
108 The higher the value of number @var{angularity},
109 the more angular the shape of the parenthesis."
110 (let* ((line-width 0.1)
111 ;; Horizontal position of baseline that end points run through.
116 ;; X value farthest from baseline on outside of curve
117 (outer-x (+ base-x width))
118 ;; X extent of bezier sandwich centerline curves
119 (x-extent (ordered-cons base-x outer-x))
120 (bottom-y (interval-start y-extent))
121 (top-y (interval-end y-extent))
123 (lower-end-point (cons base-x bottom-y))
124 (upper-end-point (cons base-x top-y))
126 (outer-control-x (+ base-x (* 4/3 width)))
127 (inner-control-x (+ outer-control-x
130 (- half-thickness))))
132 ;; Vertical distance between a control point
133 ;; and the end point it connects to.
134 (offset-index (- (* 0.6 angularity) 0.8))
135 (lower-control-y (interval-index y-extent offset-index))
136 (upper-control-y (interval-index y-extent (- offset-index)))
138 (lower-outer-control-point
139 (cons outer-control-x lower-control-y))
140 (upper-outer-control-point
141 (cons outer-control-x upper-control-y))
142 (upper-inner-control-point
143 (cons inner-control-x upper-control-y))
144 (lower-inner-control-point
145 (cons inner-control-x lower-control-y)))
148 (make-bezier-sandwich-stencil
150 ;; Step 1: move to lower end point.
152 ;; Step 2: curve through outer control points
153 ;; to upper end point.
154 lower-outer-control-point
155 upper-outer-control-point
157 ;; Step 3: curve through inner control points
158 ;; to lower end point.
159 upper-inner-control-point
160 lower-inner-control-point)
161 (min (* 2 half-thickness) line-width)))
162 (interval-widen x-extent (/ line-width 2))
163 (interval-widen y-extent (/ line-width 2)))))
165 (define-public (parenthesize-stencil
166 stencil half-thickness width angularity padding)
167 "Add parentheses around @var{stencil}, returning a new stencil."
168 (let* ((y-extent (ly:stencil-extent stencil Y))
169 (lp (make-parenthesis-stencil
170 y-extent half-thickness (- width) angularity))
171 (rp (make-parenthesis-stencil
172 y-extent half-thickness width angularity)))
173 (set! stencil (ly:stencil-combine-at-edge stencil X LEFT lp padding))
174 (set! stencil (ly:stencil-combine-at-edge stencil X RIGHT rp padding))
177 (define-public (make-line-stencil width startx starty endx endy)
178 "Make a line stencil of given linewidth and set its extents accordingly."
179 (let ((xext (cons (min startx endx) (max startx endx)))
180 (yext (cons (min starty endy) (max starty endy))))
182 (list 'draw-line width startx starty endx endy)
183 ;; Since the line has rounded edges, we have to / can safely add half the
184 ;; width to all coordinates!
185 (interval-widen xext (/ width 2))
186 (interval-widen yext (/ width 2)))))
188 (define-public (make-transparent-box-stencil xext yext)
189 "Make a transparent box."
191 (list 'transparent-stencil
192 (ly:stencil-expr (make-filled-box-stencil xext yext)))
195 (define-public (make-filled-box-stencil xext yext)
199 (list 'round-filled-box (- (car xext)) (cdr xext)
200 (- (car yext)) (cdr yext) 0.0)
203 (define-public (make-circle-stencil radius thickness fill)
204 "Make a circle of radius @var{radius} and thickness @var{thickness}."
206 ((out-radius (+ radius (/ thickness 2.0))))
209 (list 'circle radius thickness fill)
210 (cons (- out-radius) out-radius)
211 (cons (- out-radius) out-radius))))
213 (define-public (make-oval-stencil x-radius y-radius thickness fill)
214 "Make an oval from two Bezier curves, of x@tie{}radius @var{x-radius},
215 y@tie{}radius @code{y-radius}, and thickness @var{thickness} with fill
216 defined by @code{fill}."
218 ((x-out-radius (+ x-radius (/ thickness 2.0)))
219 (y-out-radius (+ y-radius (/ thickness 2.0)))
224 (commands `(,(list 'moveto x-max 0)
225 ,(list 'curveto x-max y-max x-min y-max x-min 0)
226 ,(list 'curveto x-min y-min x-max y-min x-max 0)
228 (command-list (fold-right append '() commands)))
230 `(path ,thickness `(,@',command-list) 'round 'round ,fill)
231 (cons (- x-out-radius) x-out-radius)
232 (cons (- y-out-radius) y-out-radius))))
235 (make-partial-ellipse-stencil
236 x-radius y-radius start-angle end-angle thick connect fill)
237 "Create an elliptical arc
238 @var{x-radius} is the X radius of the arc.
239 @var{y-radius} is the Y radius of the arc.
240 @var{start-angle} is the starting angle of the arc in degrees.
241 @var{end-angle} is the ending angle of the arc in degrees.
242 @var{thick} is the thickness of the line.
243 @var{connect} is a boolean flag indicating if the end should
244 be connected to the start by a line.
245 @var{fill} is a boolean flag indicating if the shape should be filled."
246 (define (make-radius-list x-radius y-radius)
247 "Makes a list of angle/radius pairs at intervals of PI/2 for
248 the partial ellipse until 7*PI/2. For example, in pseudo-code:
249 > (make-radius-list 2 3)\
250 \n((0.0 . 2) (PI/2 . 3) (PI . -2) (3*PI/2 . -3)\
251 \n(2*PI . 2) (5*PI/2 . 3) (3*PI . -2) (7*PI/2 . -3))
255 (map (lambda (quadrant)
256 (cons (+ adder (car quadrant))
258 `((0.0 . (,x-radius . 0.0))
259 (,PI-OVER-TWO . (0.0 . ,y-radius))
260 (,PI . (,(- x-radius) . 0.0))
261 (,THREE-PI-OVER-TWO . (0.0 . ,(- y-radius))))))
265 (insert-in-ordered-list ordering-function value inlist cutl? cutr?)
266 "Insert @var{value} in ordered list @var{inlist}. If @var{cutl?}, we
267 cut away any parts of @var{inlist} before @var{value}. @var{cutr?} works
268 the same way but for the right side. For example:
269 > (insert-in-ordered-list < 4 '(1 2 3 6 7) #f #f)
271 > (insert-in-ordered-list < 4 '(1 2 3 6 7) #t #f)
273 > (insert-in-ordered-list < 4 '(1 2 3 6 7) #f #t)
277 (helper ordering-function value left-list right-list cutl? cutr?)
278 (if (null? right-list)
280 (if cutl? '() left-list)
282 (if cutr? '() right-list))
283 (if (ordering-function value (car right-list))
285 (if cutl? '() left-list)
287 (if cutr? '() right-list))
291 (append left-list (list (car right-list)))
295 (helper ordering-function value '() inlist cutl? cutr?))
297 (define (ordering-function-1 a b) (car< a b))
299 (define (ordering-function-2 a b) (car<= a b))
301 (define (min-max-crawler min-max side l)
302 "Apply function @var{side} to each member of list and
303 then reduce using @var{min-max}:
304 > (min-max-crawler min car '((0 . 3) (-1 . 4) (1 . 2)))
306 > (min-max-crawler min cdr '((0 . 3) (-1 . 4) (1 . 2)))
310 (if (eq? min-max min) 100000 -100000)
314 (;; the outside limit of the x-radius
315 (x-out-radius (+ x-radius (/ thick 2.0)))
316 ;; the outside limit of the y-radius
317 (y-out-radius (+ y-radius (/ thick 2.0)))
318 ;; end angle to radians
319 (new-end-angle (angle-0-2pi (degrees->radians end-angle)))
320 ;; length of the radius at the end angle
321 (end-radius (ellipse-radius x-out-radius y-out-radius new-end-angle))
322 ;; start angle to radians
323 (new-start-angle (angle-0-2pi (degrees->radians start-angle)))
324 ;; length of the radius at the start angle
325 (start-radius (ellipse-radius x-out-radius y-out-radius new-start-angle))
326 ;; points that the arc passes through at 90 degree intervals
327 (radius-list (make-radius-list x-out-radius y-out-radius))
328 ;; rectangular coordinates of arc endpoint
329 (rectangular-end-radius (polar->rectangular end-radius end-angle))
330 ;; rectangular coordinates of arc begin point
331 (rectangular-start-radius (polar->rectangular start-radius start-angle))
332 ;; we want the end angle to always be bigger than the start angle
333 ;; so we redefine it here just in case it is less
335 (if (<= new-end-angle new-start-angle)
336 (+ TWO-PI new-end-angle)
338 ;; all the points that may be extrema of the arc
339 ;; this is the 90 degree points plus the beginning and end points
340 ;; we use this to calculate extents
342 (insert-in-ordered-list
344 (cons new-end-angle rectangular-end-radius)
345 (insert-in-ordered-list
347 (cons new-start-angle rectangular-start-radius)
363 ;; we know the extrema points by crawling through the
364 ;; list of possible extrema and finding the min and max
366 (cons (min-max-crawler min cadr possible-extrema)
367 (min-max-crawler max cadr possible-extrema))
368 (cons (min-max-crawler min cddr possible-extrema)
369 (min-max-crawler max cddr possible-extrema)))))
371 (define (line-part-min-max x1 x2)
372 (list (min x1 x2) (max x1 x2)))
374 (define (bezier-part-min-max x1 x2 x3 x4)
375 ((lambda (x) (list (reduce min 10000 x) (reduce max -10000 x)))
378 (+ (* x1 (expt (- 1 x) 3))
379 (+ (* 3 (* x2 (* (expt (- 1 x) 2) x)))
380 (+ (* 3 (* x3 (* (- 1 x) (expt x 2))))
381 (* x4 (expt x 3))))))
382 (if (< (+ (expt x2 2) (+ (expt x3 2) (* x1 x4)))
383 (+ (* x1 x3) (+ (* x2 x4) (* x2 x3))))
386 (lambda (x) (and (>= x 0) (<= x 1)))
391 (exact->inexact (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2))))))
392 ;; Zeros of the bezier curve
393 (/ (+ (- x1 (* 2 x2))
395 (sqrt (- (+ (expt x2 2)
396 (+ (expt x3 2) (* x1 x4)))
398 (+ (* x2 x4) (* x2 x3)))))))
399 (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2))))
400 ;; Apply L'hopital's rule to get the zeros if 0/0
403 (sqrt (- (+ (* x2 x2)
404 (+ (* x3 x3) (* x1 x4)))
406 (+ (* x2 x4) (* x2 x3)))))))))
409 (define (bezier-min-max x1 y1 x2 y2 x3 y3 x4 y4)
411 (apply bezier-part-min-max x))
412 `((,x1 ,x2 ,x3 ,x4) (,y1 ,y2 ,y3 ,y4))))
414 (define (line-min-max x1 y1 x2 y2)
416 (apply line-part-min-max x))
417 `((,x1 ,x2) (,y1 ,y2))))
419 (define (path-min-max origin pointlist)
423 (reduce min +inf.0 (map caar x))
424 (reduce max -inf.0 (map cadar x))
425 (reduce min +inf.0 (map caadr x))
426 (reduce max -inf.0 (map cadadr x))))
429 (apply bezier-min-max x)
430 (apply line-min-max x)))
432 (append (list (cadr (reverse x)) (car (reverse x))) y))
433 (append (list origin)
434 (reverse (cdr (reverse pointlist)))) pointlist))))
436 (define-public (make-path-stencil path thickness x-scale y-scale fill)
437 "Make a stencil based on the path described by the list @var{path},
438 with thickness @var{thickness}, and scaled by @var{x-scale} in the X
439 direction and @var{y-scale} in the Y direction. @var{fill} is a boolean
440 argument that specifies if the path should be filled. Valid path
441 commands are: moveto rmoveto lineto rlineto curveto rcurveto closepath,
442 and their standard SVG single letter equivalents: M m L l C c Z z."
444 (define (convert-path path origin previous-point)
445 "Recursive function to standardize command names and
446 convert any relative path expressions (in @var{path}) to absolute
447 values. Returns a list of lists. @var{origin} is a pair of x and y
448 coordinates for the origin point of the path (used for closepath and
449 reset by moveto commands). @var{previous-point} is a pair of x and y
450 coordinates for the previous point in the path."
453 ((head-raw (car path))
456 ((memq head-raw '(rmoveto M m)) 'moveto)
457 ((memq head-raw '(rlineto L l)) 'lineto)
458 ((memq head-raw '(rcurveto C c)) 'curveto)
459 ((memq head-raw '(Z z)) 'closepath)
462 ((memq head '(lineto moveto)) 2)
463 ((eq? head 'curveto) 6)
465 (coordinates-raw (take rest arity))
466 (is-absolute (if (memq head-raw
467 '(rmoveto m rlineto l rcurveto c)) #f #t))
468 (coordinates (if is-absolute
470 ;; convert relative coordinates to absolute by
471 ;; adding them to previous point values
474 (+ c (car previous-point))
475 (+ c (cdr previous-point))))
478 (new-point (if (eq? head 'closepath)
481 (list-ref coordinates (- arity 2))
482 (list-ref coordinates (- arity 1)))))
483 (new-origin (if (eq? head 'moveto)
486 (cons (cons head coordinates)
487 (convert-path (drop rest arity) new-origin new-point)))
490 (let* ((path-absolute (convert-path path (cons 0 0) (cons 0 0)))
492 (path-scaled (if (and (= 1 x-scale) (= 1 y-scale))
494 (map (lambda (path-unit)
498 ((odd? n) (* c x-scale))
499 (else (* c y-scale))))
501 (iota (length path-unit))))
503 ;; a path must begin with a 'moveto'
504 (path-final (if (eq? 'moveto (car (car path-scaled)))
506 (append (list (list 'moveto 0 0)) path-scaled)))
507 ;; remove all commands in order to calculate bounds
508 (path-headless (map cdr (delete (list 'closepath) path-final)))
509 (bound-list (path-min-max
511 (cdr path-headless))))
514 `(,@',(concatenate path-final))
519 ((if (< x-scale 0) reverse-interval identity)
521 (list-ref bound-list 0)
522 (list-ref bound-list 1)))
523 `(,(/ thickness -2) . ,(/ thickness 2)))
525 ((if (< y-scale 0) reverse-interval identity)
527 (list-ref bound-list 2)
528 (list-ref bound-list 3)))
529 `(,(/ thickness -2) . ,(/ thickness 2))))))
531 (define-public (make-connected-path-stencil pointlist thickness
532 x-scale y-scale connect fill)
533 "Make a connected path described by the list @var{pointlist}, beginning
534 at point '(0 . 0), with thickness @var{thickness}, and scaled by
535 @var{x-scale} in the X direction and @var{y-scale} in the Y direction.
536 @var{connect} and @var{fill} are boolean arguments that specify if the
537 path should be connected or filled, respectively."
541 (map (lambda (path-unit)
542 (case (length path-unit)
543 ((2) (append (list 'lineto) path-unit))
544 ((6) (append (list 'curveto) path-unit))))
546 ;; if this path is connected, add closepath to the end
547 (if connect (list '(closepath)) '())))
548 thickness x-scale y-scale fill))
550 (define-public (make-ellipse-stencil x-radius y-radius thickness fill)
551 "Make an ellipse of x@tie{}radius @var{x-radius}, y@tie{}radius
552 @code{y-radius}, and thickness @var{thickness} with fill defined by
555 ((x-out-radius (+ x-radius (/ thickness 2.0)))
556 (y-out-radius (+ y-radius (/ thickness 2.0))) )
559 (list 'ellipse x-radius y-radius thickness fill)
560 (cons (- x-out-radius) x-out-radius)
561 (cons (- y-out-radius) y-out-radius))))
563 (define-public (box-grob-stencil grob)
564 "Make a box of exactly the extents of the grob. The box precisely
565 encloses the contents."
566 (let* ((xext (ly:grob-extent grob grob 0))
567 (yext (ly:grob-extent grob grob 1))
571 (make-filled-box-stencil xext (cons (- (car yext) thick) (car yext)))
572 (make-filled-box-stencil xext (cons (cdr yext) (+ (cdr yext) thick)))
573 (make-filled-box-stencil (cons (cdr xext) (+ (cdr xext) thick)) yext)
574 (make-filled-box-stencil (cons (- (car xext) thick) (car xext)) yext))))
576 ;; TODO merge this and prev function.
577 (define-public (box-stencil stencil thickness padding)
578 "Add a box around @var{stencil}, producing a new stencil."
579 (let* ((x-ext (interval-widen (ly:stencil-extent stencil 0) padding))
580 (y-ext (interval-widen (ly:stencil-extent stencil 1) padding))
581 (y-rule (make-filled-box-stencil (cons 0 thickness) y-ext))
582 (x-rule (make-filled-box-stencil
583 (interval-widen x-ext thickness) (cons 0 thickness))))
584 (set! stencil (ly:stencil-combine-at-edge stencil X 1 y-rule padding))
585 (set! stencil (ly:stencil-combine-at-edge stencil X -1 y-rule padding))
586 (set! stencil (ly:stencil-combine-at-edge stencil Y 1 x-rule 0.0))
587 (set! stencil (ly:stencil-combine-at-edge stencil Y -1 x-rule 0.0))
590 (define-public (circle-stencil stencil thickness padding)
591 "Add a circle around @var{stencil}, producing a new stencil."
592 (let* ((x-ext (ly:stencil-extent stencil X))
593 (y-ext (ly:stencil-extent stencil Y))
594 (diameter (max (interval-length x-ext)
595 (interval-length y-ext)))
596 (radius (+ (/ diameter 2) padding thickness))
597 (circle (make-circle-stencil radius thickness #f)))
601 (ly:stencil-translate circle
603 (interval-center x-ext)
604 (interval-center y-ext))))))
606 (define-public (oval-stencil stencil thickness x-padding y-padding)
607 "Add an oval around @code{stencil}, padded by the padding pair,
608 producing a new stencil."
609 (let* ((x-ext (ly:stencil-extent stencil X))
610 (y-ext (ly:stencil-extent stencil Y))
611 (x-length (+ (interval-length x-ext) x-padding thickness))
612 (y-length (+ (interval-length y-ext) y-padding thickness))
613 (x-radius (* 0.707 x-length) )
614 (y-radius (* 0.707 y-length) )
615 (oval (make-oval-stencil x-radius y-radius thickness #f)))
619 (ly:stencil-translate oval
621 (interval-center x-ext)
622 (interval-center y-ext))))))
624 (define-public (ellipse-stencil stencil thickness x-padding y-padding)
625 "Add an ellipse around @var{stencil}, padded by the padding pair,
626 producing a new stencil."
627 (let* ((x-ext (ly:stencil-extent stencil X))
628 (y-ext (ly:stencil-extent stencil Y))
629 (x-length (+ (interval-length x-ext) x-padding thickness))
630 (y-length (+ (interval-length y-ext) y-padding thickness))
631 ;; (aspect-ratio (/ x-length y-length))
632 (x-radius (* 0.707 x-length) )
633 (y-radius (* 0.707 y-length) )
634 ;; (diameter (max (- (cdr x-ext) (car x-ext))
635 ;; (- (cdr y-ext) (car y-ext))))
636 ;; radius (+ (/ diameter 2) padding thickness))
637 (ellipse (make-ellipse-stencil x-radius y-radius thickness #f)))
641 (ly:stencil-translate ellipse
643 (interval-center x-ext)
644 (interval-center y-ext))))))
646 (define-public (rounded-box-stencil stencil thickness padding blot)
647 "Add a rounded box around @var{stencil}, producing a new stencil."
649 (let* ((xext (interval-widen (ly:stencil-extent stencil 0) padding))
650 (yext (interval-widen (ly:stencil-extent stencil 1) padding))
651 (min-ext (min (-(cdr xext) (car xext)) (-(cdr yext) (car yext))))
652 (ideal-blot (min blot (/ min-ext 2)))
653 (ideal-thickness (min thickness (/ min-ext 2)))
654 (outer (ly:round-filled-box
655 (interval-widen xext ideal-thickness)
656 (interval-widen yext ideal-thickness)
658 (inner (ly:make-stencil (list 'color (x11-color 'white)
659 (ly:stencil-expr (ly:round-filled-box
660 xext yext (- ideal-blot ideal-thickness)))))))
661 (set! stencil (ly:stencil-add outer inner))
664 (define-public (flip-stencil axis stil)
665 "Flip stencil @var{stil} in the direction of @var{axis}.
666 Value @code{X} (or @code{0}) for @var{axis} flips it horizontally.
667 Value @code{Y} (or @code{1}) flips it vertically. @var{stil} is
668 flipped in place; its position, the coordinates of its bounding
669 box, remains the same."
671 ;; scale stencil using -1 to flip it and
672 ;; then restore it to its original position
673 (xy (if (= axis X) '(-1 . 1) '(1 . -1)))
674 (flipped-stil (ly:stencil-scale stil (car xy) (cdr xy)))
675 (flipped-ext (ly:stencil-extent flipped-stil axis))
676 (original-ext (ly:stencil-extent stil axis))
677 (offset (- (car original-ext) (car flipped-ext)))
678 (replaced-stil (ly:stencil-translate-axis flipped-stil offset axis)))
681 (define-public (stencil-with-color stencil color)
683 (list 'color color (ly:stencil-expr stencil))
684 (ly:stencil-extent stencil X)
685 (ly:stencil-extent stencil Y)))
687 (define*-public (stencil-whiteout-outline
688 stil #:optional (thickness 0.3) (color white)
689 (angle-increments 16) (radial-increments 1))
690 "This function works by creating a series of white or @var{color}
691 stencils radially offset from the original stencil with angles from
692 0 to 2*pi, at an increment of @code{angle-inc}, and with radii
693 from @code{radial-inc} to @var{thickness}. @var{thickness} is how big
694 the white outline is, as a multiple of line-thickness.
695 @var{radial-increments} is how many copies of the white stencil we make
696 on our way out to thickness. @var{angle-increments} is how many copies
697 of the white stencil we make between 0 and 2*pi."
698 (if (or (not (positive? angle-increments))
699 (not (positive? radial-increments)))
701 (ly:warning "Both angle-increments and radial-increments must be positive numbers.")
703 (let* ((2pi 6.283185307)
704 (angle-inc (/ 2pi angle-increments))
705 (radial-inc (/ thickness radial-increments)))
707 (define (circle-plot ang dec radius original-stil new-stil)
708 ;; ang (angle) and dec (decrement) are in radians, not degrees
711 (circle-plot (- ang dec) dec radius original-stil
714 (ly:stencil-translate original-stil
717 (* radius (sin ang))))))))
719 (define (radial-plot radius original-stil new-stil)
722 (ly:stencil-add new-stil
724 (- radius radial-inc)
726 (circle-plot 2pi angle-inc
727 radius original-stil empty-stencil)))))
732 (radial-plot thickness stil empty-stencil)
736 `(delay-stencil-evaluation ,(delay whiteout-expr)))
739 (define*-public (stencil-whiteout-box stil
740 #:optional (thickness 0) (blot 0) (color white))
741 "@var{thickness} is how far, as a multiple of line-thickness,
742 the white outline extends past the extents of stencil @var{stil}."
744 ((x-ext (interval-widen (ly:stencil-extent stil X) thickness))
745 (y-ext (interval-widen (ly:stencil-extent stil Y) thickness)))
748 (stencil-with-color (ly:round-filled-box x-ext y-ext blot) color)
751 (define-public (stencil-whiteout stil style thickness line-thickness)
752 "@var{style} is a symbol that determines the shape of the white
753 background. @var{thickness} is how far, as a multiple of
754 @var{line-thickness}, the white background extends past the extents
755 of stencil @var{stil}. If @var{thickness} has not been specified
756 by the user, an appropriate default is chosen based on @var{style}."
757 (let ((thick (* line-thickness
758 (if (number? thickness)
760 (if (eq? style 'outline) 3 0)))))
761 (if (eq? style 'outline)
762 (stencil-whiteout-outline stil thick)
763 (stencil-whiteout-box stil thick))))
765 (define-public (arrow-stencil-maker start? end?)
766 "Return a function drawing a line from current point to @code{destination},
767 with optional arrows of @code{max-size} on start and end controlled by
768 @var{start?} and @var{end?}."
769 (lambda (destination max-size)
773 (distance (sqrt (+ (* (car destination) (car destination))
774 (* (cdr destination) (cdr destination)))))
775 (size (min max-size (/ distance 3)))
776 (rotate (lambda (z ang)
777 (* (make-polar 1 ang)
779 (complex-to-offset (lambda (z)
780 (list (real-part z) (imag-part z))))
782 (z-dest (+ (* e_x (car destination)) (* e_y (cdr destination))))
783 (e_z (/ z-dest (magnitude z-dest)))
784 (triangle-points (list
788 (p1s (map (lambda (z)
789 (+ z-dest (rotate z (angle z-dest))))
791 (p2s (map (lambda (z)
792 (rotate z (angle (- z-dest))))
797 `(polygon (quote ,(append-map complex-to-offset p1s))
802 `(polygon (quote ,(append-map complex-to-offset p2s))
805 (thickness (min (/ distance 12) 0.1))
806 (shorten-line (min (/ distance 3) 0.5))
807 (start (complex-to-offset (/ (* e_z shorten-line) 2)))
808 (end (complex-to-offset (- z-dest (/ (* e_z shorten-line) 2))))
810 (line (ly:make-stencil
811 `(draw-line ,thickness
812 ,(car start) ,(cadr start)
813 ,(car end) ,(cadr end)
815 (cons (min 0 (car destination))
816 (min 0 (cdr destination)))
817 (cons (max 0 (car destination))
818 (max 0 (cdr destination)))))
822 (if start? arrow-2 empty-stencil)
823 (if end? arrow-1 empty-stencil)
828 (define-public dimension-arrows (arrow-stencil-maker #t #t))
830 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
833 ;; annotations are arrows indicating the numerical value of
835 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
837 (define*-public (annotate-y-interval layout name extent is-length
838 #:key (color darkblue))
839 (let ((text-props (cons '((font-size . -3)
840 (font-family . typewriter))
841 (layout-extract-page-properties layout)))
843 (define (center-stencil-on-extent stil)
844 (ly:stencil-translate (ly:stencil-aligned-to stil Y CENTER)
845 (cons 0 (interval-center extent))))
846 ;; do something sensible for 0,0 intervals.
847 (set! extent (interval-widen extent 0.001))
848 (if (not (interval-sane? extent))
849 (set! annotation (interpret-markup
851 (make-simple-markup (simple-format #f "~a: NaN/inf" name))))
852 (let ((text-stencil (interpret-markup
854 (markup #:whiteout #:simple name)))
855 (dim-stencil (interpret-markup
859 ((interval-empty? extent)
862 (ly:format "~$" (interval-length extent)))
865 (car extent) (cdr extent)))))))
866 (arrows (ly:stencil-translate-axis
867 (dimension-arrows (cons 0 (interval-length extent)) 1.0)
868 (interval-start extent) Y)))
870 (center-stencil-on-extent text-stencil))
872 (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5))
874 (ly:stencil-combine-at-edge annotation X LEFT
875 (center-stencil-on-extent dim-stencil)
878 (stencil-with-color annotation color))))
882 ;; TODO: figure out how to annotate padding nicely
883 ;; TODO: emphasize either padding or min-dist depending on which constraint was active
884 (define*-public (annotate-spacing-spec layout name spacing-spec
885 start-Y-offset next-staff-Y
886 #:key (base-color blue))
887 (let* ((get-spacing-var (lambda (sym) (assoc-get sym spacing-spec 0.0)))
888 (space (get-spacing-var 'basic-distance))
889 (padding (get-spacing-var 'padding))
890 (min-dist (get-spacing-var 'minimum-distance))
891 (contrast-color (append (cdr base-color) (list (car base-color))))
892 (min-dist-blocks (<= (- start-Y-offset min-dist) next-staff-Y))
893 (min-dist-color (if min-dist-blocks contrast-color base-color))
894 (name-string (if (string-null? name)
896 (simple-format #f " (~a)" name)))
898 (annotate-y-interval layout
899 (simple-format #f "basic-dist~a" name-string)
900 (cons (- start-Y-offset space) start-Y-offset)
902 #:color (map (lambda (x) (* x 0.25)) base-color)))
904 (annotate-y-interval layout
905 (simple-format #f "min-dist~a" name-string)
906 (cons (- start-Y-offset min-dist) start-Y-offset)
908 #:color min-dist-color))
910 (annotate-y-interval layout
911 (simple-format #f "extra dist~a" name-string)
912 (cons next-staff-Y (- start-Y-offset min-dist))
914 #:color (map (lambda (x) (* x 0.5)) min-dist-color))))
916 (stack-stencils X RIGHT 0.0
921 (ly:stencil-add min-annotation extra-annotation))))))
923 (define-public (eps-file->stencil axis size file-name)
925 ((contents (ly:gulp-file file-name))
926 (bbox (get-postscript-bbox (car (string-split contents #\nul))))
927 (bbox-size (if (= axis X)
928 (- (list-ref bbox 2) (list-ref bbox 0))
929 (- (list-ref bbox 3) (list-ref bbox 1))
931 (factor (if (< 0 bbox-size)
932 (exact->inexact (/ size bbox-size))
935 (map (lambda (x) (* factor x)) bbox))
936 ;; We need to shift the whole eps to (0,0), otherwise it will appear
937 ;; displaced in lilypond (displacement will depend on the scaling!)
938 (translate-string (ly:format "~a ~a translate" (- (list-ref bbox 0)) (- (list-ref bbox 1))))
939 (clip-rect-string (ly:format
940 "~a ~a ~a ~a rectclip"
943 (- (list-ref bbox 2) (list-ref bbox 0))
944 (- (list-ref bbox 3) (list-ref bbox 1)))))
955 currentpoint translate
961 " factor translate-string clip-rect-string
970 ;; Stencil starts at (0,0), since we have shifted the eps, and its
971 ;; size is exactly the size of the scaled bounding box
972 (cons 0 (- (list-ref scaled-bbox 2) (list-ref scaled-bbox 0)))
973 (cons 0 (- (list-ref scaled-bbox 3) (list-ref scaled-bbox 1))))
975 (ly:make-stencil "" '(0 . 0) '(0 . 0)))
978 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
979 ;; output signatures.
981 (define-public (write-system-signatures basename paper-systems count)
982 (if (pair? paper-systems)
985 ((outname (simple-format #f "~a-~a.signature" basename count)) )
987 (ly:message "Writing ~a" outname)
988 (write-system-signature outname (car paper-systems))
989 (write-system-signatures basename (cdr paper-systems) (1+ count))))))
991 (use-modules (scm paper-system))
992 (define-public (write-system-signature filename paper-system)
994 (and (number? x) (inexact? x)))
997 (paper-system-system-grob paper-system))
999 (define output (open-output-file filename))
1001 ;; todo: optionally use a command line flag? Or just junk this?
1002 (define compare-expressions #f)
1003 (define (strip-floats expr)
1004 "Replace floats by #f"
1007 ((ly:font-metric? expr) (ly:font-name expr))
1008 ((pair? expr) (cons (strip-floats (car expr))
1009 (strip-floats (cdr expr))))
1012 (define (fold-false-pairs expr)
1013 "Try to remove lists of #f as much as possible."
1017 (rest (fold-false-pairs (cdr expr))))
1020 (cons (fold-false-pairs first) rest)
1024 (define (raw-string expr)
1025 "escape quotes and slashes for python consumption"
1026 (regexp-substitute/global #f "[@\n]" (simple-format #f "~a" expr) 'pre " " 'post))
1028 (define (raw-pair expr)
1029 (simple-format #f "~a ~a"
1030 (car expr) (cdr expr)))
1032 (define (found-grob expr)
1037 (cause (event-cause grob))
1038 (input (if (ly:stream-event? cause) (ly:event-property cause 'origin) #f))
1039 (location (if (ly:input-location? input) (ly:input-file-line-char-column input) '()))
1041 ;; todo: use stencil extent if available.
1042 (x-ext (ly:grob-extent grob system-grob X))
1043 (y-ext (ly:grob-extent grob system-grob Y))
1044 (expression-skeleton
1045 (if compare-expressions
1046 (interpret-for-signature
1048 (set! collected (cons e collected)))
1052 (simple-format output
1054 (cdr (assq 'name (ly:grob-property grob 'meta) ))
1055 (raw-string location)
1056 (raw-pair (if (interval-empty? x-ext) '(1 . -1) x-ext))
1057 (raw-pair (if (interval-empty? y-ext) '(1 . -1) y-ext))
1058 (raw-string collected))
1061 (define (interpret-for-signature escape collect expr)
1062 (define (interpret expr)
1064 ((head (if (pair? expr)
1069 ((eq? head 'grob-cause) (escape (cdr expr)))
1070 ((eq? head 'color) (interpret (caddr expr)))
1071 ((eq? head 'rotate-stencil) (interpret (caddr expr)))
1072 ((eq? head 'translate-stencil) (interpret (caddr expr)))
1073 ((eq? head 'combine-stencil)
1074 (for-each (lambda (e) (interpret e)) (cdr expr)))
1076 (collect (fold-false-pairs (strip-floats expr))))
1082 (if (ly:grob? system-grob)
1084 (display (simple-format #f "# Output signature\n# Generated by LilyPond ~a\n" (lilypond-version))
1086 (interpret-for-signature found-grob (lambda (x) #f)
1088 (paper-system-stencil paper-system)))))
1090 ;; should be superfluous, but leaking "too many open files"?
1091 (close-port output))