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.
typesetting/pitfall/pitfall/pdf.rkt

153 lines
5.3 KiB
Racket

6 years ago
#lang debug racket/base
(require
6 years ago
"core.rkt"
racket/class
racket/match
racket/format
6 years ago
racket/dict
sugar/unstable/dict
6 years ago
"annotation.rkt"
"reference.rkt"
"object.rkt"
"page.rkt"
"vector.rkt"
6 years ago
"font.rkt")
6 years ago
(provide (all-defined-out))
(define (store-ref doc ref)
6 years ago
(set-pdf-refs! doc (cons ref (pdf-refs doc))))
6 years ago
(define (resolve-page-size! pdf width height size orientation)
(match-define (list parsed-width parsed-height)
(sort
(hash-ref page-sizes (string-upcase size) (λ () (hash-ref page-sizes "LETTER")))
;; for portrait, shorter edge is width
(if (member orientation '("portrait" "tall")) < >)))
(set-pdf-width! pdf (or width parsed-width))
(set-pdf-height! pdf (or height parsed-height)))
(define (make-pdf #:output-path [output-path #f]
#:compress [compress? (current-compress-streams)]
#:auto-first-page [auto-first-page? (current-auto-first-page)]
#:size [size "letter"]
#:orientation [orientation "portrait"]
#:width [width #f]
#:height [height #f])
6 years ago
;; initial values
(define pages null)
(define refs null)
(define info (mhasheq 'Producer "PITFALL"
'Creator "PITFALL"
'CreationDate (current-seconds)))
(define opacity-registry (make-hash))
(define current-fill-color '("black" 1))
6 years ago
(define ctm default-ctm-value)
(define ctm-stack null)
(define font-families (make-hash))
(define current-font-features null)
6 years ago
(define current-font-size 12)
(define current-font #false)
(define registered-fonts (make-hash))
6 years ago
(define font-count 0)
6 years ago
(define line-gap 0)
(define x 0)
(define y 0)
(define image-registry (make-hash))
(define new-doc (pdf #f
#f
pages
refs
'dummy-root-value-that-will-be-replaced-below
info
opacity-registry
current-fill-color
ctm
ctm-stack
font-families
current-font-features
current-font-size
current-font
registered-fonts
6 years ago
font-count
line-gap
x
y
image-registry
output-path))
6 years ago
(set-current-ref-id! 1)
(reset-annotations-cache!)
6 years ago
(register-ref-listener (λ (ref) (store-ref new-doc ref)))
6 years ago
(set-pdf-root! new-doc (make-ref (mhasheq 'Type 'Catalog
'Pages (make-ref (mhasheq 'Type 'Pages)))))
(resolve-page-size! new-doc width height size orientation)
6 years ago
;; initialize params
(current-compress-streams compress?)
(current-auto-first-page auto-first-page?)
6 years ago
(when (current-auto-first-page) (add-page new-doc))
6 years ago
(when (current-auto-helvetica) (font new-doc "Helvetica"))
6 years ago
new-doc)
(define (add-page doc [width (pdf-width doc)] [height (pdf-height doc)])
6 years ago
;; create a page object
6 years ago
(define page-parent (dict-ref (pdf-root doc) 'Pages))
(set-pdf-pages! doc (cons (make-page #:parent page-parent #:width width #:height height) (pdf-pages doc)))
6 years ago
(when (test-mode)
;; default values for tests
(set-pdf-x! doc 72)
(set-pdf-y! doc 72))
6 years ago
;; flip PDF coordinate system so that the origin is in
;; the top left rather than the bottom left
6 years ago
(set-pdf-ctm! doc default-ctm-value)
6 years ago
(transform doc 1 0 0 -1 0 ($page-height (current-page doc)))
6 years ago
doc)
(define last-output-port #f)
6 years ago
(define (start-doc doc)
(define output-port (match (pdf-output-path doc)
[(? path-string? ps) (open-output-file ps #:exists 'replace)]
[(? output-port? op) op]
[#false (current-output-port)]))
(set! last-output-port (current-output-port))
(current-output-port output-port)
6 years ago
(write-bytes-out (format "%PDF-~a" (current-pdf-version)))
(write-bytes-out "%ÿÿÿÿ"))
(define (end-doc doc)
6 years ago
(for-each page-end (pdf-pages doc))
6 years ago
6 years ago
(define doc-info (make-ref (pdf-info doc)))
6 years ago
(ref-end doc-info)
(for-each font-end (sort (hash-values (pdf-font-families doc)) string<? #:key pdf-font-name))
6 years ago
6 years ago
(define pages-ref (dict-ref (pdf-root doc) 'Pages))
(dict-set! pages-ref 'Count (length (pdf-pages doc)))
(dict-set! pages-ref 'Kids (map $page-ref (reverse (pdf-pages doc))))
6 years ago
(ref-end pages-ref)
6 years ago
(ref-end (pdf-root doc))
6 years ago
6 years ago
(define xref-offset (file-position (current-output-port)))
(write-bytes-out "xref")
6 years ago
(define xref-count (add1 (length (pdf-refs doc))))
6 years ago
(write-bytes-out (format "0 ~a" xref-count))
6 years ago
(write-bytes-out "0000000000 65535 f ")
6 years ago
(for ([ref (in-list (reverse (pdf-refs doc)))])
(write-bytes-out
(string-append (~r ($ref-offset ref) #:min-width 10 #:pad-string "0") " 00000 n ")))
6 years ago
(write-bytes-out "trailer")
6 years ago
(write-bytes-out (convert (mhasheq 'Size xref-count
6 years ago
'Root (pdf-root doc)
6 years ago
'Info doc-info)))
(write-bytes-out "startxref")
(write-bytes-out (numberizer xref-offset))
(write-bytes-out "%%EOF")
(close-output-port (current-output-port))
(current-output-port last-output-port))
6 years ago
(module+ test
6 years ago
(define d (make-pdf)))