From 315b85bc4590ab3677f879e2ecc7091438031310 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sun, 26 May 2019 09:31:12 -0700 Subject: [PATCH] squeeze justified lines --- quad/quadwriter/core.rkt | 113 +++++++++++++++++++++++---------------- 1 file changed, 66 insertions(+), 47 deletions(-) diff --git a/quad/quadwriter/core.rkt b/quad/quadwriter/core.rkt index 648d367c..2bbb6f49 100644 --- a/quad/quadwriter/core.rkt +++ b/quad/quadwriter/core.rkt @@ -211,54 +211,60 @@ (struct-copy quad q [elems (list substr)]))])))) (define-quad filler quad ()) + +(define (sum-of-widths qss) + (for*/sum ([qs (in-list qss)] + [q (in-list qs)]) + (pt-x (size q)))) + +(define (space-quad? q) (equal? (quad-elems q) (list " "))) + (define (fill-wrap qs ending-q line-q) (match (and (pair? qs) (quad-ref (car qs) (if ending-q 'line-align 'line-align-last) "left")) - [(or #false "left") qs] ; default is left aligned, no filling needed [align-value - (define word-sublists (filter-split qs (λ (q) (match (quad-elems q) - [(cons " " _) #true] - [_ #false])))) + ;; words may still be in hyphenated fragments + ;; (though soft hyphens would have been removed) + ;; so group them (but no need to consolidate — that happens elsewhere) + (define-values (word-space-sublists word-sublists) (partition* space-quad? qs)) (match (length word-sublists) [1 #:when (equal? align-value "justify") qs] ; can't justify single word [word-count (match-define (list line-width line-height) (quad-size line-q)) - ;; words may still be in hyphenated fragments - ;; (though soft hyphens would have been removed) - ;; so group them (but no need to consolidate — that happens elsewhere) - (define occupied-width - (match align-value - ;; for justified line, we care about size of words without spaces - ["justify" (for*/sum ([word-sublist (in-list word-sublists)] - [word (in-list word-sublist)]) - (pt-x (size word)))] - ;; for others, we care about size with spaces - [_ (for/sum ([q (in-list qs)]) - (pt-x (size q)))])) + (define word-width (sum-of-widths word-sublists)) + (define word-space-width (sum-of-widths word-space-sublists)) (define empty-hspace (- line-width (quad-ref (car qs) 'inset-left 0) - occupied-width + word-width (quad-ref (car qs) 'inset-right 0))) - (match align-value - ["justify" - (define space-width (/ empty-hspace (sub1 word-count))) + (define line-overfull? (negative? (- empty-hspace word-space-width))) + (cond + [(or (equal? align-value "justify") + ;; force justification upon overfull lines + line-overfull?) + (define justified-space-width (/ empty-hspace (sub1 word-count))) (apply append (add-between word-sublists (list (make-quad #:from 'bo #:to 'bi #:draw-end q:string-draw-end - #:size (pt space-width line-height)))))] - [_ + #:size (pt justified-space-width line-height)))))] + + [(equal? align-value "left") qs] ; no filling needed + [else (define space-multiplier (match align-value ["center" 0.5] ["right" 1])) + ;; subtact space-width because that appears between words + ;; we only care about redistributing the space on the ends + (define end-hspace (- empty-hspace word-space-width)) ; make filler a leading quad, not a parent / grouping quad, ;; so that elements can still be reached by consolidate-runs (list* (make-quad #:type filler #:from-parent (quad-from-parent (car qs)) #:from 'bo #:to 'bi - #:size (pt (* empty-hspace space-multiplier) 0) + #:size (pt (* end-hspace space-multiplier) 0) #:attrs (quad-attrs (car qs))) (struct-copy quad (car qs) [from-parent #f]) (cdr qs))])])])) @@ -353,22 +359,35 @@ [else (list q:line-spacer)]))) ; paragraph break (define (line-wrap qs wrap-size) - (unless (positive? wrap-size) - (raise-argument-error 'line-wrap "positive number" wrap-size)) - (define line-q (struct-copy - quad q:line - [size (pt wrap-size (pt-y (size q:line)))])) - (apply append - ;; next line removes all para-break? quads as a consequence - (for/list ([qs (in-list (filter-split qs q:para-break?))]) - (wrap qs - (λ (q idx) (- wrap-size (quad-ref q 'inset-left 0) (quad-ref q 'inset-right 0))) - #:nicely (match (or (current-line-wrap) (and (pair? qs) (quad-ref (car qs) 'line-wrap))) - [(or "best" "kp") #true] - [_ #false]) - #:hard-break q:line-break? - #:soft-break soft-break-for-line? - #:finish-wrap (finish-line-wrap line-q))))) + (match qs + [(? pair?) + (unless (positive? wrap-size) + (raise-argument-error 'line-wrap "positive number" wrap-size)) + (define line-q (struct-copy + quad q:line + [size (pt wrap-size (pt-y (size q:line)))])) + (define justify-factor (match (quad-ref (car qs) 'line-align #f) + ;; allow justified lines to go wider, + ;; and then fill-wrap will tighten the 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])) + (apply append + ;; next line removes all para-break? quads as a consequence + (for/list ([qs (in-list (filter-split qs q:para-break?))]) + (wrap qs + (λ (q idx) (* (- wrap-size + (quad-ref (car qs) 'inset-left 0) + (quad-ref (car qs) 'inset-right 0)) + justify-factor)) + #:nicely (match (or (current-line-wrap) (quad-ref (car qs) 'line-wrap)) + [(or "best" "kp") #true] + [_ #false]) + #:hard-break q:line-break? + #:soft-break soft-break-for-line? + #:finish-wrap (finish-line-wrap line-q))))] + [_ null])) (define (make-nobreak! q) (quad-set! q 'no-colbr "true")) ; cooperates with col-wrap @@ -549,14 +568,14 @@ [size (pt col-gap 100)])) (add-between (wrap qs vertical-height - #:soft-break (λ (q) #true) - #:hard-break q:col-break? - #:no-break (λ (q) (quad-ref q 'no-colbr)) ; cooperates with make-nobreak - #:distance (λ (q dist-so-far wrap-qs) - ;; do trial block insertions - (for/sum ([x (in-list (insert-blocks wrap-qs))]) - (pt-y (size x)))) - #:finish-wrap (col-finish-wrap col-quad)) + #:soft-break (λ (q) #true) + #:hard-break q:col-break? + #:no-break (λ (q) (quad-ref q 'no-colbr)) ; cooperates with make-nobreak + #:distance (λ (q dist-so-far wrap-qs) + ;; do trial block insertions + (for/sum ([x (in-list (insert-blocks wrap-qs))]) + (pt-y (size x)))) + #:finish-wrap (col-finish-wrap col-quad)) col-spacer)) (define ((page-finish-wrap page-quad path) cols q0 q page-idx)