diff --git a/pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap-dc.rkt b/pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap-dc.rkt index 5f253a18eb..b857bd9e8b 100644 --- a/pkgs/draw-pkgs/draw-lib/racket/draw/private/bitmap-dc.rkt +++ b/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?) diff --git a/pkgs/draw-pkgs/draw-lib/racket/draw/private/dc.rkt b/pkgs/draw-pkgs/draw-lib/racket/draw/private/dc.rkt index eb1b589eab..50f2670fd6 100644 --- a/pkgs/draw-pkgs/draw-lib/racket/draw/private/dc.rkt +++ b/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))]) diff --git a/pkgs/draw-pkgs/draw-lib/racket/draw/private/local.rkt b/pkgs/draw-pkgs/draw-lib/racket/draw/private/local.rkt index 99146cfa8a..24d29684da 100644 --- a/pkgs/draw-pkgs/draw-lib/racket/draw/private/local.rkt +++ b/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 diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wx/common/backing-dc.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wx/common/backing-dc.rkt index 0836b15551..e0745e902b 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wx/common/backing-dc.rkt +++ b/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) diff --git a/pkgs/gui-pkgs/gui-test/tests/gracket/font-maps.rkt b/pkgs/gui-pkgs/gui-test/tests/gracket/font-maps.rkt new file mode 100644 index 0000000000..fc9a789be4 --- /dev/null +++ b/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)))