1 ;;;; This file is part of LilyPond, the GNU music typesetter.
3 ;;;; Copyright (C) 2003--2012 Han-Wen Nienhuys <hanwen@xs4all.nl>
5 ;;;; LilyPond is free software: you can redistribute it and/or modify
6 ;;;; it under the terms of the GNU General Public License as published by
7 ;;;; the Free Software Foundation, either version 3 of the License, or
8 ;;;; (at your option) any later version.
10 ;;;; LilyPond is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;;;; GNU General Public License for more details.
15 ;;;; You should have received a copy of the GNU General Public License
16 ;;;; along with LilyPond. If not, see <http://www.gnu.org/licenses/>.
18 (define-public (stack-stencils axis dir padding stils)
19 "Stack stencils @var{stils} in direction @var{axis}, @var{dir}, using
22 ((null? stils) empty-stencil)
23 ((null? (cdr stils)) (car stils))
24 (else (ly:stencil-combine-at-edge
25 (car stils) axis dir (stack-stencils axis dir padding (cdr stils))
28 (define-public (stack-stencils-padding-list axis dir padding stils)
29 "Stack stencils @var{stils} in direction @var{axis}, @var{dir}, using
30 a list of @var{padding}."
32 ((null? stils) empty-stencil)
33 ((null? (cdr stils)) (car stils))
34 (else (ly:stencil-combine-at-edge
37 (stack-stencils-padding-list axis dir (cdr padding) (cdr stils))
40 (define-public (centered-stencil stencil)
41 "Center stencil @var{stencil} in both the X and Y directions."
42 (ly:stencil-aligned-to (ly:stencil-aligned-to stencil X CENTER) Y CENTER))
44 (define-public (stack-lines dir padding baseline stils)
45 "Stack vertically with a baseline skip."
46 (define result empty-stencil)
49 ((last-stencil #f (car p))
56 (let* ((dy (max (+ (* dir (interval-bound (ly:stencil-extent last-stencil Y) dir))
58 (* (- dir) (interval-bound (ly:stencil-extent (car p) Y) (- dir))))
60 (y (+ last-y (* dir dy))))
65 (ly:stencil-add result (ly:stencil-translate-axis (car p) y Y)))
69 (set! result (car p)))))
74 (define-public (bracketify-stencil stil axis thick protrusion padding)
75 "Add brackets around @var{stil}, producing a new stencil."
77 (let* ((ext (ly:stencil-extent stil axis))
78 (lb (ly:bracket axis ext thick protrusion))
79 (rb (ly:bracket axis ext thick (- protrusion))))
81 (ly:stencil-combine-at-edge stil (other-axis axis) 1 rb padding))
83 (ly:stencil-combine-at-edge lb (other-axis axis) 1 stil padding))
86 (define (make-parenthesis-stencil
87 y-extent half-thickness width angularity)
88 "Create a parenthesis stencil.
89 @var{y-extent} is the Y extent of the markup inside the parenthesis.
90 @var{half-thickness} is the half thickness of the parenthesis.
91 @var{width} is the width of a parenthesis.
92 The higher the value of number @var{angularity},
93 the more angular the shape of the parenthesis."
94 (let* ((line-width 0.1)
95 ;; Horizontal position of baseline that end points run through.
100 ;; X value farthest from baseline on outside of curve
101 (outer-x (+ base-x width))
102 ;; X extent of bezier sandwich centerline curves
103 (x-extent (ordered-cons base-x outer-x))
104 (bottom-y (interval-start y-extent))
105 (top-y (interval-end y-extent))
107 (lower-end-point (cons base-x bottom-y))
108 (upper-end-point (cons base-x top-y))
110 (outer-control-x (+ base-x (* 4/3 width)))
111 (inner-control-x (+ outer-control-x
114 (- half-thickness))))
116 ;; Vertical distance between a control point
117 ;; and the end point it connects to.
118 (offset-index (- (* 0.6 angularity) 0.8))
119 (lower-control-y (interval-index y-extent offset-index))
120 (upper-control-y (interval-index y-extent (- offset-index)))
122 (lower-outer-control-point
123 (cons outer-control-x lower-control-y))
124 (upper-outer-control-point
125 (cons outer-control-x upper-control-y))
126 (upper-inner-control-point
127 (cons inner-control-x upper-control-y))
128 (lower-inner-control-point
129 (cons inner-control-x lower-control-y)))
132 (list 'bezier-sandwich
134 ;; Step 4: curve through inner control points
135 ;; to lower end point.
136 upper-inner-control-point
137 lower-inner-control-point
139 ;; Step 3: move to upper end point.
141 ;; Step 2: curve through outer control points
142 ;; to upper end point.
143 lower-outer-control-point
144 upper-outer-control-point
146 ;; Step 1: move to lower end point.
149 (interval-widen x-extent (/ line-width 2))
150 (interval-widen y-extent (/ line-width 2)))))
152 (define-public (parenthesize-stencil
153 stencil half-thickness width angularity padding)
154 "Add parentheses around @var{stencil}, returning a new stencil."
155 (let* ((y-extent (ly:stencil-extent stencil Y))
156 (lp (make-parenthesis-stencil
157 y-extent half-thickness (- width) angularity))
158 (rp (make-parenthesis-stencil
159 y-extent half-thickness width angularity)))
160 (set! stencil (ly:stencil-combine-at-edge lp X RIGHT stencil padding))
161 (set! stencil (ly:stencil-combine-at-edge stencil X RIGHT rp padding))
164 (define-public (make-line-stencil width startx starty endx endy)
165 "Make a line stencil of given linewidth and set its extents accordingly."
166 (let ((xext (cons (min startx endx) (max startx endx)))
167 (yext (cons (min starty endy) (max starty endy))))
169 (list 'draw-line width startx starty endx endy)
170 ; Since the line has rounded edges, we have to / can safely add half the
171 ; width to all coordinates!
172 (interval-widen xext (/ width 2))
173 (interval-widen yext (/ width 2)))))
176 (define-public (make-filled-box-stencil xext yext)
180 (list 'round-filled-box (- (car xext)) (cdr xext)
181 (- (car yext)) (cdr yext) 0.0)
184 (define-public (make-circle-stencil radius thickness fill)
185 "Make a circle of radius @var{radius} and thickness @var{thickness}."
187 ((out-radius (+ radius (/ thickness 2.0))))
190 (list 'circle radius thickness fill)
191 (cons (- out-radius) out-radius)
192 (cons (- out-radius) out-radius))))
194 (define-public (make-oval-stencil x-radius y-radius thickness fill)
195 "Make an oval from two Bezier curves, of x@tie{}radius @var{x-radius},
196 y@tie{}radius @code{y-radius}, and thickness @var{thickness} with fill
197 defined by @code{fill}."
199 ((x-out-radius (+ x-radius (/ thickness 2.0)))
200 (y-out-radius (+ y-radius (/ thickness 2.0))) )
203 (list 'oval x-radius y-radius thickness fill)
204 (cons (- x-out-radius) x-out-radius)
205 (cons (- y-out-radius) y-out-radius))))
208 (make-partial-ellipse-stencil
209 x-radius y-radius start-angle end-angle thick connect fill)
211 (define (make-radius-list x-radius y-radius)
214 (map (lambda (quadrant)
215 (cons (+ adder (car quadrant))
217 `((0.0 . (,x-radius . 0.0))
218 (,PI-OVER-TWO . (0.0 . ,y-radius))
219 (,PI . (,(- x-radius) . 0.0))
220 (,THREE-PI-OVER-TWO . (0.0 . ,(- y-radius))))))
224 (insert-in-ordered-list ordering-function value inlist cutl? cutr?)
226 (helper ordering-function value left-list right-list cutl? cutr?)
227 (if (null? right-list)
229 (if cutl? '() left-list)
231 (if cutr? '() right-list))
232 (if (ordering-function value (car right-list))
234 (if cutl? '() left-list)
236 (if cutr? '() right-list))
240 (append left-list (list (car right-list)))
244 (helper ordering-function value '() inlist cutl? cutr?))
246 (define (ordering-function-1 a b) (car< a b))
248 (define (ordering-function-2 a b) (car<= a b))
250 (define (min-max-crawler min-max side l)
252 (if (eq? min-max min) 100000 -100000)
253 (map (lambda (x) (side x)) l)))
256 ((x-out-radius (+ x-radius (/ thick 2.0)))
257 (y-out-radius (+ y-radius (/ thick 2.0)))
258 (new-end-angle (angle-0-2pi (degrees->radians end-angle)))
259 (end-radius (ellipse-radius x-out-radius y-out-radius new-end-angle))
260 (new-start-angle (angle-0-2pi (degrees->radians start-angle)))
261 (start-radius (ellipse-radius x-out-radius y-out-radius new-start-angle))
262 (radius-list (make-radius-list x-out-radius y-out-radius))
263 (rectangular-end-radius (polar->rectangular end-radius end-angle))
264 (rectangular-start-radius (polar->rectangular start-radius start-angle))
266 (if (<= new-end-angle new-start-angle)
267 (+ TWO-PI new-end-angle)
270 (insert-in-ordered-list
272 (cons new-end-angle rectangular-end-radius)
273 (insert-in-ordered-list
275 (cons new-start-angle rectangular-start-radius)
291 (cons (min-max-crawler min cadr possible-extrema)
292 (min-max-crawler max cadr possible-extrema))
293 (cons (min-max-crawler min cddr possible-extrema)
294 (min-max-crawler max cddr possible-extrema)))))
296 (define (path-min-max origin pointlist)
298 (define (line-part-min-max x1 x2)
299 (list (min x1 x2) (max x1 x2)))
301 (define (bezier-part-min-max x1 x2 x3 x4)
302 ((lambda (x) (list (reduce min 10000 x) (reduce max -10000 x)))
305 (+ (* x1 (expt (- 1 x) 3))
306 (+ (* 3 (* x2 (* (expt (- 1 x) 2) x)))
307 (+ (* 3 (* x3 (* (- 1 x) (expt x 2))))
308 (* x4 (expt x 3))))))
309 (if (< (+ (expt x2 2) (+ (expt x3 2) (* x1 x4)))
310 (+ (* x1 x3) (+ (* x2 x4) (* x2 x3))))
313 (lambda (x) (and (>= x 0) (<= x 1)))
318 (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2)))))
319 ;; Zeros of the bezier curve
320 (/ (+ (- x1 (* 2 x2))
322 (sqrt (- (+ (expt x2 2)
323 (+ (expt x3 2) (* x1 x4)))
325 (+ (* x2 x4) (* x2 x3)))))))
326 (- (+ x1 (* 3 x3)) (+ x4 (* 3 x2))))
327 ;; Apply L'hopital's rule to get the zeros if 0/0
330 (sqrt (- (+ (* x2 x2)
331 (+ (* x3 x3) (* x1 x4)))
333 (+ (* x2 x4) (* x2 x3)))))))))
336 (define (bezier-min-max x1 y1 x2 y2 x3 y3 x4 y4)
338 (apply bezier-part-min-max x))
339 `((,x1 ,x2 ,x3 ,x4) (,y1 ,y2 ,y3 ,y4))))
341 (define (line-min-max x1 y1 x2 y2)
343 (apply line-part-min-max x))
344 `((,x1 ,x2) (,y1 ,y2))))
348 (reduce min +inf.0 (map caar x))
349 (reduce max -inf.0 (map cadar x))
350 (reduce min +inf.0 (map caadr x))
351 (reduce max -inf.0 (map cadadr x))))
353 (if (eq? (length x) 8)
354 (apply bezier-min-max x)
355 (apply line-min-max x)))
357 (append (list (cadr (reverse x)) (car (reverse x))) y))
358 (append (list origin)
359 (reverse (cdr (reverse pointlist)))) pointlist))))
361 (define-public (make-connected-path-stencil pointlist thickness
362 x-scale y-scale connect fill)
363 "Make a connected path described by the list @var{pointlist}, with
364 thickness @var{thickness}, and scaled by @var{x-scale} in the X direction
365 and @var{y-scale} in the Y direction. @var{connect} and @var{fill} are
366 boolean arguments that specify if the path should be connected or filled,
369 ;; paths using this routine are designed to begin at point '(0 . 0)
370 (let* ((origin (list 0 0))
371 (boundlist (path-min-max origin pointlist))
372 ;; modify pointlist to scale the coordinates
373 (path (map (lambda (x)
375 (if (eq? 6 (length x))
376 (lambda (x1 x2 x3 x4 x5 x6)
390 ;; a path must begin with a `moveto'
391 (prepend-origin (apply list (cons 'moveto origin) path))
392 ;; if this path is connected, add closepath to the end
393 (final-path (if connect
394 (append prepend-origin (list 'closepath))
396 (command-list (fold-right append '() final-path)))
405 ((if (< x-scale 0) reverse-interval identity)
406 (cons (* x-scale (list-ref boundlist 0))
407 (* x-scale (list-ref boundlist 1))))
408 `(,(/ thickness -2) . ,(/ thickness 2)))
410 ((if (< y-scale 0) reverse-interval identity)
411 (cons (* y-scale (list-ref boundlist 2))
412 (* y-scale (list-ref boundlist 3))))
413 `(,(/ thickness -2) . ,(/ thickness 2))))))
415 (define-public (make-ellipse-stencil x-radius y-radius thickness fill)
416 "Make an ellipse of x@tie{}radius @var{x-radius}, y@tie{}radius
417 @code{y-radius}, and thickness @var{thickness} with fill defined by
420 ((x-out-radius (+ x-radius (/ thickness 2.0)))
421 (y-out-radius (+ y-radius (/ thickness 2.0))) )
424 (list 'ellipse x-radius y-radius thickness fill)
425 (cons (- x-out-radius) x-out-radius)
426 (cons (- y-out-radius) y-out-radius))))
428 (define-public (box-grob-stencil grob)
429 "Make a box of exactly the extents of the grob. The box precisely
430 encloses the contents."
431 (let* ((xext (ly:grob-extent grob grob 0))
432 (yext (ly:grob-extent grob grob 1))
436 (make-filled-box-stencil xext (cons (- (car yext) thick) (car yext)))
437 (make-filled-box-stencil xext (cons (cdr yext) (+ (cdr yext) thick)))
438 (make-filled-box-stencil (cons (cdr xext) (+ (cdr xext) thick)) yext)
439 (make-filled-box-stencil (cons (- (car xext) thick) (car xext)) yext))))
441 ;; TODO merge this and prev function.
442 (define-public (box-stencil stencil thickness padding)
443 "Add a box around @var{stencil}, producing a new stencil."
444 (let* ((x-ext (interval-widen (ly:stencil-extent stencil 0) padding))
445 (y-ext (interval-widen (ly:stencil-extent stencil 1) padding))
446 (y-rule (make-filled-box-stencil (cons 0 thickness) y-ext))
447 (x-rule (make-filled-box-stencil
448 (interval-widen x-ext thickness) (cons 0 thickness))))
449 (set! stencil (ly:stencil-combine-at-edge stencil X 1 y-rule padding))
450 (set! stencil (ly:stencil-combine-at-edge stencil X -1 y-rule padding))
451 (set! stencil (ly:stencil-combine-at-edge stencil Y 1 x-rule 0.0))
452 (set! stencil (ly:stencil-combine-at-edge stencil Y -1 x-rule 0.0))
455 (define-public (circle-stencil stencil thickness padding)
456 "Add a circle around @var{stencil}, producing a new stencil."
457 (let* ((x-ext (ly:stencil-extent stencil X))
458 (y-ext (ly:stencil-extent stencil Y))
459 (diameter (max (interval-length x-ext)
460 (interval-length y-ext)))
461 (radius (+ (/ diameter 2) padding thickness))
462 (circle (make-circle-stencil radius thickness #f)))
466 (ly:stencil-translate circle
468 (interval-center x-ext)
469 (interval-center y-ext))))))
471 (define-public (oval-stencil stencil thickness x-padding y-padding)
472 "Add an oval around @code{stencil}, padded by the padding pair,
473 producing a new stencil."
474 (let* ((x-ext (ly:stencil-extent stencil X))
475 (y-ext (ly:stencil-extent stencil Y))
476 (x-length (+ (interval-length x-ext) x-padding thickness))
477 (y-length (+ (interval-length y-ext) y-padding thickness))
478 (x-radius (* 0.707 x-length) )
479 (y-radius (* 0.707 y-length) )
480 (oval (make-oval-stencil x-radius y-radius thickness #f)))
484 (ly:stencil-translate oval
486 (interval-center x-ext)
487 (interval-center y-ext))))))
489 (define-public (ellipse-stencil stencil thickness x-padding y-padding)
490 "Add an ellipse around @var{stencil}, padded by the padding pair,
491 producing a new stencil."
492 (let* ((x-ext (ly:stencil-extent stencil X))
493 (y-ext (ly:stencil-extent stencil Y))
494 (x-length (+ (interval-length x-ext) x-padding thickness))
495 (y-length (+ (interval-length y-ext) y-padding thickness))
496 ;(aspect-ratio (/ x-length y-length))
497 (x-radius (* 0.707 x-length) )
498 (y-radius (* 0.707 y-length) )
499 ;(diameter (max (- (cdr x-ext) (car x-ext))
500 ; (- (cdr y-ext) (car y-ext))))
501 ;(radius (+ (/ diameter 2) padding thickness))
502 (ellipse (make-ellipse-stencil x-radius y-radius thickness #f)))
506 (ly:stencil-translate ellipse
508 (interval-center x-ext)
509 (interval-center y-ext))))))
511 (define-public (rounded-box-stencil stencil thickness padding blot)
512 "Add a rounded box around @var{stencil}, producing a new stencil."
514 (let* ((xext (interval-widen (ly:stencil-extent stencil 0) padding))
515 (yext (interval-widen (ly:stencil-extent stencil 1) padding))
516 (min-ext (min (-(cdr xext) (car xext)) (-(cdr yext) (car yext))))
517 (ideal-blot (min blot (/ min-ext 2)))
518 (ideal-thickness (min thickness (/ min-ext 2)))
519 (outer (ly:round-filled-box
520 (interval-widen xext ideal-thickness)
521 (interval-widen yext ideal-thickness)
523 (inner (ly:make-stencil (list 'color (x11-color 'white)
524 (ly:stencil-expr (ly:round-filled-box
525 xext yext (- ideal-blot ideal-thickness)))))))
526 (set! stencil (ly:stencil-add outer inner))
529 (define-public (stencil-with-color stencil color)
531 (list 'color color (ly:stencil-expr stencil))
532 (ly:stencil-extent stencil X)
533 (ly:stencil-extent stencil Y)))
535 (define-public (stencil-whiteout stencil)
537 ((x-ext (ly:stencil-extent stencil X))
538 (y-ext (ly:stencil-extent stencil Y))
543 (stencil-with-color (ly:round-filled-box x-ext y-ext 0.0)
548 (define-public (arrow-stencil-maker start? end?)
549 "Return a function drawing a line from current point to @code{destination},
550 with optional arrows of @code{max-size} on start and end controlled by
551 @var{start?} and @var{end?}."
552 (lambda (destination max-size)
556 (distance (sqrt (+ (* (car destination) (car destination))
557 (* (cdr destination) (cdr destination)))))
558 (size (min max-size (/ distance 3)))
559 (rotate (lambda (z ang)
560 (* (make-polar 1 ang)
562 (complex-to-offset (lambda (z)
563 (list (real-part z) (imag-part z))))
565 (z-dest (+ (* e_x (car destination)) (* e_y (cdr destination))))
566 (e_z (/ z-dest (magnitude z-dest)))
567 (triangle-points (list
571 (p1s (map (lambda (z)
572 (+ z-dest (rotate z (angle z-dest))))
574 (p2s (map (lambda (z)
575 (rotate z (angle (- z-dest))))
580 `(polygon (quote ,(concatenate (map complex-to-offset p1s)))
585 `(polygon (quote ,(concatenate (map complex-to-offset p2s)))
588 (thickness (min (/ distance 12) 0.1))
589 (shorten-line (min (/ distance 3) 0.5))
590 (start (complex-to-offset (/ (* e_z shorten-line) 2)))
591 (end (complex-to-offset (- z-dest (/ (* e_z shorten-line) 2))))
593 (line (ly:make-stencil
594 `(draw-line ,thickness
595 ,(car start) ,(cadr start)
596 ,(car end) ,(cadr end)
598 (cons (min 0 (car destination))
599 (min 0 (cdr destination)))
600 (cons (max 0 (car destination))
601 (max 0 (cdr destination)))))
605 (if start? arrow-2 empty-stencil)
606 (if end? arrow-1 empty-stencil)
611 (define-public dimension-arrows (arrow-stencil-maker #t #t))
613 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
616 ;; annotations are arrows indicating the numerical value of
618 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
620 (define*-public (annotate-y-interval layout name extent is-length
621 #:key (color darkblue))
622 (let ((text-props (cons '((font-size . -3)
623 (font-family . typewriter))
624 (layout-extract-page-properties layout)))
626 (define (center-stencil-on-extent stil)
627 (ly:stencil-translate (ly:stencil-aligned-to stil Y CENTER)
628 (cons 0 (interval-center extent))))
629 ;; do something sensible for 0,0 intervals.
630 (set! extent (interval-widen extent 0.001))
631 (if (not (interval-sane? extent))
632 (set! annotation (interpret-markup
634 (make-simple-markup (simple-format #f "~a: NaN/inf" name))))
635 (let ((text-stencil (interpret-markup
637 (markup #:whiteout #:simple name)))
638 (dim-stencil (interpret-markup
642 ((interval-empty? extent)
645 (ly:format "~$" (interval-length extent)))
648 (car extent) (cdr extent)))))))
649 (arrows (ly:stencil-translate-axis
650 (dimension-arrows (cons 0 (interval-length extent)) 1.0)
651 (interval-start extent) Y)))
653 (center-stencil-on-extent text-stencil))
655 (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5))
657 (ly:stencil-combine-at-edge annotation X LEFT
658 (center-stencil-on-extent dim-stencil)
661 (stencil-with-color annotation color))))
665 ;; TODO: figure out how to annotate padding nicely
666 ;; TODO: emphasize either padding or min-dist depending on which constraint was active
667 (define*-public (annotate-spacing-spec layout spacing-spec start-Y-offset next-staff-Y
668 #:key (base-color blue))
669 (let* ((get-spacing-var (lambda (sym) (assoc-get sym spacing-spec 0.0)))
670 (space (get-spacing-var 'basic-distance))
671 (padding (get-spacing-var 'padding))
672 (min-dist (get-spacing-var 'minimum-distance))
673 (contrast-color (append (cdr base-color) (list (car base-color))))
674 (min-dist-blocks (<= (- start-Y-offset min-dist) next-staff-Y))
675 (min-dist-color (if min-dist-blocks contrast-color base-color))
676 (basic-annotation (annotate-y-interval layout
678 (cons (- start-Y-offset space) start-Y-offset)
680 #:color (map (lambda (x) (* x 0.25)) base-color)))
681 (min-annotation (annotate-y-interval layout
683 (cons (- start-Y-offset min-dist) start-Y-offset)
685 #:color min-dist-color))
686 (extra-annotation (annotate-y-interval layout
688 (cons next-staff-Y (- start-Y-offset min-dist))
690 #:color (map (lambda (x) (* x 0.5)) min-dist-color))))
692 (stack-stencils X RIGHT 0.0
697 (ly:stencil-add min-annotation extra-annotation))))))
699 (define-public (eps-file->stencil axis size file-name)
701 ((contents (ly:gulp-file file-name))
702 (bbox (get-postscript-bbox (car (string-split contents #\nul))))
703 (bbox-size (if (= axis X)
704 (- (list-ref bbox 2) (list-ref bbox 0))
705 (- (list-ref bbox 3) (list-ref bbox 1))
707 (factor (if (< 0 bbox-size)
708 (exact->inexact (/ size bbox-size))
711 (map (lambda (x) (* factor x)) bbox))
712 ; We need to shift the whole eps to (0,0), otherwise it will appear
713 ; displaced in lilypond (displacement will depend on the scaling!)
714 (translate-string (ly:format "~a ~a translate" (- (list-ref bbox 0)) (- (list-ref bbox 1))))
715 (clip-rect-string (ly:format
716 "~a ~a ~a ~a rectclip"
719 (- (list-ref bbox 2) (list-ref bbox 0))
720 (- (list-ref bbox 3) (list-ref bbox 1)))))
731 currentpoint translate
737 " factor translate-string clip-rect-string
746 ; Stencil starts at (0,0), since we have shifted the eps, and its
747 ; size is exactly the size of the scaled bounding box
748 (cons 0 (- (list-ref scaled-bbox 2) (list-ref scaled-bbox 0)))
749 (cons 0 (- (list-ref scaled-bbox 3) (list-ref scaled-bbox 1))))
751 (ly:make-stencil "" '(0 . 0) '(0 . 0)))
754 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
755 ;; output signatures.
757 (define-public (write-system-signatures basename paper-systems count)
758 (if (pair? paper-systems)
761 ((outname (simple-format #f "~a-~a.signature" basename count)) )
763 (ly:message "Writing ~a" outname)
764 (write-system-signature outname (car paper-systems))
765 (write-system-signatures basename (cdr paper-systems) (1+ count))))))
767 (use-modules (scm paper-system))
768 (define-public (write-system-signature filename paper-system)
770 (and (number? x) (inexact? x)))
773 (paper-system-system-grob paper-system))
775 (define output (open-output-file filename))
777 ;; todo: optionally use a command line flag? Or just junk this?
778 (define compare-expressions #f)
779 (define (strip-floats expr)
780 "Replace floats by #f"
783 ((ly:font-metric? expr) (ly:font-name expr))
784 ((pair? expr) (cons (strip-floats (car expr))
785 (strip-floats (cdr expr))))
788 (define (fold-false-pairs expr)
789 "Try to remove lists of #f as much as possible."
793 (rest (fold-false-pairs (cdr expr))))
796 (cons (fold-false-pairs first) rest)
800 (define (raw-string expr)
801 "escape quotes and slashes for python consumption"
802 (regexp-substitute/global #f "[@\n]" (simple-format #f "~a" expr) 'pre " " 'post))
804 (define (raw-pair expr)
805 (simple-format #f "~a ~a"
806 (car expr) (cdr expr)))
808 (define (found-grob expr)
813 (cause (event-cause grob))
814 (input (if (ly:stream-event? cause) (ly:event-property cause 'origin) #f))
815 (location (if (ly:input-location? input) (ly:input-file-line-char-column input) '()))
817 ;; todo: use stencil extent if available.
818 (x-ext (ly:grob-extent grob system-grob X))
819 (y-ext (ly:grob-extent grob system-grob Y))
821 (if compare-expressions
822 (interpret-for-signature
824 (set! collected (cons e collected)))
828 (simple-format output
830 (cdr (assq 'name (ly:grob-property grob 'meta) ))
831 (raw-string location)
832 (raw-pair (if (interval-empty? x-ext) '(1 . -1) x-ext))
833 (raw-pair (if (interval-empty? y-ext) '(1 . -1) y-ext))
834 (raw-string collected))
837 (define (interpret-for-signature escape collect expr)
838 (define (interpret expr)
840 ((head (if (pair? expr)
845 ((eq? head 'grob-cause) (escape (cdr expr)))
846 ((eq? head 'color) (interpret (caddr expr)))
847 ((eq? head 'rotate-stencil) (interpret (caddr expr)))
848 ((eq? head 'translate-stencil) (interpret (caddr expr)))
849 ((eq? head 'combine-stencil)
850 (for-each (lambda (e) (interpret e)) (cdr expr)))
852 (collect (fold-false-pairs (strip-floats expr))))
858 (if (ly:grob? system-grob)
860 (display (simple-format #f "# Output signature\n# Generated by LilyPond ~a\n" (lilypond-version))
862 (interpret-for-signature found-grob (lambda (x) #f)
864 (paper-system-stencil paper-system)))))
866 ;; should be superfluous, but leaking "too many open files"?