X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=scm%2Fstencil.scm;h=fb46ef7251cf7eef4733eeff09711ced4da1b44a;hb=9eb7b52b9154259f98c00c7fe868dbba609727a8;hp=283f04fe2d6665055ab605b3eb564a0b63e8f874;hpb=f0e8911e5a86748a9c70afcee42b6a3618dbef10;p=lilypond.git diff --git a/scm/stencil.scm b/scm/stencil.scm index 283f04fe2d..fb46ef7251 100644 --- a/scm/stencil.scm +++ b/scm/stencil.scm @@ -2,7 +2,7 @@ ;;;; ;;;; source file of the GNU LilyPond music typesetter ;;;; -;;;; (c) 2003--2006 Han-Wen Nienhuys +;;;; (c) 2003--2007 Han-Wen Nienhuys (define-public (stack-stencils axis dir padding stils) "Stack stencils STILS in direction AXIS, DIR, using PADDING." @@ -80,10 +80,13 @@ (define-public (make-circle-stencil radius thickness fill) "Make a circle of radius @var{radius} and thickness @var{thickness}" + (let* + ((out-radius (+ radius (/ thickness 2.0)))) + (ly:make-stencil (list 'circle radius thickness fill) - (cons (- radius) radius) - (cons (- radius) radius))) + (cons (- out-radius) out-radius) + (cons (- out-radius) out-radius)))) (define-public (box-grob-stencil grob) "Make a box of exactly the extents of the grob. The box precisely @@ -129,6 +132,24 @@ encloses the contents. (interval-center x-ext) (interval-center y-ext)))))) +(define-public (rounded-box-stencil stencil thickness padding blot) + "Add a rounded box around STENCIL, producing a new stencil." + + (let* ((xext (interval-widen (ly:stencil-extent stencil 0) padding)) + (yext (interval-widen (ly:stencil-extent stencil 1) padding)) + (min-ext (min (-(cdr xext) (car xext)) (-(cdr yext) (car yext)))) + (ideal-blot (min blot (/ min-ext 2))) + (ideal-thickness (min thickness (/ min-ext 2))) + (outer (ly:round-filled-box + (interval-widen xext ideal-thickness) + (interval-widen yext ideal-thickness) + ideal-blot)) + (inner (ly:make-stencil (list 'color (x11-color 'white) + (ly:stencil-expr (ly:round-filled-box + xext yext (- ideal-blot ideal-thickness))))))) + (set! stencil (ly:stencil-add outer inner)) + stencil)) + (define-public (fontify-text font-metric text) "Set TEXT with font FONT-METRIC, returning a stencil." @@ -238,7 +259,7 @@ encloses the contents. (if (not (interval-sane? extent)) (set! annotation (interpret-markup layout text-props - (make-simple-markup (format "~a: NaN/inf" name)))) + (make-simple-markup (simple-format #f "~a: NaN/inf" name)))) (let ((text-stencil (interpret-markup layout text-props (markup #:whiteout #:simple name))) @@ -249,9 +270,9 @@ encloses the contents. ((interval-empty? extent) (format "empty")) (is-length - (format "~$" (interval-length extent))) + (ly:format "~$" (interval-length extent))) (else - (format "(~$,~$)" + (ly:format "(~$,~$)" (car extent) (cdr extent))))))) (arrows (ly:stencil-translate-axis (dimension-arrows (cons 0 (interval-length extent))) @@ -274,28 +295,39 @@ encloses the contents. (define-public (eps-file->stencil axis size file-name) (let* ((contents (ly:gulp-file file-name)) - (bbox (get-postscript-bbox contents)) + (bbox (get-postscript-bbox (car (string-split contents #\nul)))) (bbox-size (if (= axis X) (- (list-ref bbox 2) (list-ref bbox 0)) (- (list-ref bbox 3) (list-ref bbox 1)) )) - (factor (exact->inexact (/ size bbox-size))) + (factor (if (< 0 bbox-size) + (exact->inexact (/ size bbox-size)) + 0)) (scaled-bbox - (map (lambda (x) (* factor x)) bbox))) + (map (lambda (x) (* factor x)) bbox)) + (clip-rect-string (ly:format + "~a ~a ~a ~a rectclip" + (list-ref bbox 0) + (list-ref bbox 1) + (- (list-ref bbox 2) (list-ref bbox 0)) + (- (list-ref bbox 3) (list-ref bbox 1))))) + (if bbox (ly:make-stencil (list 'embedded-ps (string-append - (format + (ly:format " gsave currentpoint translate BeginEPSF -~a ~a scale +~a dup scale +~a %%BeginDocument: ~a -" factor factor +" factor clip-rect-string + file-name ) contents @@ -317,13 +349,12 @@ grestore (if (pair? paper-systems) (begin (let* - ((outname (format "~a-~a.signature" basename count)) ) + ((outname (simple-format #f "~a-~a.signature" basename count)) ) (ly:message "Writing ~a" outname) (write-system-signature outname (car paper-systems)) (write-system-signatures basename (cdr paper-systems) (1+ count)))))) - (use-modules (scm paper-system)) (define-public (write-system-signature filename paper-system) (define (float? x) @@ -333,7 +364,9 @@ grestore (paper-system-system-grob paper-system)) (define output (open-output-file filename)) - + + ;; todo: optionally use a command line flag? Or just junk this? + (define compare-expressions #f) (define (strip-floats expr) "Replace floats by #f" (cond @@ -355,22 +388,12 @@ grestore rest)) expr)) - - (define (pythonic-string expr) - "escape quotes and slashes for python consumption" - (regexp-substitute/global #f "([\n\\\\'\"])" (format "~a" expr) 'pre "\\" 1 'post)) - - (define (pythonic-pair expr) - (format "(~a,~a)" - (car expr) (cdr expr))) - - (define (raw-string expr) "escape quotes and slashes for python consumption" - (regexp-substitute/global #f "[@\n]" (format "~a" expr) 'pre " " 'post)) + (regexp-substitute/global #f "[@\n]" (simple-format #f "~a" expr) 'pre " " 'post)) (define (raw-pair expr) - (format "~a ~a" + (simple-format #f "~a ~a" (car expr) (cdr expr))) (define (found-grob expr) @@ -385,13 +408,15 @@ grestore ;; todo: use stencil extent if available. (x-ext (ly:grob-extent grob system-grob X)) (y-ext (ly:grob-extent grob system-grob Y)) - ) - - (interpret-for-signature #f (lambda (e) - (set! collected (cons e collected))) - rest) - - (format output + (expression-skeleton + (if compare-expressions + (interpret-for-signature + #f (lambda (e) + (set! collected (cons e collected))) + rest) + ""))) + + (simple-format output "~a@~a@~a@~a@~a\n" (cdr (assq 'name (ly:grob-property grob 'meta) )) (raw-string location) @@ -423,7 +448,7 @@ grestore (if (ly:grob? system-grob) (begin - (display (format "# Output signature\n# Generated by LilyPond ~a\n" (lilypond-version)) + (display (simple-format #f "# Output signature\n# Generated by LilyPond ~a\n" (lilypond-version)) output) (interpret-for-signature found-grob (lambda (x) #f) (ly:stencil-expr