racket/draw: fix font metrics versus transformations

For a font with 'aligned hinting, the font map caches metric
information that depends on the destination transformation,
at least on Windows. Make the font-map cache sensitive to the
destination's current transformation.

This bug was exposed by support for DPI-aware GUIs on Windows,
but the problem was more general.

pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap-dc.rkt

@@ -32,6 +32,12 @@
           (cairo_scale cr s s)))
       (super init-cr-matrix cr))
 
+    (define/override (init-effective-matrix mx)
+      (when bm
+	(define s (send bm get-cairo-device-scale))
+	(unless (= s 1)
+          (cairo_matrix_scale mx s s))))
+
     (define/override (ok?) (and c #t))
 
     (define/private (do-set-bitmap v reset?)

pkgs/draw-pkgs/draw-lib/racket/draw/private/dc.rkt

@@ -76,11 +76,16 @@
     ;; been called before any call to flush.
     flush-cr
 
-    ;; method init-cr-matrix : -> void
+    ;; method init-cr-matrix : cr -> void
     ;;
     ;; Initializes/resets the transformation matrix
     init-cr-matrix
 
+    ;; method init-effective-matrix : matrix -> void
+    ;;
+    ;; Like init-cr-matrix, but given a matrix
+    init-effective-matrix
+
     ;; method reset-clip : cr -> void
     ;;
     ;; Resets the clipping region
@@ -170,6 +175,7 @@
     (define/public (flush-cr) (void))
 
     (define/public (init-cr-matrix cr) (void))
+    (define/public (init-effective-matrix mx) (void))
 
     (define/public (reset-clip cr)
       (cairo_reset_clip cr))
@@ -234,13 +240,20 @@
 ;; at least for the Quartz and Win32 back-ends.
 ;; (But we create the font maps on demand.)
 ;; We fold hinting in, too, as an extra factor of 2.
+;; In the case of aligned hinting, at least, the font map
+;; might further depend on the transformation, at least
+;; for Windows, so each element of `font-maps` is
+;;  (vector font-map xform (hash xform -> font-map))
+;; where the first two elements of the vector act as
+;; a cache for the hash-table lookup.
 (define font-maps (make-vector 8 #f))
 
 (define (dc-mixin backend%)
   (defclass* dc% backend% (dc<%>)
     (super-new)
 
-    (inherit flush-cr get-cr release-cr end-cr init-cr-matrix get-pango
+    (inherit flush-cr get-cr release-cr end-cr init-cr-matrix init-effective-matrix
+	     get-pango
              install-color dc-adjust-smoothing get-hairline-width dc-adjust-cap-shape
              reset-clip
              collapse-bitmap-b&w?
@@ -360,7 +373,9 @@
       (set-effective-scale-font-cached?!)
       (set! effective-origin-x 0.0)
       (set! effective-origin-y 0.0)
-      (set! current-xform (vector 1.0 0.0 0.0 1.0 0.0 0.0))
+      (let* ([mx (make-cairo_matrix_t 1 0 0 1 0 0)])
+        (init-effective-matrix mx)
+	(set! current-xform (matrix->vector mx)))
       (set! pen (send the-pen-list find-or-create-pen "black" 1 'solid))
       (set! brush (send the-brush-list find-or-create-brush "white" 'solid))
       (set! font (send the-font-list find-or-create-font 12 'default))
@@ -380,6 +395,7 @@
 
     (define/private (reset-effective!)
       (let* ([mx (make-cairo_matrix_t 1 0 0 1 0 0)])
+        (init-effective-matrix mx)
         (cairo_matrix_multiply mx mx matrix)
         (cairo_matrix_translate mx origin-x origin-y)
         (cairo_matrix_scale mx scale-x scale-y)
@@ -394,15 +410,18 @@
         (set-effective-scale-font-cached?!)
         (set! effective-origin-x (cairo_matrix_t-x0 mx))
         (set! effective-origin-y (cairo_matrix_t-y0 mx))
-        (let ([v (vector (cairo_matrix_t-xx mx)
-                         (cairo_matrix_t-yx mx)
-                         (cairo_matrix_t-xy mx)
-                         (cairo_matrix_t-yy mx)
-                         (cairo_matrix_t-x0 mx)
-                         (cairo_matrix_t-y0 mx))])
+        (let ([v (matrix->vector mx)])
           (unless (equal? v current-xform)
             (set! current-xform v)))))
 
+    (define/private (matrix->vector mx)
+      (vector (cairo_matrix_t-xx mx)
+	      (cairo_matrix_t-yx mx)
+	      (cairo_matrix_t-xy mx)
+	      (cairo_matrix_t-yy mx)
+	      (cairo_matrix_t-x0 mx)
+	      (cairo_matrix_t-y0 mx)))
+
     (define/override (set-auto-scroll dx dy)
       (unless (and (= scroll-dx (- dx))
                    (= scroll-dy (- dy)))
@@ -1302,11 +1321,7 @@
                      (vector-set! c 1 xform)))
                  (vector-ref c 0)))
 	  (let ([c (pango_font_map_create_context
-		    (let ([fm (vector-ref font-maps smoothing-index)])
-		      (or fm
-			  (let ([fm (pango_cairo_font_map_new)])
-			    (vector-set! font-maps smoothing-index fm)
-			    fm))))])
+		    (get-font-map smoothing-index xform))])
 	    (pango_cairo_update_context cr c)
 	    (vector-set! contexts smoothing-index (vector c xform))
 	    (set-font-antialias c 
@@ -1314,6 +1329,28 @@
                                 (send font get-hinting))
 	    c)))
 
+    (define/private (get-font-map smoothing-index xform)
+      (define old-fmv (vector-ref font-maps smoothing-index))
+      (define fmv (or old-fmv (vector #f #f #hash())))
+      (unless old-fmv
+        (vector-set! font-maps smoothing-index fmv))
+      (or (and (equal? xform (vector-ref fmv 1))
+	       (vector-ref fmv 0))
+	  (let* ([fm (hash-ref (vector-ref fmv 2) xform #f)]
+		 [new-fm (or fm
+			     (pango_cairo_font_map_new))])
+	    (vector-set! fmv 0 new-fm)
+	    (vector-set! fmv 1 xform)
+	    (unless fm
+              (define ht (vector-ref fmv 2))
+              (define new-ht
+                ;; Limit the number of font maps that we cache:
+                (if ((hash-count ht) . < . 8)
+                    ht
+                    #hash()))
+              (vector-set! fmv 2 (hash-set new-ht xform new-fm)))
+	    new-fm)))
+
     (define/private (do-text cr draw-mode s x y font combine? offset angle)
       (let* ([s (if (zero? offset) 
                     s
@@ -1943,7 +1980,7 @@
 	     [attrs (send font get-pango-attrs)]
 	     [index (get-smoothing-index font)]
 	     [context (get-context cr index font current-xform)]
-	     [fontmap (vector-ref font-maps index)]
+	     [fontmap (get-font-map index current-xform)]
 	     [font (pango_font_map_load_font fontmap context desc)])
           (and font ;; else font match failed
                (let ([metrics (pango_font_get_metrics font (pango_language_get_default))])

pkgs/draw-pkgs/draw-lib/racket/draw/private/local.rkt

@@ -47,6 +47,7 @@
   reset-cr
   flush-cr
   init-cr-matrix
+  init-effective-matrix
   get-font-metrics-key
   install-color
   dc-adjust-smoothing

pkgs/gui-pkgs/gui-lib/mred/private/wx/common/backing-dc.rkt

@@ -183,8 +183,13 @@
     
     (define/override (init-cr-matrix cr)
       (unless (= backing-scale 1.0)
-	      (cairo_scale cr backing-scale backing-scale))
+        (cairo_scale cr backing-scale backing-scale))
       (super init-cr-matrix cr))
+
+    (define/override (init-effective-matrix mx)
+      (unless (= backing-scale 1.0)
+        (cairo_matrix_scale mx backing-scale backing-scale))
+      (super init-effective-matrix mx))
     
     (define/override (reset-config s)
       (set! backing-scale s)

pkgs/gui-pkgs/gui-test/tests/gracket/font-maps.rkt

@@ -0,0 +1,37 @@
+#lang racket
+(require racket/draw)
+
+;; Check for pollution of font metrics from differently
+;; scaled contexts.
+
+(define font (make-font #:face "Times"))
+
+;; Running `go` might affect the result of `go2`
+(define (go)
+  (define bm (make-bitmap 1 1))
+  (send (send bm make-dc) get-text-extent
+	"Extra regexp"
+	font
+	#t))
+
+;; `go2` is like `go`, but for a different scale
+(define (go2)
+  (define bm2 (make-platform-bitmap 1 1))
+  (define dc (send bm2 make-dc))
+  (send dc scale 1.25 1.25)
+  (send dc get-text-extent
+	"Extra regexp"
+	font
+	#t))
+
+;; Running `go2` again in a separate place might produce
+;; results unaffected by `go`:
+(define (go2/p)
+  (place pch (place-channel-put pch (call-with-values go2 list))))
+
+(module+ test
+  (call-with-values go void)
+  (define l1 (call-with-values go2 list))
+  (define l2 (sync (go2/p)))
+  (unless (equal? l1 l2)
+    (error 'different "~s ~s" l1 l2)))