Speed up text measurement

mwitmer · Feb 4, 2014 · 1070454 · 1070454
1 parent b952d40
commit 1070454
Showing 1 changed file with 43 additions and 18 deletions.
diff --git a/module/guile-wm/text.scm b/module/guile-wm/text.scm
@@ -21,6 +21,7 @@
   #:use-module (guile-wm draw)
   #:use-module (guile-wm color)
   #:use-module (guile-wm shared)
+  #:use-module (flow event-loop)
   #:use-module (xcb xml xproto)
   #:use-module (xcb xml)
   #:use-module (xcb event-loop)
@@ -37,33 +38,57 @@
     ((= (string-length text) 0)
      (case (read-char port)
        ((#\newline) '(start-new-line))
-       ((#\^) 
+       ((#\^)
         (if (char=? #\^ (peek-char port))
             `(output-text ,(string (read-char port)))
             (read port)))))
     (else `(output-text ,text))))
   exp)
 
 (define (measure-text text font-string)
+  (define (overall-width extents) (xref extents 'overall-width))
   (define font-info (with-font (font-string font) (reply-for query-font font)))
   (define ascent (xref font-info 'font-ascent))
   (define descent (xref font-info 'font-descent))
   (define height (+ ascent descent 2))
-  (with-input-from-string text
-    (lambda ()
-      (let measure ((dimens (make-q)) (widest 0) (x 2) (y ascent))
-        (match (read-escaped-text)
-          ((? eof-object?) 
-           (values (+ (max x widest) 2) (+ (+ y descent) 2) (car dimens)))
-          (('color co1 co2) (measure dimens widest x y))
-          (('color co) (measure dimens widest x y))
-          (('invert) (measure dimens widest x y))
-          (('start-new-line) (measure dimens (max x widest) 2 (+ y height)))
-          (('output-text m)
-           (with-font (font-string font)
-             (let ((width (xref (reply-for query-text-extents font m)
-                                'overall-width)))
-               (measure (enq! dimens (cons x y)) widest (+ x width) y)))))))))
+  (define cookies
+   (with-input-from-string text
+     (lambda ()
+       (let measure ((row-extent-requests '()) (extent-requests '()))
+         (match (read-escaped-text)
+           ((? eof-object?)
+            (reverse (cons (reverse row-extent-requests) extent-requests)))
+           (('color co1 co2) (measure row-extent-requests extent-requests))
+           (('color co) (measure row-extent-requests extent-requests))
+           (('invert) (measure row-extent-requests extent-requests))
+           (('start-new-line)
+            (measure '() (cons (reverse row-extent-requests) extent-requests)))
+           (('output-text m)
+            (with-font (font-string font)
+              (let ((cookie (delay-reply query-text-extents font m)))
+                (measure (cons cookie row-extent-requests) extent-requests)))))))))
+  (define (text-coords widths y)
+    (let lp ((widths widths) (coords '()) (x 2))
+      (cond
+       ((null? widths) (reverse coords))
+       (else (lp (cdr widths)
+                 (cons (cons x y) coords)
+                 (+ x (car widths)))))))
+  (define all-widths
+    (map (lambda (row)
+           (if (not (null? row))
+               (map overall-width (solicit (notify-map row))) '())) cookies))
+  (values
+   (+ 4 (apply max (map (lambda (row) (apply + row)) all-widths)))
+   (* (length all-widths) height)
+   (apply
+    append
+    (let lp ((all-widths all-widths) (coords '()) (y ascent))
+      (cond
+       ((null? all-widths) (reverse coords))
+       (else (lp (cdr all-widths)
+                 (cons (text-coords (car all-widths) y) coords)
+                 (+ y height))))))))
 
 (define-public (unescape-text text)
   (with-input-from-string text
@@ -90,14 +115,14 @@
           (('color nfg) (disp dimens (->pixel nfg) bg))
           (('invert) (disp dimens bg fg))
           (('start-new-line) (disp dimens fg bg))
-          (('output-text m) 
+          (('output-text m)
            (with-font (font-name font)
              (with-gc (gc target #:foreground fg #:background bg #:font font)
                (image-text16 target gc (caar dimens) (cdar dimens) m)))
            (disp (cdr dimens) fg bg)))))))
 
 (define-public (put-text text win fg bg font-string)
-  (receive (width height positions) (measure-text text font-string) 
+  (receive (width height positions) (measure-text text font-string)
     (define (draw!)
       (with-pixmap (pixmap win bg width height)
         (display-text text positions pixmap font-string fg bg)