From 70c1fd68f2cd3e480c8486cc27b26459d27fc7ac Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sun, 4 Mar 2018 14:56:58 -0800 Subject: [PATCH] soft hyphen victory --- quad/quad/wrap.rkt | 162 ++++++++++++++++++++------------------------- 1 file changed, 73 insertions(+), 89 deletions(-) diff --git a/quad/quad/wrap.rkt b/quad/quad/wrap.rkt index a1e1bec9..0a4e8b67 100644 --- a/quad/quad/wrap.rkt +++ b/quad/quad/wrap.rkt @@ -28,97 +28,82 @@ #:finish-wrap-proc procedure?) . ->* . (listof any/c)) (define start-signal (gensym)) (define (nonprinting-at-start? x) (zero? (distance x 'start))) - (define (nonprinting-at-middle? x) (zero? (distance x))) (define (nonprinting-at-end? x) (zero? (distance x 'end))) - (define (finish-wrap pieces) (finish-wrap-proc (reverse (dropf pieces (λ (x) (and (optional-break? x) (nonprinting-at-end? x))))))) + (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) (call/prompt ;; continuation boundary for last-optional-break-k (thunk (define (capture-optional-break-k!) (let/cc k (set! last-optional-break-k k) #f)) - (for/fold ([segments null] - [pieces null] - [dist-so-far start-signal] - #:result (append* (reverse (cons (finish-wrap pieces) segments)))) - ([x (in-list 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 (add-to-segment) (values segments (cons x pieces) (if at-start? - (distance x 'start) - (+ dist-so-far (distance x))))) - (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. - ;; 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) - ;; In both cases, the `finish-wrap` proc will strip off any trailing white breaks from the new segment. - (define-values (pieces-for-this-wrap pieces-for-next-wrap starting-distance-for-next-wrap) - (if before? - (values pieces (list x) (distance x 'start)) - (values (if (nonprinting-at-end? x) pieces (cons x pieces)) null start-signal))) - (values (list* (list break-val) (finish-wrap pieces-for-this-wrap) segments) - pieces-for-next-wrap - starting-distance-for-next-wrap)) + (let loop ([segments null][pieces null][dist-so-far start-signal][xs xs]) (cond - [(mandatory-break? x) - ;; easiest case. Always put a break where a mandatory break indicates (duh, or it's not mandatory) - (when debug (report x 'got-mandatory-break)) - (insert-break)] - [(optional-break? x) - ;; hardest case, because behavior of optional breaks depends on location in the wrap, and printability + [(null? xs) + ;; 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) + (dropf-right (append* (reverse (cons (finish-wrap pieces) segments))) (λ (x) (eq? x break-val)))] + [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 (add-to-segment) (loop segments + (cons x pieces) + (if at-start? + (distance x 'start) + (+ dist-so-far (distance x))) + (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. + ;; 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. + (define-values (pieces-for-this-wrap next-xs) + (if before? + (values pieces xs) + (values (if (nonprinting-at-end? x) pieces (cons x pieces)) (cdr xs)))) + (loop (list* (list break-val) (finish-wrap pieces-for-this-wrap) segments) + null + start-signal + next-xs)) (cond - [(and at-start? (nonprinting-at-start? x)) - ;; a nonprinting optional break is something like a word space - ;; we don't want to accumulate these at the front of a wrap. We want to start with a printable quad. - ;; So skip them. - (when debug (report x 'skipping-opt-break-at-beginning)) - (values segments null dist-so-far)] - [(and underflow? (capture-optional-break-k!)) - ;; This branch creates a continuation point for a later wrap. - ;; on the first pass, it just marks the optional break as a potential break location. - ;; if another optional break is encountered before a wrap is needed, - ;; then it becomes the captured break. - ;; Meaning, the continuation always points at the last available break. - ;; Then, in an overflow situation (handled later in this cond) - ;; the continuation is invoked, which causes the rest of this branch to be evaluated. - (when debug (report x 'resuming-breakpoint)) + [(and at-start? (optional-break? x) (nonprinting-at-start? x)) + (when debug (report x 'skipping-optional-break-at-beginning)) + (loop segments null dist-so-far (cdr xs))] + [(or (mandatory-break? x) + (and underflow? (optional-break? x) (capture-optional-break-k!))) + (when debug (if (mandatory-break? x) + (report x 'got-mandatory-break) + (report x 'resuming-break-from-continuation))) (set! last-optional-break-k #f) ;; prevents continuation loop (insert-break)] - [(or underflow? (nonprinting-at-end? x)) - ;; we do want to accumulate nonprinting optional breaks (like wordspaces) in the middle. - ;; in case we encounter a printing quad that fits on the line. + [(or underflow? + at-start? ;; assume printing (nonprinting were handled in first case) + (and (optional-break? x) (nonprinting-at-end? x))) + ;; the easy case of accumulating quads in the middle of a wrap + ;; we do want to accumulate nonprinting optional 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` - (when debug (report x 'add-optional-break-nonprinting-or-underflow)) - (add-to-segment)] - [at-start? - ;; this branch is only reached if the first quad on the line causes an overflow + + ;; with `at-start?` this branch is also reached if the first quad on the line causes an overflow ;; That sounds weird, but maybe it's just really big. - (when debug (report x 'add-optional-break-overflow+printing+at-start)) + (when debug (report x 'add-ordinary-quad)) (add-to-segment)] - [else - ;; this case is equivalent to the final case of the enclosing cond - ;; where we have an overflow and no available optional break - ;; so we just break before and move on - (when debug (report x 'add-optional-break-overflow+printing+not-at-start)) - (insert-break 'before)])] - [(or at-start? underflow?) - ;; the easy case of accumulating quads in the middle of a wrap - (when debug (report x 'add-ordinary-quad)) - (add-to-segment)] - ;; the previous branch will catch all `underflow?` cases - ;; therefore, in these last two cases, we have overflow - [last-optional-break-k ;; overflow implied - ;; if we have an optional break stored, we jump back and use it - ;; now that we know we need it. - (when debug (report x 'invoking-last-breakpoint)) - (last-optional-break-k #t)] - [else ;; overflow implied - ;; if we don't have an optional 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 x 'falling-back)) - (insert-break 'before)]))))) + ;; the previous branch will catch all `underflow?` cases + ;; therefore, in these last two cases, we have overflow + [last-optional-break-k ;; overflow implied + ;; if we have an optional break stored, we jump back and use it + ;; now that we know we need it. + (when debug (report x 'invoking-last-breakpoint)) + (last-optional-break-k #t)] + [else ;; overflow implied + ;; if we don't have an optional 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 x 'falling-back)) + (insert-break 'before)])]))))) (define x (q #f #\x)) @@ -195,15 +180,14 @@ (check-equal? (linewrap (list shy) 1) (list)) (check-equal? (linewrap (list shy shy) 2) (list)) (check-equal? (linewrap (list shy shy shy) 2) (list)) - (check-equal? (linewrap (list x shy) 1 42) (list x)) - #| - (check-equal? (linewrap (list x x shy x x) 1) (list x 'lb x 'lb shy 'lb x 'lb x)) - (check-equal? (linewrap (list x x shy x x) 2) (list x x 'lb shy x 'lb x)) + (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)) (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 '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))) (test-case "zero width nonbreakers" @@ -215,10 +199,10 @@ (test-case "mandatory breaks" - (check-equal? (linewrap (list br) 2) (list 'lb)) + (check-equal? (linewrap (list br) 2) (list)) ;; only insert a break if it's between things (check-equal? (linewrap (list a br b) 2) (list a 'lb b)) - (check-equal? (linewrap (list a b br) 2) (list a b 'lb)) - (check-equal? (linewrap (list a b br br) 2) (list a b 'lb 'lb)) + (check-equal? (linewrap (list a b br) 2) (list a b)) + (check-equal? (linewrap (list a b br br) 2) (list a b)) (check-equal? (linewrap (list x br x x) 3) (list x 'lb x x)) (check-equal? (linewrap (list x x br x) 3) (list x x 'lb x)) (check-equal? (linewrap (list x x x x) 3) (list x x x 'lb x))