From 2832abefabee7946245611f00084fcbfe86c793a Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Tue, 28 Jan 2020 11:35:51 -0800 Subject: [PATCH] allow variable-width columns (sort of) (fixes #51) --- quad/qtest/test-breaks.rkt | 2 + quad/quad/wrap.rkt | 1016 ++++++++++++++++++------------------ quad/quadwriter/layout.rkt | 135 +++-- 3 files changed, 589 insertions(+), 564 deletions(-) diff --git a/quad/qtest/test-breaks.rkt b/quad/qtest/test-breaks.rkt index 96c052a1..6822b0e2 100644 --- a/quad/qtest/test-breaks.rkt +++ b/quad/qtest/test-breaks.rkt @@ -10,6 +10,8 @@ (q ((break "column"))) +(q ((break "para"))) + "Page 1 Column 2 Line 1" (q ((break "line"))) diff --git a/quad/quad/wrap.rkt b/quad/quad/wrap.rkt index ca7c9c1f..92c46810 100644 --- a/quad/quad/wrap.rkt +++ b/quad/quad/wrap.rkt @@ -7,10 +7,10 @@ (syntax-case stx () [(_ SYM) (with-syntax ([DEBUG (datum->syntax stx 'debug)]) - #'(when DEBUG (log-quad-debug (format "~a" SYM))))] + #'(when DEBUG (displayln (format "~a" SYM))))] [(_ VAL SYM) (with-syntax ([DEBUG (datum->syntax stx 'debug)]) - #'(when DEBUG (log-quad-debug (format "~a: ~a" SYM VAL))))])) + #'(when DEBUG (displayln (format "~a: ~a" SYM VAL))))])) (define (nonprinting-at-start? x) (not (printable? x 'start))) (define (nonprinting-at-end? x) (not (printable? x 'end))) @@ -77,535 +77,535 @@ ;; for instance, a hyphen is `soft-break?` but shouldn't be trimmed. (define has-footnotes? (pair? footnote-qs)) (apply finish-wrap-func - (reverse (dropf qs nonprinting-at-end?)) previous-wrap-ender wrap-triggering-q wrap-idx - (if has-footnotes? (list fn-qs) null))) - (wrap-proc qs - max-distance - debug - hard-break? - soft-break? - finish-wrap - wrap-count - distance-func - initial-wrap-idx + (reverse (dropf qs nonprinting-at-end?)) previous-wrap-ender wrap-triggering-q wrap-idx + (if has-footnotes? (list fn-qs) null))) + (wrap-proc qs + max-distance + debug + hard-break? + soft-break? + finish-wrap + wrap-count + distance-func + initial-wrap-idx - footnote-qs - footnote-leftover-proc - footnote-new-proc)) - - (define (wrap-first qs - max-distance - debug - hard-break? - soft-break? - finish-wrap - wrap-count - distance-func - initial-wrap-idx + footnote-qs + footnote-leftover-proc + footnote-new-proc)) + +(define (wrap-first qs + max-distance + debug + hard-break? + soft-break? + finish-wrap + wrap-count + distance-func + initial-wrap-idx - footnote-qs-in - footnote-leftover-proc - footnote-new-proc) + footnote-qs-in + footnote-leftover-proc + footnote-new-proc) - (define has-footnotes? (pair? footnote-qs-in)) + (define has-footnotes? (pair? footnote-qs-in)) - (let loop ([wraps null] ; list of (list of quads) - [wrap-idx initial-wrap-idx] ; wrap count (could be (length wraps) but we'd rather avoid `length`) - [next-wrap-head null] ; list of quads ending in previous `soft-break?` or `hard-break?` - [next-wrap-tail null] ; list of unbreakable quads - [current-dist #false] ; #false (to indicate start) or integer - [previous-wrap-ender #f] - [qs qs] ; list of quads - [footnote-qs footnote-qs-in] ; list of footnote quads - [footnote-next-wrap null] - [footnote-wraps null] ; list of footnote lines wrapped into footnote area for this col - [footnote-dist 0] ; dist consumed by footnotes in current footnote wrap - ; this needs to be tracked separately from current-dist because #false is used to detect start - [max-distance max-distance] ; might be reduced by footnotes - ) - #| + (let loop ([wraps null] ; list of (list of quads) + [wrap-idx initial-wrap-idx] ; wrap count (could be (length wraps) but we'd rather avoid `length`) + [next-wrap-head null] ; list of quads ending in previous `soft-break?` or `hard-break?` + [next-wrap-tail null] ; list of unbreakable quads + [current-dist #false] ; #false (to indicate start) or integer + [previous-wrap-ender #f] + [qs qs] ; list of quads + [footnote-qs footnote-qs-in] ; list of footnote quads + [footnote-next-wrap null] + [footnote-wraps null] ; list of footnote lines wrapped into footnote area for this col + [footnote-dist 0] ; dist consumed by footnotes in current footnote wrap + ; this needs to be tracked separately from current-dist because #false is used to detect start + [max-distance max-distance] ; might be reduced by footnotes + ) + #| 1) If there are lines left over from a previous footnote, set as many of those lines on the current page as space allows. If the footnote zone is empty, this is a footnote continuation, so start with a continuation break. Loop without making a new column break. |# - (let-values ([(max-distance footnote-next-wrap footnote-qs) - ((if has-footnotes? - footnote-leftover-proc - values) max-distance footnote-next-wrap footnote-qs)]) + (let-values ([(max-distance footnote-next-wrap footnote-qs) + ((if has-footnotes? + footnote-leftover-proc + values) max-distance footnote-next-wrap footnote-qs)]) - (match qs - [(or (== empty) (list (? hard-break?))) ; ignore single trailing hard break - (define last-wrap (finish-wrap (append next-wrap-tail next-wrap-head) previous-wrap-ender wrap-idx #f)) - (finalize-reversed-wraps (cons last-wrap wraps))] - [(cons q other-qs) - (debug-report q 'next-q) - (debug-report (quad-elems q) 'next-q-elems) - (define would-be-wrap-qs (append (cons q next-wrap-tail) next-wrap-head)) - (define (handle-hard-overflow) + (match qs + [(? null?) + (define last-wrap + (finish-wrap (append next-wrap-tail next-wrap-head) previous-wrap-ender wrap-idx #f)) + (finalize-reversed-wraps (cons last-wrap wraps))] + [(cons q other-qs) + (debug-report q 'next-q) + (debug-report (quad-elems q) 'next-q-elems) + (define would-be-wrap-qs (append (cons q next-wrap-tail) next-wrap-head)) + (define (handle-hard-overflow) + (cond + [(empty? next-wrap-head) + (define-values (next-wrap-qs other-qs) + (cond + [(empty? next-wrap-tail) + ;; degenerate case where q is big enough to trigger a wrap on its own, + ;; but nothing left in next-wrap-head or next-wrap-tail. + ;; so we put it in its own wrap and recur, because otherwise we can't proceed + ;; though it will look screwy + (debug-report 'making-the-best-of-a-bad-situation) + (values (list q) (cdr qs))] + [else + (debug-report 'would-overflow-hard-without-captured-break) + (values next-wrap-tail qs)])) + (loop (cons (finish-wrap next-wrap-qs previous-wrap-ender wrap-idx (car next-wrap-qs) footnote-next-wrap) wraps) + (wrap-count wrap-idx q) + null + null + #false + (car next-wrap-qs) + other-qs + footnote-qs + null ; reset footnote-next-wrap + footnote-wraps + 0 ; reset footnote-dist + max-distance)] + [else ; finish the wrap & reset the line without consuming a quad + (loop (cons (finish-wrap next-wrap-head previous-wrap-ender wrap-idx (car next-wrap-head) footnote-next-wrap) wraps) + (wrap-count wrap-idx q) + null + next-wrap-tail + (for/sum ([item (in-list next-wrap-tail)]) (distance item)) + (car next-wrap-head) + qs + footnote-qs + null ; reset footnote-next-wrap + footnote-wraps + 0 ; reset footnote-dist + max-distance)])) + (with-handlers ([symbol? (λ (exn) (handle-hard-overflow))]) + (let-values ([(max-distance footnote-next-wrap footnote-qs) + (if has-footnotes? + (footnote-new-proc max-distance footnote-next-wrap footnote-qs q) + (values max-distance footnote-next-wrap footnote-qs))]) (cond - [(empty? next-wrap-head) - (define-values (next-wrap-qs other-qs) - (cond - [(empty? next-wrap-tail) - ;; degenerate case where q is big enough to trigger a wrap on its own, - ;; but nothing left in next-wrap-head or next-wrap-tail. - ;; so we put it in its own wrap and recur, because otherwise we can't proceed - ;; though it will look screwy - (debug-report 'making-the-best-of-a-bad-situation) - (values (list q) (cdr qs))] - [else - (debug-report 'would-overflow-hard-without-captured-break) - (values next-wrap-tail qs)])) - (loop (cons (finish-wrap next-wrap-qs previous-wrap-ender wrap-idx (car next-wrap-qs) footnote-next-wrap) wraps) + [(hard-break? q) + (debug-report 'found-hard-break) + ;; must break. finish the wrap and consume the hard break + (loop (cons (finish-wrap would-be-wrap-qs previous-wrap-ender wrap-idx) wraps) (wrap-count wrap-idx q) null null #false - (car next-wrap-qs) + q other-qs footnote-qs - null ; reset footnote-next-wrap + footnote-next-wrap footnote-wraps - 0 ; reset footnote-dist + footnote-dist max-distance)] - [else ; finish the wrap & reset the line without consuming a quad - (loop (cons (finish-wrap next-wrap-head previous-wrap-ender wrap-idx (car next-wrap-head) footnote-next-wrap) wraps) - (wrap-count wrap-idx q) - null - next-wrap-tail - (for/sum ([item (in-list next-wrap-tail)]) (distance item)) - (car next-wrap-head) - qs - footnote-qs - null ; reset footnote-next-wrap - footnote-wraps - 0 ; reset footnote-dist - max-distance)])) - (with-handlers ([symbol? (λ (exn) (handle-hard-overflow))]) - (let-values ([(max-distance footnote-next-wrap footnote-qs) - (if has-footnotes? - (footnote-new-proc max-distance footnote-next-wrap footnote-qs q) - (values max-distance footnote-next-wrap footnote-qs))]) - (cond - [(hard-break? q) - (debug-report 'found-hard-break) - ;; must break. finish the wrap and consume the hard break - (loop (cons (finish-wrap would-be-wrap-qs previous-wrap-ender wrap-idx) wraps) - (wrap-count wrap-idx q) - null - null - #false - q - other-qs - footnote-qs - footnote-next-wrap - footnote-wraps - footnote-dist - max-distance)] - [(let ([at-start? (not current-dist)]) at-start?) - (match q - [(and (? soft-break?) (? nonprinting-at-start?)) - (debug-report q 'skipping-soft-break-at-beginning) + [(let ([at-start? (not current-dist)]) at-start?) + (match q + [(and (? soft-break?) (? nonprinting-at-start?)) + (debug-report q 'skipping-soft-break-at-beginning) + (loop wraps + wrap-idx + next-wrap-head + next-wrap-tail + current-dist + previous-wrap-ender + other-qs + footnote-qs + footnote-next-wrap + footnote-wraps + footnote-dist + max-distance)] + [_ (debug-report 'hard-quad-at-start) (loop wraps wrap-idx next-wrap-head - next-wrap-tail - current-dist - previous-wrap-ender - other-qs - footnote-qs - footnote-next-wrap - footnote-wraps - footnote-dist - max-distance)] - [_ (debug-report 'hard-quad-at-start) - (loop wraps - wrap-idx - next-wrap-head - (list q) - (distance-func q 0 would-be-wrap-qs) - previous-wrap-ender - other-qs - footnote-qs - footnote-next-wrap - footnote-wraps - footnote-dist - max-distance)])] - [else ; cases that require computing distance - (define wrap-distance (distance-func q current-dist would-be-wrap-qs)) - (define would-overflow? (> wrap-distance max-distance)) - (cond - [would-overflow? - (cond - [(and (soft-break? q) (nonprinting-at-end? q)) - (debug-report 'would-overflow-soft-nonprinting) - ;; 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 - wrap-idx - (append (cons q next-wrap-tail) next-wrap-head) - null - wrap-distance - previous-wrap-ender - other-qs - footnote-qs - footnote-next-wrap - footnote-wraps - footnote-dist - max-distance)] - [else (handle-hard-overflow)])] - [(soft-break? q) - (debug-report 'would-not-overflow-soft) - ;; a soft break that fits, so move it on top of the next-wrap-head with the next-wrap-tail - (loop wraps - wrap-idx - (append (cons q next-wrap-tail) next-wrap-head) - null - wrap-distance + (list q) + (distance-func q 0 would-be-wrap-qs) previous-wrap-ender other-qs footnote-qs footnote-next-wrap footnote-wraps footnote-dist - max-distance)] - [else - (debug-report 'would-not-overflow) - ;; add to partial - (loop wraps - wrap-idx - next-wrap-head - (cons q next-wrap-tail) - wrap-distance - previous-wrap-ender - other-qs - footnote-qs - footnote-next-wrap - footnote-wraps - footnote-dist - max-distance)])])))])))) - - (define last-line-can-be-short? #t) - (define mega-penalty 1e8) - (define hyphen-penalty +inf.0) - (define max-consecutive-hyphens 1) - (define (pieces-sublist pieces i j) - (reverse (apply append (for/list ([n (in-range i j)]) - (vector-ref pieces n))))) - - (define (wrap-best qs - max-distance - debug - hard-break? - soft-break? - finish-wrap - wrap-count - distance-func - initial-wrap-idx . _) - (for*/fold ([wrapss null] - [wrap-idx initial-wrap-idx] - [previous-wrap-ender #f] - #:result (finalize-reversed-wraps (apply append wrapss))) - ([pieces-maybe-ending-in-hard-break (in-list (slicef-after qs hard-break?))]) - (define-values (pieces last-ender) - (match pieces-maybe-ending-in-hard-break - [(list pieces ... (? hard-break? hbr)) (values pieces hbr)] - [pieces (values pieces #f)])) - (define pieces-vec (list->vector (slicef-after pieces soft-break?))) - (define-values (wraps idx ender) - (wrap-pieces-best pieces-vec wrap-idx previous-wrap-ender last-ender wrap-count distance-func max-distance finish-wrap)) - (values (cons wraps wrapss) idx last-ender))) - - (struct penalty-rec (val idx hyphen-count) #:transparent) - (define (wrap-pieces-best pieces-vec starting-wrap-idx previous-last-q last-ender wrap-count distance-func max-distance finish-wrap) - (define (penalty i j) - (cond - [(or (eq? i j) (> j (vector-length pieces-vec))) - (define out-of-bounds-signal (- i)) - (penalty-rec out-of-bounds-signal #f 0)] - [else - (match-define (penalty-rec last-val starting-idx hyphen-count) (ocm-min-value ocm i)) - (define would-be-wrap-qs (pieces-sublist pieces-vec i j)) ; `reverse` to track ordinary wrap logic - (define wrap-distance (for/fold ([last-dist 0]) - ([q (in-list would-be-wrap-qs)]) - (distance-func q last-dist would-be-wrap-qs))) - (define underflow (- max-distance wrap-distance)) - (define new-consecutive-hyphen-count - (if (equal? (quad-elems (car would-be-wrap-qs)) '("\u00AD")) (add1 hyphen-count) 0)) - (penalty-rec - (+ last-val ; include penalty so far - mega-penalty ; new line penalty - (if (> new-consecutive-hyphen-count max-consecutive-hyphens) - (* hyphen-penalty (- new-consecutive-hyphen-count max-consecutive-hyphens)) - 0) - (cond - [(negative? underflow) - ;; overfull line: huge penalty prevents break; multiplier is essential for monotonicity. - (* mega-penalty (- underflow))] - [(let ([on-last-line? (eq? j (vector-length pieces-vec))]) - (or (not on-last-line?) - (and on-last-line? (not last-line-can-be-short?)))) - ;; standard penalty - (expt underflow 2)] - [else 0])) - (wrap-count starting-idx (car would-be-wrap-qs)) - new-consecutive-hyphen-count)])) + max-distance)])] + [else ; cases that require computing distance + (define wrap-distance (distance-func q current-dist would-be-wrap-qs)) + (define would-overflow? (> wrap-distance max-distance)) + (cond + [would-overflow? + (cond + [(and (soft-break? q) (nonprinting-at-end? q)) + (debug-report 'would-overflow-soft-nonprinting) + ;; 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 + wrap-idx + (append (cons q next-wrap-tail) next-wrap-head) + null + wrap-distance + previous-wrap-ender + other-qs + footnote-qs + footnote-next-wrap + footnote-wraps + footnote-dist + max-distance)] + [else (handle-hard-overflow)])] + [(soft-break? q) + (debug-report 'would-not-overflow-soft) + ;; a soft break that fits, so move it on top of the next-wrap-head with the next-wrap-tail + (loop wraps + wrap-idx + (append (cons q next-wrap-tail) next-wrap-head) + null + wrap-distance + previous-wrap-ender + other-qs + footnote-qs + footnote-next-wrap + footnote-wraps + footnote-dist + max-distance)] + [else + (debug-report 'would-not-overflow) + ;; add to partial + (loop wraps + wrap-idx + next-wrap-head + (cons q next-wrap-tail) + wrap-distance + previous-wrap-ender + other-qs + footnote-qs + footnote-next-wrap + footnote-wraps + footnote-dist + max-distance)])])))])))) + +(define last-line-can-be-short? #t) +(define mega-penalty 1e8) +(define hyphen-penalty +inf.0) +(define max-consecutive-hyphens 1) +(define (pieces-sublist pieces i j) + (reverse (apply append (for/list ([n (in-range i j)]) + (vector-ref pieces n))))) + +(define (wrap-best qs + max-distance + debug + hard-break? + soft-break? + finish-wrap + wrap-count + distance-func + initial-wrap-idx . _) + (for*/fold ([wrapss null] + [wrap-idx initial-wrap-idx] + [previous-wrap-ender #f] + #:result (finalize-reversed-wraps (apply append wrapss))) + ([pieces-maybe-ending-in-hard-break (in-list (slicef-after qs hard-break?))]) + (define-values (pieces last-ender) + (match pieces-maybe-ending-in-hard-break + [(list pieces ... (? hard-break? hbr)) (values pieces hbr)] + [pieces (values pieces #f)])) + (define pieces-vec (list->vector (slicef-after pieces soft-break?))) + (define-values (wraps idx ender) + (wrap-pieces-best pieces-vec wrap-idx previous-wrap-ender last-ender wrap-count distance-func max-distance finish-wrap)) + (values (cons wraps wrapss) idx last-ender))) + +(struct penalty-rec (val idx hyphen-count) #:transparent) +(define (wrap-pieces-best pieces-vec starting-wrap-idx previous-last-q last-ender wrap-count distance-func max-distance finish-wrap) + (define (penalty i j) + (cond + [(or (eq? i j) (> j (vector-length pieces-vec))) + (define out-of-bounds-signal (- i)) + (penalty-rec out-of-bounds-signal #f 0)] + [else + (match-define (penalty-rec last-val starting-idx hyphen-count) (ocm-min-value ocm i)) + (define would-be-wrap-qs (pieces-sublist pieces-vec i j)) ; `reverse` to track ordinary wrap logic + (define wrap-distance (for/fold ([last-dist 0]) + ([q (in-list would-be-wrap-qs)]) + (distance-func q last-dist would-be-wrap-qs))) + (define underflow (- max-distance wrap-distance)) + (define new-consecutive-hyphen-count + (if (equal? (quad-elems (car would-be-wrap-qs)) '("\u00AD")) (add1 hyphen-count) 0)) + (penalty-rec + (+ last-val ; include penalty so far + mega-penalty ; new line penalty + (if (> new-consecutive-hyphen-count max-consecutive-hyphens) + (* hyphen-penalty (- new-consecutive-hyphen-count max-consecutive-hyphens)) + 0) + (cond + [(negative? underflow) + ;; overfull line: huge penalty prevents break; multiplier is essential for monotonicity. + (* mega-penalty (- underflow))] + [(let ([on-last-line? (eq? j (vector-length pieces-vec))]) + (or (not on-last-line?) + (and on-last-line? (not last-line-can-be-short?)))) + ;; standard penalty + (expt underflow 2)] + [else 0])) + (wrap-count starting-idx (car would-be-wrap-qs)) + new-consecutive-hyphen-count)])) - ;; starting from last position, ask ocm for position of row minimum (= new-pos) - ;; collect this value, and use it as the input next time - ;; until you reach first position. - (define ocm (make-ocm penalty (penalty-rec 0 starting-wrap-idx 0) penalty-rec-val)) - (define last-j (vector-length pieces-vec)) - (define breakpoints - (if (zero? last-j) - (list 0 0) - (let loop ([bps (list last-j)]) ; start from end - (match (ocm-min-index ocm (car bps)) ; look to the previous line - [0 (cons 0 bps)]; zero means we're at first position, and therefore done - [min-i (loop (cons min-i bps))])))) - (for/fold ([wraps null] - [wrap-idx starting-wrap-idx] - [previous-wrap-ender previous-last-q]) - ([i (in-list breakpoints)] - [j (in-list (cdr breakpoints))]) - (define wrap-qs (pieces-sublist pieces-vec i j)) ; first-fit gets wrap-qs in reverse, so be consistent - ;; last wrap-ender must be #false - (define this-wrap-ender (if (eq? j last-j) last-ender (car wrap-qs))) - (values (cons (finish-wrap wrap-qs previous-wrap-ender wrap-idx this-wrap-ender) wraps) - (wrap-count wrap-idx this-wrap-ender) - this-wrap-ender))) - - - (module+ test - (define q-zero (q #:size (pt 0 0))) - (define q-one (q #:size (pt 1 1) #:printable #t)) - (define x (quad-copy q-one [elems '(#\x)])) - (define zwx (quad-copy q-zero - [printable (λ _ #t)] - [elems '(#\z)])) - (define hyph (quad-copy q-one [elems '(#\-)])) - (define shy (quad-copy q-one - [printable (λ (q [sig #f]) - (case sig - [(end) #t] - [else #f]))] - [elems '(#\-)])) - (define a (quad-copy q-one [elems '(#\a)])) - (define b (quad-copy q-one [elems '(#\b)])) - (define c (quad-copy q-one [elems '(#\c)])) - (define d (quad-copy q-one [elems '(#\d)])) - (define sp (quad-copy q-one - [printable (λ (q [sig #f]) - (case sig - [(start end) #f] - [else #t]))] - [elems '(#\space)])) - (define lbr (quad-copy q-one - [printable (λ _ #f)] - [elems '(#\newline)])) - - (define (soft-break? q) (memv (car (quad-elems q)) '(#\space #\-))) - - (define (linewrap xs size [debug #f] #:nicely [nicely? #f]) - (add-between (wrap xs size debug - #:nicely nicely? - #:finish-wrap (λ (xs . _) (list xs)) - #:hard-break (λ (q) (char=? (car (quad-elems q)) #\newline)) - #:soft-break soft-break?) lbr)) - - - (define (visual-wrap str int [debug #f] #:nicely [nicely? #f]) - (string-join - (for/list ([x (in-list (linewrap (for/list ([c (in-string str)]) - (define atom (q c)) - (if (equal? (quad-elems atom) '(#\space)) - (quad-copy sp) - (quad-copy q-one - [attrs (quad-attrs atom)] - [elems (quad-elems atom)]))) int debug - #:nicely nicely?))] - #:when (and (list? x) (andmap quad? x))) - (list->string (map car (map quad-elems x)))) - "|")) - - (define (pagewrap xs size [debug #f]) - (add-between - (wrap (flatten xs) size debug - #:hard-break (λ (x) (and (quad? x) (memv (car (quad-elems x)) '(#\page)))) - #:soft-break (λ (x) (and (quad? x) (eq? x lbr)))) pbr)) - (define pbr (q #:size #false - #:printable #false - #:elems '(#\page))) - - (define (linewrap2 xs size [debug #f]) - (add-between - (wrap xs size debug - #:hard-break (λ (q) (memv (car (quad-elems q)) '(#\newline))) - #:soft-break soft-break? - #:finish-wrap (λ (pcs . _) (list (apply q pcs)))) - lbr))) - - - (module+ test (require rackunit)) - - #;(module+ test - (test-case - "kp linebreaking" - (define meg-is-an-ally (list a b c sp a b sp c d sp a b c d x)) ; "Meg is an ally." - (check-equal? (linewrap meg-is-an-ally 6) - ;; Meg is - ;; an - ;; ally. - (list (list a b c sp a b) lbr (list c d) lbr (list a b c d x))) - (check-equal? (linewrap meg-is-an-ally 6 #:nicely #t) - ;; Meg - ;; is an - ;; ally. - (list (list a b c) lbr (list a b sp c d) lbr (list a b c d x))))) - - (module+ test - (test-begin - (test-case - "chars" - (check-equal? (linewrap (list) 1) (list)) - (check-equal? (linewrap (list a) 1) (list (list a))) - (check-equal? (linewrap (list a b) 1) (list (list a) lbr (list b))) - (check-equal? (linewrap (list a b c) 1) (list (list a) lbr (list b) lbr (list c))) - (check-equal? (linewrap (list a b c) 2) (list (list a b) lbr (list c))) - (check-equal? (linewrap (list x x x x) 2) (list (list x x) lbr (list x x))) - (check-equal? (linewrap (list x x x x x) 3) (list (list x x x) lbr (list x x))) - (check-equal? (linewrap (list x x x x x) 1) - (list (list x) lbr (list x) lbr (list x) lbr (list x) lbr (list x))) - (check-equal? (linewrap (list x x x x x) 10) (list (list x x x x x)))) - - (test-case - "chars and spaces" - (check-equal? (linewrap (list a sp b) 1) (list (list a) lbr (list b))) - (check-equal? (linewrap (list a b sp c) 2) (list (list a b) lbr (list c))) - (check-equal? (linewrap (list a sp b) 3) (list (list a sp b))) - (check-equal? (linewrap (list a sp b c) 3) (list (list a) lbr (list b c)))) - - (test-case - "leading & trailing spaces" - (check-equal? (linewrap (list sp x) 2) (list (list x))) - (check-equal? (linewrap (list x sp) 2) (list (list x))) - (check-equal? (linewrap (list sp x sp) 2) (list (list x))) - (check-equal? (linewrap (list sp sp x sp sp) 2) (list (list x))) - (check-equal? (linewrap (list sp sp x sp sp x sp) 1) (list (list x) lbr (list x)))) - - (test-case - "hard hyphens" - (check-equal? (linewrap (list hyph) 1) (list (list hyph))) - (check-equal? (linewrap (list hyph hyph) 1) (list (list hyph) lbr (list hyph))) - (check-equal? (linewrap (list hyph hyph) 2) (list (list hyph hyph))) - (check-equal? (linewrap (list hyph hyph hyph) 2) (list (list hyph hyph) lbr (list hyph))) - (check-equal? (linewrap (list x hyph) 1) (list (list x) lbr (list hyph))) - (check-equal? (linewrap (list a b hyph c d) 1) - (list (list a) lbr (list b) lbr (list hyph) lbr (list c) lbr (list d))) - (check-equal? (linewrap (list a b hyph c d) 2) (list (list a b) lbr (list hyph c) lbr (list d))) - (check-equal? (linewrap (list a b hyph c d) 3) (list (list a b hyph) lbr (list c d))) - (check-equal? (linewrap (list x x hyph x x) 4) (list (list x x hyph) lbr (list x x))) - (check-equal? (linewrap (list x x hyph x x) 5) (list (list x x hyph x x)))) - - ;; todo: fix soft hyphens - #;(test-case - "soft hyphens" - (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) (list (list x))) - (check-equal? (linewrap (list x shy shy shy shy) 1) (list (list x))) - ;; todo: degenerate cases that don't work without continuations - ;(check-equal? (linewrap (list x x shy x x) 1) (list x br x br x br x)) - ;(check-equal? (linewrap (list x x shy x x) 2) (list x x br x x)) - (check-equal? (linewrap (list x x shy x x) 3) (list (list x x shy) lbr (list x x))) - (check-equal? (linewrap (list x x shy x x) 4) (list (list x x x x))) - (check-equal? (linewrap (list x x shy x x) 5) (list (list x x x x))) - (check-equal? (linewrap (list x x shy x sp x) 4) (list (list x x x) lbr (list x)))) - - (test-case - "zero width nonbreakers" - (check-equal? (linewrap (list sp zwx) 2) (list (list zwx))) - (check-equal? (linewrap (list zwx sp) 2) (list (list zwx))) - (check-equal? (linewrap (list sp zwx sp) 2) (list (list zwx))) - (check-equal? (linewrap (list sp sp zwx sp sp) 2) (list (list zwx))) - (check-equal? (linewrap (list sp sp zwx sp sp zwx sp) 2) (list (list zwx sp sp zwx)))) - - (test-case - "hard breaks" - (check-equal? (linewrap (list lbr) 2) (list)) ;; only insert a break if it's between things - (check-equal? (linewrap (list a lbr b) 2) (list (list a) lbr (list b))) - (check-equal? (linewrap (list a b lbr) 2) (list (list a b))) - (check-equal? (linewrap (list a b lbr lbr) 2) (list (list a b) lbr (list))) - (check-equal? (linewrap (list x lbr x x) 3) (list (list x) lbr (list x x))) - (check-equal? (linewrap (list x x lbr x) 3) (list (list x x) lbr (list x))) - (check-equal? (linewrap (list x x x x) 3) (list (list x x x) lbr (list x))) - (check-equal? (linewrap (list x x x sp x x) 2) (list (list x x) lbr (list x) lbr (list x x))) - (check-equal? (linewrap (list x x x sp x x) 3) (list (list x x x) lbr (list x x)))) - - - (test-case - "hard breaks and spurious spaces" - (check-equal? (linewrap (list a sp sp sp lbr b) 2) (list (list a) lbr (list b))) - (check-equal? (linewrap (list a sp lbr sp sp b c sp) 3) (list (list a) lbr (list b c))) - (check-equal? (linewrap (list sp sp x x sp sp lbr sp sp sp x) 3) (list (list x x) lbr (list x))) - (check-equal? (linewrap (list a sp b sp sp lbr sp c) 3) (list (list a sp b) lbr (list c))) - (check-equal? (linewrap (list x x x x) 3) (list (list x x x) lbr (list x))) - (check-equal? (linewrap (list x x x sp x x) 2) (list (list x x) lbr (list x) lbr (list x x))) - (check-equal? (linewrap (list x x x sp x x) 3) (list (list x x x) lbr (list x x)))) - - (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" 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") - (check-equal? (visual-wrap "My dog has fleas" 5) "My|dog|has|fleas") - (check-equal? (visual-wrap "My dog has fleas" 6) "My dog|has|fleas") - (check-equal? (visual-wrap "My dog has fleas" 7) "My dog|has|fleas") - (check-equal? (visual-wrap "My dog has fleas" 8) "My dog|has|fleas") - (check-equal? (visual-wrap "My dog has fleas" 9) "My dog|has fleas") - (check-equal? (visual-wrap "My dog has fleas" 10) "My dog has|fleas") - (check-equal? (visual-wrap "My dog has fleas" 11) "My dog has|fleas") - (check-equal? (visual-wrap "My dog has fleas" 12) "My dog has|fleas") - (check-equal? (visual-wrap "My dog has fleas" 13) "My dog has|fleas") - (check-equal? (visual-wrap "My dog has fleas" 14) "My dog has|fleas") - (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")) - - (test-case - "soft page breaks" - (check-equal? (pagewrap null 2) (list)) - (check-equal? (pagewrap (list x) 2) (list (list x))) - (check-equal? (pagewrap (list x x) 2) (list (list x x))) - (check-equal? (pagewrap (list x x x) 1) (list (list x) pbr (list x) pbr (list x))) - (check-equal? (pagewrap (list x x x) 2) (list (list x x) pbr (list x))) - (check-equal? (pagewrap (list x x x) 3) (list (list x x x))) - (check-equal? (pagewrap (list x x x) 4) (list (list x x x))) - (check-equal? (pagewrap (list x lbr x x) 2) (list (list x) pbr (list x x)))) - - (test-case - "hard page breaks" - (check-equal? (pagewrap (list a pbr b c) 2) (list (list a) pbr (list b c))) - (check-equal? (pagewrap (list x pbr x x) 1) (list (list x) pbr (list x) pbr (list x))) - (check-equal? (pagewrap (list x pbr pbr x x) 1) (list (list x) pbr (list) pbr (list x) pbr (list x))) - (check-equal? (pagewrap (list x pbr pbr x x) 2) (list (list x) pbr (list) pbr (list x x))) - (check-equal? (pagewrap (list lbr x lbr lbr pbr lbr x x lbr) 2) (list (list x) pbr (list x x)))) - - (test-case - "composed line breaks and page breaks" - (check-equal? (pagewrap (linewrap null 1) 2) (list)) - (check-equal? (pagewrap (linewrap (list x) 1) 2) (list (list x))) - (check-equal? (pagewrap (linewrap (list x x x) 1) 2) (list (list x lbr x) pbr (list x))) - (check-equal? (pagewrap (linewrap (list x x x) 2) 2) (list (list x x) pbr (list x))) - (check-equal? (pagewrap (linewrap (list x x x) 2) 1) (list (list x) pbr (list x) pbr (list x)))) - - (test-case - "hard breaks and spurious spaces with slugs" - (check-equal? (linewrap2 (list a sp sp sp lbr b) 2) (list (q a) lbr (q b))) - (check-equal? (linewrap2 (list x sp lbr sp sp x x sp) 3) (list (q x) lbr (q x x))) - (check-equal? (linewrap2 (list sp sp x x sp sp lbr sp sp sp x) 3) (list (q x x) lbr (q x))) - (check-equal? (linewrap2 (list a sp b sp sp lbr sp c) 3) (list (q a sp b) lbr (q c))) - (check-equal? (linewrap2 (list x x x x) 3) (list (q x x x) lbr (q x))) - (check-equal? (linewrap2 (list x x x sp x x) 2) (list (q x x) lbr (q x) lbr (q x x))) - (check-equal? (linewrap2 (list x x x sp x x) 3) (list (q x x x) lbr (q x x)))))) - - \ No newline at end of file + ;; starting from last position, ask ocm for position of row minimum (= new-pos) + ;; collect this value, and use it as the input next time + ;; until you reach first position. + (define ocm (make-ocm penalty (penalty-rec 0 starting-wrap-idx 0) penalty-rec-val)) + (define last-j (vector-length pieces-vec)) + (define breakpoints + (if (zero? last-j) + (list 0 0) + (let loop ([bps (list last-j)]) ; start from end + (match (ocm-min-index ocm (car bps)) ; look to the previous line + [0 (cons 0 bps)]; zero means we're at first position, and therefore done + [min-i (loop (cons min-i bps))])))) + (for/fold ([wraps null] + [wrap-idx starting-wrap-idx] + [previous-wrap-ender previous-last-q]) + ([i (in-list breakpoints)] + [j (in-list (cdr breakpoints))]) + (define wrap-qs (pieces-sublist pieces-vec i j)) ; first-fit gets wrap-qs in reverse, so be consistent + ;; last wrap-ender must be #false + (define this-wrap-ender (if (eq? j last-j) last-ender (car wrap-qs))) + (values (cons (finish-wrap wrap-qs previous-wrap-ender wrap-idx this-wrap-ender) wraps) + (wrap-count wrap-idx this-wrap-ender) + this-wrap-ender))) + + +(module+ test + (define q-zero (q #:size (pt 0 0))) + (define q-one (q #:size (pt 1 1) #:printable #t)) + (define x (quad-copy q-one [elems '(#\x)])) + (define zwx (quad-copy q-zero + [printable (λ _ #t)] + [elems '(#\z)])) + (define hyph (quad-copy q-one [elems '(#\-)])) + (define shy (quad-copy q-one + [printable (λ (q [sig #f]) + (case sig + [(end) #t] + [else #f]))] + [elems '(#\-)])) + (define a (quad-copy q-one [elems '(#\a)])) + (define b (quad-copy q-one [elems '(#\b)])) + (define c (quad-copy q-one [elems '(#\c)])) + (define d (quad-copy q-one [elems '(#\d)])) + (define sp (quad-copy q-one + [printable (λ (q [sig #f]) + (case sig + [(start end) #f] + [else #t]))] + [elems '(#\space)])) + (define lbr (quad-copy q-one + [printable (λ _ #f)] + [elems '(#\newline)])) + + (define (soft-break? q) (memv (car (quad-elems q)) '(#\space #\-))) + + (define (linewrap xs size [debug #f] #:nicely [nicely? #f]) + (add-between (wrap xs size debug + #:nicely nicely? + #:finish-wrap (λ (xs . _) (list xs)) + #:hard-break (λ (q) (char=? (car (quad-elems q)) #\newline)) + #:soft-break soft-break?) lbr)) + + + (define (visual-wrap str int [debug #f] #:nicely [nicely? #f]) + (string-join + (for/list ([x (in-list (linewrap (for/list ([c (in-string str)]) + (define atom (q c)) + (if (equal? (quad-elems atom) '(#\space)) + (quad-copy sp) + (quad-copy q-one + [attrs (quad-attrs atom)] + [elems (quad-elems atom)]))) int debug + #:nicely nicely?))] + #:when (and (list? x) (andmap quad? x))) + (list->string (map car (map quad-elems x)))) + "|")) + + (define (pagewrap xs size [debug #f]) + (add-between + (wrap (flatten xs) size debug + #:hard-break (λ (x) (and (quad? x) (memv (car (quad-elems x)) '(#\page)))) + #:soft-break (λ (x) (and (quad? x) (eq? x lbr)))) pbr)) + (define pbr (q #:size #false + #:printable #false + #:elems '(#\page))) + + (define (linewrap2 xs size [debug #f]) + (add-between + (wrap xs size debug + #:hard-break (λ (q) (memv (car (quad-elems q)) '(#\newline))) + #:soft-break soft-break? + #:finish-wrap (λ (pcs . _) (list (apply q pcs)))) + lbr))) + + +(module+ test (require rackunit)) + +#;(module+ test + (test-case + "kp linebreaking" + (define meg-is-an-ally (list a b c sp a b sp c d sp a b c d x)) ; "Meg is an ally." + (check-equal? (linewrap meg-is-an-ally 6) + ;; Meg is + ;; an + ;; ally. + (list (list a b c sp a b) lbr (list c d) lbr (list a b c d x))) + (check-equal? (linewrap meg-is-an-ally 6 #:nicely #t) + ;; Meg + ;; is an + ;; ally. + (list (list a b c) lbr (list a b sp c d) lbr (list a b c d x))))) + +(module+ test + (test-begin + (test-case + "chars" + (check-equal? (linewrap (list) 1) (list)) + (check-equal? (linewrap (list a) 1) (list (list a))) + (check-equal? (linewrap (list a b) 1) (list (list a) lbr (list b))) + (check-equal? (linewrap (list a b c) 1) (list (list a) lbr (list b) lbr (list c))) + (check-equal? (linewrap (list a b c) 2) (list (list a b) lbr (list c))) + (check-equal? (linewrap (list x x x x) 2) (list (list x x) lbr (list x x))) + (check-equal? (linewrap (list x x x x x) 3) (list (list x x x) lbr (list x x))) + (check-equal? (linewrap (list x x x x x) 1) + (list (list x) lbr (list x) lbr (list x) lbr (list x) lbr (list x))) + (check-equal? (linewrap (list x x x x x) 10) (list (list x x x x x)))) + + (test-case + "chars and spaces" + (check-equal? (linewrap (list a sp b) 1) (list (list a) lbr (list b))) + (check-equal? (linewrap (list a b sp c) 2) (list (list a b) lbr (list c))) + (check-equal? (linewrap (list a sp b) 3) (list (list a sp b))) + (check-equal? (linewrap (list a sp b c) 3) (list (list a) lbr (list b c)))) + + (test-case + "leading & trailing spaces" + (check-equal? (linewrap (list sp x) 2) (list (list x))) + (check-equal? (linewrap (list x sp) 2) (list (list x))) + (check-equal? (linewrap (list sp x sp) 2) (list (list x))) + (check-equal? (linewrap (list sp sp x sp sp) 2) (list (list x))) + (check-equal? (linewrap (list sp sp x sp sp x sp) 1) (list (list x) lbr (list x)))) + + (test-case + "hard hyphens" + (check-equal? (linewrap (list hyph) 1) (list (list hyph))) + (check-equal? (linewrap (list hyph hyph) 1) (list (list hyph) lbr (list hyph))) + (check-equal? (linewrap (list hyph hyph) 2) (list (list hyph hyph))) + (check-equal? (linewrap (list hyph hyph hyph) 2) (list (list hyph hyph) lbr (list hyph))) + (check-equal? (linewrap (list x hyph) 1) (list (list x) lbr (list hyph))) + (check-equal? (linewrap (list a b hyph c d) 1) + (list (list a) lbr (list b) lbr (list hyph) lbr (list c) lbr (list d))) + (check-equal? (linewrap (list a b hyph c d) 2) (list (list a b) lbr (list hyph c) lbr (list d))) + (check-equal? (linewrap (list a b hyph c d) 3) (list (list a b hyph) lbr (list c d))) + (check-equal? (linewrap (list x x hyph x x) 4) (list (list x x hyph) lbr (list x x))) + (check-equal? (linewrap (list x x hyph x x) 5) (list (list x x hyph x x)))) + + ;; todo: fix soft hyphens + #;(test-case + "soft hyphens" + (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) (list (list x))) + (check-equal? (linewrap (list x shy shy shy shy) 1) (list (list x))) + ;; todo: degenerate cases that don't work without continuations + ;(check-equal? (linewrap (list x x shy x x) 1) (list x br x br x br x)) + ;(check-equal? (linewrap (list x x shy x x) 2) (list x x br x x)) + (check-equal? (linewrap (list x x shy x x) 3) (list (list x x shy) lbr (list x x))) + (check-equal? (linewrap (list x x shy x x) 4) (list (list x x x x))) + (check-equal? (linewrap (list x x shy x x) 5) (list (list x x x x))) + (check-equal? (linewrap (list x x shy x sp x) 4) (list (list x x x) lbr (list x)))) + + (test-case + "zero width nonbreakers" + (check-equal? (linewrap (list sp zwx) 2) (list (list zwx))) + (check-equal? (linewrap (list zwx sp) 2) (list (list zwx))) + (check-equal? (linewrap (list sp zwx sp) 2) (list (list zwx))) + (check-equal? (linewrap (list sp sp zwx sp sp) 2) (list (list zwx))) + (check-equal? (linewrap (list sp sp zwx sp sp zwx sp) 2) (list (list zwx sp sp zwx)))) + + (test-case + "hard breaks" + (check-equal? (linewrap (list lbr) 2) (list (list) lbr (list))) + (check-equal? (linewrap (list a lbr b) 2) (list (list a) lbr (list b))) + (check-equal? (linewrap (list a b lbr) 2) (list (list a b) lbr (list))) + (check-equal? (linewrap (list a b lbr lbr) 2) (list (list a b) lbr (list) lbr (list))) + (check-equal? (linewrap (list x lbr x x) 3) (list (list x) lbr (list x x))) + (check-equal? (linewrap (list x x lbr x) 3) (list (list x x) lbr (list x))) + (check-equal? (linewrap (list x x x x) 3) (list (list x x x) lbr (list x))) + (check-equal? (linewrap (list x x x sp x x) 2) (list (list x x) lbr (list x) lbr (list x x))) + (check-equal? (linewrap (list x x x sp x x) 3) (list (list x x x) lbr (list x x)))) + + + (test-case + "hard breaks and spurious spaces" + (check-equal? (linewrap (list a sp sp sp lbr b) 2) (list (list a) lbr (list b))) + (check-equal? (linewrap (list a sp lbr sp sp b c sp) 3) (list (list a) lbr (list b c))) + (check-equal? (linewrap (list sp sp x x sp sp lbr sp sp sp x) 3) (list (list x x) lbr (list x))) + (check-equal? (linewrap (list a sp b sp sp lbr sp c) 3) (list (list a sp b) lbr (list c))) + (check-equal? (linewrap (list x x x x) 3) (list (list x x x) lbr (list x))) + (check-equal? (linewrap (list x x x sp x x) 2) (list (list x x) lbr (list x) lbr (list x x))) + (check-equal? (linewrap (list x x x sp x x) 3) (list (list x x x) lbr (list x x)))) + + (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" 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") + (check-equal? (visual-wrap "My dog has fleas" 5) "My|dog|has|fleas") + (check-equal? (visual-wrap "My dog has fleas" 6) "My dog|has|fleas") + (check-equal? (visual-wrap "My dog has fleas" 7) "My dog|has|fleas") + (check-equal? (visual-wrap "My dog has fleas" 8) "My dog|has|fleas") + (check-equal? (visual-wrap "My dog has fleas" 9) "My dog|has fleas") + (check-equal? (visual-wrap "My dog has fleas" 10) "My dog has|fleas") + (check-equal? (visual-wrap "My dog has fleas" 11) "My dog has|fleas") + (check-equal? (visual-wrap "My dog has fleas" 12) "My dog has|fleas") + (check-equal? (visual-wrap "My dog has fleas" 13) "My dog has|fleas") + (check-equal? (visual-wrap "My dog has fleas" 14) "My dog has|fleas") + (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")) + + (test-case + "soft page breaks" + (check-equal? (pagewrap null 2) (list)) + (check-equal? (pagewrap (list x) 2) (list (list x))) + (check-equal? (pagewrap (list x x) 2) (list (list x x))) + (check-equal? (pagewrap (list x x x) 1) (list (list x) pbr (list x) pbr (list x))) + (check-equal? (pagewrap (list x x x) 2) (list (list x x) pbr (list x))) + (check-equal? (pagewrap (list x x x) 3) (list (list x x x))) + (check-equal? (pagewrap (list x x x) 4) (list (list x x x))) + (check-equal? (pagewrap (list x lbr x x) 2) (list (list x) pbr (list x x)))) + + (test-case + "hard page breaks" + (check-equal? (pagewrap (list a pbr b c) 2) (list (list a) pbr (list b c))) + (check-equal? (pagewrap (list x pbr x x) 1) (list (list x) pbr (list x) pbr (list x))) + (check-equal? (pagewrap (list x pbr pbr x x) 1) (list (list x) pbr (list) pbr (list x) pbr (list x))) + (check-equal? (pagewrap (list x pbr pbr x x) 2) (list (list x) pbr (list) pbr (list x x))) + (check-equal? (pagewrap (list lbr x lbr lbr pbr lbr x x lbr) 2) (list (list x) pbr (list x x)))) + + (test-case + "composed line breaks and page breaks" + (check-equal? (pagewrap (linewrap null 1) 2) (list)) + (check-equal? (pagewrap (linewrap (list x) 1) 2) (list (list x))) + (check-equal? (pagewrap (linewrap (list x x x) 1) 2) (list (list x lbr x) pbr (list x))) + (check-equal? (pagewrap (linewrap (list x x x) 2) 2) (list (list x x) pbr (list x))) + (check-equal? (pagewrap (linewrap (list x x x) 2) 1) (list (list x) pbr (list x) pbr (list x)))) + + (test-case + "hard breaks and spurious spaces with slugs" + (check-equal? (linewrap2 (list a sp sp sp lbr b) 2) (list (q a) lbr (q b))) + (check-equal? (linewrap2 (list x sp lbr sp sp x x sp) 3) (list (q x) lbr (q x x))) + (check-equal? (linewrap2 (list sp sp x x sp sp lbr sp sp sp x) 3) (list (q x x) lbr (q x))) + (check-equal? (linewrap2 (list a sp b sp sp lbr sp c) 3) (list (q a sp b) lbr (q c))) + (check-equal? (linewrap2 (list x x x x) 3) (list (q x x x) lbr (q x))) + (check-equal? (linewrap2 (list x x x sp x x) 2) (list (q x x) lbr (q x) lbr (q x x))) + (check-equal? (linewrap2 (list x x x sp x x) 3) (list (q x x x) lbr (q x x)))))) + diff --git a/quad/quadwriter/layout.rkt b/quad/quadwriter/layout.rkt index a95b971d..2792128b 100644 --- a/quad/quadwriter/layout.rkt +++ b/quad/quadwriter/layout.rkt @@ -327,9 +327,9 @@ (append sublists (list last-sublist))])] [_ word-sublists])) (define word-width (for/sum ([qs (in-list hung-word-sublists)]) - (sum-x qs))) + (sum-x qs))) (define word-space-width (for/sum ([qs (in-list word-space-sublists)]) - (sum-x qs))) + (sum-x qs))) (define empty-hspace (- line-width (quad-ref (car qs) :inset-left 0) word-width @@ -390,7 +390,7 @@ ;; remove unused soft hyphens so they don't affect final shaping (define pcs-printing (for/list ([pc (in-list pcs-in)] #:unless (equal? (quad-elems pc) '("\u00AD"))) - pc)) + pc)) (define new-lines (cond [(empty? pcs-printing) null] @@ -460,37 +460,60 @@ [_ null]))) ; hard line break -(define (line-wrap qs wrap-size) +(define (line-wrap qs wrap-size [debug #false]) + (unless (positive? wrap-size) + (raise-argument-error 'line-wrap "positive number" wrap-size)) (match qs - [(? null?) null] - [_ - (unless (positive? wrap-size) - (raise-argument-error 'line-wrap "positive number" wrap-size)) - (define line-q (quad-copy q:line [size (pt wrap-size (quad-ref (car qs) :line-height default-line-height))])) + [(cons q _) + (define line-q (quad-copy q:line [size (pt wrap-size (quad-ref q :line-height default-line-height))])) (define permitted-justify-overfill - (match (quad-ref (car qs) :line-align) + (match (quad-ref q :line-align) ;; allow justified lines to go wider, ;; and then fill-wrap will tighten thes word spaces ;; this makes justified paragraphs more even, becuase ;; some lines are a little tight, as opposed to all of them being loose ["justify" 1.04] [_ 1])) + ;; group lines into sublists separated by para-breaks, but then omit the para-breaks themselves + ;; because they've served their purpose (leave the others, to be expressed later) + ;; however, leave line-breaks in, because they will be handled by wrap. + (define para-qss (let loop ([qs qs][acc null]) + (match qs + [(? null?) (reverse acc)] + [(cons (? para-break-quad?) rest) + (loop rest acc)] + [(cons (? column-break-quad? bq) rest) + (loop rest (cons bq acc))] + [(list* (and (not (? para-break-quad?)) nbqs) ... rest) + (loop rest (cons nbqs acc))]))) (apply append - ;; next line removes all para-break? quads as a consequence - (for/list ([qs (in-list (filter-split qs para-break-quad?))]) - (wrap qs - (* (- wrap-size - (quad-ref (car qs) :inset-left 0) - (quad-ref (car qs) :inset-right 0)) - permitted-justify-overfill) - #:nicely (match (or (current-line-wrap) (quad-ref (car qs) :line-wrap)) - [(or "best" "kp") #true] - [_ #false]) - #:hard-break line-break-quad? - #:soft-break soft-break-for-line? - #:finish-wrap (line-wrap-finish line-q))))])) - -(define (make-nobreak! q) (quad-set! q :no-colbr #true)) ; cooperates with col-wrap + (for/list ([para-qs (in-list para-qss)]) + (match para-qs + [(? break-quad? bq) (list bq)] + [(cons pq _) + (wrap para-qs + (* (- wrap-size + (quad-ref pq :inset-left 0) + (quad-ref pq :inset-right 0)) + permitted-justify-overfill) + debug + #:nicely (match (or (current-line-wrap) (quad-ref pq :line-wrap)) + [(or "best" "kp") #true] + [_ #false]) + #:hard-break line-break-quad? + #:soft-break soft-break-for-line? + #:finish-wrap (line-wrap-finish line-q))])))] + [_ null])) + +(module+ test +(line-wrap (list (make-quad "foo" #:type string-quad) + (make-quad #:type column-break-quad) + (make-quad "foo2" #:type string-quad) ) 10 #t) + +(line-wrap (list (make-quad "foo" #:type string-quad) + (make-quad #:type column-break-quad)) 10 #t)) + +(define (make-nobreak! q) (quad-set! q :no-colbr #true)) ; scooperates with col-wrap (define (do-keep-with-next! reversed-lines) ;; paints nobreak onto the kwn line itself, @@ -538,9 +561,9 @@ ;; explicit measurements from page-height and page-width supersede those from page-size. (match-define (list page-width page-height) (for/list ([k (list :page-width :page-height)]) - (and (quad? q) (match (quad-ref q k) - [#false #false] - [val (inexact->exact (floor val))])))) + (and (quad? q) (match (quad-ref q k) + [#false #false] + [val (inexact->exact (floor val))])))) (resolve-page-size (or (debug-page-width) page-width) (or (debug-page-height) page-height) @@ -610,7 +633,7 @@ ;; adjust drawing coordinates for border inset (match-define (list bil bit bir bib) (for/list ([k (in-list (list :border-inset-left :border-inset-top :border-inset-right :border-inset-bottom))]) - (quad-ref first-line k 0))) + (quad-ref first-line k 0))) (match-define (list left top) (pt+ (quad-origin q) (list bil bit))) (match-define (list width height) (pt- (size q) (list (+ bil bir) (+ bit bib)))) ;; fill rect @@ -648,14 +671,14 @@ [(#true) (when (eq? (log-clipping?) 'warn) (for ([line (in-list (quad-elems q))]) - (define line-width (pt-x (size line))) - (define line-elem-width (sum-x (quad-elems line))) - (when (< line-width line-elem-width) - (define error-str (apply string-append (for/list ([q (in-list (quad-elems line))]) - (match (quad-elems q) - [(list (? string? str)) str] - [_ ""])))) - (log-quadwriter-warning (format "clipping overfull line: ~v" error-str))))) + (define line-width (pt-x (size line))) + (define line-elem-width (sum-x (quad-elems line))) + (when (< line-width line-elem-width) + (define error-str (apply string-append (for/list ([q (in-list (quad-elems line))]) + (match (quad-elems q) + [(list (? string? str)) str] + [_ ""])))) + (log-quadwriter-warning (format "clipping overfull line: ~v" error-str))))) (save doc) (rect doc left top width height) (clip doc)])) @@ -692,10 +715,10 @@ (define ((column-wrap-finish col-quad) lns q0 ending-q idx [reversed-fn-lines null]) (define fn-lines (from-parent (for/list ([fn-line (in-list reversed-fn-lines)]) - ;; position bottom to top, in reverse - (quad-update! fn-line - [from 'nw] - [to 'sw])) 'sw)) + ;; position bottom to top, in reverse + (quad-update! fn-line + [from 'nw] + [to 'sw])) 'sw)) (append (match lns @@ -754,10 +777,10 @@ https://github.com/mbutterick/typesetter/blob/882ec681ad1fa6eaee6287e53bc4320d96 (raise 'boom))))) (define reversed-fn-lines (from-parent (for/list ([fn-line (in-list (reverse fn-lines))]) - ;; position bottom to top, in reverse - (quad-update! fn-line - [from 'nw] - [to 'sw])) 'sw)) + ;; position bottom to top, in reverse + (quad-update! fn-line + [from 'nw] + [to 'sw])) 'sw)) (quad-update! (car cols) [elems (append (quad-elems (car cols)) reversed-fn-lines)]) (define col-spacer (quad-copy q:column-spacer [size (pt column-gap (and 'arbitrary-irrelevant-value 100))])) @@ -794,9 +817,9 @@ https://github.com/mbutterick/typesetter/blob/882ec681ad1fa6eaee6287e53bc4320d96 (define (insert-blocks lines) (define groups-of-lines (contiguous-group-by (λ (x) (quad-ref x :display)) lines)) (append* (for/list ([line-group (in-list groups-of-lines)]) - (if (quad-ref (car line-group) :display) - (list (lines->block line-group)) - line-group)))) + (if (quad-ref (car line-group) :display) + (list (lines->block line-group)) + line-group)))) (define-quad first-line-indent-quad quad) @@ -814,11 +837,11 @@ https://github.com/mbutterick/typesetter/blob/882ec681ad1fa6eaee6287e53bc4320d96 (apply append (for/list ([q (in-list qs)] [next-q (in-list (cdr qs))]) - (match (and (para-break-quad? q) (quad-ref next-q :first-line-indent 0)) - [(or #false 0) (list next-q)] - [indent-val (list (make-quad #:from 'bo - #:to 'bi - #:draw-end q:string-draw-end - #:type first-line-indent-quad - #:attrs (quad-attrs next-q) - #:size (pt indent-val 10)) next-q)])))) + (match (and (para-break-quad? q) (quad-ref next-q :first-line-indent 0)) + [(or #false 0) (list next-q)] + [indent-val (list (make-quad #:from 'bo + #:to 'bi + #:draw-end q:string-draw-end + #:type first-line-indent-quad + #:attrs (quad-attrs next-q) + #:size (pt indent-val 10)) next-q)]))))