speedier

quad/main-typed-sample.rkt

@@ -1,10 +1,10 @@
 #lang typed/racket/base
-(require "main-typed.rkt" "logger-typed.rkt" "world-typed.rkt" "samples-typed.rkt" "quads-typed.rkt")
+(require "main-typed.rkt" "logger-typed.rkt" "world-typed.rkt" "samples-typed.rkt")
 
-(require/typed contract-profile
+#;(require/typed contract-profile
                 [contract-profile-thunk ((-> Any) . -> . Quad)])
 
-(require "render-typed.rkt" racket/class optimization-coach)
+(require "render-typed.rkt" typed/racket/class)
 (activate-logger quad-logger)
 
 (parameterize ([world:quality-default world:draft-quality]

quad/measure-typed.rkt

@@ -1,5 +1,5 @@
 #lang typed/racket/base
-(require (for-syntax typed/racket/base ))
+(require (for-syntax typed/racket/base))
 (require typed/racket/class math/flonum racket/list racket/file)
 (require/typed racket/draw 
                [record-dc%  (Class (init-field) 
@@ -13,8 +13,10 @@
 (define precision 4.0)
 (define base (flexpt 10.0 precision))
 
-(define-syntax-rule (round-float x)
-  (fl/ (flround (fl* base (fl x))) base))
+(: round-float (Float . -> . Float))
+(define (round-float x)
+  (/ (round (* base x)) base))
+
 
 (define-syntax (values->list stx)
   (syntax-case stx ()
@@ -36,9 +38,9 @@
   (build-path "font.cache"))
 
 
-(define current-text-cache (make-parameter (make-hash '())))
-(define current-text-cache-changed? (make-parameter #f))
-(define current-font-cache (make-parameter (make-hash '())))
+(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)))) '())))
 
 
 (define (update-text-cache-file)
@@ -49,20 +51,21 @@
 (define (load-text-cache-file) 
   (define cache-file-path (get-cache-file-path))
   (current-text-cache (if (file-exists? cache-file-path)
-                          (deserialize (file->value cache-file-path))
-                          (make-hash '()))))
+                          (cast (deserialize (file->value cache-file-path)) (HashTable (List String String Symbol Symbol) Measurement-Result-Type))
+                          ((inst make-hash (List String String Symbol Symbol) Measurement-Result-Type) '()))))
 
 
-(define-type Measurement-Result-Type (List Nonnegative-Real Nonnegative-Real Nonnegative-Real Nonnegative-Real))
+(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))
 
 (: measure-max-size-base MMS-Type)
 (define (measure-max-size-base text font [weight 'normal] [style 'normal])
-  (define font-instance (cast (hash-ref! (current-font-cache) (list font weight style) (λ() (make-font #:size max-size #:style style #:weight weight #:face font))) (Instance (Class (init-field)))))
-  ;; 'combine' boolean only makes a difference for two or more chars
-  (send dc get-text-extent text font-instance (>= (string-length text) 1))
-  (cast (hash-ref! (current-text-cache) (list text font weight style) (λ() #;(current-text-cache-changed? #t)
-                                                                        (values->list (send dc get-text-extent text font-instance (>= (string-length text) 1))))) Measurement-Result-Type))
+  (define font-instance (hash-ref! (current-font-cache) (list font weight style) (λ() (make-font #:size max-size #:style style #:weight weight #:face font))))
+  ;; 'combine' boolean only makes a difference for two or more chars, so use (>= (string-length text) 1) for speed
+  ((inst hash-ref! (List String String Symbol Symbol) Measurement-Result-Type) (current-text-cache) (list text font weight style) (λ() (current-text-cache-changed? #t)
+                                                                        (define-values (width height descent extra) (send dc get-text-extent text font-instance (>= (string-length text) 1)))
+                                                                  (list (fl width) (fl height) (fl descent) (fl extra)))))
 
 (define measure-cache ((inst make-hash (List String String Symbol Symbol) Measurement-Result-Type)))
 
@@ -70,32 +73,20 @@
 (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)) 
+#;(define-syntax-rule (extra x) (fourth x)) 
 
-
-(define-syntax-rule (measure-text-max-size text font weight style)
-  (width (measure-max-size text font weight style)))
-
-(: measure-text ((String Nonnegative-Float String) (Symbol Symbol) . ->* . Nonnegative-Float))
+;; 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])
-  ;; Native function only accepts integers, so get max-size and scale down to size needed.
-  (define raw-measure (measure-text-max-size text font weight style))
-  (cast (round-float (/ (* (exact->inexact raw-measure) (exact->inexact size)) max-size)) Nonnegative-Float))
-
-
-(define-syntax-rule (measure-ascent-max-size text font weight style)
-  (let ([result-list (measure-max-size text font weight style)])
-    (- (height result-list) (descent result-list))))
+  (define raw-width (width (measure-max-size text font weight style)))
+  (round-float (/ (* raw-width size) max-size)))
 
-(: measure-ascent ((String Nonnegative-Float String) (Symbol Symbol) . ->* . Nonnegative-Float))
+;; 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])
-  ;  ((string? flonum? string?) (symbol? symbol?) . ->* . flonum?)
-  ;; Native function only accepts integers, so get max-size and scale down to size needed.
-  (define raw-baseline-distance (measure-ascent-max-size text font weight style))
-  (cast (round-float (/ (* (exact->inexact raw-baseline-distance) (exact->inexact size)) max-size)) Nonnegative-Float))
+  (define result-list : Measurement-Result-Type (measure-max-size text font weight style))
+  (define raw-baseline-distance (- (height result-list) (descent result-list)))
+  (round-float (/ (* raw-baseline-distance size) max-size)))

quad/wrap-typed.rkt

@@ -93,10 +93,10 @@
 
 ;; extract font attributes from quad, or get default values
 (define/typed (font-attributes-with-defaults q)
-  (Quad . -> . (List Nonnegative-Float String Symbol Symbol))
+  (Quad . -> . (List Positive-Float String Symbol Symbol))
   (list
    (cast (let ([size (quad-attr-ref/parameter q world:font-size-key)])
-           (if (exact-integer? size) (fl size) size)) Nonnegative-Float)
+           (if (exact-integer? size) (fl size) size)) Positive-Float)
    (cast (quad-attr-ref/parameter q world:font-name-key) String)
    (cast (quad-attr-ref/parameter q world:font-weight-key) Symbol)
    (cast (quad-attr-ref/parameter q world:font-style-key) Symbol)))
@@ -257,7 +257,7 @@
                                                      (let ([interleaver (copy-with-attrs middle q)])
                                                        (list interleaver q interleaver)) 
                                                      q)) qs) 
-                         ;; (last qs) is a single quad, but wrap it in a list to make it spliceable
+                           ;; (last qs) is a single quad, but wrap it in a list to make it spliceable
                            ,@(cast (if after (list (copy-with-attrs after (last qs))) null) (Listof Quad))
                            ))) QuadList)))
 
@@ -368,7 +368,8 @@
 
 (define/typed (install-measurement-keys p)
   (Quad . -> . Quad)
-  (define basic-width (round-float (apply + ((inst map Float Quad) quad-width (cast (quad-list p) (Listof Quad))))))
+  (define basic-width (round-float 
+                       (foldl + 0.0 ((inst map Float Quad) quad-width (cast (quad-list p) (Listof Quad))))))
   (define p-word-break (cast (quad-attr-ref p world:word-break-key #f) Quad))
   (define before-break-width (fl+ basic-width (if p-word-break
                                                   (quad-width (word (quad-attrs p-word-break) (cast (quad-attr-ref p-word-break world:before-break-key) QuadListItem)))
@@ -387,11 +388,11 @@
       (vector
        ;; throw in 0.0 in case for/list returns empty
        (apply + 0.0 (for/list : (Listof Float) ([qli (in-list (quad-list p))])
-                        (define q (cast qli Quad))
-                        (define str (quad->string q))
-                        (if (equal? str "")
-                            (cast (quad-attr-ref q world:width-key 0.0) Float)
-                            (apply measure-text (quad->string q) (font-attributes-with-defaults q)))))
+                      (define q (cast qli Quad))
+                      (define str (quad->string q))
+                      (if (equal? str "")
+                          (cast (quad-attr-ref q world:width-key 0.0) Float)
+                          (apply measure-text (quad->string q) (font-attributes-with-defaults q)))))
        (if wb (cast (apply measure-text (cast (quad-attr-ref wb world:no-break-key) String) (font-attributes-with-defaults wb)) Float) 0.0)
        (if wb (cast (apply measure-text (cast (quad-attr-ref wb world:before-break-key) String) (font-attributes-with-defaults wb)) Float) 0.0))))
   (values
@@ -409,7 +410,7 @@
 
 (define/typed (get-line-width line)
   ((Vectorof Float) . -> . Float)
-  (round-float (apply + (vector->list line))))
+  (round-float (foldl + 0.0 (vector->list line))))
 
 (struct $penalty ([hyphens : Nonnegative-Integer][width : Value-Type]) #:transparent #:mutable)
 
@@ -532,23 +533,23 @@
     (define name expr ...)))
 
 (define+provide wrap-first (make-wrap-proc  
-                    make-pieces 
-                    quad-width 
-                    pieces->line 
-                    (λ(x y) (adaptive-fit-proc (cast x (Vectorof Quad)) (cast y Float) #t #f))))
+                            make-pieces 
+                            quad-width 
+                            pieces->line 
+                            (λ(x y) (adaptive-fit-proc (cast x (Vectorof Quad)) (cast y Float) #t #f))))
 
 ;; wrap proc based on penalty function
 (define+provide wrap-best (make-wrap-proc
-                   make-pieces
-                   quad-width
-                   pieces->line
-                   (λ(x y) (adaptive-fit-proc (cast x (Vectorof Quad)) (cast y Float) #f #t)))) ; note difference in boolean args
+                           make-pieces
+                           quad-width
+                           pieces->line
+                           (λ(x y) (adaptive-fit-proc (cast x (Vectorof Quad)) (cast y Float) #f #t)))) ; note difference in boolean args
 
 (define+provide wrap-adaptive (make-wrap-proc 
-                       make-pieces
-                       quad-width
-                       pieces->line
-                       adaptive-fit-proc))
+                               make-pieces
+                               quad-width
+                               pieces->line
+                               adaptive-fit-proc))
 
 
 (define/typed (fixed-width? q)