diff --git a/quad/core-types.rkt b/quad/core-types.rkt new file mode 100644 index 00000000..be0fafb7 --- /dev/null +++ b/quad/core-types.rkt @@ -0,0 +1,71 @@ +#lang typed/racket/base +(require (for-syntax typed/racket/base racket/syntax) (only-in typed/racket/draw Font-Weight Font-Style)) +(provide (all-defined-out) (all-from-out typed/racket/draw)) + +(define-syntax (define/typed stx) + (syntax-case stx () + [(_ (proc-name arg ... . rest-arg) type-expr body ...) + #'(define/typed proc-name type-expr + (λ(arg ... . rest-arg) body ...))] + [(_ proc-name type-expr body ...) + #'(begin + (: proc-name type-expr) + (define proc-name body ...))])) + +(define-syntax (define/typed+provide stx) + (syntax-case stx () + [(_ (proc-name arg ... . rest-arg) type-expr body ...) + #'(begin + (provide proc-name) + (define/typed proc-name type-expr + (λ(arg ... . rest-arg) body ...)))] + [(_ proc-name type-expr body ...) + #'(begin + (provide proc-name) + (begin + (: proc-name type-expr) + (define proc-name body ...)))])) + +(define-syntax (define-type+predicate stx) + (syntax-case stx () + [(_ id basetype) + (with-syntax ([id? (format-id stx "~a?" #'id)]) + #'(begin + (define-type id basetype) + (define-predicate id? id)))])) + +(define-type+predicate QuadName Symbol) +(define-type+predicate QuadAttrKey Symbol) +(define-type+predicate QuadAttrValue (U Float Index String Symbol Boolean Quad QuadAttrs QuadList Integer)) +;; QuadAttr could be a list, but that would take twice as many cons cells. +;; try the economical approach. +(define-type+predicate QuadAttr (Pairof QuadAttrKey QuadAttrValue)) +(define-type+predicate QuadAttrs (Listof QuadAttr)) +(define quad-attrs? QuadAttrs?) +(define-type+predicate HashableList (Rec duo (U Null (List* QuadAttrKey Any duo)))) +(define-type JoinableType (U Quad QuadAttrs HashableList)) + + +(define-type QuadListItem (U String Quad)) +(define-type+predicate QuadList (Listof QuadListItem)) +(define-type+predicate GroupQuadList (Listof Quad)) +(define-type (Treeof A) (Rec as (U A (Listof as)))) + + +;; funky implementation +(define-type+predicate Quad (List* QuadName QuadAttrs QuadList)) +(define-type+predicate GroupQuad (List* QuadName QuadAttrs GroupQuadList)) +(define-predicate quad? Quad) +(define/typed (quad name attrs items) + (QuadName QuadAttrs QuadList . -> . Quad) + `(,name ,attrs ,@items)) + +(define-type+predicate QuadSet (List QuadName QuadAttrs (Listof Quad))) + + +(define-type+predicate Font-Name String) +(define-type+predicate Font-Size Positive-Flonum) +(define-predicate Font-Weight? Font-Weight) +(define-predicate Font-Style? Font-Style) + +(define-predicate Index? Index) diff --git a/quad/measure-typed.rkt b/quad/measure-typed.rkt index 3b094b3d..91cff25a 100644 --- a/quad/measure-typed.rkt +++ b/quad/measure-typed.rkt @@ -1,13 +1,11 @@ #lang typed/racket/base (require (for-syntax typed/racket/base)) -(require typed/racket/class math/flonum racket/list racket/file typed/racket/draw) - +(require typed/racket/class math/flonum racket/list racket/file typed/racket/draw "core-types.rkt") (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) @@ -17,37 +15,36 @@ (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 Font-Name Font-Weight Font-Style) (Instance Font%)) '()))) - -(: round-float (Float . -> . Float)) -(define (round-float x) +(define/typed (round-float x) + (Float . -> . Float) (/ (round (* base x)) base)) -(: get-cache-file-path (-> Path)) -(define (get-cache-file-path) +(define/typed (get-cache-file-path) + (-> Path) (build-path "font.cache")) -(: update-text-cache-file (-> Void)) -(define (update-text-cache-file) +(define/typed (update-text-cache-file) + (-> Void) (write-to-file (serialize (current-text-cache)) (get-cache-file-path) #:exists 'replace)) -(: load-text-cache-file (-> Void)) -(define (load-text-cache-file) +(define/typed (load-text-cache-file) + (-> Void) (define cache-file-path (get-cache-file-path)) (current-text-cache (if (file-exists? cache-file-path) (deserialize (file->value cache-file-path)) ((inst make-hash (List String String Symbol Symbol) Measurement-Result-Type) '())))) -(: get-cached-font (Font-Name Font-Weight Font-Style . -> . (Instance Font%))) -(define (get-cached-font font weight style) +(define/typed (get-cached-font font weight style) + (Font-Name Font-Weight Font-Style . -> . (Instance Font%)) (hash-ref! (current-font-cache) (list font weight style) (λ() (make-font #:size max-size #:style style #:weight weight #:face font)))) -(: measure-max-size ((String Font-Name) (Font-Weight Font-Style) . ->* . Measurement-Result-Type)) -(define (measure-max-size text font [weight 'normal] [style 'normal]) +(define/typed (measure-max-size text font [weight 'normal] [style 'normal]) + ((String Font-Name) (Font-Weight Font-Style) . ->* . Measurement-Result-Type) (: hash-updater (-> Measurement-Result-Type)) (define (hash-updater) #;(current-text-cache-changed? #t) @@ -66,15 +63,15 @@ ;; works by taking max size and scaling it down. Allows caching of results. -(: measure-text (String Positive-Float String Font-Weight Font-Style . -> . Float)) -(define (measure-text text size font weight style) +(define/typed (measure-text text size font weight style) + (String Font-Size Font-Name Font-Weight Font-Style . -> . Float) (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) (Font-Weight Font-Style) . ->* . Float)) -(define (measure-ascent text size font [weight 'normal] [style 'normal]) +(define/typed (measure-ascent text size font [weight 'normal] [style 'normal]) + ((String Font-Size Font-Name) (Font-Weight Font-Style) . ->* . 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))) \ No newline at end of file diff --git a/quad/quads-typed.rkt b/quad/quads-typed.rkt index de2e19ab..d3b2d23e 100644 --- a/quad/quads-typed.rkt +++ b/quad/quads-typed.rkt @@ -1,6 +1,6 @@ #lang typed/racket/base (require (for-syntax typed/racket/base racket/syntax racket/string)) -(require "lib-typed.rkt") +(require "lib-typed.rkt" "core-types.rkt") ;; note to self: a require/typed function with proper typing ;; is faster than a generic function + type assertion at location of call (require/typed racket/list @@ -13,67 +13,11 @@ (provide (all-defined-out)) -(define-syntax (define/typed stx) - (syntax-case stx () - [(_ (proc-name arg ... . rest-arg) type-expr body ...) - #'(define/typed proc-name type-expr - (λ(arg ... . rest-arg) body ...))] - [(_ proc-name type-expr body ...) - #'(begin - (: proc-name type-expr) - (define proc-name body ...))])) - -(define-syntax (define/typed+provide stx) - (syntax-case stx () - [(_ (proc-name arg ... . rest-arg) type-expr body ...) - #'(begin - (provide proc-name) - (define/typed proc-name type-expr - (λ(arg ... . rest-arg) body ...)))] - [(_ proc-name type-expr body ...) - #'(begin - (provide proc-name) - (begin - (: proc-name type-expr) - (define proc-name body ...)))])) - - (define-syntax-rule (even-members xs) (for/list : (Listof Any) ([(x i) (in-indexed xs)] #:when (even? i)) x)) -(define-syntax (define-type+predicate stx) - (syntax-case stx () - [(_ id basetype) - (with-syntax ([id? (format-id stx "~a?" #'id)]) - #'(begin - (define-type id basetype) - (define-predicate id? id)))])) - -(define-type+predicate QuadName Symbol) -(define-type+predicate QuadAttrKey Symbol) -(define-type+predicate QuadAttrValue (U Float Index String Symbol Boolean)) -;; QuadAttr could be a list, but that would take twice as many cons cells. -;; try the economical approach. -(define-type+predicate QuadAttr (Pairof QuadAttrKey QuadAttrValue)) -(define-type+predicate QuadAttrs (Listof QuadAttr)) -(define-type+predicate HashableList (Rec duo (U Null (List* QuadAttrKey Any duo)))) -(define quad-attrs? QuadAttrs?) - -(define-type QuadListItem (U String Quad)) -(define-type QuadList (Listof QuadListItem)) -(define-type (Treeof A) (Rec as (U A (Listof as)))) - - -;; funky implementation -(define-type+predicate Quad (List* QuadName QuadAttrs (Listof (U String Quad)))) -(define-predicate quad? Quad) -(define/typed (quad name attrs items) - (QuadName QuadAttrs QuadList . -> . Quad) - `(,name ,attrs ,@items)) - -(define-type+predicate QuadSet (List QuadName QuadAttrs (Listof Quad))) (define/typed (quad-name q) (Quad . -> . QuadName) @@ -102,7 +46,9 @@ ((inst map QuadAttrKey QuadAttr) car qas))) (define/typed (quad-list q) - (Quad . -> . QuadList) + (case-> + (GroupQuad . -> . GroupQuadList) + (Quad . -> . QuadList)) (cdr (cdr q))) @@ -199,6 +145,8 @@ [idsym (format-id #'id "~asym" #'id)] [IdQuad (format-id #'id "~aQuad" (string-titlecase (symbol->string (syntax->datum #'id))))] [IdQuad? (format-id #'id "~aQuad?" (string-titlecase (symbol->string (syntax->datum #'id))))] + [IdGroupQuad (format-id #'id "~aGroupQuad" (string-titlecase (symbol->string (syntax->datum #'id))))] + [IdGroupQuad? (format-id #'id "~aGroupQuad?" (string-titlecase (symbol->string (syntax->datum #'id))))] [quads->id (format-id #'id "quads->~a" #'id)]) #'(begin ;; quad converter @@ -209,6 +157,10 @@ ;; (define-type IdInteger id-integer) ; for experimental quad names (= faster, smaller fixnum names) (define-type IdQuad (List* 'id QuadAttrs (Listof (U String Quad)))) (define-predicate IdQuad? IdQuad) + + ;; group version of quad has no strings in its quad-list + (define-type IdGroupQuad (List* 'id QuadAttrs (Listof Quad))) + (define-predicate IdGroupQuad? IdGroupQuad) (define id? IdQuad?) (define/typed (id [attrs '()] #:zzz [zzz 0] . xs) diff --git a/quad/utils-typed.rkt b/quad/utils-typed.rkt index 12548a9e..48d2a538 100644 --- a/quad/utils-typed.rkt +++ b/quad/utils-typed.rkt @@ -1,7 +1,7 @@ #lang typed/racket/base (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 racket/list sugar/debug racket/bool racket/function math/flonum) -(require "quads-typed.rkt" "world-typed.rkt" "measure-typed.rkt") +(require "quads-typed.rkt" "world-typed.rkt" "measure-typed.rkt" "core-types.rkt") (define/typed+provide (quad-map proc q) ((QuadListItem . -> . QuadListItem) Quad . -> . Quad) @@ -20,7 +20,6 @@ ;; push together multiple attr sources into one list of pairs. ;; mostly a helper function for the two attr functions below. ;; 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 JoinableType) . -> . QuadAttrs) (append-map (λ([x : JoinableType]) @@ -160,7 +159,8 @@ (define result (let loop : QuadListItem ([qli : QuadListItem qli][parent-x : Float 0.0][parent-y : Float 0.0]) (cond - [(quad? qli) + [(quad? qli) + (display 'foom3) (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) (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)))] @@ -232,6 +232,7 @@ (define/typed+provide (quad-height q) (Quad . -> . Float) + (display 'foom) (assert (quad-attr-ref q world:height-key 0.0) flonum?)) ;; use heights to compute vertical positions @@ -240,6 +241,7 @@ (define-values (new-quads final-height) (for/fold ([new-quads : (Listof Quad) empty][height-so-far : Float 0.0]) ([q (in-list (quad-list starting-quad))]) + (display 'foom2) (assert q quad?) (values (cons (quad-attr-set q world:y-position-key height-so-far) new-quads) (round-float (+ height-so-far (quad-height q)))))) diff --git a/quad/world-typed.rkt b/quad/world-typed.rkt index 229f6aae..c78be45b 100644 --- a/quad/world-typed.rkt +++ b/quad/world-typed.rkt @@ -1,45 +1,46 @@ #lang typed/racket/base -(require (for-syntax typed/racket/base racket/syntax)) +(require (for-syntax typed/racket/base racket/syntax) "core-types.rkt") (provide (prefix-out world: (all-defined-out))) -(define-syntax-rule (define-parameter name val) - (define name (make-parameter val))) + +(define-syntax-rule (define-parameter-typed name val type) + (define name : (Parameterof type) (make-parameter val))) (define-syntax (define-key-and-parameter stx) (syntax-case stx () - [(_ name keyname val) + [(_ name keyname val type) (with-syntax ([name-key (format-id #'name "~a-key" #'name)] [name-default (format-id #'name "~a-default" #'name)]) #'(begin - (define name-key keyname) - (define-parameter name-default val)))])) + (define name-key : QuadAttrKey keyname) + (define-parameter-typed name-default val type)))])) -(define-key-and-parameter measure 'measure 300.0) +(define-key-and-parameter measure 'measure 300.0 QuadAttrValue) -(define-key-and-parameter font-size 'size 13.0) -(define-key-and-parameter font-name 'font "Triplicate T4") -(define-key-and-parameter font-weight 'weight 'normal) -(define-key-and-parameter font-style 'style 'normal) -(define-key-and-parameter font-color 'color "black") -(define-key-and-parameter font-background 'background "none") +(define-key-and-parameter font-size 'size 13.0 Font-Size) +(define-key-and-parameter font-name 'font "Triplicate T4" Font-Name) +(define-key-and-parameter font-weight 'weight 'normal Font-Weight) +(define-key-and-parameter font-style 'style 'normal Font-Style) +(define-key-and-parameter font-color 'color "black" String) +(define-key-and-parameter font-background 'background "none" String) -(define-key-and-parameter column-count 'column-count 2) -(define-key-and-parameter column-gutter 'column-gutter 30.0) +(define-key-and-parameter column-count 'column-count 2 Index) +(define-key-and-parameter column-gutter 'column-gutter 30.0 Float) (define max-quality 100) (define adaptive-quality 50) (define draft-quality 20) -(define-key-and-parameter quality 'quality max-quality) +(define-key-and-parameter quality 'quality max-quality Index) -(define-key-and-parameter horiz-alignment 'x-align 'left) -(define-key-and-parameter leading 'leading (floor (* (font-size-default) 1.4))) +(define-key-and-parameter horiz-alignment 'x-align 'left QuadAttrKey) +(define-key-and-parameter leading 'leading (floor (* (font-size-default) 1.4)) Float) -(define-key-and-parameter paper-width 'paper-width (* 8.5 72)) -(define-key-and-parameter paper-height 'paper-height (* 11.0 72)) +(define-key-and-parameter paper-width 'paper-width (* 8.5 72) Float) +(define-key-and-parameter paper-height 'paper-height (* 11.0 72) Float) (define line-looseness-key 'looseness) (define width-key 'width) @@ -71,11 +72,9 @@ (define mergeable-quad-types '(char run word)) +(define default-word-break-list : (Parameterof JoinableType) (make-parameter '(nb "" bb "-"))) - -(define-parameter default-word-break-list '(nb "" bb "-")) - -(define-parameter optical-overhang 0.8) +(define-parameter-typed optical-overhang 0.8 Float) (define line-looseness-tolerance 0.05) ; 0.04 seems to be the magic point that avoids a lot of hyphenation (define hyphen-limit 1) ; does not work with first-fit wrapping @@ -96,5 +95,4 @@ (define min-last-lines 2) (define default-lines-per-column 36) -(: logging-level (Parameterof Log-Level)) -(define logging-level (make-parameter 'debug)) ;; usually 'debug for dev. change to 'info for less \ No newline at end of file +(define-parameter-typed logging-level 'debug Log-Level) ;; usually 'debug for dev. change to 'info for less \ No newline at end of file diff --git a/quad/wrap-typed.rkt b/quad/wrap-typed.rkt index 3cd1a5cd..7ad3d7b0 100644 --- a/quad/wrap-typed.rkt +++ b/quad/wrap-typed.rkt @@ -3,9 +3,9 @@ (require/typed sugar/list [slicef-after ((Listof Quad) (Quad . -> . Boolean) . -> . (Listof (Listof Quad)))] [shift ((Listof Any) (Listof Integer) . -> . (Listof Any))] [break-at ((Listof Quad) (Listof Nonnegative-Integer) . -> . (Listof (Listof Quad)))]) -(require math/flonum (except-in racket/list flatten) racket/vector math/statistics) +(require math/flonum (except-in racket/list flatten) racket/vector math/statistics racket/bool) (require/typed racket/list [flatten (All (A) (Rec as (U Any (Listof as))) -> (Listof Any))]) -(require "ocm-typed.rkt" "quads-typed.rkt" "utils-typed.rkt" "measure-typed.rkt" "world-typed.rkt" "logger-typed.rkt") +(require "ocm-typed.rkt" "quads-typed.rkt" "utils-typed.rkt" "measure-typed.rkt" "world-typed.rkt" "logger-typed.rkt" "core-types.rkt") ;; predicate for the soft hyphen (define/typed (soft-hyphen? x) @@ -63,7 +63,7 @@ [(soft-hyphen? str) (list world:no-break-key "" world:before-break-key "-")] ;; a visible breakable character is always visible [(visible-breakable? str) (list world:no-break-key str world:before-break-key str)] - [else (cast (world:default-word-break-list) HashableList)])) (quad-list q))] + [else (world:default-word-break-list)])) (quad-list q))] [else #f])) (or result (error 'convert-to-word-break "result was a not word break for input:" q))) @@ -82,25 +82,25 @@ Make-Pieces-Type (define-values (breakable-items items-to-make-unbreakable) (split-at-right qs (min world:minimum-last-line-chars (length qs)))) (define unbreak-qs (append breakable-items (map make-unbreakable items-to-make-unbreakable))) - (define lists-of-quads (slicef-after unbreak-qs (λ(q) (and (possible-word-break-quad? (cast q Quad)) (not (quad-attr-ref (cast q Quad) world:unbreakable-key #f)))))) + (define lists-of-quads (slicef-after unbreak-qs (λ([q : Quad]) (and (possible-word-break-quad? q) (not (quad-attr-ref q world:unbreakable-key #f)))))) (define-values (first-lists-of-quads last-list-of-quads) ((inst split-last (Listof Quad)) lists-of-quads)) (define/typed (make-first-pieces qs) ((Listof Quad) . -> . Quad) (let-values ([(first-qs last-q) ((inst split-last Quad) qs)]) - (apply piece (list world:word-break-key (convert-to-word-break (cast last-q Quad))) (cast first-qs QuadList)))) + (apply piece (list world:word-break-key (convert-to-word-break last-q)) first-qs))) (append (map make-first-pieces first-lists-of-quads) - (list (apply piece #f (cast last-list-of-quads QuadList))))) + (list (apply piece null last-list-of-quads)))) ;; extract font attributes from quad, or get default values (define/typed (font-attributes-with-defaults q) - (Quad . -> . (List Positive-Float String Symbol Symbol)) + (Quad . -> . (List Font-Size Font-Name Font-Weight Font-Style)) (list - (cast (let ([size (quad-attr-ref/parameter q world:font-size-key)]) - (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))) + (assert (let ([size (quad-attr-ref/parameter q world:font-size-key)]) + (if (exact-integer? size) (fl size) size)) Font-Size?) + (assert (quad-attr-ref/parameter q world:font-name-key) Font-Name?) + (assert (quad-attr-ref/parameter q world:font-weight-key) Font-Weight?) + (assert (quad-attr-ref/parameter q world:font-style-key) Font-Style?))) ;; get the width of a quad. @@ -111,11 +111,11 @@ (define/typed (quad-width q) Measure-Quad-Type (cond - [(quad-has-attr? q world:width-key) (fl (cast (quad-attr-ref q world:width-key) Real))] + [(quad-has-attr? q world:width-key) (fl (assert (quad-attr-ref q world:width-key) flonum?))] [(ormap (λ([pred : (Any . -> . Boolean)]) (pred q)) (list char? run? word? word-break?)) (apply measure-text (word-string q) (font-attributes-with-defaults q))] - [(line? q) (fl (apply + ((inst map Float Quad) quad-width (cast (quad-list q) (Listof Quad)))))] + [(LineGroupQuad? q) (foldl + 0.0 (map quad-width (quad-list q)))] [else 0.0])) ;; get the ascent (distance from top of text to baseline) @@ -145,7 +145,7 @@ ;; only needs it if the appearance of the piece changes based on location. ;; so words are likely to have a word-break item; boxes not. ;; the word break item contains the different characters needed to finish the piece. - (define the-word-break (cast (quad-attr-ref p world:word-break-key #f) (Option Quad))) + (define the-word-break (assert (quad-attr-ref p world:word-break-key #f) (λ(v) (or (false? v) (Quad? v))))) (let ([p (quad-attr-remove p world:word-break-key)]) ; so it doesn't propagate into subquads (if the-word-break (quad (quad-name p) (quad-attrs p) @@ -170,7 +170,7 @@ (Quad Symbol . -> . Quad) (let ([break-char (quad-attr-ref wb key)]) (quad (if (whitespace? break-char) 'word-break 'word) - (hash-remove (hash-remove (quad-attrs wb) world:no-break-key) world:before-break-key) (list (cast (quad-attr-ref wb key) String))))) + (quad-attrs (quad-attr-remove* wb world:no-break-key world:before-break-key)) (list (assert (quad-attr-ref wb key) string?))))) ;; uses macro above in no-break mode. (define/typed (word-break->no-break wb) @@ -185,8 +185,8 @@ ;; is this the last line? compare current line-idx to total lines (define/typed (last-line? line) (Quad . -> . Boolean) - (define line-idx (cast (quad-attr-ref line world:line-index-key #f) Number)) - (define lines (cast (quad-attr-ref line world:total-lines-key #f) Number)) + (define line-idx (assert (quad-attr-ref line world:line-index-key #f) Index?)) + (define lines (assert (quad-attr-ref line world:total-lines-key #f) Index?)) (and line-idx lines (= (add1 line-idx) lines))) ;; optical kerns are automatically inserted at the beginning and end of a line @@ -202,8 +202,8 @@ ((Listof Quad) . -> . (Listof Quad)) (define/typed (overhang-width q) ((U Quad False) . -> . Float) - (if (and (word? q) (member (word-string (cast q Quad)) world:hanging-chars)) - (* -1.0 (world:optical-overhang) (apply measure-text (word-string (cast q Quad)) (font-attributes-with-defaults (cast q Quad)))) + (if (and (word? q) (member (word-string q) world:hanging-chars)) + (* -1.0 (world:optical-overhang) (apply measure-text (word-string q) (font-attributes-with-defaults q))) 0.0)) (cond [(not (empty? exploded-line-quads)) @@ -245,9 +245,9 @@ (define/typed (copy-with-attrs q attr-source) (Quad Quad . -> . Quad) (define keys-to-ignore '(width)) ; width will be determined during fill routine - (define filtered-hash (cast (and (quad-attrs attr-source) - (foldl (λ(k [ht : HashTableTop]) (hash-remove ht k)) (quad-attrs attr-source) keys-to-ignore)) QuadAttrs)) - (quad (quad-name q) (merge-attrs filtered-hash q) (quad-list q))) + (define filtered-attrs (and (quad-attrs attr-source) + (quad-attrs (apply quad-attr-remove* attr-source keys-to-ignore)))) + (quad (quad-name q) (merge-attrs (or filtered-attrs null) q) (quad-list q))) (quad (quad-name line) (quad-attrs line) @@ -298,15 +298,15 @@ (define rendered-pieces (render-pieces ps)) (define split-pieces (map quad-list rendered-pieces)) (define line-quads (let ([result (append* split-pieces)]) - (if (andmap Quad? result) - result - (error 'line-quads "bad result")))) + (if (andmap Quad? result) + result + (error 'line-quads "bad result")))) (define line-quads-maybe-with-opticals (if (and world:use-optical-kerns? (> (length line-quads) 0)) - (render-optical-kerns - (let ([my-ok (list (optical-kern (quad-attrs (car line-quads))))]) ; take attrs from line, incl measure - (append my-ok line-quads my-ok))) - line-quads)) + (render-optical-kerns + (let ([my-ok (list (optical-kern (quad-attrs (car line-quads))))]) ; take attrs from line, incl measure + (append my-ok line-quads my-ok))) + line-quads)) (define merged-quads (join-quads line-quads-maybe-with-opticals)) (define merged-quad-widths (map measure-quad-proc merged-quads)) ; 10% of function time @@ -317,9 +317,9 @@ (error 'pieces->line "quad has no measure key: ~a" (first line-quads))) (define measure (let ([val (quad-attr-ref (first merged-quads) world:measure-key)]) - (if (flonum? val) - val - (error "got bad value for measure")))) + (if (flonum? val) + val + (error "got bad value for measure")))) (define looseness (calc-looseness (foldl fl+ 0.0 merged-quad-widths) measure)) ;; quads->line function hoists common attributes into the line @@ -384,7 +384,7 @@ (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))) 0.0))) - (quad-attr-set* p 'bb-width before-break-width 'nb-width no-break-width)) + (quad-attr-set* p (list 'bb-width before-break-width 'nb-width no-break-width))) (require sugar/debug) (define/typed (make-piece-vectors pieces)