tweks

10 years ago · f4eaf84dc2
parent 528569efd5
commit f4eaf84dc2
2 changed files with 29 additions and 37 deletions
--- a/quad/measure-typed.rkt
+++ b/quad/measure-typed.rkt
@ -5,49 +5,38 @@
               [record-dc%  (Class (init-field) 
                                   (get-text-extent (String (Instance (Class (init-field))) Any . -> . (values Nonnegative-Real Nonnegative-Real Nonnegative-Real Nonnegative-Real))))]
               [make-font ((#:size Nonnegative-Float) (#:style Symbol) (#:weight Symbol) (#:face String) . -> . (Instance (Class (init-field))))])
-(require/typed sugar/cache [make-caching-proc (Procedure . -> . Procedure)])
 (require/typed racket/serialize [serialize (Any . -> . Any)]
               [deserialize (Any . -> . (HashTable Any Any))])
-(provide measure-text measure-ascent round-float update-text-cache-file load-text-cache-file make-font/caching)
+(provide measure-text measure-ascent round-float update-text-cache-file load-text-cache-file)

 (define precision 4.0)
-(define base (flexpt 10.0 precision))
+(define base (expt 10.0 precision))
+(define max-size 1024.0)
+(define dc (new record-dc%))
+(define-type Measurement-Result-Type (List Float Float Float Float))
+(define mrt? (make-predicate Measurement-Result-Type))
+(define-type MMS-Type ((String String) (Symbol Symbol) . ->* . Measurement-Result-Type))
+(define current-text-cache (make-parameter ((inst make-hash (List String String Symbol Symbol) Measurement-Result-Type) '())))
+(define current-text-cache-changed? : (Parameterof Boolean) (make-parameter #f))
+(define current-font-cache (make-parameter ((inst make-hash (List String Symbol Symbol) (Instance (Class (init-field)))) '())))
+

 (: round-float (Float . -> . Float))
 (define (round-float x)
  (/ (round (* base x)) base))

-
-(define-syntax (values->list stx)
-  (syntax-case stx ()
-    [(_ values-expr) #'(call-with-values (λ () values-expr) list)]))
-
-(define dc (new record-dc%))
-
-(define max-size 1024.0) ; use fixnum to trigger faster bitshift division
-
-;; changing max-size invalidates font cache (because it's based on max size, duh)
-
-
-(define make-font/caching
-  (make-caching-proc (λ (font weight style)
-                       (make-font #:size max-size #:style style #:weight weight #:face font))))
-
-
-(define (get-cache-file-path)
+(: get-cache-file-path (-> Path))
+(define (get-cache-file-path) 
  (build-path "font.cache"))


-(define current-text-cache (make-parameter ((inst make-hash (List String String Symbol Symbol) Measurement-Result-Type) '())))
-(define current-text-cache-changed? : (Parameterof Boolean) (make-parameter #f))
-(define current-font-cache (make-parameter ((inst make-hash (List String Symbol Symbol) (Instance (Class (init-field)))) '())))
-
 (: update-text-cache-file (-> Void))
 (define (update-text-cache-file)
  (when (current-text-cache-changed?)
    (write-to-file (serialize (current-text-cache)) (get-cache-file-path) #:exists 'replace)
    (current-text-cache-changed? #f)))

+
 (:  load-text-cache-file (-> Void))
 (define (load-text-cache-file) 
  (define cache-file-path (get-cache-file-path))
@ -56,16 +45,17 @@
                          ((inst make-hash (List String String Symbol Symbol) Measurement-Result-Type) '()))))


-(define-type Measurement-Result-Type (List Float Float Float Float))
-(define mrt? (make-predicate Measurement-Result-Type))
-(define-type MMS-Type ((String String) (Symbol Symbol) . ->* . Measurement-Result-Type))
+(: get-cached-font (String Symbol Symbol . -> . (Instance (Class (init-field)))))
+(define (get-cached-font font weight style)
+  (hash-ref! (current-font-cache) (list font weight style) (λ() (make-font #:size max-size #:style style #:weight weight #:face font))))
+

 (: measure-max-size-base (String String Symbol Symbol . -> . Measurement-Result-Type))
 (define (measure-max-size-base text font weight style)
  (: hash-updater (-> Measurement-Result-Type))
  (define (hash-updater) 
    (current-text-cache-changed? #t)
-    (define font-instance (hash-ref! (current-font-cache) (list font weight style) (λ() (make-font #:size max-size #:style style #:weight weight #:face font))))
+    (define font-instance (get-cached-font font weight style))
    ;; 'combine' boolean only makes a difference for two or more chars, so use (>= (string-length text) 1) for speed
    (define-values (width height descent extra) (send dc get-text-extent text font-instance (>= (string-length text) 1)))
    ;; avoid `map` here because it requires a cast to ensure the type
@ -74,26 +64,26 @@
  ((inst hash-ref! (List String String Symbol Symbol) Measurement-Result-Type) (current-text-cache) (list text font weight style) hash-updater))


-;; todo: why did I add this measure-cache? It helps performance, but why?
-;; see https://github.com/mbutterick/quad/commit/294c5b59a3d94afd53a0d9f46202dca38bee256e
-;; oh: because I couldn't yet make it work with define/caching
+;; rather than use define/caching from the (untyped) sugar/cache, implement the cache "manually"
 (define measure-cache ((inst make-hash (List String String Symbol Symbol) Measurement-Result-Type)))
-
 (: measure-max-size MMS-Type)
 (define (measure-max-size text font [weight 'normal] [style 'normal])
  (hash-ref! measure-cache (list text font weight style) (λ () (measure-max-size-base text font weight style))))

+
 (define-syntax-rule (width x) (first x))
 (define-syntax-rule (height x) (second x))
 (define-syntax-rule (descent x) (third x))
 #;(define-syntax-rule (extra x) (fourth x)) 

+
 ;; works by taking max size and scaling it down. Allows caching of results.
 (: measure-text ((String Positive-Float String) (Symbol Symbol) . ->* . Float))
 (define (measure-text text size font [weight 'normal] [style 'normal])
  (define raw-width (width (measure-max-size text font weight style)))
  (round-float (/ (* raw-width size) max-size)))

+
 ;; works by taking max size and scaling it down. Allows caching of results.
 (: measure-ascent ((String Positive-Float String) (Symbol Symbol) . ->* . Float))
 (define (measure-ascent text size font [weight 'normal] [style 'normal])
--- a/quad/render-typed.rkt
+++ b/quad/render-typed.rkt
@ -93,9 +93,11 @@
    
    (inherit render-element)
    
-    (define make-font/caching
-      (make-caching-proc (λ (font size style weight)
-                           (make-font #:face font #:size size #:style style #:weight weight))))
+    
+    (define font-cache ((inst make-hash (List String Nonnegative-Flonum Symbol Symbol) (Instance (Class (init-field)))) '()))
+    (: get-cached-font (String Nonnegative-Flonum Symbol Symbol . -> .  (Instance (Class (init-field)))))
+    (define (get-cached-font font size style weight)
+      (hash-ref! font-cache (list font size style weight) (λ () (make-font #:face font #:size size #:style style #:weight weight))))
    
    
    (define/override (render-word w)
@ -105,7 +107,7 @@
      (define word-weight (cast (quad-attr-ref/parameter w world:font-weight-key) Symbol))
      (define word-color (cast (quad-attr-ref/parameter w world:font-color-key) String))
      (define word-background (cast (quad-attr-ref/parameter w world:font-background-key) String))
-      (send dc set-font (make-font/caching word-font word-size word-style word-weight))
+      (send dc set-font (get-cached-font word-font word-size word-style word-weight))
      (define foreground-color (send the-color-database find-color word-color))
      (when foreground-color
        (send dc set-text-foreground foreground-color))