diff --git a/quad/quadwriter/render.rkt b/quad/quadwriter/render.rkt index 66981751..40dae44f 100644 --- a/quad/quadwriter/render.rkt +++ b/quad/quadwriter/render.rkt @@ -189,29 +189,132 @@ (or (debug-column-gap) (quad-ref (car qs) :column-gap default-column-gap))) (define (setup-pdf-metadata! qs pdf) - (for ([k (in-list (list :pdf-title - :pdf-author - :pdf-subject - :pdf-keywords))] - [pdf-k (in-list (list 'Title - 'Author - 'Subject - 'Keywords))]) - (hash-set! (pdf-info pdf) pdf-k (quad-ref (car qs) k ""))) + (for ([k (in-list (list :pdf-title :pdf-author :pdf-subject :pdf-keywords))] + [pdf-k (in-list '(Title Author Subject Keywords))]) + (hash-set! (pdf-info pdf) pdf-k (match (and (pair? qs) (quad-ref (car qs) k #false)) + [#false ""] ; default val is empty string + [val val]))) (hash-set! (pdf-info pdf) 'Creator (format "Racket ~a [Quad library]" (version)))) (define (footnote-flow? q) (equal? (quad-ref q 'flow) "footnote")) +(define (make-lines qs line-wrap-size) + (define-values (fn-qs main-qs) (partition footnote-flow? qs)) + (define line-qs (time-log line-wrap (apply-keeps (line-wrap main-qs line-wrap-size)))) + (define fn-line-qs (time-log fn-line-wrap (apply-keeps (line-wrap fn-qs line-wrap-size)))) + (values line-qs fn-line-qs)) + +(define (make-columns line-qs fn-line-qs line-wrap-size printable-height column-gap) + (define col-quad-prototype (quad-copy q:column + [size (pt line-wrap-size printable-height)])) + (time-log column-wrap (column-wrap line-qs fn-line-qs printable-height column-gap col-quad-prototype))) + +(define (make-pages column-qs + left-margin + top-margin + gutter-margin + line-wrap-size + printable-width + printable-height) + (define (page-quad-prototype page-count) + (define left-shift (+ left-margin (if (odd? page-count) gutter-margin 0))) + (quad-copy q:page + [shift (pt left-shift top-margin)] + [size (pt line-wrap-size printable-height)])) + (time-log page-wrap (page-wrap column-qs printable-width page-quad-prototype))) + + +(define (make-sections qs) + (for/fold ([sections-acc null] + #:result (reverse sections-acc)) + ([qs (in-list (filter-split qs section-break-quad?))]) + ;; section properties + (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)) + (define gutter-margin (and (pair? qs) (quad-ref (car qs) :page-margin-gutter 0))) + (define printable-width (- page-width left-margin right-margin gutter-margin)) + (define printable-height (- page-height top-margin bottom-margin)) + (define column-count (setup-column-count qs)) + (define column-gap (setup-column-gap qs)) + (define line-wrap-size (/ (- printable-width (* (sub1 column-count) column-gap)) column-count)) + + ;; layout actions + (define-values (line-qs fn-line-qs) (make-lines qs line-wrap-size)) + (define column-qs (make-columns line-qs fn-line-qs line-wrap-size printable-height column-gap)) + (define section-starting-side (string->symbol (quad-ref (car qs) :page-side-start "right"))) + (define insert-blank-page? + (and (pair? qs) + ;; if we need a 'left page and will get 'right (or vice versa) then insert page + (let ([next-page-side (if (even? (add1 (section-pages-used))) 'left 'right)]) + (not (eq? section-starting-side next-page-side))))) + + ;; update page count before starting page wrap + (when insert-blank-page? + (section-pages-used (add1 (section-pages-used)))) + + (define section-pages (make-pages column-qs + left-margin + top-margin + gutter-margin + line-wrap-size + printable-width + printable-height)) + + (begin0 + (cond + ;; ignore empty section + [(zero? (length section-pages)) sections-acc] + [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 (quad-copy page-from-current-section [elems null])) + (define new-section (quad-copy 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 (quad-copy q:section [elems section-pages])) + (match sections-acc + [(cons previous-section other-sections) + (define previous-section-pages (quad-elems previous-section)) + ;; we know previous section has pages because we ignore empty sections + (define page-from-previous-section (car previous-section-pages)) + (define blank-page (quad-copy page-from-previous-section [elems null])) + (define updated-previous-section + (quad-update! previous-section + [elems (append previous-section-pages (list blank-page))])) + (list* new-section updated-previous-section other-sections)] + [_ (list new-section)])])] + [else (define new-section (quad-copy q:section [elems section-pages]) ) + (cons new-section sections-acc)]) + (section-pages-used (+ (section-pages-used) (length section-pages)))))) + +(define (correct-line-alignment doc) + ;; correct lines with inner / outer alignment + (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))] + [block (in-list (quad-elems col))] + [line (in-list (quad-elems block))]) + ;; all inner / outer lines are initially filled as if they were right-aligned + (define zero-filler-side (if (odd? (add1 page-idx)) "inner" "outer")) + (when (equal? zero-filler-side (quad-ref line :line-align)) + (match (quad-elems line) + [(cons (? filler-quad? fq) _) (set-quad-size! fq (pt 0 0))] + [_ (void)]))) + doc) + (define/contract (render-pdf qx-arg [pdf-path-arg #false] [base-dir-arg #false] #:replace [replace-existing-file? #t] #:compress [compress? #t]) - ((qexpr?) - ((or/c #false path? path-string?) - (or/c #false path? path-string?) - #:replace any/c - #:compress any/c) . ->* . (or/c void? bytes?)) + ((qexpr?) ((or/c #false path? path-string?) + (or/c #false path? path-string?) + #:replace any/c #:compress any/c) . ->* . (or/c void? bytes?)) (match-define-values (base-dir _ _) (split-path (match base-dir-arg @@ -226,109 +329,18 @@ (unless replace-existing-file? (when (file-exists? pdf-path) (raise-argument-error 'render-pdf "path that doesn't exist" pdf-path))) - - (define the-pdf (make-pdf #:compress compress? - #:auto-first-page #false - #:output-path pdf-path)) - (parameterize ([current-pdf the-pdf] + + (parameterize ([current-pdf (make-pdf #:compress compress? + #:auto-first-page #false + #:output-path pdf-path)] ;; set `current-directory` so that ops like `path->complete-path` ;; will be handled relative to the original directory [current-directory base-dir] [section-pages-used 0] [verbose-quad-printing? #false]) (define qs (time-log setup-qs (setup-qs qx-arg base-dir))) - (when (pair? qs) - (setup-pdf-metadata! qs the-pdf)) - (define sections - (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)) - (define gutter-margin (and (pair? qs) (quad-ref (car qs) :page-margin-gutter 0))) - (define printable-width (- page-width left-margin right-margin gutter-margin)) - (define printable-height (- page-height top-margin bottom-margin)) - (define column-count (setup-column-count qs)) - (define column-gap (setup-column-gap qs)) - - (define-values (fn-qs main-qs) (partition footnote-flow? qs)) - - (define line-wrap-size (/ (- printable-width (* (sub1 column-count) column-gap)) column-count)) - (define line-qs (time-log line-wrap (apply-keeps (line-wrap main-qs line-wrap-size)))) - (define fn-line-qs (time-log fn-line-wrap (apply-keeps (line-wrap fn-qs line-wrap-size)))) - - (define col-quad-prototype (quad-copy q:column - [size (pt line-wrap-size printable-height)])) - (define column-qs (time-log column-wrap (column-wrap line-qs fn-line-qs printable-height column-gap col-quad-prototype))) - - (define page-quad-prototype - (λ (page-count) - (define left-shift (+ left-margin (if (odd? page-count) gutter-margin 0))) - (quad-copy q:page - [shift (pt left-shift top-margin)] - [size (pt line-wrap-size printable-height)]))) - - (define section-starting-side (string->symbol (quad-ref (car qs) :page-side-start "right"))) - (define insert-blank-page? - (and (pair? qs) - ;; if we need a 'left page and will get 'right (or vice versa) then insert page - (let ([next-page-side (if (even? (add1 (section-pages-used))) 'left 'right)]) - (not (eq? section-starting-side next-page-side))))) - ;; update page count before starting page wrap - (when insert-blank-page? - (section-pages-used (add1 (section-pages-used)))) - - (define section-pages (time-log page-wrap (page-wrap column-qs printable-width page-quad-prototype))) - - (define (section-empty? section-pages) (zero? (length section-pages))) - - (begin0 - (cond - ;; ignore empty section - [(section-empty? section-pages) sections-acc] - [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 (quad-copy page-from-current-section [elems null])) - (define new-section (quad-copy 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 (quad-copy q:section [elems section-pages])) - (match sections-acc - [(cons previous-section other-sections) - (define previous-section-pages (quad-elems previous-section)) - ;; we know previous section has pages because we ignore empty sections - (define page-from-previous-section (car previous-section-pages)) - (define blank-page (quad-copy page-from-previous-section [elems null])) - (define updated-previous-section - (quad-update! previous-section - [elems (append previous-section-pages (list blank-page))])) - (list* new-section updated-previous-section other-sections)] - [_ (list new-section)])])] - [else (define new-section (quad-copy q:section [elems section-pages]) ) - (cons new-section sections-acc)]) - (section-pages-used (+ (section-pages-used) (length section-pages)))))) - - (define doc (quad-copy q:doc [elems sections])) - - ;; correct lines with inner / outer alignment - (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))] - [block (in-list (quad-elems col))] - [line (in-list (quad-elems block))]) - ;; all inner / outer lines are initially filled as if they were right-aligned - (define zero-filler-side (if (odd? (add1 page-idx)) "inner" "outer")) - (when (equal? zero-filler-side (quad-ref line :line-align)) - (match (quad-elems line) - [(cons (? filler-quad? fq) _) (set-quad-size! fq (pt 0 0))] - [_ (void)]))) - + (setup-pdf-metadata! qs (current-pdf)) + (define doc (correct-line-alignment (quad-copy q:doc [elems (make-sections qs)]))) (define positioned-doc (time-log position (position doc))) (time-log draw (draw positioned-doc (current-pdf))))