From b9e371d1021ce7bfa4f335fd9dea745ce13687cb Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Sun, 11 Aug 2019 12:32:43 -0700 Subject: [PATCH] improve handling of blank pages and continuous page numbering --- quad/qtest/all.rkt | 6 ++- quad/quadwriter/layout.rkt | 83 ++++++++++++++++++------------------- quad/quadwriter/render.rkt | 85 ++++++++++++++++++++++++-------------- 3 files changed, 99 insertions(+), 75 deletions(-) diff --git a/quad/qtest/all.rkt b/quad/qtest/all.rkt index 9dfcf2dc..482c82c4 100644 --- a/quad/qtest/all.rkt +++ b/quad/qtest/all.rkt @@ -10,8 +10,10 @@ [(_ PATH . REST) (with-syntax ([PDF-NAME (test-pdf-name (syntax-e #'PATH))]) #'(begin - (parameterize ([quadwriter-test-mode #t]) - (render-pdf (dynamic-require PATH 'doc) PDF-NAME PATH)) + (define-runtime-path rp PATH) + (time + (parameterize ([quadwriter-test-mode #t]) + (render-pdf (dynamic-require PATH 'doc) PDF-NAME rp))) (make-test-pdf . REST)))])) (define-syntax (test-each stx) diff --git a/quad/quadwriter/layout.rkt b/quad/quadwriter/layout.rkt index f508c9b3..c9f2505c 100644 --- a/quad/quadwriter/layout.rkt +++ b/quad/quadwriter/layout.rkt @@ -169,7 +169,7 @@ (define-quad section-break-quad page-break-quad ()) (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) #:from 'sw @@ -207,9 +207,9 @@ (define new-run (quad-copy q:string [attrs (quad-attrs strq)] [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)]) - (pt-x (size pc))) + (pt-x (size pc))) (pt-y (size strq))))])) (loop (cons new-run runs) rest)] [(cons first rest) (loop (cons first runs) rest)]))) @@ -242,7 +242,7 @@ (define (sum-of-widths qss) (for*/sum ([qs (in-list qss)] [q (in-list qs)]) - (pt-x (size q)))) + (pt-x (size q)))) (define (space-quad? q) (equal? (quad-elems q) (list " "))) @@ -334,7 +334,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] @@ -424,17 +424,17 @@ (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 - (λ (q idx) (* (- 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 (finish-line-wrap line-q))))])) + (wrap qs + (λ (q idx) (* (- 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 (finish-line-wrap line-q))))])) (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))] #:when (and (line-spacer-quad? this-ln) (quad-ref prev-ln :keep-with-next))) - (make-nobreak! this-ln) - (make-nobreak! prev-ln))])) + (make-nobreak! this-ln) + (make-nobreak! prev-ln))])) (define (apply-keeps 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. (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) @@ -505,14 +505,14 @@ (font doc default-font-face) (fill-color doc default-font-color) (text doc (format "~a · ~a at ~a" (quad-ref q :page-number 0) - (quad-ref q :doc-title "untitled") - (date->string (current-date) #t)) + (if (quadwriter-test-mode) "test" (quad-ref q :doc-title "untitled")) + (date->string (if (quadwriter-test-mode) (seconds->date 0) (current-date)) #t)) x y)) (define (make-footer-quad col-q page-idx path) (define-values (dir name _) (split-path (path-replace-extension path #""))) (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))) #:from-parent 'sw #:to 'nw @@ -521,8 +521,7 @@ #:draw-start (λ (q doc) (when draw-debug-line? (draw-debug q doc "goldenrod" "goldenrod")) - (unless (quadwriter-test-mode) - (draw-page-footer q doc))))) + (draw-page-footer q doc)))) (define q:column (q #:id 'col @@ -549,7 +548,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 @@ -588,15 +587,15 @@ [(#true) (when (eq? (log-clipping?) 'warn) (for ([line (in-list (quad-elems q))]) - (define line-width (pt-x (size line))) - (define line-elem-width (for/sum ([q (in-list (quad-elems line))]) - (pt-x (size q)))) - (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 (for/sum ([q (in-list (quad-elems line))]) + (pt-x (size q)))) + (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)])) @@ -616,7 +615,7 @@ #:attrs (quad-attrs ln0) #:size (delay (pt (pt-x (size ln0)) ; (+ (for/sum ([line (in-list lines)]) - (pt-y (size line))) + (pt-y (size line))) (quad-ref ln0 :inset-top 0) (quad-ref ln0 :inset-bottom 0)))) #:shift-elems (pt 0 (quad-ref ln0 :inset-top 0)) @@ -658,7 +657,7 @@ #:distance (λ (q dist-so-far wrap-qs) ;; do trial block insertions (for/sum ([x (in-list (insert-blocks wrap-qs))]) - (pt-y (size x)))) + (pt-y (size x)))) #:finish-wrap (col-finish-wrap column-quad)) col-spacer)) @@ -681,15 +680,15 @@ #:no-break (λ (q) (quad-ref q :no-pbr)) #:distance (λ (q dist-so-far 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))))) (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 ()) diff --git a/quad/quadwriter/render.rkt b/quad/quadwriter/render.rkt index a4eff9dc..6e17074b 100644 --- a/quad/quadwriter/render.rkt +++ b/quad/quadwriter/render.rkt @@ -34,10 +34,10 @@ [(_ ALL-BREAKS-ID . TYPES) (with-syntax ([((TYPE-BREAK TYPE-STR Q:TYPE-BREAK) ...) (for/list ([type (in-list (syntax->list #'TYPES))]) - (list - (format-id #'TYPES "~a-break" type) - (symbol->string (syntax->datum type)) - (format-id #'TYPES "q:~a-break" type)))]) + (list + (format-id #'TYPES "~a-break" type) + (symbol->string (syntax->datum type)) + (format-id #'TYPES "q:~a-break" type)))]) #'(begin (define TYPE-BREAK '(q ((break TYPE-STR)))) ... (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 (apply append (for/list ([q (in-list qs)]) - (match (quad-ref q :hyphenate) - [#true #:when (and (pair? (quad-elems q)) - (andmap string? (quad-elems q))) - (for*/list ([str (in-list (quad-elems q))] - [hyphen-char (in-value #\u00AD)] - [hstr (in-value (hyphenate str hyphen-char - #:min-left-length 3 - #:min-right-length 3))] - [substr (in-list (regexp-match* (regexp (string hyphen-char)) hstr #:gap-select? #t))]) - (struct-copy quad q [elems (list substr)]))] - [_ (list q)])))) + (match (quad-ref q :hyphenate) + [#true #:when (and (pair? (quad-elems q)) + (andmap string? (quad-elems q))) + (for*/list ([str (in-list (quad-elems q))] + [hyphen-char (in-value #\u00AD)] + [hstr (in-value (hyphenate str hyphen-char + #:min-left-length 3 + #:min-right-length 3))] + [substr (in-list (regexp-match* (regexp (string hyphen-char)) hstr #:gap-select? #t))]) + (struct-copy quad q [elems (list substr)]))] + [_ (list q)])))) (define (string->feature-list 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) (cond @@ -93,14 +93,14 @@ (define (parse-dimension-strings! attrs) (for ([k (in-hash-keys attrs)] #:when (takes-dimension-string? k)) - (hash-update! attrs k parse-dimension)) + (hash-update! attrs k parse-dimension)) attrs) (define (complete-every-path! attrs) ;; relies on `current-directory` being parameterized to source file's dir (for ([k (in-hash-keys attrs)] #: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) (define (handle-cascading-attrs attrs) @@ -199,7 +199,9 @@ [verbose-quad-printing? #false]) (define qs (time-log setup-qs (setup-qs qx-arg pdf-path))) (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 left-margin top-margin right-margin bottom-margin) (setup-margins qs page-width page-height)) @@ -219,23 +221,44 @@ [shift (pt left-margin top-margin)] [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? (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))))) + ;; update page count before starting page wrap + (when insert-blank-page? + (current-page-count (add1 (current-page-count)))) - (define page-qs - (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])) + (define section-pages (time-log page-wrap (page-wrap column-qs printable-width page-quad-prototype))) - (begin0 - (struct-copy quad q:section [elems page-qs]) - (current-page-count (+ (current-page-count) (length page-qs)))))) + (begin0 + (cond + [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])))) (time-log draw (draw doc (current-pdf))))