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