performance research

main
Matthew Butterick 10 years ago
parent fa6430e0bc
commit d98ac52705

@ -194,7 +194,7 @@
(coerce/input? . -> . doc?)
(cond
[(input? x) (load-text-cache-file)
(define multipages (input->multipages x)) ; 125 = timings for jude0
(define multipages (time (input->multipages x))) ; 125 = timings for jude0
(define pages (append-map typeset multipages)) ; 1446
(define doc (typeset pages)) ; 250
(update-text-cache-file)

@ -1,5 +1,5 @@
#lang racket/base
(require math/flonum racket/draw racket/class racket/contract sugar/debug sugar/list racket/list sugar/cache racket/serialize racket/file)
(require math/flonum racket/draw racket/class sugar/debug sugar/list racket/list sugar/cache racket/serialize racket/file)
(provide measure-text measure-ascent round-float update-text-cache-file load-text-cache-file)
(define precision 4.0)
@ -10,7 +10,7 @@
(define dc (new record-dc%))
(define max-size 1000.0)
(define max-size 1024) ; use fixnum to trigger faster bitshift division
(define/caching (make-font/caching font weight style)
(make-font #:size max-size #:style style #:weight weight #:face font))
@ -26,8 +26,8 @@
(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))))
(deserialize (file->value cache-file-path))
(make-hash))))
(define current-text-cache (make-parameter (make-hash)))
(define current-text-cache-changed? (make-parameter #f))
@ -36,32 +36,32 @@
(define/caching (measure-max-size text font [weight 'normal] [style 'normal])
;((string? string?) (symbol? symbol?) . ->* . number?)
(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
;; 'combine' boolean only makes a difference for two or more chars
(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))))))
(define (width x) (first x))
(define (height x) (second x))
(define (descent x) (third x))
(define (extra x) (fourth x))
(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 (measure-text-max-size text font [weight 'normal] [style 'normal])
(define-syntax-rule (measure-text-max-size text font weight style)
(width (measure-max-size text font weight style)))
(define/contract (measure-text text size font [weight 'normal] [style 'normal])
((string? flonum? string?) (symbol? symbol?) . ->* . flonum?)
(define (measure-text 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-measure (measure-text-max-size text font weight style))
(round-float (fl/ (fl* (fl raw-measure) size) max-size)))
(round-float (/ (* (exact->inexact raw-measure) (exact->inexact size)) max-size)))
(define (measure-ascent-max-size text font [weight 'normal] [style 'normal])
(define result-list (measure-max-size text font weight style))
(- (height result-list) (descent result-list)))
(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/contract (measure-ascent text size font [weight 'normal] [style 'normal])
((string? flonum? string?) (symbol? symbol?) . ->* . flonum?)
(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))
(round-float (fl/ (fl* (fl raw-baseline-distance) size) max-size)))
(round-float (/ (* (exact->inexact raw-baseline-distance) (exact->inexact size)) max-size)))

@ -96,8 +96,7 @@
;; flatten quad as above,
;; then dissolve it into individual character quads while copying attributes
;; input is often large, so macro allows us to avoid allocation
(provide split-quad)
(define-syntax-rule (split-quad q)
(define+provide (split-quad q)
;(quad? . -> . quads?)
(letrec ([do-explode (λ(x [parent #f])
(cond
@ -105,9 +104,11 @@
(if (empty? (quad-list x))
x ; no subelements, so stop here
(map (λ(xi) (do-explode xi x)) (quad-list x)))] ; replace quad with its elements, exploded
[(string? x) (map (λ(xc) (quad 'word (quad-attrs parent) (list xc))) (regexp-match* #px"." x))]))])
[else (map (λ(xc) (quad 'word (quad-attrs parent) (list xc))) (regexp-match* #px"." x))]))])
(flatten (map do-explode (flatten-quad q)))))
;; merge chars into words (and boxes), leave the rest
;; if two quads are mergeable types, and have the same attributes,
;; they get merged.

@ -94,4 +94,4 @@
(define min-last-lines 2)
(define default-lines-per-column 36)
(define-parameter logging-level 'debug)
(define-parameter logging-level 'info)
Loading…
Cancel
Save