diff options
| -rw-r--r-- | configure.ac | 1 | ||||
| -rw-r--r-- | pict.scm | 136 |
2 files changed, 96 insertions, 41 deletions
diff --git a/configure.ac b/configure.ac index 175f2fc..4f43f9f 100644 --- a/configure.ac +++ b/configure.ac @@ -30,6 +30,7 @@ if test "x$GUILD" = "x"; then AC_MSG_ERROR(['guild' binary not found; please check your Guile installation.]) fi +GUILE_MODULE_REQUIRED(cairo) GUILE_MODULE_REQUIRED(rsvg) AC_PATH_PROG([RSVG_CONVERT], [rsvg-convert]) @@ -27,11 +27,13 @@ #:use-module (ice-9 binary-ports) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-4) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (rsvg) + #:use-module (cairo) #:use-module (ice-9 match) #:export (pict? pict-sxml @@ -147,6 +149,7 @@ the file to determine the file name. Return the file name." ".svg"))))) (format port "#<Image: ~a>" name)))) +(define %dpi 72) ; like cairo ;;; Miscellaneous utilities @@ -789,51 +792,102 @@ filled with black." ;; use path-aligned text, but that also won't work. To work around ;; this problem we first compute the full height of rendered text with ;; U+2588 and then align the text. - (define* (text txt #:key (color "black") (font-family "sans-serif") (font-size 32) - (font-style "normal") - (font-weight "normal")) - "Render the provided string TXT. The keywords COLOR, FONT-FAMILY, -FONT-SIZE, FONT-STYLE, and FONT-WEIGHT can be used to change the -appearance." - ;; This is more complicated than it should be because librsvg does - ;; not seem to support dominant-baseline. - (let ((make-text (lambda (content) - (let ((height (string-append (number->string font-size) "px"))) - `(text (@ (style ,(style-list->string - `(("fill" ,color) - ("font-family" ,font-family) - ("font-style" ,font-style)))) - (font-size ,height) - (font-weight ,font-weight) - (y ,(format #f "~apx" font-size))) - ,content))))) - (let ((full-height - (let ((h (rsvg-handle-new))) - (rsvg-handle-write h (with-output-to-string - (lambda _ (sxml->xml `(svg ,(make-text "█")))))) - (call-with-values (lambda () (rsvg-handle-get-dimensions h)) - (lambda (width full-height . rest) - ;; XXX sometimes closing the handle fails... - (false-if-exception (rsvg-handle-close h)) - full-height)))) - (h (rsvg-handle-new)) - (text-tag (make-text txt))) - (rsvg-handle-write h (with-output-to-string - (lambda _ (sxml->xml `(svg ,text-tag))))) - (call-with-values (lambda () (rsvg-handle-get-dimensions h)) - (lambda (width height . rest) - ;; XXX sometimes closing the handle fails... - (false-if-exception (rsvg-handle-close h)) - (make-pict `(svg (@ (height ,(format #f "~apx" full-height)) - ;; TODO: for some reason the width is insufficient - (width ,(format #f "~apx" (+ width 5))) - (x 0) - (y 0)) - ,text-tag))))))) + (font-style 'normal) + (font-weight 'normal)) + "Render the provided string TXT. The keywords COLOR (a string), +FONT-FAMILY (a string), FONT-SIZE (an integer), FONT-STYLE (a symbol), +and FONT-WEIGHT (also a symbol) can be used to change the appearance." + ;; Return ascent, descent, height, max_x_advance, max_y_advance + (define (font-extents) + (call-with-values + (lambda () + (let ((surf #f)) + (dynamic-wind + (const #f) + (lambda () + (set! surf (cairo-image-surface-create 'rgb24 1 1)) + (let ((ctx (cairo-create surf))) + (cairo-select-font-face ctx font-family font-style font-weight) + (cairo-set-font-size ctx font-size) + (cairo-font-extents ctx))) + (lambda () + (when surf + (cairo-surface-finish surf) + (cairo-surface-destroy surf)))))) + (lambda (dimensions) + (apply values (f64vector->list dimensions))))) + (define (text-extents) + (call-with-values + (lambda () + (let ((surf #f)) + (dynamic-wind + (const #f) + (lambda () + (set! surf (cairo-image-surface-create 'rgb24 1 1)) + (let ((ctx (cairo-create surf))) + (cairo-select-font-face ctx font-family font-style font-weight) + (cairo-set-font-size ctx font-size) + (cairo-text-extents ctx txt))) + (lambda () + (when surf + (cairo-surface-finish surf) + (cairo-surface-destroy surf)))))) + (lambda (dimensions) + (apply values (f64vector->list dimensions))))) + + ;; XXX: We cannot use rsvg-handle-write nor + ;; rsvg-handle-new-from-data, because they throw an error upon + ;; closing the handle if we had written any non-ASCII characters to + ;; them before. So we write the SVG to a file and use + ;; rsvg-handle-new-from-file. + (define (dimensions svg) + (let* ((port (mkstemp! (string-copy "/tmp/pictXXXXXXX"))) + (name (port-filename port))) + (sxml->xml svg port) + (close-port port) + (let*-values (((d) (rsvg-set-default-dpi-x-y %dpi %dpi)) + ;; This fails with non-ASCII data. Curious. + ;; But it leads to the correct font dimensions! + #; + ((handle) (rsvg-handle-new-from-data + (with-output-to-string + (lambda () + (sxml->xml svg))))) + ((handle) (rsvg-handle-new-from-file name)) + ((c) (rsvg-handle-close handle)) + ((width height em ex) (rsvg-handle-get-dimensions handle))) + (values width height)))) + (define (make-text content) + `(text (@ (style ,(style-list->string + `(("fill" ,color) + ("font-family" ,font-family) + ("font-style" ,(symbol->string font-style))))) + (font-size ,font-size) + (font-weight ,(symbol->string font-weight))) + ,content)) + (let-values (((ascent descent height max-x-advance max-y-advance) + (font-extents)) + ((x-bearing y-bearing t-width t-height x-advance y-advance) + (text-extents)) + ((full-width _h) + (dimensions `(svg (@ (xmlns "http://www.w3.org/2000/svg")) + ,(make-text txt))))) + (make-pict `(svg (@ (height ,(+ ascent descent)) + ;; XXX: Annoyingly, Cairo reports the wrong + ;; x-advance when Chinese characters are + ;; involved, so we're using the width of the + ;; rendered SVG together with the x-bearing. + (width ,(+ x-bearing full-width)) + (x 0) + (y 0)) + ;; Shift the text into view. + ,((attribute-modifier + 'y (const ascent)) + (make-text txt)))))) (define* (pict-attr attr pict #:key (path '())) |