some call it progress

quad/qtest/typewriter.rkt

@@ -75,7 +75,7 @@
                 (set-field! out this 'sw)))
 (define page% (class quad% (super-new)
                 (set-field! offset this'(36 36))
-                (define/override (start doc)
+                (define/override (pre-draw doc)
                   (add-page doc)
                   (font-size doc 10)
                   (define str (string-append "page " (number->string page-count)))
@@ -86,8 +86,8 @@
                   (restore doc)
                   (set! page-count (add1 page-count)))))
 (define doc% (class quad% (super-new)
-               (define/override (start doc) (start-doc doc))
-               (define/override (end doc) (end-doc doc))))
+               (define/override (pre-draw doc) (start-doc doc))
+               (define/override (post-draw doc) (end-doc doc))))
 (define break% (class quad% (super-new)))
 (define page-count 1)
 (define (make-break . xs) (make-object break% (hasheq 'printable? #f 'size '(0 0)) xs))
@@ -122,20 +122,12 @@
                                                  (consolidate-runs pcs)
                                                  pcs))))))
 
-;; 181231 it's weird that setup work for page is in the page break,
-;; which is between pages, not associated with either
-(define pb (make-object (let ([pb (class break%
-                                    (super-new)
-                                    (define/override (printable?) #f)
-                                    (inherit-field (@size size))
-                                    (set! @size '(0 0)))])
-                          pb) '(#\page)))
 
 (define ($break? x) (is-a? x break%))
 (define (page-wrap xs size [debug #f])
   (break xs size debug
          #:break-before? #t
-         #:break-val pb
+         #:break-val (make-object break%)
          #:soft-break-proc $break?
          #:finish-wrap-proc (λ (pcs) (list (make-object page% (hasheq) (filter-not $break? pcs))))))
 
@@ -144,8 +136,8 @@
   (define line-width (* 7.2 chars))
   (define lines-per-page (* 40 line-height))
   (time-name config-pdf
-             [font pdf (path->string charter)]
-             [font-size pdf 12])
+             (font pdf (path->string charter))
+             (font-size pdf 12))
   (let* ([x (time-name runify (runify qarg))]
          [x (time-name quadify (map (λ (x) (quadify pdf x)) x))]
          [x (time-name line-wrap (line-wrap x line-width))]
@@ -154,10 +146,12 @@
     x))
 
 (define (run qin [path "test.pdf"])
-  (define pdf (time-name make-pdf (make-pdf #:compress #t)))
+  (define pdf (time-name make-pdf (make-pdf #:compress #t
+                                            #:auto-first-page #f
+                                            #:output-path path)))
   (define q (typeset pdf qin))
   (report draw-counter)
-  (time-name draw (with-output-to-file path (λ () (send q draw pdf)) #:exists 'replace))
+  (time-name draw (send q draw pdf))
   (report draw-counter))
 
 (define-syntax (mb stx)

quad/quad/atomize.rkt

@@ -1,5 +1,5 @@
 #lang debug racket/base
-(require racket/class racket/match racket/list txexpr racket/dict racket/function
+(require racket/string racket/class racket/match racket/list txexpr racket/dict racket/function
          "quad.rkt" "param.rkt")
 (provide (all-defined-out))
 (module+ test (require rackunit))
@@ -16,15 +16,15 @@
    ((hasheq 'foo "bar" 'zim "zam") . update-with .  (hasheq 'zim "BANG") (hasheq 'toe "jam") (hasheq 'foo "zay"))
    (make-hasheq '((zim . "BANG") (foo . "zay") (toe . "jam")))))
 
-(define (merge-whitespace aqs [white-aq? (λ (aq) (char-whitespace? (car (get-field elems aq))))])
-  ;; collapse each sequence of whitespace aqs to the first one, and make it a space
+(define (merge-whitespace qs [white-q? (λ (aq) (char-whitespace? (car (get-field elems aq))))])
+  ;; collapse each sequence of whitespace qs to the first one, and make it a space
   ;; also drop leading & trailing whitespaces
   ;; (same behavior as web browsers)
-  (let loop ([acc null][aqs aqs])
-    (if (null? aqs)
+  (let loop ([acc null][qs qs])
+    (if (null? qs)
         (flatten acc)
-        (let*-values ([(bs rest) (splitf-at aqs (negate white-aq?))]
-                      [(ws rest) (splitf-at rest white-aq?)])
+        (let*-values ([(bs rest) (splitf-at qs (negate white-q?))]
+                      [(ws rest) (splitf-at rest white-q?)])
           (loop (list acc bs (if (and (pair? rest) ;; we precede bs (only #t if rest starts with bs, because we took the ws)
                                       (pair? bs) ;; we follow bs
                                       (pair? ws)) ;; we have ws
@@ -32,8 +32,8 @@
                                  null)) rest)))))
 
 #;(module+ test
-  (check-equal? (merge-whitespace (list (q #\space) (q #\newline) (q #\H) (q #\space) (q #\newline) (q #\space) (q #\i) (q #\newline)))
-                (list (q #\H) (q #\space) (q #\i))))
+    (check-equal? (merge-whitespace (list (q #\space) (q #\newline) (q #\H) (q #\space) (q #\newline) (q #\space) (q #\i) (q #\newline)))
+                  (list (q #\H) (q #\space) (q #\i))))
 
 (define (atomize qx)
   ;; normalize a quad by reducing it to one-character quads.
@@ -43,58 +43,56 @@
       (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?) ;; qexprs with attributes are recursed
          (define this-attrs (get-field attrs x))
          (define elems (get-field elems x))
          (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))
 
-(module+ test
-  (require rackunit)
-  (check-equal? (atomize (q "Hi")) (list (q #\H) (q #\i)))
-  (check-equal? (atomize (q "Hi " (q "You"))) (list (q #\H) (q #\i) (q #\space) (q #\Y) (q #\o) (q #\u)))
-  (check-exn exn:fail:contract? (λ () (atomize #t)))
-  (check-equal? (atomize (q "H i")) (list (q #\H) (q #\space) (q #\i)))
-  (check-equal? (atomize (q "H \n\n i")) (list (q #\H) (q #\space) (q #\i))) ;; collapse whitespace to single
+#;(module+ test
+    (require rackunit)
+    (check-equal? (atomize (q "Hi")) (list (q #\H) (q #\i)))
+    (check-equal? (atomize (q "Hi " (q "You"))) (list (q #\H) (q #\i) (q #\space) (q #\Y) (q #\o) (q #\u)))
+    (check-exn exn:fail:contract? (λ () (atomize #t)))
+    (check-equal? (atomize (q "H i")) (list (q #\H) (q #\space) (q #\i)))
+    (check-equal? (atomize (q "H \n\n i")) (list (q #\H) (q #\space) (q #\i))) ;; collapse whitespace to single
 
-  ;; with attributes
-  (check-equal? (atomize (q (hasheq 'k "v") "Hi")) (list (q (hasheq 'k "v") #\H) (q (hasheq 'k "v") #\i)))
-  (check-equal? (atomize (q (hasheq 'k "v") "Hi " (q "You")))
-                (list
-                 (quad (hasheq 'k "v") #\H)
-                 (quad (hasheq 'k "v") #\i)
-                 (quad (hasheq 'k "v") #\space)
-                 (quad (hasheq 'k "v") #\Y)
-                 (quad (hasheq 'k "v") #\o)
-                 (quad (hasheq 'k "v") #\u)))
-  (check-equal? (atomize (q (hasheq 'k1 "v1" 'k2 42) "Hi \n\n" (q (hasheq 'k1 "v2" 'k3 "foo") "\n \nYou")))
-                (list
-                 (quad (hasheq 'k1 "v1" 'k2 42) #\H)
-                 (quad (hasheq 'k1 "v1" 'k2 42) #\i)
-                 (quad (hasheq 'k1 "v1" 'k2 42) #\space)
-                 (quad (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\Y)
-                 (quad (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\o)
-                 (quad (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\u))))
+    ;; with attributes
+    (check-equal? (atomize (q (hasheq 'k "v") "Hi")) (list (q (hasheq 'k "v") #\H) (q (hasheq 'k "v") #\i)))
+    (check-equal? (atomize (q (hasheq 'k "v") "Hi " (q "You")))
+                  (list
+                   (quad (hasheq 'k "v") #\H)
+                   (quad (hasheq 'k "v") #\i)
+                   (quad (hasheq 'k "v") #\space)
+                   (quad (hasheq 'k "v") #\Y)
+                   (quad (hasheq 'k "v") #\o)
+                   (quad (hasheq 'k "v") #\u)))
+    (check-equal? (atomize (q (hasheq 'k1 "v1" 'k2 42) "Hi \n\n" (q (hasheq 'k1 "v2" 'k3 "foo") "\n \nYou")))
+                  (list
+                   (quad (hasheq 'k1 "v1" 'k2 42) #\H)
+                   (quad (hasheq 'k1 "v1" 'k2 42) #\i)
+                   (quad (hasheq 'k1 "v1" 'k2 42) #\space)
+                   (quad (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\Y)
+                   (quad (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\o)
+                   (quad (hasheq 'k1 "v2" 'k2 42 'k3 "foo") #\u))))
 
 (define whitespace-pat #px"\\s+")
-(define (merge-white str) (regexp-replace* whitespace-pat str " "))
-
-(define (isolate-white str)
-  (for/list ([m (in-list (regexp-match* " " str #:gap-select? #t))]
-             #:when (positive? (string-length m)))
-            m))
+(define (merge-and-isolate-white str)
+  (for/list ([(m idx) (in-indexed (regexp-match* whitespace-pat str #:gap-select? #t))]
+             #:when (non-empty-string? m))
+            (if (even? idx) m " ")))
 
 (define (merge-adjacent-strings xs [isolate-white? #false])
   (let loop ([xs xs][acc null])
     (match xs
-      [(== empty) (reverse acc)]
+      [(list) (reverse acc)]
       [(list (? string? strs) ..1 others ...)
        (loop others (append (reverse ((if isolate-white?
-                                          (compose1 isolate-white merge-white)
+                                          merge-and-isolate-white
                                           list) (apply string-append strs))) acc))]
       [(cons x others) (loop others (cons x acc))])))
 
@@ -127,7 +125,7 @@
    (λ (q) (string=? " " (car (get-field elems q))))))
 
 #;(module+ test
-(check-equal?
+    (check-equal?
      (runify  (quad (hasheq 'foo 42) (quad "Hi" "    idiot" (quad (hasheq 'bar 84) "There") "Eve" "ry" "one")))
      (list (quad (hasheq 'foo 42) "Hi") (quad (hasheq 'foo 42) " ") (quad (hasheq 'foo 42) "idiot") (quad (hasheq 'foo 42 'bar 84) "There") (quad (hasheq 'foo 42) "Everyone"))))
    

quad/quad/quad.rkt

@@ -37,13 +37,13 @@
         [(? promise? prom) (force prom)]
         [val val]))
     
-    (define/public (start surface) (void))
-    (define/public (end surface) (void))
+    (define/public (pre-draw surface) (void))
+    (define/public (post-draw surface) (void))
 
     (define/public (draw [surface #f])
-      (start surface)
+      (pre-draw surface)
       (for-each (λ (e) (send e draw surface)) @elems)
-      (end surface))
+      (post-draw surface))
 
     ;; equal<%> interface
     (define/public-final (equal-to? other recur)