From a900bb4ec4324b50b2dc022c6b8818ed2e5188d2 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sat, 3 Nov 2018 21:37:30 -0700 Subject: [PATCH] dog and fleas --- quad/quad/break.rkt | 146 +++++++++++++++----------------------------- 1 file changed, 50 insertions(+), 96 deletions(-) diff --git a/quad/quad/break.rkt b/quad/quad/break.rkt index e22b819f..9ce5794a 100644 --- a/quad/quad/break.rkt +++ b/quad/quad/break.rkt @@ -85,6 +85,14 @@ (define (nonprinting-at-start? x) (if (quad? x) (not (printable? x 'start)) #t)) (define (nonprinting-at-end? x) (if (quad? x) (not (printable? x 'end)) #t)) +(define (nonprinting-in-middle-soft-break? x) (and (not (printable? x)) (soft-break? x))) + +(define (append-to-wrap partial wrap) + (match/values + (values partial wrap) + [((== empty) _) wrap] + [(partial (list (? nonprinting-in-middle-soft-break?) ... rest ...)) (append (or partial null) rest)])) + (define (break-softs qs target-size debug @@ -104,38 +112,20 @@ ;; combine the segments into a flat list, and drop any trailing breaks ;; (on the idea that breaks should separate things, and there's nothing left to separate) ;; wraps alternate with breaks - (for/list ([wrap (in-list (cons (append current-partial current-wrap) wraps))]) - (match wrap - [(list (? nonprinting-at-end?)) wrap] ; matches break signals - ;; pieces will have been accumulated in reverse order - ;; thus beginning of list represents the end of the wrap - [(list (? (conjoin soft-break? nonprinting-at-end?)) ... rest ...) - (debug-report (finish-wrap-proc (reverse rest))) - (finish-wrap-proc (reverse rest))]))] + (debug-report wraps) + ;; use false as signal to indicate the end + (define last-wrap (append-to-wrap #false (append-to-wrap current-partial current-wrap))) + (for/list ([wrap (in-list (cons last-wrap wraps))]) + (match wrap + [(list (? nonprinting-at-end?)) wrap] ; matches break signals + ;; pieces will have been accumulated in reverse order + ;; thus beginning of list represents the end of the wrap + [(list (? (conjoin soft-break? nonprinting-at-end?)) ... rest ...) + (debug-report (finish-wrap-proc (reverse rest))) + (finish-wrap-proc (reverse rest))]))] [(cons q other-qs) (debug-report q 'next-q) (define at-start? (eq? current-dist start-signal)) - #;(define underflow? - (and (not at-start?) - (<= (+ current-dist (if (and (quad? q) (printable? q 'end)) - (distance q) - 0)) target-size))) - #;(define (values-for-insert-break [before? #f]) - ;; a break can be inserted before or after the current quad. - ;; At an ordinary break (hard or soft) it goes after the wrap point. - ;; The wrap signal consumes the break if it's nonprinting (e.g., word space or hard break) - ;; but not if it's printing (e.g., hyphen). - ;; But if no ordinary break can be found for a line, the wrap will happen before the quad. - ;; The wrap signal will not consume the quad (rather, it will become the first quad in the next wrap) - ;; (we do this by resetting next-xs to the whole xs list) - ;; In both cases, the `finish-wrap` proc will strip off any trailing white breaks from the new segment. - (if before? - (values current-wrap qs) - ; omit nonprinting quad - (values (if (and (quad? q) (nonprinting-at-end? q)) - current-wrap - (cons q current-wrap)) (cdr qs)))) - (cond [at-start? (cond @@ -146,16 +136,17 @@ current-wrap current-partial current-dist - (cdr qs))] + other-qs)] [else ; printing quad (debug-report 'hard-quad-at-start) (loop wraps current-wrap (cons q current-partial) (distance q) - (cdr qs))])] + other-qs)])] [else - (define dist (and (quad? q) (or (printable? q) (printable? q 'end)) (distance q))) + (define dist (and (quad? q) (if (printable? q) (distance q) 0))) + (debug-report current-dist) (debug-report dist) (define would-overflow? (> (+ dist current-dist) target-size)) (cond @@ -166,12 +157,13 @@ ;; a break is inevitable but we want to wait to finish the wrap until we see a hard quad ;; but we can move the current-partial into the current-wrap (loop wraps - (append (cons q current-partial) current-wrap) + (append-to-wrap (cons q current-partial) current-wrap) null (+ dist current-dist) other-qs)] [else (debug-report 'would-overflow-hard) + (debug-report (empty? current-wrap)) ;; finish the wrap & reset the line without consuming a quad (if (empty? current-wrap) ; means we have not captured a soft break (loop (list* (list break-val) current-partial wraps) @@ -182,18 +174,20 @@ (loop (list* (list break-val) current-wrap wraps) null current-partial - start-signal + (apply + (map distance current-partial)) qs))])] [else (cond [(soft-break? q) ; printing soft break, like a hyphen (debug-report 'would-not-overflow-soft) ;; a soft break that fits, so move it on top of the current-wrap with the current-partial - (loop wraps - (append (cons q current-partial) current-wrap) - null - (+ dist current-dist) - other-qs)] + (cond + [else + (loop wraps + (append-to-wrap (cons q current-partial) current-wrap) + null + (+ dist current-dist) + other-qs)])] [else (debug-report 'would-not-overflow) ;; add to partial @@ -203,46 +197,7 @@ (+ dist current-dist) other-qs)])]) - ]) - #;[(and underflow? (soft-break? q)) - (when debug (report q 'underflow-soft-break)) - (loop (list* (list break-val) pieces-for-this-wrap wraps) - null - current-hard - start-signal - next-xs)] - ;; the easy case of accumulating quads in the middle of a wrap - #;[(or (and underflow? (when debug (report q 'add-underflow)) #t) - ;; assume printing (nonprinting were handled in first case) - ;; this branch reached if the first quad on the line causes an overflow - ;; That sounds weird, but maybe it's just really big. - (and at-start? (when debug (report q 'add-at-start)) #t) - ;; we do want to accumulate nonprinting soft breaks (like wordspaces and soft hyphens) in the middle. - ;; in case we eventually encounter a printing quad that fits on the line. - ;; if we don't (ie. the line overflows) then they will get stripped by `finish-wrap` - (and (soft-break? q) (nonprinting-at-end? q) (when debug (report q 'add-nonprinting-soft-break)) #t)) - (define printable (and (quad? q) (printable? q (and at-start? 'start)))) - (define dist (and printable (distance q))) - (loop wraps - (if (and (quad? q) (not printable)) current-wrap (cons q current-wrap)) ; omit nonprinting quad - current-partial - (if at-start? (or dist start-signal) (+ current-dist (or dist 0))) - (cdr qs))] - ;; the previous branch will catch all `underflow?` cases - ;; therefore, in these last two cases, we have overflow - - #;[else ;; overflow implied - ;; if we don't have an soft break stored, we need to just end the wrap and move on - ;; we insert the break `before` so that the current quad is moved to the next wrap - ;; no, it's not going to look good, but if we reach this point, we are in weird conditions - (when debug (report q 'falling-back)) - (define-values (pieces-for-this-wrap next-xs) (values-for-insert-break 'before)) - (loop (list* (list break-val) pieces-for-this-wrap wraps) - null - current-partial - start-signal - next-xs)] - ]))) + ])]))) (define x (q (list 'size (pt 1 1)) #\x)) @@ -317,9 +272,6 @@ (check-equal? (linewrap (list x x hyph x x) 4) (list x x hyph 'lb x x)) (check-equal? (linewrap (list x x hyph x x) 5) (list x x hyph x x)))) -(linewrap (list a b shy c d) 4 #t) -;(check-equal? (linewrap (list x x shy x x) 4) (list x x x x)) - (module+ test (test-case "soft hyphens" @@ -328,15 +280,16 @@ (check-equal? (linewrap (list shy shy shy) 2) (list)) (check-equal? (linewrap (list x shy) 1) (list x)) (check-equal? (linewrap (list x shy shy shy shy) 1) (list x)) - (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)) + ;; todo: degenerate cases + ;(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 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)) + (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)) )) -#;(module+ test +(module+ test (test-case "zero width nonbreakers" (check-equal? (linewrap (list sp zwx) 2) (list zwx)) @@ -345,7 +298,7 @@ (check-equal? (linewrap (list sp sp zwx sp sp) 2) (list zwx)) (check-equal? (linewrap (list sp sp zwx sp sp zwx sp) 2) (list zwx sp sp zwx)))) -#;(module+ test +(module+ test (test-case "hard breaks" (check-equal? (linewrap (list br) 2) (list)) ;; only insert a break if it's between things @@ -358,7 +311,7 @@ (check-equal? (linewrap (list x x x sp x x) 2) (list x x 'lb x 'lb x x)) (check-equal? (linewrap (list x x x sp x x) 3) (list x x x 'lb x x)))) -#;(module+ test +(module+ test (test-case "hard breaks and spurious spaces" (check-equal? (linewrap (list a sp sp sp br b) 2) (list a 'lb b)) @@ -371,12 +324,13 @@ (define (visual-wrap str int [debug #f]) (apply string (for/list ([b (in-list (linewrap (for/list ([atom (atomize str)]) - ($quad (hash-set (attrs atom) 'size '(1 1)) - (elems atom))) int debug))]) - (cond - [(quad? b) (car (elems b))] - [else #\|])))) -#;(module+ test + ($quad (hash-set (attrs atom) 'size '(1 1)) + (elems atom))) int debug))]) + (cond + [(quad? b) (car (elems b))] + [else #\|])))) + +(module+ test (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")