From 0d6af821a2d241fab97e62ab6fda584709d5accc Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Tue, 31 Mar 2015 12:42:11 -0700 Subject: [PATCH] casts eliminated --- quad/core-types.rkt | 8 +-- quad/quads-typed.rkt | 2 +- quad/wrap-typed.rkt | 116 ++++++++++++++++++++----------------------- 3 files changed, 61 insertions(+), 65 deletions(-) diff --git a/quad/core-types.rkt b/quad/core-types.rkt index bb37bc7e..6c170bd9 100644 --- a/quad/core-types.rkt +++ b/quad/core-types.rkt @@ -47,9 +47,9 @@ (define-type JoinableType (U Quad QuadAttrs HashableList)) -(define-type QuadListItem (U String Quad)) +(define-type+predicate QuadListItem (U String Quad)) (define-type+predicate QuadList (Listof QuadListItem)) -(define-type GroupQuadListItem Quad) +(define-type+predicate GroupQuadListItem Quad) (define-type+predicate GroupQuadList (Listof GroupQuadListItem)) (define-type (Treeof A) (Rec as (U A (Listof as)))) @@ -73,4 +73,6 @@ (define-predicate Font-Weight? Font-Weight) (define-predicate Font-Style? Font-Style) -(define-predicate Index? Index) +(define-predicate Index? Index) + +(define-type+predicate Breakpoint Nonnegative-Integer) diff --git a/quad/quads-typed.rkt b/quad/quads-typed.rkt index a974ff25..391fc4fb 100644 --- a/quad/quads-typed.rkt +++ b/quad/quads-typed.rkt @@ -243,5 +243,5 @@ (define-break-type page #t) (define-break-type column #t) -(define-break-type block #t) +(define-break-type block) (define-break-type line #t) diff --git a/quad/wrap-typed.rkt b/quad/wrap-typed.rkt index 19c05985..e09405ab 100644 --- a/quad/wrap-typed.rkt +++ b/quad/wrap-typed.rkt @@ -150,12 +150,12 @@ (let ([p (apply piece (attr-delete (quad-attrs p) world:word-break-key) (quad-list p))]) ; so it doesn't propagate into subquads (if the-word-break (apply piece (quad-attrs p) - (append (quad-list p) (let ([rendered-wb ((if before-break? - word-break->before-break - word-break->no-break) the-word-break)]) - (if (> (string-length (word-string rendered-wb)) 0) ; if rendered-wb is "", don't append it - (list rendered-wb) - empty)))) + (append (quad-list p) (let ([rendered-wb ((if before-break? + word-break->before-break + word-break->no-break) the-word-break)]) + (if (> (string-length (word-string rendered-wb)) 0) ; if rendered-wb is "", don't append it + (list rendered-wb) + empty)))) p))) @@ -250,13 +250,13 @@ (quad (quad-name q) (merge-attrs (or filtered-attrs null) q) (quad-list q))) (apply line (quad-attrs line-in) - (flatten-quadtree (let ([qs (quad-list line-in)]) - (list (if before (copy-with-attrs before (first qs)) null) - (map (λ([q : Quad]) (if (and middle (takes-justification-space? q)) - (let ([interleaver (copy-with-attrs middle q)]) - (list interleaver q interleaver)) - (list q))) qs) - (if after (copy-with-attrs after (last qs)) null)))))) + (flatten-quadtree (let ([qs (quad-list line-in)]) + (list (if before (copy-with-attrs before (first qs)) null) + (map (λ([q : Quad]) (if (and middle (takes-justification-space? q)) + (let ([interleaver (copy-with-attrs middle q)]) + (list interleaver q interleaver)) + (list q))) qs) + (if after (copy-with-attrs after (last qs)) null)))))) ;; installs the width in the quad. @@ -329,10 +329,7 @@ ;; a faster line-measuring function used by the wrapping function to test lines. (define/typed (measure-potential-line ps) ((Listof PieceQuad) . -> . Float) - (cast (for*/sum : (U Float Zero) - ([rendered-piece (in-list (render-pieces ps))] - [piece-quad (in-list (quad-list rendered-piece))]) - (quad-width (cast piece-quad Quad))) Float)) + (foldl fl+ 0.0 (append-map (λ([rp : PieceQuad]) (map quad-width (quad-list rp))) (render-pieces ps)))) (define/typed (vector-break-at vec bps) @@ -346,7 +343,7 @@ ;; makes a wrap function by combining component functions. -(define-type Wrap-Proc-Type (((Listof Quad)) (Float) . ->* . (Listof Quad))) +(define-type Wrap-Proc-Type (((Listof Quad)) (Float) . ->* . (Listof LineQuad))) (define/typed (make-wrap-proc make-pieces-proc measure-quad-proc @@ -354,50 +351,48 @@ find-breakpoints-proc) ((Make-Pieces-Type Measure-Quad-Type Compose-Line-Type Find-Breakpoints-Type) () . ->* . Wrap-Proc-Type) (λ(qs [measure #f]) - (let* ([measure : Float (fl+ (cast (or measure (quad-attr-ref/parameter (car qs) world:measure-key)) Float) 0.0)] - [qs : (Listof Quad) (if (quad-has-attr? (car qs) world:measure-key) + (let* ([measure (or measure (assert (quad-attr-ref/parameter (car qs) world:measure-key) flonum?))] + [qs (if (quad-has-attr? (car qs) world:measure-key) qs ((inst map Quad Quad) (λ(q) (quad-attr-set q world:measure-key measure)) qs))]) (log-quad-debug "wrapping on measure = ~a" measure) - (define pieces : (Listof PieceQuad) (make-pieces-proc qs)) - (define bps : (Listof Nonnegative-Integer) (find-breakpoints-proc (list->vector pieces) measure)) - (define broken-pieces : (Listof (Listof PieceQuad)) (break-at pieces bps)) - #; (define-type Compose-Line-Type ((Listof Quad) (Quad . -> . Float) . -> . Quad)) - (map (λ([broken-piece : (Listof PieceQuad)]) (compose-line-proc broken-piece measure-quad-proc)) broken-pieces)))) ; 80% of runtime + (define pieces (make-pieces-proc qs)) + (define bps (find-breakpoints-proc (list->vector pieces) measure)) + (define broken-pieces (break-at pieces bps)) + (map (λ([broken-piece : (Listof PieceQuad)]) (compose-line-proc broken-piece measure-quad-proc)) broken-pieces)))) (define width? flonum?) (define measure? flonum?) (define (breakpoints? x) (and (list? x) (andmap integer? x))) (define/typed (install-measurement-keys p) - (Quad . -> . 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)) + (GroupQuad . -> . Quad) + (define basic-width (round-float + (foldl fl+ 0.0 (map quad-width (quad-list p))))) + (define p-word-break (assert (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))) + (quad-width (word (quad-attrs p-word-break) (assert (quad-attr-ref p-word-break world:before-break-key) QuadListItem?))) 0.0))) (define no-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:no-break-key) QuadListItem))) + (quad-width (word (quad-attrs p-word-break) (assert (quad-attr-ref p-word-break world:no-break-key) QuadListItem?))) 0.0))) (quad-attr-set* p (list 'bb-width before-break-width 'nb-width no-break-width))) (require sugar/debug) (define/typed (make-piece-vectors pieces) - ((Vectorof Quad) . -> . (values (Vectorof Float) (Vectorof Float))) + ((Vectorof PieceQuad) . -> . (values (Vectorof Float) (Vectorof Float))) (define pieces-measured (for/list : (Listof (Vector Float Float Float)) ([p (in-vector pieces)]) - (define wb (cast (quad-attr-ref p world:word-break-key #f) (U Quad False))) + (define wb (assert (quad-attr-ref p world:word-break-key #f) (λ(wb) (or (false? wb) (quad? wb))))) (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)) + (foldl fl+ 0.0 (for/list : (Listof Float) ([q (in-list (quad-list p))]) (define str (quad->string q)) (if (equal? str "") - (cast (quad-attr-ref q world:width-key 0.0) Float) + (assert (quad-attr-ref q world:width-key 0.0) flonum?) (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)))) + (if wb (apply measure-text (assert (quad-attr-ref wb world:no-break-key) string?) (font-attributes-with-defaults wb)) 0.0) + (if wb (apply measure-text (assert (quad-attr-ref wb world:before-break-key) string?) (font-attributes-with-defaults wb)) 0.0)))) (values (for/vector : (Vectorof Float) ([p (in-list pieces-measured)]) (fl+ (vector-ref p 0) (vector-ref p 1))) ; first = word length, second = nb length @@ -406,7 +401,7 @@ (define/typed (make-trial-line pieces-rendered-widths pieces-rendered-before-break-widths i j) - ((Vectorof Float) (Vectorof Float) Nonnegative-Integer Nonnegative-Integer . -> . (Vectorof Float)) + ((Vectorof Float) (Vectorof Float) Breakpoint Breakpoint . -> . (Vectorof Float)) (let ([vec (vector-copy pieces-rendered-widths i j)]) (vector-set! vec (sub1 (vector-length vec)) (vector-ref pieces-rendered-before-break-widths (sub1 j))) vec)) @@ -415,29 +410,29 @@ ((Vectorof Float) . -> . Float) (round-float (foldl + 0.0 (vector->list line)))) -(struct $penalty ([hyphens : Nonnegative-Integer][width : Value-Type]) #:transparent #:mutable) +(struct $penalty ([hyphens : Nonnegative-Integer][width : Value-Type]) #:transparent) ;; top-level adaptive wrap proc. ;; first-fit and best-fit are variants. -(define-type Find-Breakpoints-Type ((Vectorof Quad) Float . -> . (Listof Nonnegative-Integer))) +(define-type Find-Breakpoints-Type ((Vectorof PieceQuad) Float . -> . (Listof Breakpoint))) (define/typed (adaptive-fit-proc pieces measure [use-first? #t] [use-best? #t]) - (((Vectorof Quad) Float) (Boolean Boolean) . ->* . (Listof Nonnegative-Integer)) + (((Vectorof PieceQuad) Float) (Boolean Boolean) . ->* . (Listof Nonnegative-Integer)) ;; this is the winning performance strategy: extract the numbers first, then just wrap on those. ;; todo: how to avoid re-measuring pieces later? ;; todo: how to retain information about words per line and hyphen at end? (define-values (pieces-rendered-widths pieces-rendered-before-break-widths) (make-piece-vectors pieces)) - (define pieces-with-word-space ((inst vector-map Boolean Quad) (λ(piece) (and (quad-has-attr? piece world:word-break-key) (equal? (quad-attr-ref (cast (quad-attr-ref piece world:word-break-key) Quad) 'nb) " "))) pieces)) + (define pieces-with-word-space (vector-map (λ([piece : PieceQuad]) (and (quad-has-attr? piece world:word-break-key) (equal? (quad-attr-ref (assert (quad-attr-ref piece world:word-break-key) quad?) 'nb) " "))) pieces)) (define (make-first-fit-bps-and-widths) (define-values (folded-bps folded-widths) - (for/fold ([bps : (Listof Nonnegative-Integer) '(0)][line-widths : (Listof Float) empty])([j-1 (in-range (vector-length pieces))]) + (for/fold ([bps : (Listof Breakpoint) '(0)][line-widths : (Listof Float) empty])([j-1 : Breakpoint (in-range (vector-length pieces))]) (define line-width (get-line-width (make-trial-line pieces-rendered-widths pieces-rendered-before-break-widths - (car bps) (cast (add1 j-1) Nonnegative-Integer)))) + (car bps) (add1 j-1)))) (if (fl> line-width (fl* world:allowed-overfull-ratio measure)) - (values (cons (cast j-1 Nonnegative-Integer) bps) (cons line-width line-widths)) + (values (cons j-1 bps) (cons line-width line-widths)) (values bps line-widths)))) (values (cdr (reverse folded-bps)) (reverse folded-widths))) @@ -446,10 +441,10 @@ (cond [(<= line-count 2) 1.0] ; signals that first-fit is always OK with 1 or 2 lines [else ; only measure middle lines. we know bps has at least 2 bps - (define looseness-stddev (stddev ((inst map Float Float) (λ(x) (calc-looseness x measure)) (drop-right (drop trial-line-widths 1) 1)))) + (define looseness-stddev (fl (stddev ((inst map Float Float) (λ(x) (calc-looseness x measure)) (drop-right (drop trial-line-widths 1) 1))))) (define piece-count (vector-length pieces-rendered-widths)) - (define pieces-per-line (fl/ (fl piece-count) (sub1 (fl line-count)))) ; todo: more accurate to count only pieces in middle - (apply + (list 2.2 (fllog (flabs (cast looseness-stddev Float))) (* 0.09 pieces-per-line)))])) ; the FU FORMULA + (define pieces-per-line (/ piece-count (sub1 line-count))) ; todo: more accurate to count only pieces in middle + (foldl fl+ 0.0 (list 2.2 (fllog (flabs looseness-stddev)) (fl* 0.09 (fl pieces-per-line))))])) ; the FU FORMULA ;; only buy first-fit-bps if use-first? is true. ;; use (values '(0) '(0.0)) as void-ish values that will typecheck properly. @@ -479,11 +474,11 @@ (> j (vector-length pieces))) ; exceeds available pieces ($penalty 0 (fl* -1.0 (fl i)))] ; ocm out of bounds signal [else - (define penalty-up-to-i (cast (ocm-min-entry ocm i) $penalty)) + (define penalty-up-to-i (assert (ocm-min-entry ocm i) $penalty?)) (define last-piece-to-test (vector-ref pieces (sub1 j))) (define new-hyphen? (and (quad-has-attr? last-piece-to-test world:word-break-key) - (equal? (cast (quad-attr-ref (cast (quad-attr-ref last-piece-to-test world:word-break-key) Quad) world:before-break-key) String) "-"))) + (equal? (assert (quad-attr-ref (assert (quad-attr-ref last-piece-to-test world:word-break-key) quad?) world:before-break-key) string?) "-"))) (define cumulative-hyphens (if (not new-hyphen?) 0 (add1 ($penalty-hyphens penalty-up-to-i)))) @@ -511,7 +506,7 @@ ;; 0 penalty means any length is ok. ;[(< (length pieces-to-test) (world:minimum-last-line-pieces)) 50000] [else 0.0]))))))])) - + (define ocm : OCM-Type (make-ocm penalty (cast $penalty->value Entry->Value-Type) initial-value)) ;; starting from last position, ask ocm for position of row minimum (= new-pos) @@ -519,8 +514,8 @@ ;; until you reach first position. (define first-position 0) (define last-position (vector-length pieces)) - (define result (let loop : (Listof Nonnegative-Integer) ([pos : Nonnegative-Integer last-position][acc : (Listof Nonnegative-Integer) null]) - (let ([next-pos (cast (ocm-min-index ocm pos) Nonnegative-Integer)]) ; first look ahead ... + (define result (let loop : (Listof Breakpoint) ([pos : Breakpoint last-position][acc : (Listof Breakpoint) null]) + (let ([next-pos (assert (ocm-min-index ocm pos) Breakpoint?)]) ; first look ahead ... (if (= next-pos first-position) ; therefore we're done acc (loop next-pos (cons next-pos acc)))))) @@ -539,14 +534,14 @@ make-pieces quad-width pieces->line - (λ(x y) (adaptive-fit-proc (cast x (Vectorof Quad)) (cast y Float) #t #f)))) + (λ([x : (Vectorof PieceQuad)] [y : Float]) (adaptive-fit-proc x y #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 + (λ([x : (Vectorof PieceQuad)] [y : Float]) (adaptive-fit-proc x y #f #t)))) ; note difference in boolean args (define+provide wrap-adaptive (make-wrap-proc make-pieces @@ -565,8 +560,8 @@ ;; and broaden type from just LineQuad (define/typed+provide (fill starting-quad [target-width? #f]) ((LineQuad) ((Option Float)) . ->* . LineQuad) - (define target-width (fl (or target-width? (cast (quad-attr-ref starting-quad world:measure-key) Float)))) - (define subquads (cast (quad-list starting-quad) (Listof Quad))) + (define target-width (or target-width? (assert (quad-attr-ref starting-quad world:measure-key) flonum?))) + (define subquads (quad-list starting-quad)) (define-values (flexible-subquads fixed-subquads) (partition spacer? subquads)) ; only puts fill into spacers. (define width-used (apply + ((inst map Float Quad) quad-width fixed-subquads))) (define width-remaining (round-float (- target-width width-used))) @@ -587,10 +582,9 @@ ;; add x positions to a list of fixed-width quads ;; todo: adjust this to work recursively, so that positioning operation cascades down (define/typed+provide (add-horiz-positions starting-quad) - (Quad . -> . Quad) + (GroupQuad . -> . GroupQuad) (define-values (new-quads final-width) - (for/fold ([new-quads : (Listof Quad) empty][width-so-far : Float 0.0])([qi (in-list (quad-list starting-quad))]) - (define q (cast qi Quad)) + (for/fold ([new-quads : (Listof Quad) empty][width-so-far : Float 0.0])([q (in-list (quad-list starting-quad))]) (values (cons (quad-attr-set q world:x-position-key width-so-far) new-quads) (round-float (fl+ (quad-width q) width-so-far))))) (quad (quad-name starting-quad) (quad-attrs starting-quad) (reverse new-quads)))