summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRicardo Wurmus <rekado@elephly.net>2021-01-03 13:56:25 +0100
committerRicardo Wurmus <rekado@elephly.net>2021-01-03 13:56:25 +0100
commit57fd77af03bde4999d39598790a9e458533ff575 (patch)
tree7f5f9cc95d1a13cf25408105d10598a3e23acd6e
parent680adf20dca7b3a3387e666748428c41cbccc0ce (diff)
Overhaul text support.
Use librsvg to pre-render the text to obtain the dimensions.
-rw-r--r--pict.scm77
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 '()))