Overhaul text support.

Use librsvg to pre-render the text to obtain the dimensions.

1 files changed, 58 insertions, 19 deletions

diff --git a/pict.scm b/pict.scm
index 4e30f6b..abf3705 100644
--- a/pict.scm
+++ b/pict.scm
@@ -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 '()))