diff --git a/quad/quad/atomize.rkt b/quad/quad/atomize.rkt index dab572c3..eb268397 100644 --- a/quad/quad/atomize.rkt +++ b/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 diff --git a/quad/quad/typewriter-test.rkt b/quad/quad/typewriter-test.rkt index 2d4c70da..9ca14050 100644 --- a/quad/quad/typewriter-test.rkt +++ b/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.} \ No newline at end of file +◊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.} \ No newline at end of file diff --git a/quad/quad/typewriter.rkt b/quad/quad/typewriter.rkt index 87091e3c..902caaea 100644 --- a/quad/quad/typewriter.rkt +++ b/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