mbutterick
/
typesetting
2
1
Fork 0
Code Issues 13 Pull Requests Projects Releases Wiki Activity

improve handling of blank pages and continuous page numbering

Browse Source
main
Matthew Butterick 5 years ago
parent f5b520032f
commit b9e371d102
3 changed files with 99 additions and 75 deletions
Show Stats Download Patch File Download Diff File

6
quad/qtest/all.rkt
Unescape Escape View File

@ -10,8 +10,10 @@
[(_ PATH . REST) [(_ PATH . REST)
(with-syntax ([PDF-NAME (test-pdf-name (syntax-e #'PATH))]) (with-syntax ([PDF-NAME (test-pdf-name (syntax-e #'PATH))])
#'(begin #'(begin
(parameterize ([quadwriter-test-mode #t]) (define-runtime-path rp PATH)
(render-pdf (dynamic-require PATH 'doc) PDF-NAME PATH)) (time
(parameterize ([quadwriter-test-mode #t])
(render-pdf (dynamic-require PATH 'doc) PDF-NAME rp)))
(make-test-pdf . REST)))])) (make-test-pdf . REST)))]))
(define-syntax (test-each stx) (define-syntax (test-each stx)

83
quad/quadwriter/layout.rkt
Unescape Escape View File

@ -169,7 +169,7 @@
(define-quad section-break-quad page-break-quad ()) (define-quad section-break-quad page-break-quad ())
(define q:section-break (make-section-break-quad #:printable #f (define q:section-break (make-section-break-quad #:printable #f
#:id 'section-break)) #:id 'section-break))
(define q:line (q #:size (pt 0 default-line-height) (define q:line (q #:size (pt 0 default-line-height)
#:from 'sw #:from 'sw
@ -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,7 +242,7 @@
(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 " ")))
@ -334,7 +334,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]
@ -424,17 +424,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 +447,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 +484,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)
@ -505,14 +505,14 @@
(font doc default-font-face) (font doc default-font-face)
(fill-color doc default-font-color) (fill-color doc default-font-color)
(text doc (format "~a · ~a at ~a" (quad-ref q :page-number 0) (text doc (format "~a · ~a at ~a" (quad-ref q :page-number 0)
(quad-ref q :doc-title "untitled") (if (quadwriter-test-mode) "test" (quad-ref q :doc-title "untitled"))
(date->string (current-date) #t)) (date->string (if (quadwriter-test-mode) (seconds->date 0) (current-date)) #t))
x y)) x y))
(define (make-footer-quad col-q page-idx path) (define (make-footer-quad col-q page-idx path)
(define-values (dir name _) (split-path (path-replace-extension path #""))) (define-values (dir name _) (split-path (path-replace-extension path #"")))
(q #:size (pt 50 default-line-height) (q #:size (pt 50 default-line-height)
#:attrs (hasheq :page-number (+ (quad-ref col-q :page-number-start 1) (sub1 page-idx)) #:attrs (hasheq :page-number (+ (quad-ref col-q :page-number-start (add1 (current-page-count))) (sub1 page-idx))
:doc-title (string-titlecase (path->string name))) :doc-title (string-titlecase (path->string name)))
#:from-parent 'sw #:from-parent 'sw
#:to 'nw #:to 'nw
@ -521,8 +521,7 @@
#:draw-start (λ (q doc) #:draw-start (λ (q doc)
(when draw-debug-line? (when draw-debug-line?
(draw-debug q doc "goldenrod" "goldenrod")) (draw-debug q doc "goldenrod" "goldenrod"))
(unless (quadwriter-test-mode) (draw-page-footer q doc))))
(draw-page-footer q doc)))))
(define q:column (q (define q:column (q
#:id 'col #:id 'col
@ -549,7 +548,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 +587,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 +615,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))
@ -658,7 +657,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))
@ -681,15 +680,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 page-quad (pdf-output-path (current-pdf))))) #:finish-wrap (page-finish-wrap 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 ())

85
quad/quadwriter/render.rkt
Unescape Escape View File

@ -34,10 +34,10 @@
[(_ ALL-BREAKS-ID . TYPES) [(_ ALL-BREAKS-ID . TYPES)
(with-syntax ([((TYPE-BREAK TYPE-STR Q:TYPE-BREAK) ...) (with-syntax ([((TYPE-BREAK TYPE-STR Q:TYPE-BREAK) ...)
(for/list ([type (in-list (syntax->list #'TYPES))]) (for/list ([type (in-list (syntax->list #'TYPES))])
(list (list
(format-id #'TYPES "~a-break" type) (format-id #'TYPES "~a-break" type)
(symbol->string (syntax->datum type)) (symbol->string (syntax->datum type))
(format-id #'TYPES "q:~a-break" type)))]) (format-id #'TYPES "q:~a-break" type)))])
#'(begin #'(begin
(define TYPE-BREAK '(q ((break TYPE-STR)))) ... (define TYPE-BREAK '(q ((break TYPE-STR)))) ...
(define ALL-BREAKS-ID (list (cons TYPE-BREAK Q:TYPE-BREAK) ...))))])) (define ALL-BREAKS-ID (list (cons TYPE-BREAK Q:TYPE-BREAK) ...))))]))
@ -56,22 +56,22 @@
;; do this before ->string-quad so that it can handle the sizing promises ;; do this before ->string-quad so that it can handle the sizing promises
(apply append (apply append
(for/list ([q (in-list qs)]) (for/list ([q (in-list qs)])
(match (quad-ref q :hyphenate) (match (quad-ref q :hyphenate)
[#true #:when (and (pair? (quad-elems q)) [#true #:when (and (pair? (quad-elems q))
(andmap string? (quad-elems q))) (andmap string? (quad-elems q)))
(for*/list ([str (in-list (quad-elems q))] (for*/list ([str (in-list (quad-elems q))]
[hyphen-char (in-value #\u00AD)] [hyphen-char (in-value #\u00AD)]
[hstr (in-value (hyphenate str hyphen-char [hstr (in-value (hyphenate str hyphen-char
#:min-left-length 3 #:min-left-length 3
#:min-right-length 3))] #:min-right-length 3))]
[substr (in-list (regexp-match* (regexp (string hyphen-char)) hstr #:gap-select? #t))]) [substr (in-list (regexp-match* (regexp (string hyphen-char)) hstr #:gap-select? #t))])
(struct-copy quad q [elems (list substr)]))] (struct-copy quad q [elems (list substr)]))]
[_ (list q)])))) [_ (list q)]))))
(define (string->feature-list str) (define (string->feature-list str)
(for/list ([kv (in-slice 2 (string-split str))]) (for/list ([kv (in-slice 2 (string-split str))])
(cons (string->bytes/utf-8 (first kv)) (string->number (second kv))))) (cons (string->bytes/utf-8 (first kv)) (string->number (second kv)))))
(define (parse-font-features! attrs) (define (parse-font-features! attrs)
(cond (cond
@ -93,14 +93,14 @@
(define (parse-dimension-strings! attrs) (define (parse-dimension-strings! attrs)
(for ([k (in-hash-keys attrs)] (for ([k (in-hash-keys attrs)]
#:when (takes-dimension-string? k)) #:when (takes-dimension-string? k))
(hash-update! attrs k parse-dimension)) (hash-update! attrs k parse-dimension))
attrs) attrs)
(define (complete-every-path! attrs) (define (complete-every-path! attrs)
;; relies on `current-directory` being parameterized to source file's dir ;; relies on `current-directory` being parameterized to source file's dir
(for ([k (in-hash-keys attrs)] (for ([k (in-hash-keys attrs)]
#:when (takes-path? k)) #:when (takes-path? k))
(hash-update! attrs k (compose1 path->string path->complete-path))) (hash-update! attrs k (compose1 path->string path->complete-path)))
attrs) attrs)
(define (handle-cascading-attrs attrs) (define (handle-cascading-attrs attrs)
@ -199,7 +199,9 @@
[verbose-quad-printing? #false]) [verbose-quad-printing? #false])
(define qs (time-log setup-qs (setup-qs qx-arg pdf-path))) (define qs (time-log setup-qs (setup-qs qx-arg pdf-path)))
(define sections (define sections
(for/list ([qs (in-list (filter-split qs section-break-quad?))]) (for/fold ([sections-acc null]
#:result (reverse sections-acc))
([qs (in-list (filter-split qs section-break-quad?))])
(match-define (list page-width page-height) (parse-page-size (and (pair? qs) (car qs)))) (match-define (list page-width page-height) (parse-page-size (and (pair? qs) (car qs))))
(match-define (list left-margin top-margin right-margin bottom-margin) (match-define (list left-margin top-margin right-margin bottom-margin)
(setup-margins qs page-width page-height)) (setup-margins qs page-width page-height))
@ -219,23 +221,44 @@
[shift (pt left-margin top-margin)] [shift (pt left-margin top-margin)]
[size (pt line-wrap-size printable-height)])) [size (pt line-wrap-size printable-height)]))
(define next-page-side (if (even? (add1 (current-page-count))) 'left 'right)) (define section-starting-side (string->symbol (quad-ref (car qs) :page-side-start "right")))
(define insert-blank-page? (define insert-blank-page?
(and (pair? qs) (and (pair? qs)
(let ([section-starting-side (string->symbol (quad-ref (car qs) :page-side-start "right"))]) ;; if we need a 'left page and will get 'right (or vice versa) then insert page
;; if we need a 'left page and will get 'right (or vice versa) then insert page (let ([next-page-side (if (even? (add1 (current-page-count))) 'left 'right)])
(not (eq? section-starting-side next-page-side))))) (not (eq? section-starting-side next-page-side)))))
;; update page count before starting page wrap
(when insert-blank-page?
(current-page-count (add1 (current-page-count))))
(define page-qs (define section-pages (time-log page-wrap (page-wrap column-qs printable-width page-quad-prototype)))
(match (time-log page-wrap (page-wrap column-qs printable-width page-quad-prototype))
[ps #:when insert-blank-page?
(define blank-page (struct-copy quad (car ps) [elems null]))
(cons blank-page ps)]
[ps ps]))
(begin0 (begin0
(struct-copy quad q:section [elems page-qs]) (cond
(current-page-count (+ (current-page-count) (length page-qs)))))) [insert-blank-page?
(match section-starting-side
['left
;; blank page goes at beginning of current section
(define page-from-current-section (car section-pages))
(define blank-page (struct-copy quad page-from-current-section [elems null]))
(define new-section (struct-copy quad q:section [elems (cons blank-page section-pages)]))
(cons new-section sections-acc)]
[_ ;; must be 'right
;; blank page goes at end of previous section (if it exists)
(define new-section (struct-copy quad q:section [elems section-pages]))
(match sections-acc
[(cons previous-section other-sections)
(define previous-section-pages (quad-elems previous-section))
(define page-from-previous-section (car previous-section-pages))
(define blank-page (struct-copy quad page-from-previous-section [elems null]))
(define revised-previous-section
(struct-copy quad previous-section
[elems (append previous-section-pages (list blank-page))]))
(list* new-section revised-previous-section other-sections)]
[_ (list new-section)])])]
[else (define new-section (struct-copy quad q:section [elems section-pages]) )
(cons new-section sections-acc)])
(current-page-count (+ (current-page-count) (length section-pages))))))
(define doc (time-log position (position (struct-copy quad q:doc [elems sections])))) (define doc (time-log position (position (struct-copy quad q:doc [elems sections]))))
(time-log draw (draw doc (current-pdf)))) (time-log draw (draw doc (current-pdf))))

Write Preview
Loading…
Cancel
Save