3 ;;;; source file of the GNU LilyPond music typesetter
5 ;;;; (c) 2003--2009 Han-Wen Nienhuys <hanwen@xs4all.nl>
7 (define-public (stack-stencils axis dir padding stils)
8 "Stack stencils STILS in direction AXIS, DIR, using PADDING."
10 ((null? stils) empty-stencil)
11 ((null? (cdr stils)) (car stils))
12 (else (ly:stencil-combine-at-edge
13 (car stils) axis dir (stack-stencils axis dir padding (cdr stils))
16 (define-public (stack-stencils-padding-list axis dir padding stils)
17 "Stack stencils STILS in direction AXIS, DIR, using a list of PADDING."
19 ((null? stils) empty-stencil)
20 ((null? (cdr stils)) (car stils))
21 (else (ly:stencil-combine-at-edge
24 (stack-stencils-padding-list axis dir (cdr padding) (cdr stils))
27 (define-public (centered-stencil stencil)
28 "Center stencil @var{stencil} in both the X and Y directions"
29 (ly:stencil-aligned-to (ly:stencil-aligned-to stencil X CENTER) Y CENTER))
31 (define-public (stack-lines dir padding baseline stils)
32 "Stack vertically with a baseline-skip."
33 (define result empty-stencil)
36 ((last-stencil #f (car p))
43 (let* ((dy (max (+ (* dir (interval-bound (ly:stencil-extent last-stencil Y) dir))
45 (* (- dir) (interval-bound (ly:stencil-extent (car p) Y) (- dir))))
47 (y (+ last-y (* dir dy))))
52 (ly:stencil-add result (ly:stencil-translate-axis (car p) y Y)))
56 (set! result (car p)))))
61 (define-public (bracketify-stencil stil axis thick protrusion padding)
62 "Add brackets around STIL, producing a new stencil."
64 (let* ((ext (ly:stencil-extent stil axis))
65 (lb (ly:bracket axis ext thick protrusion))
66 (rb (ly:bracket axis ext thick (- protrusion))))
68 (ly:stencil-combine-at-edge stil (other-axis axis) 1 rb padding))
70 (ly:stencil-combine-at-edge lb (other-axis axis) 1 stil padding))
73 (define-public (make-line-stencil width startx starty endx endy)
74 "Make a line stencil of given linewidth and set its extents accordingly"
75 (let ((xext (cons (min startx endx) (max startx endx)))
76 (yext (cons (min starty endy) (max starty endy))))
78 (list 'draw-line width startx starty endx endy)
79 ; Since the line has rounded edges, we have to / can safely add half the
80 ; width to all coordinates!
81 (interval-widen xext (/ width 2))
82 (interval-widen yext (/ width 2)))))
85 (define-public (make-filled-box-stencil xext yext)
89 (list 'round-filled-box (- (car xext)) (cdr xext)
90 (- (car yext)) (cdr yext) 0.0)
93 (define-public (make-circle-stencil radius thickness fill)
94 "Make a circle of radius @var{radius} and thickness @var{thickness}"
96 ((out-radius (+ radius (/ thickness 2.0))))
99 (list 'circle radius thickness fill)
100 (cons (- out-radius) out-radius)
101 (cons (- out-radius) out-radius))))
103 (define-public (make-oval-stencil x-radius y-radius thickness fill)
104 "Make an oval from two Bezier curves, of x radius @var{x-radius},
105 y radius @code{y-radius},
106 and thickness @var{thickness} with fill defined by @code{fill}."
108 ((x-out-radius (+ x-radius (/ thickness 2.0)))
109 (y-out-radius (+ y-radius (/ thickness 2.0))) )
112 (list 'oval x-radius y-radius thickness fill)
113 (cons (- x-out-radius) x-out-radius)
114 (cons (- y-out-radius) y-out-radius))))
116 (define-public (make-ellipse-stencil x-radius y-radius thickness fill)
117 "Make an ellipse of x radius @var{x-radius}, y radius @code{y-radius},
118 and thickness @var{thickness} with fill defined by @code{fill}."
120 ((x-out-radius (+ x-radius (/ thickness 2.0)))
121 (y-out-radius (+ y-radius (/ thickness 2.0))) )
124 (list 'ellipse x-radius y-radius thickness fill)
125 (cons (- x-out-radius) x-out-radius)
126 (cons (- y-out-radius) y-out-radius))))
128 (define-public (box-grob-stencil grob)
129 "Make a box of exactly the extents of the grob. The box precisely
130 encloses the contents.
132 (let* ((xext (ly:grob-extent grob grob 0))
133 (yext (ly:grob-extent grob grob 1))
137 (make-filled-box-stencil xext (cons (- (car yext) thick) (car yext)))
138 (make-filled-box-stencil xext (cons (cdr yext) (+ (cdr yext) thick)))
139 (make-filled-box-stencil (cons (cdr xext) (+ (cdr xext) thick)) yext)
140 (make-filled-box-stencil (cons (- (car xext) thick) (car xext)) yext))))
142 ;; TODO merge this and prev function.
143 (define-public (box-stencil stencil thickness padding)
144 "Add a box around STENCIL, producing a new stencil."
145 (let* ((x-ext (interval-widen (ly:stencil-extent stencil 0) padding))
146 (y-ext (interval-widen (ly:stencil-extent stencil 1) padding))
147 (y-rule (make-filled-box-stencil (cons 0 thickness) y-ext))
148 (x-rule (make-filled-box-stencil
149 (interval-widen x-ext thickness) (cons 0 thickness))))
150 (set! stencil (ly:stencil-combine-at-edge stencil X 1 y-rule padding))
151 (set! stencil (ly:stencil-combine-at-edge stencil X -1 y-rule padding))
152 (set! stencil (ly:stencil-combine-at-edge stencil Y 1 x-rule 0.0))
153 (set! stencil (ly:stencil-combine-at-edge stencil Y -1 x-rule 0.0))
156 (define-public (circle-stencil stencil thickness padding)
157 "Add a circle around STENCIL, producing a new stencil."
158 (let* ((x-ext (ly:stencil-extent stencil X))
159 (y-ext (ly:stencil-extent stencil Y))
160 (diameter (max (interval-length x-ext)
161 (interval-length y-ext)))
162 (radius (+ (/ diameter 2) padding thickness))
163 (circle (make-circle-stencil radius thickness #f)))
167 (ly:stencil-translate circle
169 (interval-center x-ext)
170 (interval-center y-ext))))))
172 (define-public (oval-stencil stencil thickness x-padding y-padding)
173 "Add an oval around @code{stencil}, padded by the padding pair,
174 producing a new stencil."
175 (let* ((x-ext (ly:stencil-extent stencil X))
176 (y-ext (ly:stencil-extent stencil Y))
177 (x-length (+ (interval-length x-ext) x-padding thickness))
178 (y-length (+ (interval-length y-ext) y-padding thickness))
179 (x-radius (* 0.707 x-length) )
180 (y-radius (* 0.707 y-length) )
181 (oval (make-oval-stencil x-radius y-radius thickness #f)))
185 (ly:stencil-translate oval
187 (interval-center x-ext)
188 (interval-center y-ext))))))
190 (define-public (ellipse-stencil stencil thickness x-padding y-padding)
191 "Add an ellipse around STENCIL, padded by the padding pair,
192 producing a new stencil."
193 (let* ((x-ext (ly:stencil-extent stencil X))
194 (y-ext (ly:stencil-extent stencil Y))
195 (x-length (+ (interval-length x-ext) x-padding thickness))
196 (y-length (+ (interval-length y-ext) y-padding thickness))
197 ;(aspect-ratio (/ x-length y-length))
198 (x-radius (* 0.707 x-length) )
199 (y-radius (* 0.707 y-length) )
200 ;(diameter (max (- (cdr x-ext) (car x-ext))
201 ; (- (cdr y-ext) (car y-ext))))
202 ;(radius (+ (/ diameter 2) padding thickness))
203 (ellipse (make-ellipse-stencil x-radius y-radius thickness #f)))
207 (ly:stencil-translate ellipse
209 (interval-center x-ext)
210 (interval-center y-ext))))))
212 (define-public (rounded-box-stencil stencil thickness padding blot)
213 "Add a rounded box around STENCIL, producing a new stencil."
215 (let* ((xext (interval-widen (ly:stencil-extent stencil 0) padding))
216 (yext (interval-widen (ly:stencil-extent stencil 1) padding))
217 (min-ext (min (-(cdr xext) (car xext)) (-(cdr yext) (car yext))))
218 (ideal-blot (min blot (/ min-ext 2)))
219 (ideal-thickness (min thickness (/ min-ext 2)))
220 (outer (ly:round-filled-box
221 (interval-widen xext ideal-thickness)
222 (interval-widen yext ideal-thickness)
224 (inner (ly:make-stencil (list 'color (x11-color 'white)
225 (ly:stencil-expr (ly:round-filled-box
226 xext yext (- ideal-blot ideal-thickness)))))))
227 (set! stencil (ly:stencil-add outer inner))
231 (define-public (fontify-text font-metric text)
232 "Set TEXT with font FONT-METRIC, returning a stencil."
233 (let* ((b (ly:text-dimension font-metric text)))
235 `(text ,font-metric ,text) (car b) (cdr b))))
237 (define-public (fontify-text-white scale font-metric text)
238 "Set TEXT with scale factor SCALE"
239 (let* ((b (ly:text-dimension font-metric text))
240 ;;urg -- workaround for using ps font
241 (c `(white-text ,(* 2 scale) ,text)))
242 ;;urg -- extent is not from ps font, but we hope it's close
243 (ly:make-stencil c (car b) (cdr b))))
245 (define-public (stencil-with-color stencil color)
247 (list 'color color (ly:stencil-expr stencil))
248 (ly:stencil-extent stencil X)
249 (ly:stencil-extent stencil Y)))
251 (define-public (stencil-whiteout stencil)
253 ((x-ext (ly:stencil-extent stencil X))
254 (y-ext (ly:stencil-extent stencil Y))
259 (stencil-with-color (ly:round-filled-box x-ext y-ext 0.0)
264 (define-public (dimension-arrows destination max-size)
265 "Draw twosided arrow from here to @var{destination}"
270 (distance (sqrt (+ (* (car destination) (car destination))
271 (* (cdr destination) (cdr destination)))))
272 (size (min max-size (/ distance 3)))
273 (rotate (lambda (z ang)
274 (* (make-polar 1 ang)
276 (complex-to-offset (lambda (z)
277 (list (real-part z) (imag-part z))))
279 (z-dest (+ (* e_x (car destination)) (* e_y (cdr destination))))
280 (e_z (/ z-dest (magnitude z-dest)))
281 (triangle-points (list
285 (p1s (map (lambda (z)
286 (+ z-dest (rotate z (angle z-dest))))
288 (p2s (map (lambda (z)
289 (rotate z (angle (- z-dest))))
294 `(polygon (quote ,(concatenate (map complex-to-offset p1s)))
299 `(polygon (quote ,(concatenate (map complex-to-offset p2s)))
302 (thickness (min (/ distance 12) 0.1))
303 (shorten-line (min (/ distance 3) 0.5))
304 (start (complex-to-offset (/ (* e_z shorten-line) 2)))
305 (end (complex-to-offset (- z-dest (/ (* e_z shorten-line) 2))))
307 (line (ly:make-stencil
308 `(draw-line ,thickness
309 ,(car start) ,(cadr start)
310 ,(car end) ,(cadr end)
312 (cons (min 0 (car destination))
313 (min 0 (cdr destination)))
314 (cons (max 0 (car destination))
315 (max 0 (cdr destination)))))
317 (result (ly:stencil-add arrow-2 arrow-1 line)))
322 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
325 ;; annotations are arrows indicating the numerical value of
327 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
329 (define*-public (annotate-y-interval layout name extent is-length
330 #:key (color darkblue))
331 (let ((text-props (cons '((font-size . -3)
332 (font-family . typewriter))
333 (layout-extract-page-properties layout)))
335 (define (center-stencil-on-extent stil)
336 (ly:stencil-translate (ly:stencil-aligned-to stil Y CENTER)
337 (cons 0 (interval-center extent))))
338 ;; do something sensible for 0,0 intervals.
339 (set! extent (interval-widen extent 0.001))
340 (if (not (interval-sane? extent))
341 (set! annotation (interpret-markup
343 (make-simple-markup (simple-format #f "~a: NaN/inf" name))))
344 (let ((text-stencil (interpret-markup
346 (markup #:whiteout #:simple name)))
347 (dim-stencil (interpret-markup
351 ((interval-empty? extent)
354 (ly:format "~$" (interval-length extent)))
357 (car extent) (cdr extent)))))))
358 (arrows (ly:stencil-translate-axis
359 (dimension-arrows (cons 0 (interval-length extent)) 1.0)
360 (interval-start extent) Y)))
362 (center-stencil-on-extent text-stencil))
364 (ly:stencil-combine-at-edge arrows X RIGHT annotation 0.5))
366 (ly:stencil-combine-at-edge annotation X LEFT
367 (center-stencil-on-extent dim-stencil)
370 (ly:make-stencil (list 'color color (ly:stencil-expr annotation))
371 (ly:stencil-extent annotation X)
372 (cons 10000 -10000)))))
376 (define*-public (annotate-spacing-spec layout spacing-spec start-Y-offset prev-system-end
377 #:key (base-color blue))
378 (let* ((get-spacing-var (lambda (sym) (assoc-get sym spacing-spec 0.0)))
379 (space (get-spacing-var 'space))
380 (padding (get-spacing-var 'padding))
381 (min-dist (get-spacing-var 'minimum-distance))
382 (contrast-color (append (cdr base-color) (list (car base-color)))))
383 (stack-stencils X RIGHT 0.0
385 (annotate-y-interval layout
387 (cons (- start-Y-offset space) start-Y-offset)
389 #:color (map (lambda (x) (* x 0.25)) base-color))
390 (annotate-y-interval layout
392 (cons (- start-Y-offset min-dist) start-Y-offset)
394 #:color (map (lambda (x) (* x 0.5)) base-color))
396 (annotate-y-interval layout
398 (cons prev-system-end start-Y-offset)
401 (annotate-y-interval layout
403 (cons (- prev-system-end padding) prev-system-end)
405 #:color contrast-color))))))
408 (define-public (eps-file->stencil axis size file-name)
410 ((contents (ly:gulp-file file-name))
411 (bbox (get-postscript-bbox (car (string-split contents #\nul))))
412 (bbox-size (if (= axis X)
413 (- (list-ref bbox 2) (list-ref bbox 0))
414 (- (list-ref bbox 3) (list-ref bbox 1))
416 (factor (if (< 0 bbox-size)
417 (exact->inexact (/ size bbox-size))
420 (map (lambda (x) (* factor x)) bbox))
421 ; We need to shift the whole eps to (0,0), otherwise it will appear
422 ; displaced in lilypond (displacement will depend on the scaling!)
423 (translate-string (ly:format "~a ~a translate" (- (list-ref bbox 0)) (- (list-ref bbox 1))))
424 (clip-rect-string (ly:format
425 "~a ~a ~a ~a rectclip"
428 (- (list-ref bbox 2) (list-ref bbox 0))
429 (- (list-ref bbox 3) (list-ref bbox 1)))))
440 currentpoint translate
446 " factor translate-string clip-rect-string
455 ; Stencil starts at (0,0), since we have shifted the eps, and its
456 ; size is exactly the size of the scaled bounding box
457 (cons 0 (- (list-ref scaled-bbox 2) (list-ref scaled-bbox 0)))
458 (cons 0 (- (list-ref scaled-bbox 3) (list-ref scaled-bbox 1))))
460 (ly:make-stencil "" '(0 . 0) '(0 . 0)))
463 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
464 ;; output signatures.
466 (define-public (write-system-signatures basename paper-systems count)
467 (if (pair? paper-systems)
470 ((outname (simple-format #f "~a-~a.signature" basename count)) )
472 (ly:message "Writing ~a" outname)
473 (write-system-signature outname (car paper-systems))
474 (write-system-signatures basename (cdr paper-systems) (1+ count))))))
476 (use-modules (scm paper-system))
477 (define-public (write-system-signature filename paper-system)
479 (and (number? x) (inexact? x)))
482 (paper-system-system-grob paper-system))
484 (define output (open-output-file filename))
486 ;; todo: optionally use a command line flag? Or just junk this?
487 (define compare-expressions #f)
488 (define (strip-floats expr)
489 "Replace floats by #f"
492 ((ly:font-metric? expr) (ly:font-name expr))
493 ((pair? expr) (cons (strip-floats (car expr))
494 (strip-floats (cdr expr))))
497 (define (fold-false-pairs expr)
498 "Try to remove lists of #f as much as possible."
502 (rest (fold-false-pairs (cdr expr))))
505 (cons (fold-false-pairs first) rest)
509 (define (raw-string expr)
510 "escape quotes and slashes for python consumption"
511 (regexp-substitute/global #f "[@\n]" (simple-format #f "~a" expr) 'pre " " 'post))
513 (define (raw-pair expr)
514 (simple-format #f "~a ~a"
515 (car expr) (cdr expr)))
517 (define (found-grob expr)
522 (cause (event-cause grob))
523 (input (if (ly:stream-event? cause) (ly:event-property cause 'origin) #f))
524 (location (if (ly:input-location? input) (ly:input-file-line-char-column input) '()))
526 ;; todo: use stencil extent if available.
527 (x-ext (ly:grob-extent grob system-grob X))
528 (y-ext (ly:grob-extent grob system-grob Y))
530 (if compare-expressions
531 (interpret-for-signature
533 (set! collected (cons e collected)))
537 (simple-format output
539 (cdr (assq 'name (ly:grob-property grob 'meta) ))
540 (raw-string location)
541 (raw-pair (if (interval-empty? x-ext) '(1 . -1) x-ext))
542 (raw-pair (if (interval-empty? y-ext) '(1 . -1) y-ext))
543 (raw-string collected))
546 (define (interpret-for-signature escape collect expr)
547 (define (interpret expr)
549 ((head (if (pair? expr)
554 ((eq? head 'grob-cause) (escape (cdr expr)))
555 ((eq? head 'color) (interpret (caddr expr)))
556 ((eq? head 'rotate-stencil) (interpret (caddr expr)))
557 ((eq? head 'translate-stencil) (interpret (caddr expr)))
558 ((eq? head 'combine-stencil)
559 (for-each (lambda (e) (interpret e)) (cdr expr)))
561 (collect (fold-false-pairs (strip-floats expr))))
567 (if (ly:grob? system-grob)
569 (display (simple-format #f "# Output signature\n# Generated by LilyPond ~a\n" (lilypond-version))
571 (interpret-for-signature found-grob (lambda (x) #f)
573 (paper-system-stencil paper-system)))))
575 ;; should be superfluous, but leaking "too many open files"?