diff options
| -rw-r--r-- | pict.scm | 77 |
1 files changed, 58 insertions, 19 deletions
@@ -31,6 +31,7 @@ #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) + #:use-module (rsvg) #:use-module (ice-9 match) #:export (pict? pict-sxml @@ -772,25 +773,63 @@ filled with black." #:rx rx #:ry ry) color)) -;; XXX: We need to ask the user to provide width and height, because -;; we cannot determine these dimensions without rendering the text. -;; Even so, the text is cut off in some cases when letters go below -;; the baseline. This needs more work. -(define* (text txt w h - #:key - (color "black")) - (make-pict - `(svg (@ (width ,w) - (height ,h) - (x 0) - (y 0)) - (text (@ (style ,(style-list->string - `(("fill" ,color) - ("font-family" "sans-serif") - ("font-size" ,(number->string h)) - ("text-anchor" "middle")))) - (x ,(/ w 2)) (y ,h)) - ,txt)))) + +;;; Text support + +;; Text cannot be implemented in SVG alone because in order to +;; determine the size of a text object it first needs to be +;; constructed with a font. We use the rsvg library to obtain the +;; width and height. + +;; Unfortunately, librsvg in Geiser does not support text baseline +;; alignment, so the text is always vertically misaligned. I tried to +;; 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)) + (width ,width) + (x 0) + (y 0)) + ,text-tag))))))) (define* (pict-attr attr pict #:key (path '())) |