diff --git a/quad/quads-typed.rkt b/quad/quads-typed.rkt index 8a298d36..7445404f 100644 --- a/quad/quads-typed.rkt +++ b/quad/quads-typed.rkt @@ -10,6 +10,17 @@ (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 ...))])) + + (: hashable-list? (Any . -> . Boolean)) (define (hashable-list? x) (and (list? x) (even? (length x)))) @@ -121,11 +132,11 @@ (syntax-case stx () [(_ id) (with-syntax ([id? (format-id #'id "~a?" #'id)] - [Quads->id (format-id #'id "Quads->~a" #'id)]) + [quads->id (format-id #'id "quads->~a" #'id)]) #'(begin ;; quad converter - (: Quads->id ((Listof Quad) . -> . Quad)) - (define (Quads->id qs) + (: quads->id ((Listof Quad) . -> . Quad)) + (define (quads->id qs) (apply id (gather-common-attrs qs) qs)) (: id (case-> diff --git a/quad/utils-typed.rkt b/quad/utils-typed.rkt index 3a1f995e..2b75df16 100644 --- a/quad/utils-typed.rkt +++ b/quad/utils-typed.rkt @@ -102,6 +102,44 @@ (cast (flatten (map do-explode (flatten-quad q))) (Listof Quad))) +;; merge chars into words (and boxes), leave the rest +;; if two quads are mergeable types, and have the same attributes, +;; they get merged. +;; input is often large, so macro allows us to avoid allocation +(provide join-quads) +(define/typed (join-quads qs-in) + ((Listof Quad) . -> . (Listof Quad)) + + (let ([make-matcher (λ ([base-q : Quad]) + (λ([q : Quad]) + (and (member (quad-name q) world:mergeable-quad-types) + (not (whitespace/nbsp? q)) + ;; if key doesn't exist, it is compared against the default value. + ;; this way, a nonexistent value will test true against a default value. + (andmap (λ([key : Symbol] default) (equal? (quad-attr-ref base-q key default) (quad-attr-ref q key default))) + (list world:font-name-key + world:font-size-key + world:font-weight-key + world:font-style-key) + (list (world:font-name-default) + (world:font-size-default) + (world:font-weight-default) + (world:font-style-default))))))]) + (let loop ([qs qs-in][acc null]) + (if (null? qs) + (reverse (cast acc (Listof Quad))) + (let* ([base-q (first qs)] + [mergeable-and-matches-base? (make-matcher base-q)]) ; make a new predicate function for this quad + (cond + [(mergeable-and-matches-base? base-q) + ;; take as many quads that match, using the predicate function + (define-values (matching-qs other-qs) (splitf-at (cdr qs) mergeable-and-matches-base?)) + (define new-word (word (quad-attrs base-q) (string-append* (cast ((inst append-map QuadListItem Quad) quad-list (cons base-q matching-qs)) (Listof String))))) + (loop other-qs (cons new-word acc))] + ;; otherwise move on to the next in line + [else (loop (cdr qs) (cons base-q acc))])))))) + + ;; propagate x and y adjustments throughout the tree, ;; using parent x and y to adjust children, and so on. (provide compute-absolute-positions) diff --git a/quad/wrap-typed.rkt b/quad/wrap-typed.rkt index f8562052..a5b22fe0 100644 --- a/quad/wrap-typed.rkt +++ b/quad/wrap-typed.rkt @@ -6,17 +6,6 @@ (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") - -(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 ...))])) - ;; predicate for the soft hyphen (define/typed (soft-hyphen? x) (String . -> . Boolean) @@ -286,3 +275,40 @@ (define/typed (calc-looseness total-width measure) (Flonum Flonum . -> . Flonum) (round-float (fl/ (fl- measure total-width) measure))) + + +;; compose pieces into a finished line. +;; take the contents of the rendered pieces and merge them. +;; compute looseness for line as a whole. +;; also add ascent to each component quad, which can be different depending on font & size. +(define/typed (pieces->line ps measure-quad-proc) + ((Listof Quad) (Quad . -> . Flonum) . -> . Quad) + + ;; handle optical kerns here to avoid resplitting and rejoining later. + (define rendered-pieces (render-pieces ps)) + (define split-pieces (map quad-list rendered-pieces)) + (define line-quads (cast (append* split-pieces) (Listof Quad))) + (define line-quads-maybe-with-opticals + (if world:use-optical-kerns? + (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 + + (log-quad-debug "making pieces into line = ~v" (apply string-append (map quad->string merged-quads))) + + ;; if measure key isn't present, allow an error, because that's weird + (when (not (quad-has-attr? (first line-quads) world:measure-key)) + (error 'pieces->line "quad has no measure key: ~a" (first line-quads))) + + (define measure (cast (quad-attr-ref (first merged-quads) world:measure-key) Flonum)) + (define looseness (calc-looseness (fl (apply + merged-quad-widths)) measure)) + + ;; quads->line function hoists common attributes into the line + (let* ([new-line-quads (map embed-width merged-quads merged-quad-widths)] ; 15% of time + [new-line-quads (map record-ascent new-line-quads)] ; 35% of time + [new-line (quads->line new-line-quads)] + [new-line (quad-attr-set new-line world:line-looseness-key looseness)]) + new-line))