woe

quad/quad/atomize.rkt

@@ -7,7 +7,7 @@
 (define (update-with base-hash . update-hashes)
   ;; starting with base-hash, add or update keys found in update-hashes
   (for/hasheq ([(k v) (in-dict (append-map hash->list (list* base-hash update-hashes)))])
-    (values k v)))
+              (values k v)))
 
 (module+ test
   (check-equal?
@@ -42,11 +42,11 @@
       (match x
         [(? char? c) (list (q attrs c))]
         [(? string?) (append* (for/list ([c (in-string x)]) ;; strings are exploded
-                                (loop c attrs)))]
+                                        (loop c attrs)))]
         [($quad this-attrs elems) ;; qexprs with attributes are recursed
          (define merged-attrs (attrs . update-with . this-attrs))
          (append* (for/list ([elem (in-list elems)])
-                    (loop elem merged-attrs)))]
+                            (loop elem merged-attrs)))]
         [else (raise-argument-error 'atomize "valid item" x)])))
   (merge-whitespace atomic-quads))
 
@@ -83,14 +83,17 @@
 (define (isolate-white str)
   (for/list ([m (in-list (regexp-match* " " str #:gap-select? #t))]
              #:when (positive? (string-length m)))
-    m))
+            m))
 
-(define (merge-adjacent-strings xs [acc null])
-  (match xs
-    [(== empty) (reverse acc)]
-    [(list (? string? strs) ..1 others ...)
-     (merge-adjacent-strings others (append (reverse (isolate-white (merge-white (apply string-append strs)))) acc))]
-    [(cons x others) (merge-adjacent-strings others (cons x acc))]))
+(define (merge-adjacent-strings xs [isolate-white? #false])
+  (let loop ([xs xs][acc null])
+    (match xs
+      [(== empty) (reverse acc)]
+      [(list (? string? strs) ..1 others ...)
+       (loop others (append (reverse ((if isolate-white?
+                                           (compose1 isolate-white merge-white)
+                                           list) (apply string-append strs))) acc))]
+      [(cons x others) (loop others (cons x acc))])))
   
 (define (runify qx)
   ;; runify a quad by reducing it to a series of "runs",
@@ -100,10 +103,10 @@
      (match x
        [($quad this-attrs elems) ;; qexprs with attributes are recursed
         (define merged-attrs (attrs . update-with . this-attrs))
-        (append* (for/list ([elem (in-list (merge-adjacent-strings elems))])
-                   (if (string? elem)
-                       (list (q merged-attrs elem))
-                       (loop elem merged-attrs))))]))
+        (append* (for/list ([elem (in-list (merge-adjacent-strings elems 'merge-white))])
+                           (if (string? elem)
+                               (list (q merged-attrs elem))
+                               (loop elem merged-attrs))))]))
    (λ (q) (string=? " " (car (elems q))))))
 
 (module+ test

quad/quad/typewriter-test.rkt

@@ -1,3 +1,3 @@
 #lang quad/typewriter
 
-◊quad[#:fontsize "11"]{◊quad[#:link "http://beautifulracket.com"]{An expression that} is not a value can ◊quad[#:fontsize "22"]{always}  ◊quad[#:fontsize "7"]{be partitioned} into two parts: a redex, which is the part that changed in a single-step simplification (highlighted), and the continuation, which is the evaluation context surrounding an expression. In (- 4 (+ 1 1)), the redex is (+ 1 1), and the continuation is (- 4 []), where [] takes the place of the redex. That is, the continuation says how to "continue" after the redex is reduced to a value.}
+◊quad[#:fontsize "11"]{Get Ready ◊quad[#:link "http://beautifulracket.com"]{An expression that} is not a value can ◊quad[#:fontsize "22"]{always}  ◊quad[#:fontsize "7"]{be partitioned} into two parts: a redex, which is the part that changed in a single-step simplification (highlighted), and the continuation, which is the evaluation context surrounding an expression. In (- 4 (+ 1 1)), the redex is (+ 1 1), and the continuation is (- 4 []), where [] takes the place of the redex. That is, the continuation says how to "continue" after the redex is reduced to a value. ◊quad[#:link "http://beautifulracket.com"]{An expression that} is not a value can ◊quad[#:fontsize "22"]{always}  ◊quad[#:fontsize "7"]{be partitioned} into two parts: a redex, which is the part that changed in a single-step simplification (highlighted), and the continuation, which is the evaluation context surrounding an expression. In (- 4 (+ 1 1)), the redex is (+ 1 1), and the continuation is (- 4 []), where [] takes the place of the redex. That is, the continuation says how to "continue" after the redex is reduced to a value. ◊quad[#:link "http://beautifulracket.com"]{An expression that} is not a value can ◊quad[#:fontsize "22"]{always}  ◊quad[#:fontsize "7"]{be partitioned} into two parts: a redex, which is the part that changed in a single-step simplification (highlighted), and the continuation, which is the evaluation context surrounding an expression. In (- 4 (+ 1 1)), the redex is (+ 1 1), and the continuation is (- 4 []), where [] takes the place of the redex. That is, the continuation says how to "continue" after the redex is reduced to a value.}

quad/quad/typewriter.rkt

@@ -24,6 +24,7 @@
   (send doc restore))
 
 (define char-sizes (make-hash))
+(define string-widths (make-hash))
 (define (charify q)
   ($char (hash-set* (attrs q)
                     'in 'bi
@@ -33,12 +34,11 @@
                     (delay
                       (define fontsize (string->number (hash-ref (attrs q) 'fontsize "12")))
                       (define str (car (elems q)))
-                      #R str
                       (send* (current-doc)
                         [fontSize fontsize]
                         [font (path->string charter)])
                       (list
-                       (send (current-doc) widthOfString str)
+                       (hash-ref! string-widths str (λ () (send (current-doc) widthOfString str)))
                        (send (current-doc) currentLineHeight)))
                     'printable? (case (car (elems q))
                                   [(#\u00AD) (λ (sig) (memq sig '(end)))]
@@ -65,7 +65,7 @@
 (define (run-attrs-match left right)
   (define missing (gensym))
   (for/and ([k (in-list '(link weight fontsize))])
-    (equal? (hash-ref (attrs left) k missing) (hash-ref (attrs right) k missing))))
+           (equal? (hash-ref (attrs left) k missing) (hash-ref (attrs right) k missing))))
 
 (define (consolidate-runs pcs)
   (for/fold ([runs empty]
@@ -75,9 +75,9 @@
              #:break (empty? pcs))
     (define-values (run-pcs rest) (splitf-at pcs (λ (p) (run-attrs-match (car pcs) p))))
     (define new-run ($char (hash-set (attrs (car pcs))
-                                     'size (delay (list (pt-x (apply map + (map size run-pcs)))
-                                                        (pt-y (size (car pcs))))))
-                           (append-map elems run-pcs)))
+                                     'size (list (pt-x (apply map + (map size run-pcs)))
+                                                        (pt-y (size (car pcs)))))
+                           (merge-adjacent-strings (append-map elems run-pcs))))
     (values (cons new-run runs) rest)))
 
 (define line-height 16)
@@ -125,7 +125,7 @@
   (define chars 25)
   (define line-width (* 7.2 chars))
   (define lines-per-page (* 4 line-height))
-  (let* ([x (time-name runify #R (runify qarg))]
+  (let* ([x (time-name runify (runify qarg))]
          [x (time-name charify (map charify x))]
          [x (time-name line-wrap (line-wrap x line-width))]
          [x (time-name page-wrap (page-wrap x lines-per-page))]
@@ -154,9 +154,9 @@
 
 (define-macro (mb . ARGS)
   (with-pattern ([PS (syntax-property #'ARGS 'ps)])
-    #'(#%module-begin
-       (run (qexpr->quad (quad . ARGS)) PS)
-       (void))))
+                #'(#%module-begin
+                   (run (qexpr->quad (quad . ARGS)) PS)
+                   (void))))
 
 (module reader syntax/module-reader
   quad/typewriter