resume in wrap-typed

main
Matthew Butterick 10 years ago
parent 5b51bc72cc
commit c42bcc20b9

@ -1,14 +1,13 @@
#lang 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)
(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/racket/class math/flonum racket/list racket/file typed/racket/draw)
(require/typed racket/serialize [serialize (Any . -> . Any)]
[deserialize (Any . -> . (HashTable (List String String Symbol Symbol) Measurement-Result-Type))])
(provide measure-text measure-ascent round-float update-text-cache-file load-text-cache-file)
(define-type Font-Name String)
(define precision 4.0)
(define base (expt 10.0 precision))
(define max-size 1024.0)
@ -16,7 +15,7 @@
(define-type Measurement-Result-Type (List Float Float Float Float))
(define mrt? (make-predicate Measurement-Result-Type))
(define current-text-cache (make-parameter ((inst make-hash (List String String Symbol Symbol) Measurement-Result-Type) '())))
(define current-font-cache (make-parameter ((inst make-hash (List String Symbol Symbol) (Instance (Class (init-field)))) '())))
(define current-font-cache (make-parameter ((inst make-hash (List Font-Name Font-Weight Font-Style) (Instance Font%)) '())))
(: round-float (Float . -> . Float))
@ -42,12 +41,12 @@
((inst make-hash (List String String Symbol Symbol) Measurement-Result-Type) '()))))
(: get-cached-font (String Symbol Symbol . -> . (Instance (Class (init-field)))))
(: get-cached-font (Font-Name Font-Weight Font-Style . -> . (Instance Font%)))
(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 ((String String) (Symbol Symbol) . ->* . Measurement-Result-Type))
(: measure-max-size ((String Font-Name) (Font-Weight Font-Style) . ->* . Measurement-Result-Type))
(define (measure-max-size text font [weight 'normal] [style 'normal])
(: hash-updater (-> Measurement-Result-Type))
(define (hash-updater)
@ -67,14 +66,14 @@
;; works by taking max size and scaling it down. Allows caching of results.
(: measure-text (String Positive-Float String Symbol Symbol . -> . Float))
(: measure-text (String Positive-Float String Font-Weight Font-Style . -> . Float))
(define (measure-text text size font weight style)
(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))
(: measure-ascent ((String Positive-Float String) (Font-Weight Font-Style) . ->* . Float))
(define (measure-ascent text size font [weight 'normal] [style 'normal])
(define result-list : Measurement-Result-Type (measure-max-size text font weight style))
(define raw-baseline-distance (- (height result-list) (descent result-list)))

@ -110,9 +110,7 @@
(((U Quad QuadAttrs) QuadAttrKey) (QuadAttrValue) . ->* . QuadAttrValue)
(define qas (if (quad? q-or-qas) (quad-attrs q-or-qas) q-or-qas))
(define qa-result (memf (λ([qap : QuadAttr]) (equal? key (car qap))) qas))
;; empty check shouldn't be necessary but the memf return type is lax: #f or (Listof A)
;; really it should be #f or (List* A (Listof A))
(if (and qa-result (not (empty? qa-result)))
(if qa-result
;; car beacause result of memf is a list tail; cadr because second element in pair
(quadattr-value (car qa-result))
(if (not (equal? default attr-missing)) default (error 'key-not-found))))
@ -164,14 +162,14 @@
;; start with the set of pairs in the first quad, then filter it down
[candidate-attr-pairs : (Listof QuadAttr) (let ([first-attrs (quad-attrs (car qs))])
(if first-attrs
(for/fold ([kvps : QuadAttrs null]) ([k (in-list (quad-attr-keys first-attrs))])
(if (member k cannot-be-common-attrs)
(for/fold ([kvps : QuadAttrs null]) ([qa (in-list first-attrs)])
(if (member (car qa) cannot-be-common-attrs)
kvps
(cons (make-quadattr k (quad-attr-ref first-attrs k)) kvps)))
(cons qa kvps)))
null))])
(cond
[(null? candidate-attr-pairs) null] ; ran out of possible pairs, so return #f
[(null? qs) (flatten candidate-attr-pairs)] ; ran out of quads, so return common-attr-pairs
[(null? qs) candidate-attr-pairs] ; ran out of quads, so return common-attr-pairs
;; todo: reconsider type interface between output of this function and input to quadattrs
[else (loop (cdr qs) (filter (λ([cap : QuadAttr]) (check-cap (car qs) cap)) candidate-attr-pairs))]))))
@ -186,8 +184,10 @@
(values (cons x ks) vs #f)
(values ks (cons (assert x QuadAttrValue?) vs) #t)))])
(when (not even?) (error 'quadattrs "odd number of elements in ~a" xs))
(for/list : QuadAttrs ([k (in-list ks)][v (in-list vs)])
(make-quadattr k v))))
;; use for/fold rather than for/list to impliedly reverse the list
;; (having been reversed once above, this puts it back in order)
(for/fold ([qas : QuadAttrs null])([k (in-list ks)][v (in-list vs)])
(cons (make-quadattr k v) qas))))

@ -5,19 +5,20 @@
(check-equal? (join-attrs (list (box '(width 10.0)) (quad-attrs (box '(x 10.0))) (list 'width 20.0)))
(list (cons 'width 10.0) (cons 'x 10.0) (cons 'width 20.0)))
(check-equal? (flatten-attrs (box '(foo bar)) (hash 'x 10.0)) (apply hash '(foo bar x 10.0)))
(check-equal? (flatten-attrs (hash 'x -5.0) (hash 'x 10.0)) (apply hash '(x 5.0)))
;(check-equal? (merge-attrs (hash 'x -5.0) (hash 'x 10.0)) (apply hash '(x 10.0)))
(check-equal? (flatten-attrs (box '(foo bar)) '(xray 10.0)) '((xray . 10.0) (foo . bar)))
(check-equal? (flatten-attrs (box '(foo bar)) '(x 10.0)) '((x . 10.0) (foo . bar))) ; flatten-attrs moves x and y to front
(check-equal? (flatten-attrs '(x -5.0) '(x 10.0)) '((x . 5.0)))
(check-equal? (gather-common-attrs (list (box '(foo bar)) (box '(foo bar goo bar zam zino)) (box '(foo bar goo rab)))) '(foo bar))
(check-false (gather-common-attrs (list (box) (box '(foo bar goo bar zam zino)) (box '(foo bar)))))
(check-false (gather-common-attrs (list (box '(width bar)) (box '(width bar)) (box '(width bar)))))
(check-false (gather-common-attrs (list (box '(foo bar)) (box '(foo zam)))))
(check-equal? (flatten-attrs '(dup 100) '(dup 200)) '((dup . 200))) ; later overrides earlier
(check-equal? (gather-common-attrs (list (box '(foo bar)) (box '(foo bar goo bar zam zino)) (box '(foo bar goo rab)))) '((foo . bar)))
(check-equal? (gather-common-attrs (list (box) (box '(foo bar goo bar zam zino)) (box '(foo bar)))) empty)
(check-equal? (gather-common-attrs (list (box '(width bar)) (box '(width bar)) (box '(width bar)))) empty)
(check-equal? (gather-common-attrs (list (box '(foo bar)) (box '(foo zam)))) empty)
(define b1 (box '(x 10.0) "1st" (box '(foo bar) "2nd") "3rd"))
(define b1-flattened (list (box '(x 10.0) "1st") (box '(x 10.0 foo bar) "2nd") (box '(x 10.0) "3rd")))
(define b3 (box #f (word) (line) (page)))
(define b3 (box '() (word) (line) (page)))
(check-true (quad= (flatten-quad b1) b1-flattened))
@ -25,13 +26,16 @@
(define b2-flattened (list (spacer '(x 10.0)) (spacer '(x 25.0)) (spacer '(x 25.0)) (spacer '(x 10.0))))
(check-true (quad= (flatten-quad b2) b2-flattened))
(check-true (quad= (split-quad b2) b2-flattened))
(check-true (quad= (flatten-quad (box '(foo 10) (spacer) (box) (spacer))) (list (spacer '(foo 10)) (box '(foo 10)) (spacer '(foo 10)))))
(check-equal? (compute-absolute-positions (page '(x 100.0 y 100.0) (line '(x 10.0 y 10.0) (word '(x 1.0 y 1.0) "hello")
(word '(x 2.0 y 2.0) "world"))))
(page '(y 100.0 x 100.0) (line '(y 110.0 x 110.0) (word '(y 111.0 x 111.0) "hello")(word '(y 112.0 x 112.0) "world"))))
(page '(x 100.0 y 100.0) (line '(x 110.0 y 110.0) (word '(x 111.0 y 111.0) "hello")(word '(x 112.0 y 112.0) "world"))))
(define b2-exploded (list (word '(x 10.0) "1") (word '(x 10.0) "s") (word '(x 10.0) "t") (word '(x 10.0 foo bar) "2") (word '(x 10.0 foo bar) "n") (word '(x 10.0 foo bar) "d") (word '(x 10.0) "3") (word '(x 10.0) "r") (word '(x 10.0) "d")))
@ -41,34 +45,34 @@
(check-true (quad-has-attr? (box '(foo bar)) 'foo))
(check-equal? (quad-attr-set (box '(foo bar)) 'foo 'zam) (box '(foo zam)))
(check-equal? (quad-attr-set (box #f) 'foo 'zam) (box '(foo zam)))
(check-equal? (quad-attr-set* (box #f) 'foo 'zam 'bar 'boo) (box '(foo zam bar boo)))
(check-equal? (quad-attr-set* (box '(foo bar)) 'foo 'zam 'bar 'boo) (box '(foo zam bar boo)))
(check-equal? (quad-attr-set (box) 'foo 'zam) (box '(foo zam)))
(check-equal? (quad-attr-set* (box) '(foo zam bar boo)) (box '(bar boo foo zam)))
(check-equal? (quad-attr-set* (box '(foo bar)) '(foo zam bar boo)) (box '(bar boo foo zam)))
(check-equal? (quad-attr-remove (box '(foo bar zim zam)) 'foo) (box '(zim zam)))
(check-equal? (quad-attr-remove (box #f) 'zim) (box))
(check-equal? (quad-attr-remove (box) 'zim) (box))
(check-equal? (quad-attr-remove* (box '(foo bar zim zam ding dong)) 'foo 'ding) (box '(zim zam)))
(check-equal? (quad-attr-remove* (box #f) 'zim) (box))
(check-equal? (quad-attr-remove* (box) 'zim) (box))
(check-true (quad-ends-with? (box #f "foo") "foo"))
(check-false (quad-ends-with? (box #f "foo") "food"))
(check-false (quad-ends-with? (box #f (box #f "foo")) "food"))
(check-true (quad-ends-with? (box #f (box #f "foo")) "foo"))
(check-true (quad-ends-with? (box #f (box #f "foo")) "o"))
(check-true (quad-ends-with? (box #f (box #f (box #f (box #f (box #f "foo-"))))) "-"))
(check-true (quad-ends-with? (box '() "foo") "foo"))
(check-false (quad-ends-with? (box '() "foo") "food"))
(check-false (quad-ends-with? (box '() (box '() "foo")) "food"))
(check-true (quad-ends-with? (box '() (box '() "foo")) "foo"))
(check-true (quad-ends-with? (box '() (box '() "foo")) "o"))
(check-true (quad-ends-with? (box '() (box '() (box '() (box '() (box '() "foo-"))))) "-"))
(check-equal? (quad-append (box #f "foo") "bar") (box #f "foo" "bar"))
(check-equal? (quad-append (box #f "foo") (box #f "bar")) (box #f "foo" (box #f "bar")))
(check-equal? (quad-append (box '() "foo") "bar") (box '() "foo" "bar"))
(check-equal? (quad-append (box '() "foo") (box '() "bar")) (box '() "foo" (box '() "bar")))
(check-equal? (quad-last-char (box #f (box #f "foo") "food")) "d")
(check-equal? (quad-last-char (box #f (box #f "foo"))) "o")
(check-equal? (quad-last-char (box #f "foo")) "o")
(check-equal? (quad-last-char (box '() (box '() "foo") "food")) "d")
(check-equal? (quad-last-char (box '() (box '() "foo"))) "o")
(check-equal? (quad-last-char (box '() "foo")) "o")
(check-false (quad-last-char (box)))
(check-equal? (quad-first-char (box #f (box #f "foo") "bar")) "f")
(check-equal? (quad-first-char (box #f (box #f "foo") "bar")) "f")
(check-equal? (quad-first-char (box #f "foo")) "f")
(check-equal? (quad-first-char (box '() (box '() "foo") "bar")) "f")
(check-equal? (quad-first-char (box '() (box '() "foo") "bar")) "f")
(check-equal? (quad-first-char (box '() "foo")) "f")
(check-false (quad-first-char (box)))
(check-equal? (quad->string (box '(width 100) "foo")) "foo")
@ -78,7 +82,7 @@
(check-false (whitespace? (~a #\u00A0)))
(check-true (whitespace/nbsp? (~a #\u00A0)))
(check-true (whitespace/nbsp? (word #f (~a #\u00A0))))
(check-true (whitespace/nbsp? (word '() (~a #\u00A0))))
(check-false (whitespace? (format " ~a " #\u00A0)))
(check-true (whitespace/nbsp? (format " ~a " #\u00A0)))
(define funny-unicode-spaces (map ~a (list #\u2000 #\u2007 #\u2009 #\u200a #\u202f)))

@ -1,8 +1,6 @@
#lang typed/racket/base
(require/typed sugar/list [slice-at ((Listof (U QuadAttrKey QuadAttrValue)) Positive-Integer . -> . (Listof (List QuadAttrKey QuadAttrValue)))])
(require/typed racket/list [flatten ((Rec as (U Quad (Listof as))) . -> . (Listof Quad))])
(require/typed hyphenate [hyphenate (String #:min-length Nonnegative-Integer #:min-left-length Nonnegative-Integer #:min-right-length Nonnegative-Integer . -> . String)])
(require (for-syntax racket/syntax racket/base) racket/string (except-in racket/list flatten) sugar/debug racket/bool racket/function math/flonum)
(require (for-syntax racket/syntax racket/base) racket/string racket/list sugar/debug racket/bool racket/function math/flonum)
(require "quads-typed.rkt" "world-typed.rkt" "measure-typed.rkt")
(define/typed+provide (quad-map proc q)
@ -21,23 +19,31 @@
;; push together multiple attr sources into one list of pairs.
;; mostly a helper function for the two attr functions below.
(define-type JoinableTypes (U Quad QuadAttrs HashableList))
;; does not resolve duplicates (see merge-attrs for that)
(define-type JoinableType (U Quad QuadAttrs HashableList))
(define/typed+provide (join-attrs quads-or-attrs-or-lists)
((Listof JoinableTypes) . -> . QuadAttrs)
(append-map (λ([x : JoinableTypes])
((Listof JoinableType) . -> . QuadAttrs)
(append-map (λ([x : JoinableType])
(cond
[(quad? x) (quad-attrs x)]
[(quad-attrs? x) x]
[else (make-quadattrs x)])) quads-or-attrs-or-lists))
;; merge uses join-attrs to concatenate attributes,
;; but then resolves duplicates, with later ones overriding earlier.
(define/typed+provide (merge-attrs . quads-or-attrs-or-lists)
(JoinableType * . -> . QuadAttrs)
(define all-attrs (join-attrs quads-or-attrs-or-lists))
(hash->list (make-hash all-attrs)))
;; flatten merges attributes, but applies special logic suitable to flattening
;; for instance, resolving x and y coordinates.
(define-type QuadAttrFloatPair (Pairof QuadAttrKey Float))
(define/typed+provide (flatten-attrs . quads-or-attrs-or-falses)
((U Quad QuadAttrs) * . -> . QuadAttrs)
(define all-attrs (join-attrs quads-or-attrs-or-falses))
(define/typed+provide (flatten-attrs . joinable-items)
(JoinableType * . -> . QuadAttrs)
(define all-attrs (join-attrs joinable-items))
(define-values (x-attrs y-attrs other-attrs-reversed)
(for/fold ([xas : (Listof QuadAttrFloatPair) null]
[yas : (Listof QuadAttrFloatPair) null]
@ -54,29 +60,41 @@
(list (cons (ann key QuadAttrKey) (foldl fl+ 0.0 ((inst map Float QuadAttrFloatPair) cdr attrs))))))
(define x-attr (make-cartesian-attr world:x-position-key x-attrs))
(define y-attr (make-cartesian-attr world:y-position-key y-attrs))
(append x-attr y-attr (reverse other-attrs-reversed)))
;; use hash to resolve duplicate entries by giving priority to later ones
;; then stuff x & y at the front (they will not have duplicates because they were already resolved)
(append x-attr y-attr (hash->list ((inst make-hash QuadAttrKey QuadAttrValue) (reverse other-attrs-reversed)))))
;; ordinary flatten won't work because a quad is a bare list,
;; and flatten will go too far.
;; this version adds a check for quadness to the flattener.
(define/typed (flatten-quadtree quad-tree)
((Treeof Quad) . -> . (Listof Quad))
(let loop ([sexp quad-tree][acc : (Listof Quad) null])
(cond [(null? sexp) acc]
[(quad? sexp) (cons sexp acc)]
[else (loop (car sexp) (loop (cdr sexp) acc))])))
(require sugar/debug)
;; starting with a single nested quad,
;; pushes attributes down from parent quads to children,
;; resulting in a flat list of quads.
(define/typed+provide (flatten-quad q)
(Quad . -> . (Listof Quad))
(flatten
(flatten-quadtree
(let loop : (Treeof Quad)
([x : QuadListItem q][parent : Quad (box)])
(cond
([x : QuadListItem q][parent : Quad (quad 'null '() '())])
(cond
[(quad? x)
(let ([x-with-parent-attrs (quad (quad-name x)
(flatten-attrs parent x) ; child positioned last so it overrides parent attributes
(quad-list x))])
(if (empty? (quad-list x))
x-with-parent-attrs ; no subelements, so stop here
((inst map (Treeof Quad) QuadListItem) (λ(xi) (loop xi x-with-parent-attrs)) (quad-list x))))] ; replace quad with its elements
[else ;; it's a string
(quad (quad-name parent) (quad-attrs parent) (list x))]))))
;; 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
@ -91,7 +109,7 @@
((inst map (Treeof Quad) QuadListItem) (λ(xi) (do-explode xi x)) (quad-list x)))] ; replace quad with its elements, exploded
[else ;; it's a string
((inst map (Treeof Quad) QuadListItem) (λ(xc) (quad world:split-quad-key (quad-attrs parent) (list xc))) (regexp-match* #px"." x))]))
(flatten (map do-explode (flatten-quad q))))
(flatten-quadtree (map do-explode (flatten-quad q))))
;; merge chars into words (and boxes), leave the rest
@ -109,13 +127,13 @@
;; this way, a nonexistent value will test true against a default value.
(andmap (λ([key : QuadAttrKey] [default : QuadAttrValue]) (equal? (quad-attr-ref base-q key default) (quad-attr-ref q key default)))
(ann (list world:font-name-key
world:font-size-key
world:font-weight-key
world:font-style-key) (Listof QuadAttrKey))
world:font-size-key
world:font-weight-key
world:font-style-key) (Listof QuadAttrKey))
(ann (list (world:font-name-default)
(world:font-size-default)
(world:font-weight-default)
(world:font-style-default)) (Listof QuadAttrValue))))))])
(world:font-size-default)
(world:font-weight-default)
(world:font-style-default)) (Listof QuadAttrValue))))))])
(let loop ([qs : (Listof Quad) qs-in][acc : (Listof Quad) null])
(if (null? qs)
(reverse acc)
@ -145,7 +163,7 @@
[(quad? qli)
(define adjusted-x (round-float (+ (assert (quad-attr-ref qli world:x-position-key 0.0) flonum?) parent-x)))
(define adjusted-y (round-float (+ (assert (quad-attr-ref qli world:y-position-key 0.0) flonum?) parent-y)))
(quad (quad-name qli) (join-attrs (list qli (list world:x-position-key adjusted-x world:y-position-key adjusted-y))) ((inst map QuadListItem QuadListItem) (λ(qlii) (loop qlii adjusted-x adjusted-y)) (quad-list qli)))]
(quad (quad-name qli) (merge-attrs qli (list world:x-position-key adjusted-x world:y-position-key adjusted-y)) ((inst map QuadListItem QuadListItem) (λ(qlii) (loop qlii adjusted-x adjusted-y)) (quad-list qli)))]
[else ;; it's a string
qli])))
(if (string? result)
@ -156,27 +174,28 @@
;; functionally update a quad attr. Similar to hash-set
(define/typed+provide (quad-attr-set q k v)
(Quad QuadAttrKey QuadAttrValue . -> . Quad)
(quad (quad-name q) (join-attrs (list (quad-attrs q) (list (cons k v)))) (quad-list q)))
(quad-attr-set* q (list k v)))
;; functionally update multiple quad attrs. Similar to hash-set*
(define/typed+provide (quad-attr-set* q . kvs)
(Quad (U QuadAttrKey QuadAttrValue) * . -> . Quad)
(for/fold ([current-q q])([kv-list (in-list (slice-at kvs 2))])
(apply quad-attr-set current-q kv-list)))
(define/typed+provide (quad-attr-set* q kvs)
(Quad HashableList . -> . Quad)
(quad (quad-name q) (merge-attrs (quad-attrs q) kvs) (quad-list q)))
;; functionally remove a quad attr. Similar to hash-remove
(define/typed+provide (quad-attr-remove q k)
(Quad QuadAttrKey . -> . Quad)
(if (quad-attrs q)
(quad (quad-name q) (filter (λ(qa) (equal? (car q) k)) (quad-attrs q)) (quad-list q))
q))
;; functionally remove multiple quad attrs. Similar to hash-remove*
(define/typed+provide (quad-attr-remove* q . ks)
(Quad QuadAttrKey * . -> . Quad)
(for/fold ([current-q q])([k (in-list ks)])
(quad-attr-remove current-q k)))
(if (not (empty? (quad-attrs q)))
;; test all ks as a set so that iteration through attrs only happens once
(quad (quad-name q) (filter (λ([qa : QuadAttr]) (not (ormap (λ(k) (equal? (car qa) k)) ks))) (quad-attrs q)) (quad-list q))
q))
;; functionally remove a quad attr. Similar to hash-remove
(provide quad-attr-remove)
(define quad-attr-remove quad-attr-remove*)
;; the last char of a quad

Loading…
Cancel
Save