diff --git a/quad/quadwriter/line.rkt b/quad/quadwriter/line.rkt index 339cfc6f..3c47bbb4 100644 --- a/quad/quadwriter/line.rkt +++ b/quad/quadwriter/line.rkt @@ -90,222 +90,224 @@ ;; remove anchored quads because they don't affect line layout (define-values (absolute-qs qs) (partition (λ (q) (quad-ref q :anchor-parent)) all-qs)) - (match-define (and (cons q-first other-qs) (list _ ... q-last)) qs) - (define align-value (quad-ref q-first :line-align "left")) - - ;; 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 (spacess nonspacess) (partition* space-quad? qs)) - (match (length nonspacess) - [1 #:when (equal? align-value "justify") qs] ; can't justify single word - [nonspacess-count - (match-define (list line-prototype-width line-prototype-height) (quad-size line-prototype)) - (define hung-nonspacess (hang-punctuation nonspacess)) - (define left-tracking-adjustment (tracking-adjustment q-first)) - (define right-tracking-adjustment (tracking-adjustment q-last)) - (define nonspace-total-width - (- (sum-sum-x hung-nonspacess) left-tracking-adjustment right-tracking-adjustment)) - (define space-total-width (sum-sum-x spacess)) - (define empty-hspace (- line-prototype-width - (quad-ref q-first :inset-left 0) - nonspace-total-width - (quad-ref q-first :inset-right 0))) + (match qs + [(? null?) absolute-qs] + [(and (cons q-first other-qs) (list _ ... q-last)) + (define align-value (quad-ref q-first :line-align "left")) + ;; 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 (spacess nonspacess) (partition* space-quad? qs)) + (match (length nonspacess) + [1 #:when (equal? align-value "justify") qs] ; can't justify single word + [nonspacess-count + (match-define (list line-prototype-width line-prototype-height) (quad-size line-prototype)) + (define hung-nonspacess (hang-punctuation nonspacess)) + (define left-tracking-adjustment (tracking-adjustment q-first)) + (define right-tracking-adjustment (tracking-adjustment q-last)) + (define nonspace-total-width + (- (sum-sum-x hung-nonspacess) left-tracking-adjustment right-tracking-adjustment)) + (define space-total-width (sum-sum-x spacess)) + (define empty-hspace (- line-prototype-width + (quad-ref q-first :inset-left 0) + nonspace-total-width + (quad-ref q-first :inset-right 0))) - (define (make-left-edge-filler [width 0]) - (make-quad #:type filler-quad - #:tag 'line-filler - #:from-parent (quad-from-parent q-first) - #:from 'bo - #:to 'bi - #:shift (pt (- left-tracking-adjustment) 0) - #:size (pt width 0) - #:attrs (quad-attrs q-first))) + (define (make-left-edge-filler [width 0]) + (make-quad #:type filler-quad + #:tag 'line-filler + #:from-parent (quad-from-parent q-first) + #:from 'bo + #:to 'bi + #:shift (pt (- left-tracking-adjustment) 0) + #:size (pt width 0) + #:attrs (quad-attrs q-first))) - (cond - [(or - (and (equal? align-value "justify") (or (not last-line-in-paragraph?) - ;; don't justify the last line in a paragraph - ;; unless empty space is less than 17% of width (an arbitrary visual threshold) - (< (/ empty-hspace line-prototype-width 1.0) .17))) - (let ([line-overfull? (negative? (- empty-hspace space-total-width))]) - ;; force justification upon overfull lines, - ;; which amounts to shrinking the word spaces till the line fits - (and line-overfull? (> nonspacess-count 1)))) - (define justified-space-width (/ empty-hspace (sub1 nonspacess-count))) - (cons (make-left-edge-filler) - (apply append (add-between hung-nonspacess (list (make-quad - #:from 'bo - #:to 'bi - #:draw-end q:string-draw-end - #:size (pt justified-space-width line-prototype-height))))))] - [else - (define space-multiplier (match align-value - ["center" 0.5] - ;; fill inner & outer as if they were right, - ;; they will be corrected later, when pagination is known. - [(or "right" "inner" "outer") 1] - ;; "left" and "justify" are handled here - [_ 0])) - ;; subtact space-width because that appears between words - ;; we only care about redistributing the space on the ends - (define end-hspace (- empty-hspace space-total-width)) - ;; make filler a leading quad, not a parent / grouping quad, - ;; so that elements can still be reached by consolidate-runs - (list* (make-left-edge-filler (* end-hspace space-multiplier)) - (quad-update! q-first [from-parent #f]) - ;; ok to put back absolute quads at end, because it doesn't affect their layout - (append other-qs absolute-qs))])])) + (cond + [(or + (and (equal? align-value "justify") (or (not last-line-in-paragraph?) + ;; don't justify the last line in a paragraph + ;; unless empty space is less than 17% of width (an arbitrary visual threshold) + (< (/ empty-hspace line-prototype-width 1.0) .17))) + (let ([line-overfull? (negative? (- empty-hspace space-total-width))]) + ;; force justification upon overfull lines, + ;; which amounts to shrinking the word spaces till the line fits + (and line-overfull? (> nonspacess-count 1)))) + (define justified-space-width (/ empty-hspace (sub1 nonspacess-count))) + (cons (make-left-edge-filler) + (apply append (add-between hung-nonspacess (list (make-quad + #:from 'bo + #:to 'bi + #:draw-end q:string-draw-end + #:size (pt justified-space-width line-prototype-height))))))] + [else + (define space-multiplier (match align-value + ["center" 0.5] + ;; fill inner & outer as if they were right, + ;; they will be corrected later, when pagination is known. + [(or "right" "inner" "outer") 1] + ;; "left" and "justify" are handled here + [_ 0])) + ;; subtact space-width because that appears between words + ;; we only care about redistributing the space on the ends + (define end-hspace (- empty-hspace space-total-width)) + ;; make filler a leading quad, not a parent / grouping quad, + ;; so that elements can still be reached by consolidate-runs + (list* (make-left-edge-filler (* end-hspace space-multiplier)) + (quad-update! q-first [from-parent #f]) + ;; ok to put back absolute quads at end, because it doesn't affect their layout + (append other-qs absolute-qs))])])])) -(define (make-paragraph-spacer maybe-first-line-q key default-val) - (define arbitrary-width 20) - (make-quad #:type line-spacer-quad - #:size (pt arbitrary-width (cond - [(and maybe-first-line-q (quad-ref maybe-first-line-q key))] - [else default-val])) - #:from 'sw - #:to 'nw - #:printable only-prints-in-middle - #:draw-start (if (draw-debug-line?) draw-debug void))) + (define (make-paragraph-spacer maybe-first-line-q key default-val) + (define arbitrary-width 20) + (make-quad #:type line-spacer-quad + #:size (pt arbitrary-width (cond + [(and maybe-first-line-q (quad-ref maybe-first-line-q key))] + [else default-val])) + #:from 'sw + #:to 'nw + #:printable only-prints-in-middle + #:draw-start (if (draw-debug-line?) draw-debug void))) -(define ((line-wrap-finish line-prototype-q default-block-id) wrap-qs q-before q-after idx) - ;; we curry line-q so that the wrap size can be communicated to this operation - ;; remove unused soft hyphens so they don't affect final shaping - (define wrap-qs-printing (for/list ([wq (in-list wrap-qs)] - #:unless (equal? (quad-elems wq) '("\u00AD"))) - wq)) - (define new-lines - (cond - [(empty? wrap-qs-printing) null] - [(hr-break-quad? q-after) (list (make-hr-quad line-prototype-q))] - [else - ;; render hyphen first so that all printable characters are available for size-dependent ops. - (define pcs-with-hyphen (render-hyphen wrap-qs-printing q-after)) - ;; fill wrap so that consolidate-runs works properly - ;; (justified lines won't be totally consolidated) - (define last-line-in-paragraph? (not q-after)) - (define pcs (fill-line-wrap pcs-with-hyphen line-prototype-q last-line-in-paragraph?)) - (match (consolidate-runs pcs) - [(and (cons elem-first _) elems) - (match-define (list line-width line-height) (quad-size line-prototype-q)) - (list - (quad-copy line-quad line-prototype-q - ;; move block attrs up, so they are visible in col wrap - [attrs (let ([h (copy-block-attrs (quad-attrs elem-first) (hash-copy (quad-attrs line-prototype-q)))]) - ;; we want every group of lines in a paragraph to have a block id - ;; so that it will be wrapped as a block later. - ;; we only set this if there is no value for :display. - (hash-ref! h :display default-block-id) - h)] - ;; line width is static - ;; line height is the max 'line-height value or the natural height of q:line - [size (pt line-width (match (filter-map (λ (q) (or (quad-ref q :line-height) (pt-y (size q)))) pcs) - [(? null?) line-height] - [line-heights (apply max line-heights)]))] - ;; handle list indexes. drop new quad into line to hold list index - ;; could also use this for line numbers - [elems - ;; we assume here that a list item has already had extra inset-left - ;; with room for a bullet - ;; which we just insert at the front. - ;; this is safe because line has already been filled. - (append - ;; only put bullet into line if we're at the first line of the list item - (match (and (eq? idx 1) (quad-ref elem-first :list-index)) - [#false null] - [bullet - (define bq (quad-copy string-quad q:string ;; copy q:string to get draw routine - ;; borrow attrs from elem - [attrs (quad-attrs elem-first)] - ;; use bullet as elems - [elems (list (if (number? bullet) (format "~a." bullet) bullet))] - ;; size doesn't matter because nothing refers to this quad - ;; just for debugging box - [size (pt 15 (pt-y (size line-prototype-q)))])) - (from-parent (list bq) 'sw)]) - (from-parent - (match (quad-ref elem-first :inset-left 0) - [0 elems] - [inset-val (cons (make-quad - #:draw-end q:string-draw-end - #:to 'sw - #:size (pt inset-val 5) - #:type offsetter-quad) - elems)]) 'sw))]))] - [_ null])])) - (define maybe-first-line (and (pair? new-lines) (car new-lines))) - (append (match q-before - [#false (list (make-paragraph-spacer maybe-first-line :space-before 0))] ; paragraph break - [_ null]) - new-lines - (match q-after - [(? column-break-quad? column-break) (list column-break)] ; hard column (or section or page) break - [#false (list (make-paragraph-spacer maybe-first-line :space-after (* default-line-height 0.6)))] ; paragraph break - [_ null]))) ; hard line break + (define ((line-wrap-finish line-prototype-q default-block-id) wrap-qs q-before q-after idx) + ;; we curry line-q so that the wrap size can be communicated to this operation + ;; remove unused soft hyphens so they don't affect final shaping + (define wrap-qs-printing (for/list ([wq (in-list wrap-qs)] + #:unless (equal? (quad-elems wq) '("\u00AD"))) + wq)) + (define new-lines + (cond + [(empty? wrap-qs-printing) null] + [(hr-break-quad? q-after) (list (make-hr-quad line-prototype-q))] + [else + ;; render hyphen first so that all printable characters are available for size-dependent ops. + (define pcs-with-hyphen (render-hyphen wrap-qs-printing q-after)) + ;; fill wrap so that consolidate-runs works properly + ;; (justified lines won't be totally consolidated) + (define last-line-in-paragraph? (not q-after)) + (define pcs (fill-line-wrap pcs-with-hyphen line-prototype-q last-line-in-paragraph?)) + (match (consolidate-runs pcs) + [(and (cons elem-first _) elems) + (match-define (list line-width line-height) (quad-size line-prototype-q)) + (list + (quad-copy line-quad line-prototype-q + ;; move block attrs up, so they are visible in col wrap + [attrs (let ([h (copy-block-attrs (quad-attrs elem-first) (hash-copy (quad-attrs line-prototype-q)))]) + ;; we want every group of lines in a paragraph to have a block id + ;; so that it will be wrapped as a block later. + ;; we only set this if there is no value for :display. + (hash-ref! h :display default-block-id) + h)] + ;; line width is static + ;; line height is the max 'line-height value or the natural height of q:line + [size (pt line-width (match (filter-map (λ (q) (or (quad-ref q :line-height) (pt-y (size q)))) pcs) + [(? null?) line-height] + [line-heights (apply max line-heights)]))] + ;; handle list indexes. drop new quad into line to hold list index + ;; could also use this for line numbers + [elems + ;; we assume here that a list item has already had extra inset-left + ;; with room for a bullet + ;; which we just insert at the front. + ;; this is safe because line has already been filled. + (append + ;; only put bullet into line if we're at the first line of the list item + (match (and (eq? idx 1) (quad-ref elem-first :list-index)) + [#false null] + [bullet + (define bq (quad-copy string-quad q:string ;; copy q:string to get draw routine + ;; borrow attrs from elem + [attrs (quad-attrs elem-first)] + ;; use bullet as elems + [elems (list (if (number? bullet) (format "~a." bullet) bullet))] + ;; size doesn't matter because nothing refers to this quad + ;; just for debugging box + [size (pt 15 (pt-y (size line-prototype-q)))])) + (from-parent (list bq) 'sw)]) + (from-parent + (match (quad-ref elem-first :inset-left 0) + [0 elems] + [inset-val (cons (make-quad + #:draw-end q:string-draw-end + #:to 'sw + #:size (pt inset-val 5) + #:type offsetter-quad) + elems)]) 'sw))]))] + [_ null])])) + (define maybe-first-line (and (pair? new-lines) (car new-lines))) + (append (match q-before + [#false (list (make-paragraph-spacer maybe-first-line :space-before 0))] ; paragraph break + [_ null]) + new-lines + (match q-after + [(? column-break-quad? column-break) (list column-break)] ; hard column (or section or page) break + [#false (list (make-paragraph-spacer maybe-first-line :space-after (* default-line-height 0.6)))] ; paragraph break + [_ null]))) ; hard line break -(define softies (map string '(#\space #\- #\u00AD))) + (define softies (map string '(#\space #\- #\u00AD))) -(define (soft-break-for-line? q) - (and (pair? (quad-elems q)) - (member (unsafe-car (quad-elems q)) softies))) + (define (soft-break-for-line? q) + (and (pair? (quad-elems q)) + (member (unsafe-car (quad-elems q)) softies))) -(define (line-wrap qs wrap-size [debug #false]) - (unless (positive? wrap-size) - (raise-argument-error 'line-wrap "positive number" wrap-size)) - (match qs - [(cons q _) - (define line-q (quad-copy line-quad q:line [size (pt wrap-size (quad-ref q :line-height default-line-height))])) - (define permitted-justify-overfill - (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))]))) - (define res - (apply append - (for/list ([para-qs (in-list para-qss)]) - (define block-id (gensym)) - (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 + (define (line-wrap qs wrap-size [debug #false]) + (unless (positive? wrap-size) + (raise-argument-error 'line-wrap "positive number" wrap-size)) + (match qs + [(cons q _) + (define line-q (quad-copy line-quad q:line [size (pt wrap-size (quad-ref q :line-height default-line-height))])) + (define permitted-justify-overfill + (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))]))) + (define res + (apply append + (for/list ([para-qs (in-list para-qss)]) + (define block-id (gensym)) + (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 - ;; during wrap, anchored qs are treated as having distance 0 - ;; so they can staty in right place, so that relative queries will work. - ;; but they won't affect where lines break - #:distance (λ (q last-dist wrap-qs) - (+ last-dist (cond - [(quad-ref q :anchor-parent) 0] - [(printable? q) (distance q)] - [else 0]))) - #: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 block-id))])))) - res] - [_ null])) + ;; during wrap, anchored qs are treated as having distance 0 + ;; so they can staty in right place, so that relative queries will work. + ;; but they won't affect where lines break + #:distance (λ (q last-dist wrap-qs) + (+ last-dist (cond + [(quad-ref q :anchor-parent) 0] + [(printable? q) (distance q)] + [else 0]))) + #: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 block-id))])))) + res] + [_ null])) + \ No newline at end of file