main
Matthew Butterick 5 years ago
parent 1ea67cbecb
commit 573804651d

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

Binary file not shown.

@ -71,6 +71,7 @@
draw-end ; func called at the end of every draw event (for teardown ops) draw-end ; func called at the end of every draw event (for teardown ops)
id id
) )
#:mutable
#:transparent #:transparent
#:property prop:custom-write #:property prop:custom-write
(λ (q p w?) (display (λ (q p w?) (display

@ -207,9 +207,9 @@
(define new-run (quad-copy q:string (define new-run (quad-copy q:string
[attrs (quad-attrs strq)] [attrs (quad-attrs strq)]
[elems (merge-adjacent-strings (apply append (for/list ([pc (in-list run-pcs)]) [elems (merge-adjacent-strings (apply append (for/list ([pc (in-list run-pcs)])
(quad-elems pc))))] (quad-elems pc))))]
[size (delay (pt (for/sum ([pc (in-list run-pcs)]) [size (delay (pt (for/sum ([pc (in-list run-pcs)])
(pt-x (size pc))) (pt-x (size pc)))
(pt-y (size strq))))])) (pt-y (size strq))))]))
(loop (cons new-run runs) rest)] (loop (cons new-run runs) rest)]
[(cons first rest) (loop (cons first runs) rest)]))) [(cons first rest) (loop (cons first runs) rest)])))
@ -242,76 +242,87 @@
(define (sum-of-widths qss) (define (sum-of-widths qss)
(for*/sum ([qs (in-list qss)] (for*/sum ([qs (in-list qss)]
[q (in-list qs)]) [q (in-list qs)])
(pt-x (size q)))) (pt-x (size q))))
(define (space-quad? q) (equal? (quad-elems q) (list " "))) (define (space-quad? q) (equal? (quad-elems q) (list " ")))
(define (fill-wrap qs ending-q line-q) (define (fill-line-wrap qs ending-q line-q)
(match (and (pair? qs) (quad-ref (car qs) (if ending-q (let loop ([align-value (and (pair? qs)
:line-align (quad-ref (car qs) (if ending-q
:line-align-last) "left")) :line-align
[align-value :line-align-last) "left"))])
;; words may still be in hyphenated fragments (match align-value
;; (though soft hyphens would have been removed) ;; for inner & outer: pretend we're on right-side page now,
;; so group them (but no need to consolidate — that happens elsewhere) ;; adjust later when actual page side is known
(define-values (word-space-sublists word-sublists) (partition* space-quad? qs)) ["inner" (loop "left")]
(match (length word-sublists) ["outer" (loop "right")]
[1 #:when (equal? align-value "justify") qs] ; can't justify single word [_
[word-count ;; words may still be in hyphenated fragments
(match-define (list line-width line-height) (quad-size line-q)) ;; (though soft hyphens would have been removed)
(define hung-word-sublists ;; so group them (but no need to consolidate — that happens elsewhere)
(match word-sublists (define-values (word-space-sublists word-sublists) (partition* space-quad? qs))
[(list sublists ... (list prev-qs ... last-q)) (match (length word-sublists)
#:when (pair? (quad-elems last-q)) [1 #:when (equal? align-value "justify") qs] ; can't justify single word
(define last-char-str (regexp-match #rx"[.,:;-]$" (car (quad-elems last-q)))) [word-count
(match last-char-str (match-define (list line-width line-height) (quad-size line-q))
[#false word-sublists] (define hung-word-sublists
[_ (define hanger-q (quad-copy last-q (match word-sublists
[elems null] [(list sublists ... (list prev-qs ... last-q))
[size (let ([p (make-size-promise last-q (car last-char-str))]) #:when (pair? (quad-elems last-q))
(delay (define last-char-str (regexp-match #rx"[.,:;-]$" (car (quad-elems last-q))))
(match-define (list x y) (force p)) (match last-char-str
(pt (- x) y)))])) [#false word-sublists]
(define last-sublist (append prev-qs (list last-q hanger-q))) [_ (define hanger-q (quad-copy last-q
(append sublists (list last-sublist))])] [elems null]
[_ word-sublists])) [size (let ([p (make-size-promise last-q (car last-char-str))])
(define word-width (sum-of-widths hung-word-sublists)) (delay
(define word-space-width (sum-of-widths word-space-sublists)) (match-define (list x y) (force p))
(define empty-hspace (- line-width (pt (- x) y)))]))
(quad-ref (car qs) :inset-left 0) (define last-sublist (append prev-qs (list last-q hanger-q)))
word-width (append sublists (list last-sublist))])]
(quad-ref (car qs) :inset-right 0))) [_ word-sublists]))
(define line-overfull? (negative? (- empty-hspace word-space-width))) (define word-width (sum-of-widths hung-word-sublists))
(define word-space-width (sum-of-widths word-space-sublists))
(cond (define empty-hspace (- line-width
[(or (equal? align-value "justify") (quad-ref (car qs) :inset-left 0)
;; force justification upon overfull lines word-width
(and line-overfull? (> word-count 1))) (quad-ref (car qs) :inset-right 0)))
(define justified-space-width (/ empty-hspace (sub1 word-count))) (define line-overfull? (negative? (- empty-hspace word-space-width)))
(apply append (add-between hung-word-sublists (list (make-quad
#:from 'bo (cond
#:to 'bi [(or (equal? align-value "justify")
#:draw-end q:string-draw-end ;; force justification upon overfull lines
#:size (pt justified-space-width line-height)))))] (and line-overfull? (> word-count 1)))
(define justified-space-width (/ empty-hspace (sub1 word-count)))
[(equal? align-value "left") qs] ; no filling needed (apply append (add-between hung-word-sublists (list (make-quad
[else #:from 'bo
(define space-multiplier (match align-value #:to 'bi
["center" 0.5] #:draw-end q:string-draw-end
["right" 1])) #:size (pt justified-space-width line-height)))))]
;; subtact space-width because that appears between words [else
;; we only care about redistributing the space on the ends (define space-multiplier (match align-value
(define end-hspace (- empty-hspace word-space-width)) ["left" 0]
; make filler a leading quad, not a parent / grouping quad, ["center" 0.5]
;; so that elements can still be reached by consolidate-runs ["right" 1]))
(list* (make-quad #:type filler-quad ;; subtact space-width because that appears between words
#:from-parent (quad-from-parent (car qs)) ;; we only care about redistributing the space on the ends
#:from 'bo (define end-hspace (- empty-hspace word-space-width))
#:to 'bi ;; make filler a leading quad, not a parent / grouping quad,
#:size (pt (* end-hspace space-multiplier) 0) ;; so that elements can still be reached by consolidate-runs
#:attrs (quad-attrs (car qs))) (define fq (make-quad #:type filler-quad
(quad-copy (car qs) [from-parent #f]) #:id 'line-filler
(cdr qs))])])])) #:from-parent (quad-from-parent (car qs))
#:from 'bo
#:to 'bi
#:size (pt (* end-hspace space-multiplier) 0)
#:attrs (let ([attrs (quad-attrs (car qs))])
(hash-set! attrs 'end-hspace end-hspace)
attrs)))
(list* fq
(let ([q (car qs)])
(set-quad-from-parent! q #f)
q)
(cdr qs))])])])))
(define-quad offsetter-quad quad ()) (define-quad offsetter-quad quad ())
@ -334,7 +345,7 @@
;; remove unused soft hyphens so they don't affect final shaping ;; remove unused soft hyphens so they don't affect final shaping
(define pcs-printing (for/list ([pc (in-list pcs-in)] (define pcs-printing (for/list ([pc (in-list pcs-in)]
#:unless (equal? (quad-elems pc) '("\u00AD"))) #:unless (equal? (quad-elems pc) '("\u00AD")))
pc)) pc))
(define new-lines (define new-lines
(cond (cond
[(empty? pcs-printing) null] [(empty? pcs-printing) null]
@ -344,7 +355,7 @@
(define pcs-with-hyphen (render-hyphen pcs-printing ending-q)) (define pcs-with-hyphen (render-hyphen pcs-printing ending-q))
;; fill wrap so that consolidate-runs works properly ;; fill wrap so that consolidate-runs works properly
;; (justified lines won't be totally consolidated) ;; (justified lines won't be totally consolidated)
(define pcs (fill-wrap pcs-with-hyphen ending-q line-q)) (define pcs (fill-line-wrap pcs-with-hyphen ending-q line-q))
(match (consolidate-runs pcs ending-q) (match (consolidate-runs pcs ending-q)
[(? pair? elems) [(? pair? elems)
(define elem (unsafe-car elems)) (define elem (unsafe-car elems))
@ -424,17 +435,17 @@
(apply append (apply append
;; next line removes all para-break? quads as a consequence ;; next line removes all para-break? quads as a consequence
(for/list ([qs (in-list (filter-split qs para-break-quad?))]) (for/list ([qs (in-list (filter-split qs para-break-quad?))])
(wrap qs (wrap qs
(λ (q idx) (* (- wrap-size (λ (q idx) (* (- wrap-size
(quad-ref (car qs) :inset-left 0) (quad-ref (car qs) :inset-left 0)
(quad-ref (car qs) :inset-right 0)) (quad-ref (car qs) :inset-right 0))
permitted-justify-overfill)) permitted-justify-overfill))
#:nicely (match (or (current-line-wrap) (quad-ref (car qs) :line-wrap)) #:nicely (match (or (current-line-wrap) (quad-ref (car qs) :line-wrap))
[(or "best" "kp") #true] [(or "best" "kp") #true]
[_ #false]) [_ #false])
#:hard-break line-break-quad? #:hard-break line-break-quad?
#:soft-break soft-break-for-line? #:soft-break soft-break-for-line?
#:finish-wrap (finish-line-wrap line-q))))])) #:finish-wrap (finish-line-wrap line-q))))]))
(define (make-nobreak! q) (quad-set! q :no-colbr #true)) ; cooperates with col-wrap (define (make-nobreak! q) (quad-set! q :no-colbr #true)) ; cooperates with col-wrap
@ -447,8 +458,8 @@
[prev-ln (in-list (cdr reversed-lines))] [prev-ln (in-list (cdr reversed-lines))]
#:when (and (line-spacer-quad? this-ln) #:when (and (line-spacer-quad? this-ln)
(quad-ref prev-ln :keep-with-next))) (quad-ref prev-ln :keep-with-next)))
(make-nobreak! this-ln) (make-nobreak! this-ln)
(make-nobreak! prev-ln))])) (make-nobreak! prev-ln))]))
(define (apply-keeps lines) (define (apply-keeps lines)
(define groups-of-lines (contiguous-group-by (λ (x) (quad-ref x :display)) lines)) (define groups-of-lines (contiguous-group-by (λ (x) (quad-ref x :display)) lines))
@ -484,9 +495,9 @@
;; explicit measurements from page-height and page-width supersede those from page-size. ;; explicit measurements from page-height and page-width supersede those from page-size.
(match-define (list page-width page-height) (match-define (list page-width page-height)
(for/list ([k (list :page-width :page-height)]) (for/list ([k (list :page-width :page-height)])
(and (quad? q) (match (quad-ref q k) (and (quad? q) (match (quad-ref q k)
[#false #false] [#false #false]
[val (inexact->exact (floor val))])))) [val (inexact->exact (floor val))]))))
(resolve-page-size (resolve-page-size
(or (debug-page-width) page-width) (or (debug-page-width) page-width)
(or (debug-page-height) page-height) (or (debug-page-height) page-height)
@ -549,7 +560,7 @@
;; adjust drawing coordinates for border inset ;; adjust drawing coordinates for border inset
(match-define (list bil bit bir bib) (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))]) (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 left top) (pt+ (quad-origin q) (list bil bit)))
(match-define (list width height) (pt- (size q) (list (+ bil bir) (+ bit bib)))) (match-define (list width height) (pt- (size q) (list (+ bil bir) (+ bit bib))))
;; fill rect ;; fill rect
@ -588,15 +599,15 @@
[(#true) [(#true)
(when (eq? (log-clipping?) 'warn) (when (eq? (log-clipping?) 'warn)
(for ([line (in-list (quad-elems q))]) (for ([line (in-list (quad-elems q))])
(define line-width (pt-x (size line))) (define line-width (pt-x (size line)))
(define line-elem-width (for/sum ([q (in-list (quad-elems line))]) (define line-elem-width (for/sum ([q (in-list (quad-elems line))])
(pt-x (size q)))) (pt-x (size q))))
(when (< line-width line-elem-width) (when (< line-width line-elem-width)
(define error-str (apply string-append (for/list ([q (in-list (quad-elems line))]) (define error-str (apply string-append (for/list ([q (in-list (quad-elems line))])
(match (quad-elems q) (match (quad-elems q)
[(list (? string? str)) str] [(list (? string? str)) str]
[_ ""])))) [_ ""]))))
(log-quadwriter-warning (format "clipping overfull line: ~v" error-str))))) (log-quadwriter-warning (format "clipping overfull line: ~v" error-str)))))
(save doc) (save doc)
(rect doc left top width height) (rect doc left top width height)
(clip doc)])) (clip doc)]))
@ -616,7 +627,7 @@
#:attrs (quad-attrs ln0) #:attrs (quad-attrs ln0)
#:size (delay (pt (pt-x (size ln0)) ; #:size (delay (pt (pt-x (size ln0)) ;
(+ (for/sum ([line (in-list lines)]) (+ (for/sum ([line (in-list lines)])
(pt-y (size line))) (pt-y (size line)))
(quad-ref ln0 :inset-top 0) (quad-ref ln0 :inset-top 0)
(quad-ref ln0 :inset-bottom 0)))) (quad-ref ln0 :inset-bottom 0))))
#:shift-elems (pt 0 (quad-ref ln0 :inset-top 0)) #:shift-elems (pt 0 (quad-ref ln0 :inset-top 0))
@ -628,6 +639,8 @@
;; can be repeated without damage. ;; can be repeated without damage.
[((? null?) _) null] [((? null?) _) null]
[((cons q rest) where) [((cons q rest) where)
#;(set-quad-from-parent! q (or where (quad-from q)))
#;(cons q rest)
(cons (quad-copy q [from-parent (or where (quad-from q))]) rest)]) (cons (quad-copy q [from-parent (or where (quad-from q))]) rest)])
(define ((col-finish-wrap col-quad) lns . _) (define ((col-finish-wrap col-quad) lns . _)
@ -658,7 +671,7 @@
#:distance (λ (q dist-so-far wrap-qs) #:distance (λ (q dist-so-far wrap-qs)
;; do trial block insertions ;; do trial block insertions
(for/sum ([x (in-list (insert-blocks wrap-qs))]) (for/sum ([x (in-list (insert-blocks wrap-qs))])
(pt-y (size x)))) (pt-y (size x))))
#:finish-wrap (col-finish-wrap column-quad)) #:finish-wrap (col-finish-wrap column-quad))
col-spacer)) col-spacer))
@ -682,15 +695,15 @@
#:no-break (λ (q) (quad-ref q :no-pbr)) #:no-break (λ (q) (quad-ref q :no-pbr))
#:distance (λ (q dist-so-far wrap-qs) #:distance (λ (q dist-so-far wrap-qs)
(for/sum ([x (in-list wrap-qs)]) (for/sum ([x (in-list wrap-qs)])
(pt-x (size x)))) (pt-x (size x))))
#:finish-wrap (page-finish-wrap make-page-quad (pdf-output-path (current-pdf))))) #:finish-wrap (page-finish-wrap make-page-quad (pdf-output-path (current-pdf)))))
(define (insert-blocks lines) (define (insert-blocks lines)
(define groups-of-lines (contiguous-group-by (λ (x) (quad-ref x :display)) lines)) (define groups-of-lines (contiguous-group-by (λ (x) (quad-ref x :display)) lines))
(append* (for/list ([line-group (in-list groups-of-lines)]) (append* (for/list ([line-group (in-list groups-of-lines)])
(if (quad-ref (car line-group) :display) (if (quad-ref (car line-group) :display)
(list (lines->block line-group)) (list (lines->block line-group))
line-group)))) line-group))))
(define-quad first-line-indent-quad quad ()) (define-quad first-line-indent-quad quad ())
@ -716,4 +729,4 @@
#:draw-end q:string-draw-end #:draw-end q:string-draw-end
#:type first-line-indent-quad #:type first-line-indent-quad
#:attrs (quad-attrs next-q) #:attrs (quad-attrs next-q)
#:size (pt indent-val 10)) qs-out)]))) #:size (pt indent-val 10)) qs-out)])))

@ -280,9 +280,24 @@
[else (define new-section (struct-copy quad q:section [elems section-pages]) ) [else (define new-section (struct-copy quad q:section [elems section-pages]) )
(cons new-section sections-acc)]) (cons new-section sections-acc)])
(section-pages-used (+ (section-pages-used) (length section-pages)))))) (section-pages-used (+ (section-pages-used) (length section-pages))))))
(define doc (time-log position (position (struct-copy quad q:doc [elems sections])))) (define doc (struct-copy quad q:doc [elems sections]))
(time-log draw (draw doc (current-pdf)))) #;(for* ([(page page-idx) (in-indexed (for*/list ([section (in-list (quad-elems doc))]
[page (in-list (quad-elems section))])
page))]
[col (in-list (quad-elems page))]
[line (in-list (quad-elems col))])
(define side (if (odd? (add1 page-idx)) 'right 'left))
(when (eq? side 'left)
(match (quad-elems line)
[(cons (? filler-quad? fq) _)
(match (quad-ref line :line-align)
["inner" (set-quad-size! fq (pt (quad-ref fq 'end-hspace) 0))] ;; change filler to right-align
["outer" (set-quad-size! fq (pt 0 0))] ;; change filler to 0
[_ (void)])]
[_ (void)])))
(define positioned-doc (time-log position (position doc)))
(time-log draw (draw positioned-doc (current-pdf))))
(if pdf-path-arg (if pdf-path-arg
(log-quadwriter-info (format "wrote PDF to ~a" pdf-path)) (log-quadwriter-info (format "wrote PDF to ~a" pdf-path))

Loading…
Cancel
Save