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

tidier

Browse Source
main
Matthew Butterick 4 years ago
parent 343235335f
commit e3f103a262
1 changed files with 123 additions and 111 deletions
Show Stats Download Patch File Download Diff File

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

@ -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))))

Write Preview
Loading…
Cancel
Save