diff --git a/quad/main-typed-sample.rkt b/quad/main-typed-sample.rkt index 4dd918ee..df25a376 100644 --- a/quad/main-typed-sample.rkt +++ b/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] diff --git a/quad/measure-typed.rkt b/quad/measure-typed.rkt index 9321cab4..cd68dd56 100644 --- a/quad/measure-typed.rkt +++ b/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)) \ No newline at end of file + (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))) \ No newline at end of file diff --git a/quad/wrap-typed.rkt b/quad/wrap-typed.rkt index ae8659ea..f7eae4c2 100644 --- a/quad/wrap-typed.rkt +++ b/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)