suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

racket/gui: small speed-ups in editor drawing path

Browse Source 
Mostly, replace some method calls with field selectors (where the
path is important enough that it seems worthwhile).
This commit is contained in:
Matthew Flatt 2014-02-24 19:37:57 -07:00
parent eff53cde87
commit 78321aa4e6
6 changed files with 114 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
pkgs/draw-pkgs/draw-lib/racket/draw/private/color.rkt
View File

@ -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)

4
pkgs/draw-pkgs/draw-lib/racket/draw/private/dc.rkt
View File

@ -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))]

33
pkgs/draw-pkgs/draw-lib/racket/draw/private/font.rkt
View File

@ -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%

2
pkgs/gui-pkgs/gui-lib/mred/private/wxme/text.rkt
View File

@ -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)

8
pkgs/snip-pkgs/snip-lib/racket/snip/private/snip.rkt
View File

@ -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)))

132
pkgs/snip-pkgs/snip-lib/racket/snip/private/style.rkt
View File

@ -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