You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
190 lines
8.3 KiB
Racket
190 lines
8.3 KiB
Racket
#lang debug racket/base
|
|
(require (for-syntax racket/base racket/syntax)
|
|
racket/match
|
|
txexpr/base
|
|
racket/contract
|
|
racket/file
|
|
pitfall
|
|
quad
|
|
hyphenate
|
|
sugar/coerce
|
|
sugar/debug
|
|
"attrs.rkt"
|
|
"param.rkt"
|
|
"font.rkt"
|
|
"layout.rkt"
|
|
"log.rkt")
|
|
(provide (all-defined-out))
|
|
|
|
(define default-page-size "letter")
|
|
(define default-page-orientation "tall")
|
|
|
|
(define (setup-pdf-path pdf-path-arg)
|
|
(define fallback-path (build-path (find-system-path 'temp-dir) "quadwriter-temp.pdf"))
|
|
(path->complete-path (simplify-path (expand-user-path (->path (or pdf-path-arg fallback-path))))))
|
|
#|
|
|
(define para-break '(q ((break "para"))))
|
|
(define line-break '(q ((break "line"))))
|
|
(define page-break '(q ((break "page"))))
|
|
(define column-break '(q ((break "column"))))
|
|
(define hr-break '(q ((break "hr"))))
|
|
|#
|
|
|
|
|
|
(define-syntax (define-break-types stx)
|
|
(syntax-case stx ()
|
|
[(_ 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)))])
|
|
#'(begin
|
|
(define TYPE-BREAK '(q ((break TYPE-STR)))) ...
|
|
(define ALL-BREAKS-ID (list (cons TYPE-BREAK Q:TYPE-BREAK) ...))))]))
|
|
|
|
(define-break-types all-breaks para line page column hr)
|
|
|
|
(define (replace-breaks x)
|
|
(map-elements (λ (el)
|
|
(cond
|
|
[(assoc el all-breaks) => cdr]
|
|
[else el])) x))
|
|
|
|
|
|
(define (handle-hyphenate qs)
|
|
;; find quads that want hyphenation and split them into smaller pieces
|
|
;; 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)]))))
|
|
|
|
(define (handle-cascading-attrs attrs)
|
|
(resolve-font-path attrs)
|
|
(resolve-font-size attrs))
|
|
|
|
(define default-line-height-multiplier 1.42)
|
|
(define (setup-qs qx-arg pdf-path)
|
|
[define qexpr (replace-breaks qx-arg)]
|
|
[define the-quad
|
|
(qexpr->quad (list 'q (list->attrs
|
|
:font-family default-font-family
|
|
:font-size (number->string default-font-size)
|
|
:line-height (number->string (floor (* default-line-height-multiplier default-font-size)))) qexpr))]
|
|
(setup-font-path-table! pdf-path)
|
|
[define atomized-qs
|
|
(time-log atomize (atomize the-quad
|
|
#:attrs-proc handle-cascading-attrs
|
|
#:missing-glyph-action 'fallback
|
|
#:fallback "fallback"
|
|
#:emoji "emoji"
|
|
#:math "math"
|
|
#:font-path-resolver resolve-font-path))]
|
|
[define hyphenated-qs (time-log hyphenate (handle-hyphenate atomized-qs))]
|
|
[define stringified-qs (map ->string-quad hyphenated-qs)]
|
|
[define indented-qs (insert-first-line-indents stringified-qs)]
|
|
indented-qs)
|
|
|
|
(define (setup-pdf qs pdf-path compress?)
|
|
;; page size can be specified by name, or measurements.
|
|
;; 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)])
|
|
(match (quad-ref (car qs) k)
|
|
[#false #false]
|
|
[val (parse-dimension val 'round)])))
|
|
;; `make-pdf` will sort out conflicts among page dimensions
|
|
(make-pdf #:compress compress?
|
|
#:auto-first-page #false
|
|
#:output-path pdf-path
|
|
#:width (or (debug-page-width) page-width)
|
|
#:height (or (debug-page-height) page-height)
|
|
#:size (quad-ref (car qs) :page-size default-page-size)
|
|
#:orientation (quad-ref (car qs) :page-orientation default-page-orientation)))
|
|
|
|
(define (setup-margins qs pdf)
|
|
(define default-side-margin (min (* 72 1.5) (floor (* .20 (pdf-width pdf)))))
|
|
(define default-top-margin (min 72 (floor (* .10 (pdf-height pdf)))))
|
|
|
|
;; if only left or right margin is provided, copy other value in preference to default margin
|
|
(define left
|
|
(or (debug-x-margin)
|
|
(quad-ref (car qs) :page-margin-left
|
|
(λ () (quad-ref (car qs) :page-margin-right default-side-margin)))))
|
|
(define right
|
|
(or (debug-x-margin)
|
|
(quad-ref (car qs) :page-margin-right
|
|
(λ () (quad-ref (car qs) :page-margin-left default-side-margin)))))
|
|
(define top
|
|
(or (debug-y-margin)
|
|
(quad-ref (car qs) :page-margin-top
|
|
(λ () (quad-ref (car qs) :page-margin-bottom default-top-margin)))))
|
|
(define vert-optical-adjustment 10)
|
|
(define bottom
|
|
(or (debug-y-margin)
|
|
(quad-ref (car qs) :page-margin-bottom
|
|
(λ () (+ vert-optical-adjustment (quad-ref (car qs) :page-margin-top (* default-top-margin 1.4)))))))
|
|
(list left top right bottom))
|
|
|
|
(define default-column-count 1)
|
|
(define (setup-column-count qs)
|
|
(define cc (or (debug-column-count) (quad-ref (car qs) :column-count default-column-count)))
|
|
(unless (exact-nonnegative-integer? cc)
|
|
(raise-argument-error 'render-pdf "positive integer" cc))
|
|
cc)
|
|
|
|
(define default-column-gap 36)
|
|
(define (setup-column-gap qs)
|
|
(or (debug-column-gap) (quad-ref (car qs) :column-gap default-column-gap)))
|
|
|
|
|
|
(define/contract (render-pdf qx-arg pdf-path-arg
|
|
#:replace [replace? #t]
|
|
#:compress [compress? #t])
|
|
((qexpr? (or/c #false path? path-string?)) (#:replace any/c
|
|
#:compress any/c) . ->* . (or/c void? bytes?))
|
|
|
|
(define pdf-path (setup-pdf-path pdf-path-arg))
|
|
(when (and (not replace?) (file-exists? pdf-path))
|
|
(raise-argument-error 'render-pdf "path that doesn't exist" pdf-path))
|
|
|
|
(define qs (setup-qs qx-arg pdf-path))
|
|
|
|
(parameterize ([current-pdf (setup-pdf qs pdf-path compress?)]
|
|
[verbose-quad-printing? #false])
|
|
(match-define (list left-margin top-margin right-margin bottom-margin) (setup-margins qs (current-pdf)))
|
|
(define printable-width (- (pdf-width (current-pdf)) left-margin right-margin))
|
|
(define printable-height (- (pdf-height (current-pdf)) 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))
|
|
(define line-qs (time-log line-wrap (apply-keeps (line-wrap qs line-wrap-size))))
|
|
|
|
(define col-quad-prototype (struct-copy quad q:column
|
|
[size (pt line-wrap-size printable-height)]))
|
|
(define column-qs (time-log column-wrap (column-wrap line-qs printable-height column-gap col-quad-prototype)))
|
|
|
|
(define page-quad-prototype (struct-copy quad q:page
|
|
[shift (pt left-margin top-margin)]
|
|
[size (pt line-wrap-size printable-height)]))
|
|
(define page-qs (time-log page-wrap (page-wrap column-qs printable-width page-quad-prototype)))
|
|
|
|
(define positioned-qs (time-log position (position (struct-copy quad q:doc [elems page-qs]))))
|
|
(time-log draw (draw positioned-qs (current-pdf))))
|
|
|
|
(if pdf-path-arg
|
|
(log-quadwriter-info (format "wrote PDF to ~a" pdf-path))
|
|
(begin0
|
|
(file->bytes pdf-path)
|
|
(delete-file pdf-path)))) |