summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--configure.ac1
-rw-r--r--pict.scm136
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 '()))