diff --git a/pkgs/draw-pkgs/draw-lib/racket/draw/private/color.rkt b/pkgs/draw-pkgs/draw-lib/racket/draw/private/color.rkt index b8e229d27f..6fa87b8a72 100644 --- a/pkgs/draw-pkgs/draw-lib/racket/draw/private/color.rkt +++ b/pkgs/draw-pkgs/draw-lib/racket/draw/private/color.rkt @@ -16,7 +16,8 @@ (define-local-member-name r g b a - set-immutable) + set-immutable + s-immutable?) (define color% (class object% @@ -24,7 +25,7 @@ [g 0] [b 0] [a 1.0]) - (define immutable? #f) + (field [s-immutable? #f]) (init-rest args) (super-new) @@ -61,7 +62,7 @@ (define/public (alpha) a) (define/public (set rr rg rb [ra 1.0]) - (if immutable? + (if s-immutable? (error (method-name 'color% 'set) "object is immutable") (begin (set! r rr) @@ -70,11 +71,11 @@ (set! a (exact->inexact ra))))) (define/public (ok?) #t) - (define/public (is-immutable?) immutable?) - (define/public (set-immutable) (set! immutable? #t)) + (define/public (is-immutable?) s-immutable?) + (define/public (set-immutable) (set! s-immutable? #t)) (define/public (copy-from c) - (if immutable? + (if s-immutable? (error (method-name 'color% 'copy-from) "object is immutable") (begin (set (color-red c) (color-green c) (color-blue c) (color-alpha c)) this))))) @@ -83,6 +84,7 @@ (define color-green (class-field-accessor color% g)) (define color-blue (class-field-accessor color% b)) (define color-alpha (class-field-accessor color% a)) +(define color-is-immutable? (class-field-accessor color% s-immutable?)) ;; byte byte byte real -> color% ;; produce an immutable color% object @@ -92,7 +94,7 @@ color) (define (color->immutable-color c) - (if (send c is-immutable?) + (if (color-is-immutable? c) c (let ([c2 (new color%)]) (send c2 copy-from c) 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 08f196b48b..047bef9511 100644 --- a/pkgs/draw-pkgs/draw-lib/racket/draw/private/dc.rkt +++ b/pkgs/draw-pkgs/draw-lib/racket/draw/private/dc.rkt @@ -1345,8 +1345,8 @@ (cairo_translate cr x y) (cairo_rotate cr (- angle))) (let ([desc (get-pango font)] - [attrs (send font get-pango-attrs)] - [force-hinting (case (send font get-hinting) + [attrs (font->pango-attrs font)] + [force-hinting (case (font->hinting font) [(aligned) round] [else values])] [x (if rotate? 0.0 (exact->inexact x))] diff --git a/pkgs/draw-pkgs/draw-lib/racket/draw/private/font.rkt b/pkgs/draw-pkgs/draw-lib/racket/draw/private/font.rkt index ae9e9e464e..5a202ab297 100644 --- a/pkgs/draw-pkgs/draw-lib/racket/draw/private/font.rkt +++ b/pkgs/draw-pkgs/draw-lib/racket/draw/private/font.rkt @@ -17,10 +17,14 @@ get-pango-attrs get-face-list (protect-out substitute-fonts? - install-alternate-face)) + install-alternate-face + font->pango-attrs + font->hinting)) (define-local-member-name - get-pango-attrs) + get-pango-attrs + s-pango-attrs + s-hinting) (define underlined-attrs (let ([l (pango_attr_list_new)]) (pango_attr_list_insert l (pango_attr_underline_new @@ -166,10 +170,9 @@ (atomically (hash-set! font-descs key desc)) desc))) + (field [s-pango-attrs #f]) (define/public (get-pango-attrs) - (if underlined? - underlined-attrs - #f)) + s-pango-attrs) (define face #f) (def/public (get-face) face) @@ -186,14 +189,13 @@ (define smoothing 'default) (def/public (get-smoothing) smoothing) - (define hinting 'aligned) - (def/public (get-hinting) hinting) + (field [s-hinting 'aligned]) + (def/public (get-hinting) s-hinting) (define style 'normal) (def/public (get-style) style) - (define underlined? #f) - (def/public (get-underlined) underlined?) + (def/public (get-underlined) (and s-pango-attrs #t)) (define weight 'normal) (def/public (get-weight) weight) @@ -221,10 +223,10 @@ (set! family _family) (set! style _style) (set! weight _weight) - (set! underlined? _underlined?) + (set! s-pango-attrs (and _underlined? underlined-attrs)) (set! smoothing _smoothing) (set! size-in-pixels? _size-in-pixels?) - (set! hinting _hinting)] + (set! s-hinting _hinting)] [([size? _size] [(make-or-false string?) _face] [family-symbol? _family] @@ -239,10 +241,10 @@ (set! family _family) (set! style _style) (set! weight _weight) - (set! underlined? _underlined?) + (set! s-pango-attrs (and _underlined? underlined-attrs)) (set! smoothing _smoothing) (set! size-in-pixels? _size-in-pixels?) - (set! hinting _hinting)] + (set! s-hinting _hinting)] (init-name 'font%)) (define id @@ -250,7 +252,7 @@ (send the-font-name-directory find-or-create-font-id face family) (send the-font-name-directory find-family-default-font-id family))) (define key - (let ([key (vector id size style weight underlined? smoothing size-in-pixels? hinting)]) + (let ([key (vector id size style weight (and s-pango-attrs #t) smoothing size-in-pixels? s-hinting)]) (let ([old-key (atomically (hash-ref keys key #f))]) (if old-key (weak-box-value old-key) @@ -258,6 +260,9 @@ (atomically (hash-set! keys key (make-weak-box key))) key)))))) +(define font->pango-attrs (class-field-accessor font% s-pango-attrs)) +(define font->hinting (class-field-accessor font% s-hinting)) + ;; ---------------------------------------- (defclass font-list% object% diff --git a/pkgs/gui-pkgs/gui-lib/mred/private/wxme/text.rkt b/pkgs/gui-pkgs/gui-lib/mred/private/wxme/text.rkt index 25803b4a33..56a8fcc6b7 100644 --- a/pkgs/gui-pkgs/gui-lib/mred/private/wxme/text.rkt +++ b/pkgs/gui-pkgs/gui-lib/mred/private/wxme/text.rkt @@ -5293,7 +5293,7 @@ (let ([old-style (snip->style snip)]) (let-boxes ([w 0.0] [h 0.0] [descent 0.0] [space 0.0]) (send snip get-extent dc x ycounter w h descent space #f #f) - (let* ([align (send (snip->style snip) get-alignment)] + (let* ([align (style->alignment (snip->style snip))] [down (cond [(eq? 'bottom align) diff --git a/pkgs/snip-pkgs/snip-lib/racket/snip/private/snip.rkt b/pkgs/snip-pkgs/snip-lib/racket/snip/private/snip.rkt index dc971ac74d..d9283160ec 100644 --- a/pkgs/snip-pkgs/snip-lib/racket/snip/private/snip.rkt +++ b/pkgs/snip-pkgs/snip-lib/racket/snip/private/snip.rkt @@ -445,18 +445,20 @@ (when wo (set-box! wo (if (vector? str-metric) (vector-ref str-metric 0) str-metric))) + (when (or ho dso so) + (send s-style reset-text-metrics dc)) (when ho (set-box! ho (if (vector? str-metric) (vector-ref str-metric 1) - (send s-style get-text-height dc)))) + (style->cached-text-height s-style)))) (when dso (set-box! dso (if (vector? str-metric) (vector-ref str-metric 2) - (send s-style get-text-descent dc)))) + (style->cached-text-descent s-style)))) (when so (set-box! so (if (vector? str-metric) (vector-ref str-metric 3) - (send s-style get-text-space dc)))) + (style->cached-text-space s-style)))) (when ls (set-box! ls 0.0)) (when rs (set-box! rs 0.0))) diff --git a/pkgs/snip-pkgs/snip-lib/racket/snip/private/style.rkt b/pkgs/snip-pkgs/snip-lib/racket/snip/private/style.rkt index 7b4284dc87..bdf88a2846 100644 --- a/pkgs/snip-pkgs/snip-lib/racket/snip/private/style.rkt +++ b/pkgs/snip-pkgs/snip-lib/racket/snip/private/style.rkt @@ -5,6 +5,7 @@ racket/draw racket/draw/private/syntax racket/draw/private/font-syms + (only-in racket/draw/private/color color-red color-blue color-green) racket/snip/private/private "prefs.rkt") @@ -17,7 +18,12 @@ setup-style-reads-writes done-style-reads-writes read-styles-from-file - write-styles-to-file) + write-styles-to-file + (protect-out style->alignment + style->cached-text-width + style->cached-text-height + style->cached-text-descent + style->cached-text-space)) ;; for contracts (define editor-stream-out% object%) @@ -561,12 +567,15 @@ s-remove-child s-set-as-basic s-update + s-font get-s-font get-s-pen get-s-brush get-s-alignment get-s-trans-text? + s-foreground get-s-foreground + s-background get-s-background get-s-base-style get-s-join-shift-style @@ -582,7 +591,12 @@ set-s-cached-sizes set-s-pen set-s-brush - set-s-shift-style) + set-s-shift-style + s-alignment + s-text-width + s-text-height + s-text-descent + s-text-space) (defclass style% object% (super-new) @@ -608,19 +622,19 @@ ;; cache computation: (define trans-text? #f) - (define foreground (new color%)) - (define background (new color%)) - (define font #f) + (field [s-foreground (new color%)] + [s-background (new color%)] + [s-font #f]) (define pen #f) (define brush #f) - (define alignment 'bottom) + (field [s-alignment 'bottom]) (define cached-sizes 0) (define/public (set-s-cached-sizes v) (set! cached-sizes v)) - (define text-width 0.0) - (define text-height 0.0) - (define text-descent 0.0) - (define text-space 0.0) + (field [s-text-width 0.0] + [s-text-height 0.0] + [s-text-descent 0.0] + [s-text-space 0.0]) (define children null) @@ -633,13 +647,13 @@ (set! nonjoin-delta (new style-delta%)) (send nonjoin-delta set-delta 'change-normal) - (set! font (send the-font-list find-or-create-font + (set! s-font (send the-font-list find-or-create-font default-size 'default 'normal 'normal)) - (send foreground set 0 0 0) - (send background set 255 255 255) - (set! pen (send the-pen-list find-or-create-pen foreground 0 'solid)) - (set! brush (send the-brush-list find-or-create-brush background 'solid)) - (set! alignment 'bottom) + (send s-foreground set 0 0 0) + (send s-background set 255 255 255) + (set! pen (send the-pen-list find-or-create-pen s-foreground 0 'solid)) + (set! brush (send the-brush-list find-or-create-brush s-background 'solid)) + (set! s-alignment 'bottom) (set! trans-text? #t)) (define/public (s-update basic target propagate? top-level? send-notify?) @@ -765,9 +779,9 @@ (send target get-s-background)) (send target set-s-pen - (send the-pen-list find-or-create-pen foreground 0 'solid)) + (send the-pen-list find-or-create-pen s-foreground 0 'solid)) (send target set-s-brush - (send the-brush-list find-or-create-brush background 'solid)) + (send the-brush-list find-or-create-brush s-background 'solid)) (when propagate? (for-each (lambda (child) @@ -781,19 +795,19 @@ (send style-list style-was-changed #f))))))))))) (def/public (get-name) name) - (def/public (get-family) (send font get-family)) - (def/public (get-face) (send font get-face)) - (def/public (get-font) font) - (def/public (get-size) (send font get-point-size)) - (def/public (get-weight) (send font get-weight)) - (def/public (get-style) (send font get-style)) - (def/public (get-smoothing) (send font get-smoothing)) - (def/public (get-underlined) (send font get-underlined)) - (def/public (get-size-in-pixels) (send font get-size-in-pixels)) + (def/public (get-family) (send s-font get-family)) + (def/public (get-face) (send s-font get-face)) + (def/public (get-font) s-font) + (def/public (get-size) (send s-font get-point-size)) + (def/public (get-weight) (send s-font get-weight)) + (def/public (get-style) (send s-font get-style)) + (def/public (get-smoothing) (send s-font get-smoothing)) + (def/public (get-underlined) (send s-font get-underlined)) + (def/public (get-size-in-pixels) (send s-font get-size-in-pixels)) (def/public (get-transparent-text-backing) trans-text?) - (def/public (get-foreground) (make-object color% foreground)) - (def/public (get-background) (make-object color% background)) - (def/public (get-alignment) alignment) + (def/public (get-foreground) (make-object color% s-foreground)) + (def/public (get-background) (make-object color% s-background)) + (def/public (get-alignment) s-alignment) (def/public (is-join?) (and join-shift-style #t)) (def/public (get-delta [style-delta% d]) @@ -855,26 +869,26 @@ (s-update #f #f #t #t #t)))))) (define/private (color->rgb c) - (values (send c red) (send c green) (send c blue))) + (values (color-red c) (color-green c) (color-blue c))) (def/public (switch-to [dc<%> dc] [(make-or-false style<%>) old-style]) - (let-values ([(afr afg afb) (if old-style (color->rgb (send old-style get-s-foreground)) (values 0 0 0))] - [(bfr bfg bfb) (color->rgb foreground)] - [(abr abg abb) (if old-style (color->rgb (send old-style get-s-background)) (values 0 0 0))] - [(bbr bbg bbb) (color->rgb background)]) + (let-values ([(afr afg afb) (if old-style (color->rgb (style->foreground old-style)) (values 0 0 0))] + [(bfr bfg bfb) (color->rgb s-foreground)] + [(abr abg abb) (if old-style (color->rgb (style->background old-style)) (values 0 0 0))] + [(bbr bbg bbb) (color->rgb s-background)]) (when (or (not old-style) - (not (eq? (send old-style get-s-font) font))) - (send dc set-font font)) + (not (eq? (send old-style get-s-font) s-font))) + (send dc set-font s-font)) (when (or (not old-style) (not (= afr bfr)) (not (= afb bfb)) (not (= afg bfg))) - (send dc set-text-foreground foreground)) + (send dc set-text-foreground s-foreground)) (when (or (not old-style) (not (= abr bbr)) (not (= abb bbb)) (not (= abg bbg))) - (send dc set-text-background background)) + (send dc set-text-background s-background)) (when (or (not old-style) (not (eq? (send old-style get-s-pen) pen))) (send dc set-pen pen)) @@ -886,28 +900,28 @@ (let ([can-cache (send dc cache-font-metrics-key)]) (unless (and (not (zero? cached-sizes)) (eq? cached-sizes can-cache)) - (let-values ([(w h d s) (send dc get-text-extent " " font)]) - (set! text-width w) - (set! text-height h) - (set! text-descent d) - (set! text-space s) + (let-values ([(w h d s) (send dc get-text-extent " " s-font)]) + (set! s-text-width w) + (set! s-text-height h) + (set! s-text-descent d) + (set! s-text-space s) (set! cached-sizes can-cache))))) (def/public (get-text-width [dc<%> dc]) (reset-text-metrics dc) - text-width) + s-text-width) (def/public (get-text-height [dc<%> dc]) (reset-text-metrics dc) - text-height) + s-text-height) (def/public (get-text-descent [dc<%> dc]) (reset-text-metrics dc) - text-descent) + s-text-descent) (def/public (get-text-space [dc<%> dc]) (reset-text-metrics dc) - text-space) + s-text-space) (define/public (s-add-child c) (set! children (cons c children))) @@ -915,20 +929,30 @@ (define/public (s-remove-child c) (set! children (remq c children))) - (define/public (get-s-font) font) - (define/public (set-s-font v) (set! font v)) + (define/public (get-s-font) s-font) + (define/public (set-s-font v) (set! s-font v)) (define/public (get-s-pen) pen) (define/public (set-s-pen v) (set! pen v)) (define/public (get-s-brush) brush) (define/public (set-s-brush v) (set! brush v)) - (define/public (get-s-alignment) alignment) - (define/public (set-s-alignment v) (set! alignment v)) + (define/public (get-s-alignment) s-alignment) + (define/public (set-s-alignment v) (set! s-alignment v)) (define/public (get-s-trans-text?) trans-text?) - (define/public (get-s-foreground) foreground) - (define/public (get-s-background) background)) + (define/public (get-s-foreground) s-foreground) + (define/public (get-s-background) s-background)) (define style<%> (class->interface style%)) +(define style->foreground (class-field-accessor style% s-foreground)) +(define style->background (class-field-accessor style% s-background)) +(define style->font (class-field-accessor style% s-font)) +(define style->alignment (class-field-accessor style% s-alignment)) + +(define style->cached-text-width (class-field-accessor style% s-text-width)) +(define style->cached-text-height (class-field-accessor style% s-text-height)) +(define style->cached-text-descent (class-field-accessor style% s-text-descent)) +(define style->cached-text-space (class-field-accessor style% s-text-space)) + ;; ---------------------------------------- (define-local-member-name