]> git.donarmstrong.com Git - lilypond.git/blob - scm/stencil.scm
f994b10c5c1bbe78e205f35bd52e1d7c2cda7e18
[lilypond.git] / scm / stencil.scm
1 ;;;; This file is part of LilyPond, the GNU music typesetter.
2 ;;;;
3 ;;;; Copyright (C) 2003--2014 Han-Wen Nienhuys <hanwen@xs4all.nl>
4 ;;;;
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.
9 ;;;;
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.
14 ;;;;
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/>.
17
18 (define (make-bezier-sandwich-stencil coords thick xext yext)
19   (let* ((command-list `(moveto
20                          ,(car (list-ref coords 3))
21                          ,(cdr (list-ref coords 3))
22                          curveto
23                          ,(car (list-ref coords 0))
24                          ,(cdr (list-ref coords 0))
25                          ,(car (list-ref coords 1))
26                          ,(cdr (list-ref coords 1))
27                          ,(car (list-ref coords 2))
28                          ,(cdr (list-ref coords 2))
29                          curveto
30                          ,(car (list-ref coords 4))
31                          ,(cdr (list-ref coords 4))
32                          ,(car (list-ref coords 5))
33                          ,(cdr (list-ref coords 5))
34                          ,(car (list-ref coords 6))
35                          ,(cdr (list-ref coords 6))
36                          closepath)))
37     (ly:make-stencil
38      `(path ,thick `(,@' ,command-list) 'round 'round #t)
39      xext
40      yext)))
41
42 (define-public (stack-stencils axis dir padding stils)
43   "Stack stencils @var{stils} in direction @var{axis}, @var{dir}, using
44 @var{padding}."
45   (reduce
46    (lambda (next front)
47      (ly:stencil-stack front axis dir next padding))
48    empty-stencil
49    stils))
50
51 (define-public (stack-stencils-padding-list axis dir paddings stils)
52   "Stack stencils @var{stils} in direction @var{axis}, @var{dir}, using
53 a list of @var{paddings}."
54   (if (null? stils)
55       empty-stencil
56       (fold
57        (lambda (next padding front)
58          (let ((offset (+ (- (interval-end (ly:stencil-extent front axis))
59                              (interval-start (ly:stencil-extent next axis)))
60                           padding)))
61            (ly:stencil-add
62              front
63              (ly:stencil-translate-axis next offset axis))))
64        (car stils)
65        (cdr stils)
66        paddings)))
67
68 (define-public (centered-stencil stencil)
69   "Center stencil @var{stencil} in both the X and Y directions."
70   (ly:stencil-aligned-to (ly:stencil-aligned-to stencil X CENTER) Y CENTER))
71
72 (define-public (stack-lines dir padding baseline stils)
73   "Stack vertically with a baseline skip."
74   (reduce-right
75    (lambda (next back) (ly:stencil-stack next Y dir back padding baseline))
76    empty-stencil
77    (map
78     (lambda (s)
79       ;; X-empty stencils may add vertical space.  A stencil that is
80       ;; merely Y-empty counts as horizontal spacing.  Since we want
81       ;; those to register as lines of their own (is this a good
82       ;; idea?), we make them a separately visible line.
83       (if (and (ly:stencil-empty? s Y)
84                (not (ly:stencil-empty? s X)))
85           (ly:make-stencil (ly:stencil-expr s) (ly:stencil-extent s X) '(0 . 0))
86           s))
87     stils)))
88
89 (define-public (bracketify-stencil stil axis thick protrusion padding)
90   "Add brackets around @var{stil}, producing a new stencil."
91
92   (let* ((ext (ly:stencil-extent stil axis))
93          (lb (ly:bracket axis ext thick protrusion))
94          (rb (ly:bracket axis ext thick (- protrusion))))
95     (set! stil
96           (ly:stencil-combine-at-edge stil (other-axis axis) 1 rb padding))
97     (set! stil
98           (ly:stencil-combine-at-edge stil (other-axis axis) -1 lb padding))
99     stil))
100
101 (define (make-parenthesis-stencil
102          y-extent half-thickness width angularity)
103   "Create a parenthesis stencil.
104 @var{y-extent} is the Y extent of the markup inside the parenthesis.
105 @var{half-thickness} is the half thickness of the parenthesis.
106 @var{width} is the width of a parenthesis.
107 The higher the value of number @var{angularity},
108 the more angular the shape of the parenthesis."
109   (let* ((line-width 0.1)
110          ;; Horizontal position of baseline that end points run through.
111          (base-x
112           (if (< width 0)
113               (- width)
114               0))
115          ;; X value farthest from baseline on outside  of curve
116          (outer-x (+ base-x width))
117          ;; X extent of bezier sandwich centerline curves
118          (x-extent (ordered-cons base-x outer-x))
119          (bottom-y (interval-start y-extent))
120          (top-y (interval-end y-extent))
121
122          (lower-end-point (cons base-x bottom-y))
123          (upper-end-point (cons base-x top-y))
124
125          (outer-control-x (+ base-x (* 4/3 width)))
126          (inner-control-x (+ outer-control-x
127                              (if (< width 0)
128                                  half-thickness
129                                  (- half-thickness))))
130
131          ;; Vertical distance between a control point
132          ;; and the end point it connects to.
133          (offset-index (- (* 0.6 angularity) 0.8))
134          (lower-control-y (interval-index y-extent offset-index))
135          (upper-control-y (interval-index y-extent (- offset-index)))
136
137          (lower-outer-control-point
138           (cons outer-control-x lower-control-y))
139          (upper-outer-control-point
140           (cons outer-control-x upper-control-y))
141          (upper-inner-control-point
142           (cons inner-control-x upper-control-y))
143          (lower-inner-control-point
144           (cons inner-control-x lower-control-y)))
145
146     (make-bezier-sandwich-stencil
147      (list
148       ;; Step 4: curve through inner control points
149       ;; to lower end point.
150       upper-inner-control-point
151       lower-inner-control-point
152       lower-end-point
153       ;; Step 3: move to upper end point.
154       upper-end-point
155       ;; Step 2: curve through outer control points
156       ;; to upper end point.
157       lower-outer-control-point
158       upper-outer-control-point
159       upper-end-point
160       ;; Step 1: move to lower end point.
161       lower-end-point)
162      line-width
163      (interval-widen x-extent (/ line-width 2))
164      (interval-widen y-extent (/ line-width 2)))))
165
166 (define-public (parenthesize-stencil
167                 stencil half-thickness width angularity padding)
168   "Add parentheses around @var{stencil}, returning a new stencil."
169   (let* ((y-extent (ly:stencil-extent stencil Y))
170          (lp (make-parenthesis-stencil
171               y-extent half-thickness (- width) angularity))
172          (rp (make-parenthesis-stencil
173               y-extent half-thickness width angularity)))
174     (set! stencil (ly:stencil-combine-at-edge stencil X LEFT lp padding))
175     (set! stencil (ly:stencil-combine-at-edge stencil X RIGHT rp padding))
176     stencil))
177
178 (define-public (make-line-stencil width startx starty endx endy)
179   "Make a line stencil of given linewidth and set its extents accordingly."
180   (let ((xext (cons (min startx endx) (max startx endx)))
181         (yext (cons (min starty endy) (max starty endy))))
182     (ly:make-stencil
183      (list 'draw-line width startx starty endx endy)
184      ;; Since the line has rounded edges, we have to / can safely add half the
185      ;; width to all coordinates!
186      (interval-widen xext (/ width 2))
187      (interval-widen yext (/ width 2)))))
188
189 (define-public (make-transparent-box-stencil xext yext)
190   "Make a transparent box."
191   (ly:make-stencil
192    (list 'transparent-stencil
193          (ly:stencil-expr (make-filled-box-stencil xext yext)))
194    xext yext))
195
196 (define-public (make-filled-box-stencil xext yext)
197   "Make a filled box."
198
199   (ly:make-stencil
200    (list 'round-filled-box (- (car xext)) (cdr xext)
201          (- (car yext)) (cdr yext) 0.0)
202    xext yext))
203
204 (define-public (make-circle-stencil radius thickness fill)
205   "Make a circle of radius @var{radius} and thickness @var{thickness}."
206   (let*
207       ((out-radius (+ radius (/ thickness 2.0))))
208
209     (ly:make-stencil
210      (list 'circle radius thickness fill)
211      (cons (- out-radius) out-radius)
212      (cons (- out-radius) out-radius))))
213
214 (define-public (make-oval-stencil x-radius y-radius thickness fill)
215   "Make an oval from two Bezier curves, of x@tie{}radius @var{x-radius},
216 y@tie{}radius @code{y-radius}, and thickness @var{thickness} with fill
217 defined by @code{fill}."
218   (let*
219       ((x-out-radius (+ x-radius (/ thickness 2.0)))
220        (y-out-radius (+ y-radius (/ thickness 2.0)))
221        (x-max x-radius)
222        (x-min (- x-radius))
223        (y-max y-radius)
224        (y-min (- y-radius))
225        (commands `(,(list 'moveto x-max 0)
226                    ,(list 'curveto x-max y-max x-min y-max x-min 0)
227                    ,(list 'curveto x-min y-min x-max y-min x-max 0)
228                    ,(list 'closepath)))
229        (command-list (fold-right append '() commands)))
230     (ly:make-stencil
231      `(path ,thickness `(,@',command-list) 'round 'round ,fill)
232      (cons (- x-out-radius) x-out-radius)
233      (cons (- y-out-radius) y-out-radius))))
234
235 (define-public
236   (make-partial-ellipse-stencil
237    x-radius y-radius start-angle end-angle thick connect fill)
238   "Create an elliptical arc
239 @var{x-radius} is the X radius of the arc.
240 @var{y-radius} is the Y radius of the arc.
241 @var{start-angle} is the starting angle of the arc in degrees.
242 @var{end-angle} is the ending angle of the arc in degrees.
243 @var{thick} is the thickness of the line.
244 @var{connect} is a boolean flag indicating if the end should
245 be connected to the start by a line.
246 @var{fill} is a boolean flag indicating if the shape should be filled."
247   (define (make-radius-list x-radius y-radius)
248     "Makes a list of angle/radius pairs at intervals of PI/2 for
249 the partial ellipse until 7*PI/2.  For example, in pseudo-code:
250 > (make-radius-list 2 3)\
251 \n((0.0 . 2) (PI/2 . 3) (PI . -2) (3*PI/2 . -3)\
252 \n(2*PI . 2) (5*PI/2 . 3) (3*PI . -2) (7*PI/2 . -3))
253 "
254     (append-map
255      (lambda (adder)
256        (map (lambda (quadrant)
257               (cons (+ adder (car quadrant))
258                     (cdr quadrant)))
259             `((0.0 . (,x-radius . 0.0))
260               (,PI-OVER-TWO . (0.0 . ,y-radius))
261               (,PI . (,(- x-radius) . 0.0))
262               (,THREE-PI-OVER-TWO . (0.0 . ,(- y-radius))))))
263      `(0.0 ,TWO-PI)))
264
265   (define
266     (insert-in-ordered-list ordering-function value inlist cutl? cutr?)
267     "Insert @var{value} in ordered list @var{inlist}. If @var{cutl?}, we
268 cut away any parts of @var{inlist} before @var{value}. @var{cutr?} works
269 the same way but for the right side. For example:
270 > (insert-in-ordered-list < 4 '(1 2 3 6 7) #f #f)
271 '(1 2 3 4 6 7)
272 > (insert-in-ordered-list < 4 '(1 2 3 6 7) #t #f)
273 '(4 6 7)
274 > (insert-in-ordered-list < 4 '(1 2 3 6 7) #f #t)
275 '(1 2 3 4)
276 "
277     (define
278       (helper ordering-function value left-list right-list cutl? cutr?)
279       (if (null? right-list)
280           (append
281            (if cutl? '() left-list)
282            (list value)
283            (if cutr? '() right-list))
284           (if (ordering-function value (car right-list))
285               (append
286                (if cutl? '() left-list)
287                (list value)
288                (if cutr? '() right-list))
289               (helper
290                ordering-function
291                value
292                (append left-list (list (car right-list)))
293                (cdr right-list)
294                cutl?
295                cutr?))))
296     (helper ordering-function value '() inlist cutl? cutr?))
297
298   (define (ordering-function-1 a b) (car< a b))
299
300   (define (ordering-function-2 a b) (car<= a b))
301
302   (define (min-max-crawler min-max side l)
303     "Apply function @var{side} to each member of list and
304 then reduce using @var{min-max}:
305 > (min-max-crawler min car '((0 . 3) (-1 . 4) (1 . 2)))
306 -1
307 > (min-max-crawler min cdr '((0 . 3) (-1 . 4) (1 . 2)))
308 2
309 "
310     (reduce min-max
311             (if (eq? min-max min) 100000 -100000)
312             (map side l)))
313
314   (let*
315       (;; the outside limit of the x-radius
316        (x-out-radius (+ x-radius (/ thick 2.0)))
317        ;; the outside limit of the y-radius
318        (y-out-radius (+ y-radius (/ thick 2.0)))
319        ;; end angle to radians
320        (new-end-angle (angle-0-2pi (degrees->radians end-angle)))
321        ;; length of the radius at the end angle
322        (end-radius (ellipse-radius x-out-radius y-out-radius new-end-angle))
323        ;; start angle to radians
324        (new-start-angle (angle-0-2pi (degrees->radians start-angle)))
325        ;; length of the radius at the start angle
326        (start-radius (ellipse-radius x-out-radius y-out-radius new-start-angle))
327        ;; points that the arc passes through at 90 degree intervals
328        (radius-list (make-radius-list x-out-radius y-out-radius))
329        ;; rectangular coordinates of arc endpoint
330        (rectangular-end-radius (polar->rectangular end-radius end-angle))
331        ;; rectangular coordinates of arc begin point
332        (rectangular-start-radius (polar->rectangular start-radius start-angle))
333        ;; we want the end angle to always be bigger than the start angle
334        ;; so we redefine it here just in case it is less
335        (new-end-angle
336         (if (<= new-end-angle new-start-angle)
337             (+ TWO-PI new-end-angle)
338             new-end-angle))
339        ;; all the points that may be extrema of the arc
340        ;; this is the 90 degree points plus the beginning and end points
341        ;; we use this to calculate extents
342        (possible-extrema
343         (insert-in-ordered-list
344          ordering-function-2
345          (cons new-end-angle rectangular-end-radius)
346          (insert-in-ordered-list
347           ordering-function-1
348           (cons new-start-angle rectangular-start-radius)
349           radius-list
350           #t
351           #f)
352          #f
353          #t)))
354     (ly:make-stencil
355      (list
356       'partial-ellipse
357       x-radius
358       y-radius
359       start-angle
360       end-angle
361       thick
362       connect
363       fill)
364      ;; we know the extrema points by crawling through the
365      ;; list of possible extrema and finding the min and max
366      ;; for x and y
367      (cons (min-max-crawler min cadr possible-extrema)
368            (min-max-crawler max cadr possible-extrema))
369      (cons (min-max-crawler min cddr possible-extrema)
370            (min-max-crawler max cddr possible-extrema)))))
371
372 (define (line-part-min-max x1 x2)
373   (list (min x1 x2) (max x1 x2)))
374
375 (define (bezier-part-min-max x1 x2 x3 x4)
376   ((lambda (x) (list (reduce min 10000 x) (reduce max -10000 x)))
377    (map
378     (lambda (x)
379       (+ (* x1 (expt (- 1 x) 3))
380          (+ (* 3 (* x2 (* (expt (- 1 x) 2) x)))
381             (+ (* 3 (* x3 (* (- 1 x) (expt x 2))))
382                (* x4 (expt x 3))))))
383     (if (< (+ (expt x2 2) (+ (expt x3 2) (* x1 x4)))
384            (+ (* x1 x3) (+ (* x2 x4) (* x2 x3))))
385         (list 0.0 1.0)
386         (filter
387          (lambda (x) (and (>= x 0) (<= x 1)))
388          (append
389           (list 0.0 1.0)
390           (map (lambda (op)
391                  (if (not (eqv? 0.0
392                                 (exact->inexact (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2))))))
393                      ;; Zeros of the bezier curve
394                      (/ (+ (- x1 (* 2 x2))
395                            (op x3
396                                (sqrt (- (+ (expt x2 2)
397                                            (+ (expt x3 2) (* x1 x4)))
398                                         (+ (* x1 x3)
399                                            (+ (* x2 x4) (* x2 x3)))))))
400                         (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2))))
401                      ;; Apply L'hopital's rule to get the zeros if 0/0
402                      (* (op 0 1)
403                         (/ (/ (- x4 x3) 2)
404                            (sqrt (- (+ (* x2 x2)
405                                        (+ (* x3 x3) (* x1 x4)))
406                                     (+ (* x1 x3)
407                                        (+ (* x2 x4) (* x2 x3)))))))))
408                (list + -))))))))
409
410 (define (bezier-min-max x1 y1 x2 y2 x3 y3 x4 y4)
411   (map (lambda (x)
412          (apply bezier-part-min-max x))
413        `((,x1 ,x2 ,x3 ,x4) (,y1 ,y2 ,y3 ,y4))))
414
415 (define (line-min-max x1 y1 x2 y2)
416   (map (lambda (x)
417          (apply line-part-min-max x))
418        `((,x1 ,x2) (,y1 ,y2))))
419
420 (define (path-min-max origin pointlist)
421
422   ((lambda (x)
423      (list
424       (reduce min +inf.0 (map caar x))
425       (reduce max -inf.0 (map cadar x))
426       (reduce min +inf.0 (map caadr x))
427       (reduce max -inf.0 (map cadadr x))))
428    (map (lambda (x)
429           (if (= (length x) 8)
430               (apply bezier-min-max x)
431               (apply line-min-max x)))
432         (map (lambda (x y)
433                (append (list (cadr (reverse x)) (car (reverse x))) y))
434              (append (list origin)
435                      (reverse (cdr (reverse pointlist)))) pointlist))))
436
437 (define-public (make-path-stencil path thickness x-scale y-scale fill)
438   "Make a stencil based on the path described by the list @var{path},
439 with thickness @var{thickness}, and scaled by @var{x-scale} in the X
440 direction and @var{y-scale} in the Y direction.  @var{fill} is a boolean
441 argument that specifies if the path should be filled.  Valid path
442 commands are: moveto rmoveto lineto rlineto curveto rcurveto closepath,
443 and their standard SVG single letter equivalents: M m L l C c Z z."
444
445   (define (convert-path path origin previous-point)
446     "Recursive function to standardize command names and
447 convert any relative path expressions (in @var{path}) to absolute
448 values.  Returns a list of lists.  @var{origin} is a pair of x and y
449 coordinates for the origin point of the path (used for closepath and
450 reset by moveto commands).  @var{previous-point} is a pair of x and y
451 coordinates for the previous point in the path."
452     (if (pair? path)
453         (let*
454          ((head-raw (car path))
455           (rest (cdr path))
456           (head (cond
457                  ((memq head-raw '(rmoveto M m)) 'moveto)
458                  ((memq head-raw '(rlineto L l)) 'lineto)
459                  ((memq head-raw '(rcurveto C c)) 'curveto)
460                  ((memq head-raw '(Z z)) 'closepath)
461                  (else head-raw)))
462           (arity (cond
463                   ((memq head '(lineto moveto)) 2)
464                   ((eq? head 'curveto) 6)
465                   (else 0)))
466           (coordinates-raw (take rest arity))
467           (absolute? (if (memq head-raw
468                            '(rmoveto m rlineto l rcurveto c)) #f #t))
469           (coordinates (if absolute?
470                            coordinates-raw
471                            ;; convert relative coordinates to absolute by
472                            ;; adding them to previous point values
473                            (map (lambda (c n)
474                                   (if (even? n)
475                                       (+ c (car previous-point))
476                                       (+ c (cdr previous-point))))
477                              coordinates-raw
478                              (iota arity))))
479           (new-point (if (eq? head 'closepath)
480                          origin
481                          (cons
482                           (list-ref coordinates (- arity 2))
483                           (list-ref coordinates (- arity 1)))))
484           (new-origin (if (eq? head 'moveto)
485                           new-point
486                           origin)))
487          (cons (cons head coordinates)
488            (convert-path (drop rest arity) new-origin new-point)))
489         '()))
490
491   (let* ((path-absolute (convert-path path (cons 0 0) (cons 0 0)))
492          ;; scale coordinates
493          (path-scaled (if (and (= 1 x-scale) (= 1 y-scale))
494                           path-absolute
495                           (map (lambda (path-unit)
496                                  (map (lambda (c n)
497                                         (cond
498                                          ((= 0 n) c)
499                                          ((odd? n) (* c x-scale))
500                                          (else (* c y-scale))))
501                                    path-unit
502                                    (iota (length path-unit))))
503                             path-absolute)))
504          ;; a path must begin with a 'moveto'
505          (path-final (if (eq? 'moveto (car (car path-scaled)))
506                          path-scaled
507                          (append (list (list 'moveto 0 0)) path-scaled)))
508          ;; remove all commands in order to calculate bounds
509          (path-headless (map cdr (delete (list 'closepath) path-final)))
510          (bound-list (path-min-max
511                       (car path-headless)
512                       (cdr path-headless))))
513     (ly:make-stencil
514      `(path ,thickness
515         `(,@',(concatenate path-final))
516         'round
517         'round
518         ,(if fill #t #f))
519      (coord-translate
520       ((if (< x-scale 0) reverse-interval identity)
521        (cons
522         (list-ref bound-list 0)
523         (list-ref bound-list 1)))
524       `(,(/ thickness -2) . ,(/ thickness 2)))
525      (coord-translate
526       ((if (< y-scale 0) reverse-interval identity)
527        (cons
528         (list-ref bound-list 2)
529         (list-ref bound-list 3)))
530       `(,(/ thickness -2) . ,(/ thickness 2))))))
531
532 (define-public (make-connected-path-stencil pointlist thickness
533                                             x-scale y-scale connect fill)
534   "Make a connected path described by the list @var{pointlist}, beginning
535 at point '(0 . 0), with thickness @var{thickness}, and scaled by
536 @var{x-scale} in the X direction and @var{y-scale} in the Y direction.
537 @var{connect} and @var{fill} are boolean arguments that specify if the
538 path should be connected or filled, respectively."
539   (make-path-stencil
540    (concatenate
541     (append
542      (map (lambda (path-unit)
543             (case (length path-unit)
544               ((2) (append (list 'lineto) path-unit))
545               ((6) (append (list 'curveto) path-unit))))
546        pointlist)
547      ;; if this path is connected, add closepath to the end
548      (if connect (list '(closepath)) '())))
549    thickness x-scale y-scale fill))
550
551 (define-public (make-ellipse-stencil x-radius y-radius thickness fill)
552   "Make an ellipse of x@tie{}radius @var{x-radius}, y@tie{}radius
553 @code{y-radius}, and thickness @var{thickness} with fill defined by
554 @code{fill}."
555   (let*
556       ((x-out-radius (+ x-radius (/ thickness 2.0)))
557        (y-out-radius (+ y-radius (/ thickness 2.0))) )
558
559     (ly:make-stencil
560      (list 'ellipse x-radius y-radius thickness fill)
561      (cons (- x-out-radius) x-out-radius)
562      (cons (- y-out-radius) y-out-radius))))
563
564 (define-public (box-grob-stencil grob)
565   "Make a box of exactly the extents of the grob.  The box precisely
566 encloses the contents."
567   (let* ((xext (ly:grob-extent grob grob 0))
568          (yext (ly:grob-extent grob grob 1))
569          (thick 0.01))
570
571     (ly:stencil-add
572      (make-filled-box-stencil xext (cons (- (car yext) thick) (car yext)))
573      (make-filled-box-stencil xext (cons (cdr yext) (+ (cdr yext) thick)))
574      (make-filled-box-stencil (cons (cdr xext) (+ (cdr xext) thick)) yext)
575      (make-filled-box-stencil (cons (- (car xext) thick) (car xext)) yext))))
576
577 ;; TODO merge this and prev function.
578 (define-public (box-stencil stencil thickness padding)
579   "Add a box around @var{stencil}, producing a new stencil."
580   (let* ((x-ext (interval-widen (ly:stencil-extent stencil 0) padding))
581          (y-ext (interval-widen (ly:stencil-extent stencil 1) padding))
582          (y-rule (make-filled-box-stencil (cons 0 thickness) y-ext))
583          (x-rule (make-filled-box-stencil
584                   (interval-widen x-ext thickness) (cons 0 thickness))))
585     (set! stencil (ly:stencil-combine-at-edge stencil X 1 y-rule padding))
586     (set! stencil (ly:stencil-combine-at-edge stencil X -1 y-rule padding))
587     (set! stencil (ly:stencil-combine-at-edge stencil Y 1 x-rule 0.0))
588     (set! stencil (ly:stencil-combine-at-edge stencil Y -1 x-rule 0.0))
589     stencil))
590
591 (define-public (circle-stencil stencil thickness padding)
592   "Add a circle around @var{stencil}, producing a new stencil."
593   (let* ((x-ext (ly:stencil-extent stencil X))
594          (y-ext (ly:stencil-extent stencil Y))
595          (diameter (max (interval-length x-ext)
596                         (interval-length y-ext)))
597          (radius (+ (/ diameter 2) padding thickness))
598          (circle (make-circle-stencil radius thickness #f)))
599
600     (ly:stencil-add
601      stencil
602      (ly:stencil-translate circle
603                            (cons
604                             (interval-center x-ext)
605                             (interval-center y-ext))))))
606
607 (define-public (oval-stencil stencil thickness x-padding y-padding)
608   "Add an oval around @code{stencil}, padded by the padding pair,
609 producing a new stencil."
610   (let* ((x-ext (ly:stencil-extent stencil X))
611          (y-ext (ly:stencil-extent stencil Y))
612          (x-length (+ (interval-length x-ext) x-padding thickness))
613          (y-length (+ (interval-length y-ext) y-padding thickness))
614          (x-radius (* 0.707 x-length) )
615          (y-radius (* 0.707 y-length) )
616          (oval (make-oval-stencil x-radius y-radius thickness #f)))
617
618     (ly:stencil-add
619      stencil
620      (ly:stencil-translate oval
621                            (cons
622                             (interval-center x-ext)
623                             (interval-center y-ext))))))
624
625 (define-public (ellipse-stencil stencil thickness x-padding y-padding)
626   "Add an ellipse around @var{stencil}, padded by the padding pair,
627 producing a new stencil."
628   (let* ((x-ext (ly:stencil-extent stencil X))
629          (y-ext (ly:stencil-extent stencil Y))
630          (x-length (+ (interval-length x-ext) x-padding thickness))
631          (y-length (+ (interval-length y-ext) y-padding thickness))
632          ;; (aspect-ratio (/ x-length y-length))
633          (x-radius (* 0.707 x-length) )
634          (y-radius (* 0.707 y-length) )
635          ;; (diameter (max (- (cdr x-ext) (car x-ext))
636          ;;             (- (cdr y-ext) (car y-ext))))
637          ;; radius (+ (/ diameter 2) padding thickness))
638          (ellipse (make-ellipse-stencil x-radius y-radius thickness #f)))
639
640     (ly:stencil-add
641      stencil
642      (ly:stencil-translate ellipse
643                            (cons
644                             (interval-center x-ext)
645                             (interval-center y-ext))))))
646
647 (define-public (rounded-box-stencil stencil thickness padding blot)
648   "Add a rounded box around @var{stencil}, producing a new stencil."
649
650   (let* ((xext (interval-widen (ly:stencil-extent stencil 0) padding))
651          (yext (interval-widen (ly:stencil-extent stencil 1) padding))
652          (min-ext (min (-(cdr xext) (car xext)) (-(cdr yext) (car yext))))
653          (ideal-blot (min blot (/ min-ext 2)))
654          (ideal-thickness (min thickness (/ min-ext 2)))
655          (outer (ly:round-filled-box
656                  (interval-widen xext ideal-thickness)
657                  (interval-widen yext ideal-thickness)
658                  ideal-blot))
659          (inner (ly:make-stencil (list 'color (x11-color 'white)
660                                        (ly:stencil-expr (ly:round-filled-box
661                                                          xext yext (- ideal-blot ideal-thickness)))))))
662     (set! stencil (ly:stencil-add outer inner))
663     stencil))
664
665 (define-public (stencil-with-color stencil color)
666   (ly:make-stencil
667    (list 'color color (ly:stencil-expr stencil))
668    (ly:stencil-extent stencil X)
669    (ly:stencil-extent stencil Y)))
670
671 (define-public (stencil-whiteout stencil)
672   (let*
673       ((x-ext (ly:stencil-extent stencil X))
674        (y-ext (ly:stencil-extent stencil Y))
675
676        )
677
678     (ly:stencil-add
679      (stencil-with-color (ly:round-filled-box x-ext y-ext 0.0)
680                          white)
681      stencil)
682     ))
683
684 (define-public (arrow-stencil-maker start? end?)
685   "Return a function drawing a line from current point to @code{destination},
686 with optional arrows of @code{max-size} on start and end controlled by
687 @var{start?} and @var{end?}."
688   (lambda (destination max-size)
689     (let*
690         ((e_x 1+0i)
691          (e_y 0+1i)
692          (distance (sqrt (+ (* (car destination) (car destination))
693                             (* (cdr destination) (cdr destination)))))
694          (size (min max-size (/ distance 3)))
695          (rotate (lambda (z ang)
696                    (* (make-polar 1 ang)
697                       z)))
698          (complex-to-offset (lambda (z)
699                               (list (real-part z) (imag-part z))))
700
701          (z-dest (+ (* e_x (car destination)) (* e_y (cdr destination))))
702          (e_z (/ z-dest (magnitude z-dest)))
703          (triangle-points (list
704                            (* size -1+0.25i)
705                            0
706                            (* size -1-0.25i)))
707          (p1s (map (lambda (z)
708                      (+ z-dest (rotate z (angle z-dest))))
709                    triangle-points))
710          (p2s (map (lambda (z)
711                      (rotate z (angle (- z-dest))))
712                    triangle-points))
713          (null (cons 0 0))
714          (arrow-1
715           (ly:make-stencil
716            `(polygon (quote ,(append-map complex-to-offset p1s))
717                      0.0
718                      #t) null null))
719          (arrow-2
720           (ly:make-stencil
721            `(polygon (quote ,(append-map complex-to-offset p2s))
722                      0.0
723                      #t) null null ) )
724          (thickness (min (/ distance 12) 0.1))
725          (shorten-line (min (/ distance 3) 0.5))
726          (start (complex-to-offset (/ (* e_z shorten-line) 2)))
727          (end (complex-to-offset (- z-dest (/ (* e_z shorten-line) 2))))
728
729          (line (ly:make-stencil
730                 `(draw-line ,thickness
731                             ,(car start) ,(cadr start)
732                             ,(car end) ,(cadr end)
733                             )
734                 (cons (min 0 (car destination))
735                       (min 0 (cdr destination)))
736                 (cons (max 0 (car destination))
737                       (max 0 (cdr destination)))))
738
739          (result
740           (ly:stencil-add
741            (if start? arrow-2 empty-stencil)
742            (if end? arrow-1 empty-stencil)
743            line)))
744
745       result)))
746
747 (define-public dimension-arrows (arrow-stencil-maker #t #t))
748
749 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
750 ;; ANNOTATIONS
751 ;;
752 ;; annotations are arrows indicating the numerical value of
753 ;; spacing variables
754 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
755
756 (define*-public (annotate-y-interval layout name extent is-length
757                                      #:key (color darkblue))
758   (let ((text-props (cons '((font-size . -3)
759                             (font-family . typewriter))
760                           (layout-extract-page-properties layout)))
761         (annotation #f))
762     (define (center-stencil-on-extent stil)
763       (ly:stencil-translate (ly:stencil-aligned-to stil Y CENTER)
764                             (cons 0 (interval-center extent))))
765     ;; do something sensible for 0,0 intervals.
766     (set! extent (interval-widen extent 0.001))
767     (if (not (interval-sane? extent))
768         (set! annotation (interpret-markup
769                           layout text-props
770                           (make-simple-markup (simple-format #f "~a: NaN/inf" name))))
771         (let ((text-stencil (interpret-markup
772                              layout text-props
773                              (markup #:whiteout #:simple name)))
774               (dim-stencil (interpret-markup
775                             layout text-props
776                             (markup #:whiteout
777                                     #:simple (cond
778                                               ((interval-empty? extent)
779                                                "empty")
780                                               (is-length
781                                                (ly:format "~$" (interval-length extent)))
782                                               (else
783                                                (ly:format "(~$,~$)"
784                                                           (car extent) (cdr extent)))))))
785               (arrows (ly:stencil-translate-axis
786                        (dimension-arrows (cons 0 (interval-length extent)) 1.0)
787                        (interval-start extent) Y)))
788           (set! annotation
789                 (center-stencil-on-extent text-stencil))
790           (set! annotation
791                 (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5))
792           (set! annotation
793                 (ly:stencil-combine-at-edge annotation X LEFT
794                                             (center-stencil-on-extent dim-stencil)
795                                             0.5))
796           (set! annotation
797                 (stencil-with-color annotation color))))
798     annotation))
799
800
801 ;; TODO: figure out how to annotate padding nicely
802 ;; TODO: emphasize either padding or min-dist depending on which constraint was active
803 (define*-public (annotate-spacing-spec layout spacing-spec start-Y-offset next-staff-Y
804                                        #:key (base-color blue))
805   (let* ((get-spacing-var (lambda (sym) (assoc-get sym spacing-spec 0.0)))
806          (space (get-spacing-var 'basic-distance))
807          (padding (get-spacing-var 'padding))
808          (min-dist (get-spacing-var 'minimum-distance))
809          (contrast-color (append (cdr base-color) (list (car base-color))))
810          (min-dist-blocks (<= (- start-Y-offset min-dist) next-staff-Y))
811          (min-dist-color (if min-dist-blocks contrast-color base-color))
812          (basic-annotation (annotate-y-interval layout
813                                                 "basic-dist"
814                                                 (cons (- start-Y-offset space) start-Y-offset)
815                                                 #t
816                                                 #:color (map (lambda (x) (* x 0.25)) base-color)))
817          (min-annotation (annotate-y-interval layout
818                                               "min-dist"
819                                               (cons (- start-Y-offset min-dist) start-Y-offset)
820                                               #t
821                                               #:color min-dist-color))
822          (extra-annotation (annotate-y-interval layout
823                                                 "extra dist"
824                                                 (cons next-staff-Y (- start-Y-offset min-dist))
825                                                 #t
826                                                 #:color (map (lambda (x) (* x 0.5)) min-dist-color))))
827
828     (stack-stencils X RIGHT 0.0
829                     (list
830                      basic-annotation
831                      (if min-dist-blocks
832                          min-annotation
833                          (ly:stencil-add min-annotation extra-annotation))))))
834
835 (define-public (eps-file->stencil axis size file-name)
836   (let*
837       ((contents (ly:gulp-file file-name))
838        (bbox (get-postscript-bbox (car (string-split contents #\nul))))
839        (bbox-size (if (= axis X)
840                       (- (list-ref bbox 2) (list-ref bbox 0))
841                       (- (list-ref bbox 3) (list-ref bbox 1))
842                       ))
843        (factor (if (< 0 bbox-size)
844                    (exact->inexact (/ size bbox-size))
845                    0))
846        (scaled-bbox
847         (map (lambda (x) (* factor x)) bbox))
848        ;; We need to shift the whole eps to (0,0), otherwise it will appear
849        ;; displaced in lilypond (displacement will depend on the scaling!)
850        (translate-string (ly:format "~a ~a translate" (- (list-ref bbox 0)) (- (list-ref bbox 1))))
851        (clip-rect-string (ly:format
852                           "~a ~a ~a ~a rectclip"
853                           (list-ref bbox 0)
854                           (list-ref bbox 1)
855                           (- (list-ref bbox 2) (list-ref bbox 0))
856                           (- (list-ref bbox 3) (list-ref bbox 1)))))
857
858
859     (if bbox
860         (ly:make-stencil
861          (list
862           'embedded-ps
863           (string-append
864            (ly:format
865             "
866 gsave
867 currentpoint translate
868 BeginEPSF
869 ~a dup scale
870 ~a
871 ~a
872 %%BeginDocument: ~a
873 "         factor translate-string  clip-rect-string
874
875 file-name
876 )
877            contents
878            "%%EndDocument
879 EndEPSF
880 grestore
881 "))
882          ;; Stencil starts at (0,0), since we have shifted the eps, and its
883          ;; size is exactly the size of the scaled bounding box
884          (cons 0 (- (list-ref scaled-bbox 2) (list-ref scaled-bbox 0)))
885          (cons 0 (- (list-ref scaled-bbox 3) (list-ref scaled-bbox 1))))
886
887         (ly:make-stencil "" '(0 . 0) '(0 . 0)))
888     ))
889
890 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
891 ;; output signatures.
892
893 (define-public (write-system-signatures basename paper-systems count)
894   (if (pair? paper-systems)
895       (begin
896         (let*
897             ((outname (simple-format #f "~a-~a.signature" basename count)) )
898
899           (ly:message "Writing ~a" outname)
900           (write-system-signature outname (car paper-systems))
901           (write-system-signatures basename (cdr paper-systems) (1+ count))))))
902
903 (use-modules (scm paper-system))
904 (define-public (write-system-signature filename paper-system)
905   (define (float? x)
906     (and (number? x) (inexact? x)))
907
908   (define system-grob
909     (paper-system-system-grob paper-system))
910
911   (define output (open-output-file filename))
912
913   ;; todo: optionally use a command line flag? Or just junk this?
914   (define compare-expressions #f)
915   (define (strip-floats expr)
916     "Replace floats by #f"
917     (cond
918      ((float? expr) #f)
919      ((ly:font-metric? expr) (ly:font-name expr))
920      ((pair? expr) (cons (strip-floats (car expr))
921                          (strip-floats (cdr expr))))
922      (else expr)))
923
924   (define (fold-false-pairs expr)
925     "Try to remove lists of #f as much as possible."
926     (if (pair? expr)
927         (let*
928             ((first (car expr))
929              (rest (fold-false-pairs (cdr expr))))
930
931           (if first
932               (cons (fold-false-pairs first) rest)
933               rest))
934         expr))
935
936   (define (raw-string expr)
937     "escape quotes and slashes for python consumption"
938     (regexp-substitute/global #f "[@\n]" (simple-format #f "~a" expr) 'pre " " 'post))
939
940   (define (raw-pair expr)
941     (simple-format #f "~a ~a"
942                    (car expr) (cdr expr)))
943
944   (define (found-grob expr)
945     (let*
946         ((grob (car expr))
947          (rest (cdr expr))
948          (collected '())
949          (cause (event-cause grob))
950          (input (if (ly:stream-event? cause) (ly:event-property cause 'origin) #f))
951          (location (if (ly:input-location? input) (ly:input-file-line-char-column input) '()))
952
953          ;; todo: use stencil extent if available.
954          (x-ext (ly:grob-extent grob system-grob X))
955          (y-ext (ly:grob-extent grob system-grob Y))
956          (expression-skeleton
957           (if compare-expressions
958               (interpret-for-signature
959                #f (lambda (e)
960                     (set! collected (cons e collected)))
961                rest)
962               "")))
963
964       (simple-format output
965                      "~a@~a@~a@~a@~a\n"
966                      (cdr (assq 'name (ly:grob-property grob 'meta) ))
967                      (raw-string location)
968                      (raw-pair (if (interval-empty? x-ext) '(1 . -1) x-ext))
969                      (raw-pair (if (interval-empty? y-ext) '(1 . -1) y-ext))
970                      (raw-string collected))
971       ))
972
973   (define (interpret-for-signature escape collect expr)
974     (define (interpret expr)
975       (let*
976           ((head (if (pair? expr)
977                      (car expr)
978                      #f)))
979
980         (cond
981          ((eq? head 'grob-cause) (escape (cdr expr)))
982          ((eq? head 'color) (interpret (caddr expr)))
983          ((eq? head 'rotate-stencil) (interpret (caddr expr)))
984          ((eq? head 'translate-stencil) (interpret (caddr expr)))
985          ((eq? head 'combine-stencil)
986           (for-each (lambda (e) (interpret e))  (cdr expr)))
987          (else
988           (collect (fold-false-pairs (strip-floats expr))))
989
990          )))
991
992     (interpret expr))
993
994   (if (ly:grob? system-grob)
995       (begin
996         (display (simple-format #f "# Output signature\n# Generated by LilyPond ~a\n" (lilypond-version))
997                  output)
998         (interpret-for-signature found-grob (lambda (x) #f)
999                                  (ly:stencil-expr
1000                                   (paper-system-stencil paper-system)))))
1001
1002   ;; should be superfluous, but leaking "too many open files"?
1003   (close-port output))