diff --git a/quad/quad/wrap.rkt b/quad/quad/wrap.rkt index 0a4e8b67..00e606c4 100644 --- a/quad/quad/wrap.rkt +++ b/quad/quad/wrap.rkt @@ -32,25 +32,23 @@ (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) + (define (capture-optional-break-k!) (let/cc k (set! last-optional-break-k 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)) - (let loop ([segments null][pieces null][dist-so-far start-signal][xs xs]) + (let loop ([wraps null][wrap-pieces null][dist-so-far start-signal][xs xs]) (cond [(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)))] + (dropf-right (append* (reverse (cons (finish-wrap wrap-pieces) wraps))) (λ (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 (add-to-current-wrap) + (loop wraps (cons x wrap-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. @@ -60,37 +58,40 @@ ;; 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. + (set! last-optional-break-k #f) ;; prevents continuation loop (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) + (values wrap-pieces xs) + (values (if (nonprinting-at-end? x) wrap-pieces (cons x wrap-pieces)) (cdr xs)))) + (loop (list* (list break-val) (finish-wrap pieces-for-this-wrap) wraps) null start-signal next-xs)) + (define (skip) (loop wraps null dist-so-far (cdr xs))) (cond [(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 + (skip)] + [(mandatory-break? x) + (when debug (report x 'got-mandatory-break)) (insert-break)] - [(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 + [(and underflow? (optional-break? x) (capture-optional-break-k!)) + (when debug (report x 'resuming-break-from-continuation)) + (insert-break)] + [underflow? ; the easy case of accumulating quads in the middle of a wrap + (when debug (report x 'add-underflow)) + (add-to-current-wrap)] + [at-start? ;; 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. + (when debug (report x 'add-at-start)) + (add-to-current-wrap)] + [(and (optional-break? x) (nonprinting-at-end? x)) ;; 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` - - ;; 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-ordinary-quad)) - (add-to-segment)] + (when debug (report x 'add-nonprinting-optional-break)) + (add-to-current-wrap)] ;; the previous branch will catch all `underflow?` cases ;; therefore, in these last two cases, we have overflow [last-optional-break-k ;; overflow implied