text: Use Cairo to get ascent and descent.

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])
 
diff --git a/pict.scm b/pict.scm
index 17604d4..7ea2905 100644
--- a/pict.scm
+++ b/pict.scm
@@ -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 '()))