diff --git a/quad/measure-typed.rkt b/quad/measure-typed.rkt index dfadf769..918fa85a 100644 --- 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]) diff --git a/quad/render-typed.rkt b/quad/render-typed.rkt index 386c4bdb..54ff67de 100644 --- 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))