another

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-> 

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)

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))