diff --git a/quad/qtest/typewriter.rkt b/quad/qtest/typewriter.rkt index aa0e2424..f7c0baff 100644 --- a/quad/qtest/typewriter.rkt +++ b/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) diff --git a/quad/quad/atomize.rkt b/quad/quad/atomize.rkt index 090ccbbd..6d55242d 100644 --- a/quad/quad/atomize.rkt +++ b/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")))) diff --git a/quad/quad/quad.rkt b/quad/quad/quad.rkt index 4be24df1..2c80e367 100644 --- a/quad/quad/quad.rkt +++ b/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)