]> git.donarmstrong.com Git - lilypond.git/blob - scm/stencil.scm
Merge branch 'master' into translation
[lilypond.git] / scm / stencil.scm
1 ;;;; This file is part of LilyPond, the GNU music typesetter.
2 ;;;;
3 ;;;; Copyright (C) 2003--2015 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)
19    (make-path-stencil
20        `(moveto
21            ,(car (list-ref coords 0))
22            ,(cdr (list-ref coords 0))
23          curveto
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))
30          curveto
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))
37          closepath)
38        thick
39        1
40        1
41        #t))
42
43 (define-public (stack-stencils axis dir padding stils)
44   "Stack stencils @var{stils} in direction @var{axis}, @var{dir}, using
45 @var{padding}."
46   (reduce
47    (lambda (next front)
48      (ly:stencil-stack front axis dir next padding))
49    empty-stencil
50    stils))
51
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}."
55   (if (null? stils)
56       empty-stencil
57       (fold
58        (lambda (next padding front)
59          (let ((offset (+ (- (interval-end (ly:stencil-extent front axis))
60                              (interval-start (ly:stencil-extent next axis)))
61                           padding)))
62            (ly:stencil-add
63              front
64              (ly:stencil-translate-axis next offset axis))))
65        (car stils)
66        (cdr stils)
67        paddings)))
68
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))
72
73 (define-public (stack-lines dir padding baseline stils)
74   "Stack vertically with a baseline skip."
75   (reduce-right
76    (lambda (next back) (ly:stencil-stack next Y dir back padding baseline))
77    empty-stencil
78    (map
79     (lambda (s)
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))
87           s))
88     stils)))
89
90 (define-public (bracketify-stencil stil axis thick protrusion padding)
91   "Add brackets around @var{stil}, producing a new stencil."
92
93   (let* ((ext (ly:stencil-extent stil axis))
94          (lb (ly:bracket axis ext thick protrusion))
95          (rb (ly:bracket axis ext thick (- protrusion))))
96     (set! stil
97           (ly:stencil-combine-at-edge stil (other-axis axis) 1 rb padding))
98     (set! stil
99           (ly:stencil-combine-at-edge stil (other-axis axis) -1 lb padding))
100     stil))
101
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.
112          (base-x
113           (if (< width 0)
114               (- width)
115               0))
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))
122
123          (lower-end-point (cons base-x bottom-y))
124          (upper-end-point (cons base-x top-y))
125
126          (outer-control-x (+ base-x (* 4/3 width)))
127          (inner-control-x (+ outer-control-x
128                              (if (< width 0)
129                                  half-thickness
130                                  (- half-thickness))))
131
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)))
137
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)))
146   (ly:make-stencil
147     (ly:stencil-expr
148       (make-bezier-sandwich-stencil
149        (list
150         ;; Step 1: move to lower end point.
151         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
156         upper-end-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)))))
164
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))
175     stencil))
176
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))))
181     (ly:make-stencil
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)))))
187
188 (define-public (make-transparent-box-stencil xext yext)
189   "Make a transparent box."
190   (ly:make-stencil
191    (list 'transparent-stencil
192          (ly:stencil-expr (make-filled-box-stencil xext yext)))
193    xext yext))
194
195 (define-public (make-filled-box-stencil xext yext)
196   "Make a filled box."
197
198   (ly:make-stencil
199    (list 'round-filled-box (- (car xext)) (cdr xext)
200          (- (car yext)) (cdr yext) 0.0)
201    xext yext))
202
203 (define-public (make-circle-stencil radius thickness fill)
204   "Make a circle of radius @var{radius} and thickness @var{thickness}."
205   (let*
206       ((out-radius (+ radius (/ thickness 2.0))))
207
208     (ly:make-stencil
209      (list 'circle radius thickness fill)
210      (cons (- out-radius) out-radius)
211      (cons (- out-radius) out-radius))))
212
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}."
217   (let*
218       ((x-out-radius (+ x-radius (/ thickness 2.0)))
219        (y-out-radius (+ y-radius (/ thickness 2.0)))
220        (x-max x-radius)
221        (x-min (- x-radius))
222        (y-max y-radius)
223        (y-min (- y-radius))
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)
227                    ,(list 'closepath)))
228        (command-list (fold-right append '() commands)))
229     (ly:make-stencil
230      `(path ,thickness `(,@',command-list) 'round 'round ,fill)
231      (cons (- x-out-radius) x-out-radius)
232      (cons (- y-out-radius) y-out-radius))))
233
234 (define-public
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))
252 "
253     (append-map
254      (lambda (adder)
255        (map (lambda (quadrant)
256               (cons (+ adder (car quadrant))
257                     (cdr 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))))))
262      `(0.0 ,TWO-PI)))
263
264   (define
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)
270 '(1 2 3 4 6 7)
271 > (insert-in-ordered-list < 4 '(1 2 3 6 7) #t #f)
272 '(4 6 7)
273 > (insert-in-ordered-list < 4 '(1 2 3 6 7) #f #t)
274 '(1 2 3 4)
275 "
276     (define
277       (helper ordering-function value left-list right-list cutl? cutr?)
278       (if (null? right-list)
279           (append
280            (if cutl? '() left-list)
281            (list value)
282            (if cutr? '() right-list))
283           (if (ordering-function value (car right-list))
284               (append
285                (if cutl? '() left-list)
286                (list value)
287                (if cutr? '() right-list))
288               (helper
289                ordering-function
290                value
291                (append left-list (list (car right-list)))
292                (cdr right-list)
293                cutl?
294                cutr?))))
295     (helper ordering-function value '() inlist cutl? cutr?))
296
297   (define (ordering-function-1 a b) (car< a b))
298
299   (define (ordering-function-2 a b) (car<= a b))
300
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)))
305 -1
306 > (min-max-crawler min cdr '((0 . 3) (-1 . 4) (1 . 2)))
307 2
308 "
309     (reduce min-max
310             (if (eq? min-max min) 100000 -100000)
311             (map side l)))
312
313   (let*
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
334        (new-end-angle
335         (if (<= new-end-angle new-start-angle)
336             (+ TWO-PI new-end-angle)
337             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
341        (possible-extrema
342         (insert-in-ordered-list
343          ordering-function-2
344          (cons new-end-angle rectangular-end-radius)
345          (insert-in-ordered-list
346           ordering-function-1
347           (cons new-start-angle rectangular-start-radius)
348           radius-list
349           #t
350           #f)
351          #f
352          #t)))
353     (ly:make-stencil
354      (list
355       'partial-ellipse
356       x-radius
357       y-radius
358       start-angle
359       end-angle
360       thick
361       connect
362       fill)
363      ;; we know the extrema points by crawling through the
364      ;; list of possible extrema and finding the min and max
365      ;; for x and y
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)))))
370
371 (define (line-part-min-max x1 x2)
372   (list (min x1 x2) (max x1 x2)))
373
374 (define (bezier-part-min-max x1 x2 x3 x4)
375   ((lambda (x) (list (reduce min 10000 x) (reduce max -10000 x)))
376    (map
377     (lambda (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))))
384         (list 0.0 1.0)
385         (filter
386          (lambda (x) (and (>= x 0) (<= x 1)))
387          (append
388           (list 0.0 1.0)
389           (map (lambda (op)
390                  (if (not (eqv? 0.0
391                                 (exact->inexact (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2))))))
392                      ;; Zeros of the bezier curve
393                      (/ (+ (- x1 (* 2 x2))
394                            (op x3
395                                (sqrt (- (+ (expt x2 2)
396                                            (+ (expt x3 2) (* x1 x4)))
397                                         (+ (* x1 x3)
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
401                      (* (op 0 1)
402                         (/ (/ (- x4 x3) 2)
403                            (sqrt (- (+ (* x2 x2)
404                                        (+ (* x3 x3) (* x1 x4)))
405                                     (+ (* x1 x3)
406                                        (+ (* x2 x4) (* x2 x3)))))))))
407                (list + -))))))))
408
409 (define (bezier-min-max x1 y1 x2 y2 x3 y3 x4 y4)
410   (map (lambda (x)
411          (apply bezier-part-min-max x))
412        `((,x1 ,x2 ,x3 ,x4) (,y1 ,y2 ,y3 ,y4))))
413
414 (define (line-min-max x1 y1 x2 y2)
415   (map (lambda (x)
416          (apply line-part-min-max x))
417        `((,x1 ,x2) (,y1 ,y2))))
418
419 (define (path-min-max origin pointlist)
420
421   ((lambda (x)
422      (list
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))))
427    (map (lambda (x)
428           (if (= (length x) 8)
429               (apply bezier-min-max x)
430               (apply line-min-max x)))
431         (map (lambda (x y)
432                (append (list (cadr (reverse x)) (car (reverse x))) y))
433              (append (list origin)
434                      (reverse (cdr (reverse pointlist)))) pointlist))))
435
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."
443
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."
451     (if (pair? path)
452         (let*
453          ((head-raw (car path))
454           (rest (cdr path))
455           (head (cond
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)
460                  (else head-raw)))
461           (arity (cond
462                   ((memq head '(lineto moveto)) 2)
463                   ((eq? head 'curveto) 6)
464                   (else 0)))
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
469                            coordinates-raw
470                            ;; convert relative coordinates to absolute by
471                            ;; adding them to previous point values
472                            (map (lambda (c n)
473                                   (if (even? n)
474                                       (+ c (car previous-point))
475                                       (+ c (cdr previous-point))))
476                              coordinates-raw
477                              (iota arity))))
478           (new-point (if (eq? head 'closepath)
479                          origin
480                          (cons
481                           (list-ref coordinates (- arity 2))
482                           (list-ref coordinates (- arity 1)))))
483           (new-origin (if (eq? head 'moveto)
484                           new-point
485                           origin)))
486          (cons (cons head coordinates)
487            (convert-path (drop rest arity) new-origin new-point)))
488         '()))
489
490   (let* ((path-absolute (convert-path path (cons 0 0) (cons 0 0)))
491          ;; scale coordinates
492          (path-scaled (if (and (= 1 x-scale) (= 1 y-scale))
493                           path-absolute
494                           (map (lambda (path-unit)
495                                  (map (lambda (c n)
496                                         (cond
497                                          ((= 0 n) c)
498                                          ((odd? n) (* c x-scale))
499                                          (else (* c y-scale))))
500                                    path-unit
501                                    (iota (length path-unit))))
502                             path-absolute)))
503          ;; a path must begin with a 'moveto'
504          (path-final (if (eq? 'moveto (car (car path-scaled)))
505                          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
510                       (car path-headless)
511                       (cdr path-headless))))
512     (ly:make-stencil
513      `(path ,thickness
514         `(,@',(concatenate path-final))
515         'round
516         'round
517         ,(if fill #t #f))
518      (coord-translate
519       ((if (< x-scale 0) reverse-interval identity)
520        (cons
521         (list-ref bound-list 0)
522         (list-ref bound-list 1)))
523       `(,(/ thickness -2) . ,(/ thickness 2)))
524      (coord-translate
525       ((if (< y-scale 0) reverse-interval identity)
526        (cons
527         (list-ref bound-list 2)
528         (list-ref bound-list 3)))
529       `(,(/ thickness -2) . ,(/ thickness 2))))))
530
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."
538   (make-path-stencil
539    (concatenate
540     (append
541      (map (lambda (path-unit)
542             (case (length path-unit)
543               ((2) (append (list 'lineto) path-unit))
544               ((6) (append (list 'curveto) path-unit))))
545        pointlist)
546      ;; if this path is connected, add closepath to the end
547      (if connect (list '(closepath)) '())))
548    thickness x-scale y-scale fill))
549
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
553 @code{fill}."
554   (let*
555       ((x-out-radius (+ x-radius (/ thickness 2.0)))
556        (y-out-radius (+ y-radius (/ thickness 2.0))) )
557
558     (ly:make-stencil
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))))
562
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))
568          (thick 0.01))
569
570     (ly:stencil-add
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))))
575
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))
588     stencil))
589
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)))
598
599     (ly:stencil-add
600      stencil
601      (ly:stencil-translate circle
602                            (cons
603                             (interval-center x-ext)
604                             (interval-center y-ext))))))
605
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)))
616
617     (ly:stencil-add
618      stencil
619      (ly:stencil-translate oval
620                            (cons
621                             (interval-center x-ext)
622                             (interval-center y-ext))))))
623
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)))
638
639     (ly:stencil-add
640      stencil
641      (ly:stencil-translate ellipse
642                            (cons
643                             (interval-center x-ext)
644                             (interval-center y-ext))))))
645
646 (define-public (rounded-box-stencil stencil thickness padding blot)
647   "Add a rounded box around @var{stencil}, producing a new stencil."
648
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)
657                  ideal-blot))
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))
662     stencil))
663
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."
670   (let* (
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)))
679     replaced-stil))
680
681 (define-public (stencil-with-color stencil color)
682   (ly:make-stencil
683    (list 'color color (ly:stencil-expr stencil))
684    (ly:stencil-extent stencil X)
685    (ly:stencil-extent stencil Y)))
686
687 (define*-public (stencil-whiteout
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 in staff-spaces.  @var{radial-increments} is how
695 many copies of the white stencil we make on our way out to thickness.
696 @var{angle-increments} is how many copies of the white stencil
697 we make between 0 and 2*pi."
698   (if (or (not (positive? angle-increments))
699           (not (positive? radial-increments)))
700       (begin
701        (ly:warning "Both angle-increments and radial-increments must be positive numbers.")
702        stil)
703       (let* ((2pi 6.283185307)
704              (angle-inc (/ 2pi angle-increments))
705              (radial-inc (/ thickness radial-increments)))
706
707         (define (circle-plot ang dec radius original-stil new-stil)
708           ;; ang (angle) and dec (decrement) are in radians, not degrees
709           (if (<= ang 0)
710               new-stil
711               (circle-plot (- ang dec) dec radius original-stil
712                 (ly:stencil-add
713                  new-stil
714                  (ly:stencil-translate original-stil
715                    (cons
716                     (* radius (cos ang))
717                     (* radius (sin ang))))))))
718
719         (define (radial-plot radius original-stil new-stil)
720           (if (<= radius 0)
721               new-stil
722               (ly:stencil-add new-stil
723                 (radial-plot
724                  (- radius radial-inc)
725                  original-stil
726                  (circle-plot 2pi angle-inc
727                    radius original-stil empty-stencil)))))
728
729         (let ((whiteout-expr
730                 (ly:stencil-expr
731                  (stencil-with-color
732                   (radial-plot thickness stil empty-stencil)
733                   color))))
734           (ly:stencil-add
735             (ly:make-stencil
736               `(delay-stencil-evaluation ,(delay whiteout-expr)))
737             stil)))))
738
739 (define*-public (stencil-whiteout-box stencil
740                  #:optional (thickness 0) (blot 0) (color white))
741   "@var{thickness} is how far in staff-spaces the white outline
742 extends past the extents of @var{stencil}."
743   (let*
744    ((x-ext (interval-widen (ly:stencil-extent stencil X) thickness))
745     (y-ext (interval-widen (ly:stencil-extent stencil Y) thickness)))
746
747    (ly:stencil-add
748     (stencil-with-color (ly:round-filled-box x-ext y-ext blot) color)
749     stencil)))
750
751 (define-public (arrow-stencil-maker start? end?)
752   "Return a function drawing a line from current point to @code{destination},
753 with optional arrows of @code{max-size} on start and end controlled by
754 @var{start?} and @var{end?}."
755   (lambda (destination max-size)
756     (let*
757         ((e_x 1+0i)
758          (e_y 0+1i)
759          (distance (sqrt (+ (* (car destination) (car destination))
760                             (* (cdr destination) (cdr destination)))))
761          (size (min max-size (/ distance 3)))
762          (rotate (lambda (z ang)
763                    (* (make-polar 1 ang)
764                       z)))
765          (complex-to-offset (lambda (z)
766                               (list (real-part z) (imag-part z))))
767
768          (z-dest (+ (* e_x (car destination)) (* e_y (cdr destination))))
769          (e_z (/ z-dest (magnitude z-dest)))
770          (triangle-points (list
771                            (* size -1+0.25i)
772                            0
773                            (* size -1-0.25i)))
774          (p1s (map (lambda (z)
775                      (+ z-dest (rotate z (angle z-dest))))
776                    triangle-points))
777          (p2s (map (lambda (z)
778                      (rotate z (angle (- z-dest))))
779                    triangle-points))
780          (null (cons 0 0))
781          (arrow-1
782           (ly:make-stencil
783            `(polygon (quote ,(append-map complex-to-offset p1s))
784                      0.0
785                      #t) null null))
786          (arrow-2
787           (ly:make-stencil
788            `(polygon (quote ,(append-map complex-to-offset p2s))
789                      0.0
790                      #t) null null ) )
791          (thickness (min (/ distance 12) 0.1))
792          (shorten-line (min (/ distance 3) 0.5))
793          (start (complex-to-offset (/ (* e_z shorten-line) 2)))
794          (end (complex-to-offset (- z-dest (/ (* e_z shorten-line) 2))))
795
796          (line (ly:make-stencil
797                 `(draw-line ,thickness
798                             ,(car start) ,(cadr start)
799                             ,(car end) ,(cadr end)
800                             )
801                 (cons (min 0 (car destination))
802                       (min 0 (cdr destination)))
803                 (cons (max 0 (car destination))
804                       (max 0 (cdr destination)))))
805
806          (result
807           (ly:stencil-add
808            (if start? arrow-2 empty-stencil)
809            (if end? arrow-1 empty-stencil)
810            line)))
811
812       result)))
813
814 (define-public dimension-arrows (arrow-stencil-maker #t #t))
815
816 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
817 ;; ANNOTATIONS
818 ;;
819 ;; annotations are arrows indicating the numerical value of
820 ;; spacing variables
821 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
822
823 (define*-public (annotate-y-interval layout name extent is-length
824                                      #:key (color darkblue))
825   (let ((text-props (cons '((font-size . -3)
826                             (font-family . typewriter))
827                           (layout-extract-page-properties layout)))
828         (annotation #f))
829     (define (center-stencil-on-extent stil)
830       (ly:stencil-translate (ly:stencil-aligned-to stil Y CENTER)
831                             (cons 0 (interval-center extent))))
832     ;; do something sensible for 0,0 intervals.
833     (set! extent (interval-widen extent 0.001))
834     (if (not (interval-sane? extent))
835         (set! annotation (interpret-markup
836                           layout text-props
837                           (make-simple-markup (simple-format #f "~a: NaN/inf" name))))
838         (let ((text-stencil (interpret-markup
839                              layout text-props
840                              (markup #:whiteout-box #:simple name)))
841               (dim-stencil (interpret-markup
842                             layout text-props
843                             (markup #:whiteout-box
844                                     #:simple (cond
845                                               ((interval-empty? extent)
846                                                "empty")
847                                               (is-length
848                                                (ly:format "~$" (interval-length extent)))
849                                               (else
850                                                (ly:format "(~$,~$)"
851                                                           (car extent) (cdr extent)))))))
852               (arrows (ly:stencil-translate-axis
853                        (dimension-arrows (cons 0 (interval-length extent)) 1.0)
854                        (interval-start extent) Y)))
855           (set! annotation
856                 (center-stencil-on-extent text-stencil))
857           (set! annotation
858                 (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5))
859           (set! annotation
860                 (ly:stencil-combine-at-edge annotation X LEFT
861                                             (center-stencil-on-extent dim-stencil)
862                                             0.5))
863           (set! annotation
864                 (stencil-with-color annotation color))))
865     annotation))
866
867
868 ;; TODO: figure out how to annotate padding nicely
869 ;; TODO: emphasize either padding or min-dist depending on which constraint was active
870 (define*-public (annotate-spacing-spec layout name spacing-spec
871                                        start-Y-offset next-staff-Y
872                                        #:key (base-color blue))
873   (let* ((get-spacing-var (lambda (sym) (assoc-get sym spacing-spec 0.0)))
874          (space (get-spacing-var 'basic-distance))
875          (padding (get-spacing-var 'padding))
876          (min-dist (get-spacing-var 'minimum-distance))
877          (contrast-color (append (cdr base-color) (list (car base-color))))
878          (min-dist-blocks (<= (- start-Y-offset min-dist) next-staff-Y))
879          (min-dist-color (if min-dist-blocks contrast-color base-color))
880          (name-string (if (string-null? name)
881                          ""
882                          (simple-format #f " (~a)" name)))
883          (basic-annotation
884           (annotate-y-interval layout
885                                (simple-format #f "basic-dist~a" name-string)
886                                (cons (- start-Y-offset space) start-Y-offset)
887                                #t
888                                #:color (map (lambda (x) (* x 0.25)) base-color)))
889          (min-annotation
890           (annotate-y-interval layout
891                                (simple-format #f "min-dist~a" name-string)
892                                (cons (- start-Y-offset min-dist) start-Y-offset)
893                                #t
894                                #:color min-dist-color))
895          (extra-annotation
896           (annotate-y-interval layout
897                                (simple-format #f "extra dist~a" name-string)
898                                (cons next-staff-Y (- start-Y-offset min-dist))
899                                #t
900                                #:color (map (lambda (x) (* x 0.5)) min-dist-color))))
901
902     (stack-stencils X RIGHT 0.0
903                     (list
904                      basic-annotation
905                      (if min-dist-blocks
906                          min-annotation
907                          (ly:stencil-add min-annotation extra-annotation))))))
908
909 (define-public (eps-file->stencil axis size file-name)
910   (let*
911       ((contents (ly:gulp-file file-name))
912        (bbox (get-postscript-bbox (car (string-split contents #\nul))))
913        (bbox-size (if (= axis X)
914                       (- (list-ref bbox 2) (list-ref bbox 0))
915                       (- (list-ref bbox 3) (list-ref bbox 1))
916                       ))
917        (factor (if (< 0 bbox-size)
918                    (exact->inexact (/ size bbox-size))
919                    0))
920        (scaled-bbox
921         (map (lambda (x) (* factor x)) bbox))
922        ;; We need to shift the whole eps to (0,0), otherwise it will appear
923        ;; displaced in lilypond (displacement will depend on the scaling!)
924        (translate-string (ly:format "~a ~a translate" (- (list-ref bbox 0)) (- (list-ref bbox 1))))
925        (clip-rect-string (ly:format
926                           "~a ~a ~a ~a rectclip"
927                           (list-ref bbox 0)
928                           (list-ref bbox 1)
929                           (- (list-ref bbox 2) (list-ref bbox 0))
930                           (- (list-ref bbox 3) (list-ref bbox 1)))))
931
932
933     (if bbox
934         (ly:make-stencil
935          (list
936           'embedded-ps
937           (string-append
938            (ly:format
939             "
940 gsave
941 currentpoint translate
942 BeginEPSF
943 ~a dup scale
944 ~a
945 ~a
946 %%BeginDocument: ~a
947 "         factor translate-string  clip-rect-string
948
949 file-name
950 )
951            contents
952            "%%EndDocument
953 EndEPSF
954 grestore
955 "))
956          ;; Stencil starts at (0,0), since we have shifted the eps, and its
957          ;; size is exactly the size of the scaled bounding box
958          (cons 0 (- (list-ref scaled-bbox 2) (list-ref scaled-bbox 0)))
959          (cons 0 (- (list-ref scaled-bbox 3) (list-ref scaled-bbox 1))))
960
961         (ly:make-stencil "" '(0 . 0) '(0 . 0)))
962     ))
963
964 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
965 ;; output signatures.
966
967 (define-public (write-system-signatures basename paper-systems count)
968   (if (pair? paper-systems)
969       (begin
970         (let*
971             ((outname (simple-format #f "~a-~a.signature" basename count)) )
972
973           (ly:message "Writing ~a" outname)
974           (write-system-signature outname (car paper-systems))
975           (write-system-signatures basename (cdr paper-systems) (1+ count))))))
976
977 (use-modules (scm paper-system))
978 (define-public (write-system-signature filename paper-system)
979   (define (float? x)
980     (and (number? x) (inexact? x)))
981
982   (define system-grob
983     (paper-system-system-grob paper-system))
984
985   (define output (open-output-file filename))
986
987   ;; todo: optionally use a command line flag? Or just junk this?
988   (define compare-expressions #f)
989   (define (strip-floats expr)
990     "Replace floats by #f"
991     (cond
992      ((float? expr) #f)
993      ((ly:font-metric? expr) (ly:font-name expr))
994      ((pair? expr) (cons (strip-floats (car expr))
995                          (strip-floats (cdr expr))))
996      (else expr)))
997
998   (define (fold-false-pairs expr)
999     "Try to remove lists of #f as much as possible."
1000     (if (pair? expr)
1001         (let*
1002             ((first (car expr))
1003              (rest (fold-false-pairs (cdr expr))))
1004
1005           (if first
1006               (cons (fold-false-pairs first) rest)
1007               rest))
1008         expr))
1009
1010   (define (raw-string expr)
1011     "escape quotes and slashes for python consumption"
1012     (regexp-substitute/global #f "[@\n]" (simple-format #f "~a" expr) 'pre " " 'post))
1013
1014   (define (raw-pair expr)
1015     (simple-format #f "~a ~a"
1016                    (car expr) (cdr expr)))
1017
1018   (define (found-grob expr)
1019     (let*
1020         ((grob (car expr))
1021          (rest (cdr expr))
1022          (collected '())
1023          (cause (event-cause grob))
1024          (input (if (ly:stream-event? cause) (ly:event-property cause 'origin) #f))
1025          (location (if (ly:input-location? input) (ly:input-file-line-char-column input) '()))
1026
1027          ;; todo: use stencil extent if available.
1028          (x-ext (ly:grob-extent grob system-grob X))
1029          (y-ext (ly:grob-extent grob system-grob Y))
1030          (expression-skeleton
1031           (if compare-expressions
1032               (interpret-for-signature
1033                #f (lambda (e)
1034                     (set! collected (cons e collected)))
1035                rest)
1036               "")))
1037
1038       (simple-format output
1039                      "~a@~a@~a@~a@~a\n"
1040                      (cdr (assq 'name (ly:grob-property grob 'meta) ))
1041                      (raw-string location)
1042                      (raw-pair (if (interval-empty? x-ext) '(1 . -1) x-ext))
1043                      (raw-pair (if (interval-empty? y-ext) '(1 . -1) y-ext))
1044                      (raw-string collected))
1045       ))
1046
1047   (define (interpret-for-signature escape collect expr)
1048     (define (interpret expr)
1049       (let*
1050           ((head (if (pair? expr)
1051                      (car expr)
1052                      #f)))
1053
1054         (cond
1055          ((eq? head 'grob-cause) (escape (cdr expr)))
1056          ((eq? head 'color) (interpret (caddr expr)))
1057          ((eq? head 'rotate-stencil) (interpret (caddr expr)))
1058          ((eq? head 'translate-stencil) (interpret (caddr expr)))
1059          ((eq? head 'combine-stencil)
1060           (for-each (lambda (e) (interpret e))  (cdr expr)))
1061          (else
1062           (collect (fold-false-pairs (strip-floats expr))))
1063
1064          )))
1065
1066     (interpret expr))
1067
1068   (if (ly:grob? system-grob)
1069       (begin
1070         (display (simple-format #f "# Output signature\n# Generated by LilyPond ~a\n" (lilypond-version))
1071                  output)
1072         (interpret-for-signature found-grob (lambda (x) #f)
1073                                  (ly:stencil-expr
1074                                   (paper-system-stencil paper-system)))))
1075
1076   ;; should be superfluous, but leaking "too many open files"?
1077   (close-port output))