diff --git a/quad/quad/typewriter.rkt b/quad/quad/typewriter.rkt index 59521b59..7c666a90 100644 --- a/quad/quad/typewriter.rkt +++ b/quad/quad/typewriter.rkt @@ -6,19 +6,23 @@ (define optional-break? (λ (q) (and (quad? q) (memv (car (elems q)) '(#\space #\- #\u00AD))))) (struct $shim $quad () #:transparent) (struct $char $quad () #:transparent) -(define (charify q) +(define (charify q) ($char (hash-set* (attrs q) - 'size (if (equal? (elems q) '(#\u00AD)) - (λ (sig) (case sig - [(end) '(7.2 12)] - [else '(0 0)])) - (const '(7.2 12))) + 'size (case (car (elems q)) + [(#\u00AD) + (λ (sig) (case sig + [(end) '(7.2 12)] + [else #f]))] + [(#\space) (λ (sig) (case sig + [(start end) #f] + [else '(7.2 12)]))] + [else (const '(7.2 12))]) 'draw (λ (q doc) (send/apply doc text (apply string (elems q)) (origin q)))) (elems q))) (struct $line $quad () #:transparent) (struct $page $quad () #:transparent) (struct $doc $quad () #:transparent) (struct $break $quad () #:transparent) -(define (break . xs) ($break (hasheq 'size '(0 0)) xs)) +(define (break . xs) ($break (hasheq 'size #f) xs)) (define line-height 16) (define (line-wrap xs size [debug #f]) diff --git a/quad/quad/wrap.rkt b/quad/quad/wrap.rkt index 00e606c4..8c9c0146 100644 --- a/quad/quad/wrap.rkt +++ b/quad/quad/wrap.rkt @@ -3,14 +3,17 @@ "param.rkt" "qexpr.rkt" "atomize.rkt" "quad.rkt" "generic.rkt" "position.rkt") (define/contract (distance q [signal #f]) - ((any/c) (any/c) . ->* . real?) + ((any/c) (any/c) . ->* . (or/c #f real?)) + ;; linear distance from in point to out point + ;; or #f if quad is nonprinting (cond [(quad? q) - (match-define (list ∆x ∆y) (map - (out-point q signal) (in-point q signal))) - (cond - [(zero? ∆x) ∆y] - [(zero? ∆y) ∆x] - [else (sqrt (+ (* ∆x ∆x) (* ∆y ∆y)))])] + (and (size q signal) + (match-let ([(list ∆x ∆y) (map - (out-point q signal) (in-point q signal))]) + (cond + [(zero? ∆x) ∆y] + [(zero? ∆y) ∆x] + [else (sqrt (+ (* ∆x ∆x) (* ∆y ∆y)))])))] [else 0])) @@ -27,8 +30,8 @@ #:optional-break-proc procedure? #:finish-wrap-proc procedure?) . ->* . (listof any/c)) (define start-signal (gensym)) - (define (nonprinting-at-start? x) (zero? (distance x 'start))) - (define (nonprinting-at-end? x) (zero? (distance x 'end))) + (define (nonprinting-at-start? x) (not (distance x 'start))) + (define (nonprinting-at-end? x) (not (distance x 'end))) (define (finish-wrap pieces) (finish-wrap-proc (reverse (dropf pieces (λ (x) (and (optional-break? x) (nonprinting-at-end? x))))))) (define last-optional-break-k #f) @@ -44,11 +47,13 @@ [else (define x (car xs)) (define at-start? (eq? dist-so-far start-signal)) - (define underflow? (and (not at-start?) (<= (+ dist-so-far (distance x 'end)) target-size))) + (define underflow? (and (not at-start?) (<= (+ dist-so-far (or (distance x 'end) 0)) target-size))) (define (add-to-current-wrap) - (loop wraps (cons x wrap-pieces) (if at-start? - (distance x 'start) - (+ dist-so-far (distance x))) (cdr xs))) + (define dist (distance x (and at-start? 'start))) + (loop wraps + (if dist (cons x wrap-pieces) wrap-pieces) ; omit nonprinting quad + (if at-start? (or dist start-signal) (+ dist-so-far (or dist 0))) + (cdr xs))) (define (insert-break [before? #f]) ;; a break can be inserted before or after the current quad. ;; At an ordinary break (mandatory or optional) it goes after the wrap point. @@ -113,16 +118,16 @@ (define shy (q (list 'size (λ (sig) (case sig [(end) (pt 1 1)] - [else (pt 0 0)]))) #\-)) + [else #f]))) #\-)) (define a (q #f #\a)) (define b (q #f #\b)) (define c (q #f #\c)) (define d (q #f #\d)) (define sp (q (list 'size (λ (sig) (case sig - [(start end) (pt 0 0)] + [(start end) #f] [else (pt 1 1)]))) #\space)) -(define br (q (list 'size (pt 0 0)) #\newline)) +(define br (q (list 'size #f) #\newline)) (define optional-break? (λ (q) (and (quad? q) (memv (car (elems q)) '(#\space #\-))))) (define (linewrap xs size [debug #f]) @@ -153,7 +158,6 @@ (check-equal? (linewrap (list a sp b) 3) (list a sp b)) (check-equal? (linewrap (list x sp x x) 3) (list x 'lb x x))) - (test-case "leading & trailing spaces" (check-equal? (linewrap (list sp x) 2) (list x)) @@ -186,9 +190,9 @@ (check-equal? (linewrap (list x x shy x x) 1) (list x 'lb x 'lb x 'lb x)) (check-equal? (linewrap (list x x shy x x) 2) (list x x 'lb x x)) (check-equal? (linewrap (list x x shy x x) 3) (list x x shy 'lb x x)) - (check-equal? (linewrap (list x x shy x x) 4) (list x x shy x x)) - (check-equal? (linewrap (list x x shy x x) 5) (list x x shy x x)) - (check-equal? (linewrap (list x x shy x sp x) 4) (list x x shy x 'lb x))) + (check-equal? (linewrap (list x x shy x x) 4) (list x x x x)) + (check-equal? (linewrap (list x x shy x x) 5) (list x x x x)) + (check-equal? (linewrap (list x x shy x sp x) 4) (list x x x 'lb x))) (test-case "zero width nonbreakers" @@ -222,13 +226,16 @@ (define (visual-wrap str int [debug #f]) (apply string (for/list ([b (in-list (linewrap (atomize str) int debug))]) - (cond - [(quad? b) (car (elems b))] - [else #\|])))) + (cond + [(quad? b) (car (elems b))] + [else #\|])))) - (test-case + (check-equal? (visual-wrap "M d" 1 1) "M|d") + + #| +(test-case "visual breaks" - (check-equal? (visual-wrap "My dog has fleas" 1) "M|y|d|o|g|h|a|s|f|l|e|a|s") + (check-equal? (visual-wrap "My dog has fleas" 1 1) "M|y|d|o|g|h|a|s|f|l|e|a|s") (check-equal? (visual-wrap "My dog has fleas" 2) "My|do|g|ha|s|fl|ea|s") (check-equal? (visual-wrap "My dog has fleas" 3) "My|dog|has|fle|as") (check-equal? (visual-wrap "My dog has fleas" 4) "My|dog|has|flea|s") @@ -245,12 +252,13 @@ (check-equal? (visual-wrap "My dog has fleas" 15) "My dog has|fleas") (check-equal? (visual-wrap "My dog has fleas" 16) "My dog has fleas")) + (define (pagewrap xs size [debug #f]) (wrap xs size debug #:break-val 'pb #:mandatory-break-proc (λ (x) (and (quad? x) (memv (car (elems x)) '(#\page)))) #:optional-break-proc (λ (x) (eq? x 'lb)))) - (define pbr (q '(size (0 0)) #\page)) + (define pbr (q '(size #f) #\page)) (test-case "soft page breaks" @@ -297,4 +305,7 @@ (check-equal? (linewrap2 (list a sp b sp sp br sp c) 3) (list (slug a sp b) 'lb (slug c))) (check-equal? (linewrap2 (list x x x x) 3) (list (slug x x x) 'lb (slug x))) (check-equal? (linewrap2 (list x x x sp x x) 2) (list (slug x x) 'lb (slug x) 'lb (slug x x))) - (check-equal? (linewrap2 (list x x x sp x x) 3) (list (slug x x x) 'lb (slug x x))))) \ No newline at end of file + (check-equal? (linewrap2 (list x x x sp x x) 3) (list (slug x x x) 'lb (slug x x)))) +|# + + ) \ No newline at end of file