diff --git a/pitfall/pitfall/core.rkt b/pitfall/pitfall/core.rkt index e35f7633..8fada01d 100644 --- a/pitfall/pitfall/core.rkt +++ b/pitfall/pitfall/core.rkt @@ -4,7 +4,8 @@ ;; structs -(struct pdf (options +(struct pdf (width + height pages refs root @@ -42,16 +43,13 @@ ;; for reference (struct $ref (id payload offset port) #:transparent #:mutable #:methods gen:dict - [(define (dict-ref $ key [thunk (λ () (error 'dict-ref-key-not-found))]) - (hash-ref ($ref-payload $) key)) - (define (dict-ref! $ key thunk) - (hash-ref! ($ref-payload $) key thunk)) - (define (dict-set! $ key val) (hash-set! ($ref-payload $) key val)) - (define (dict-update! $ key updater [failure-result (λ () (error 'update-no-key))]) - (hash-update! ($ref-payload $) key updater failure-result))]) - -;; for page -(struct margin (top left bottom right) #:transparent #:mutable) + [(define (dict-ref ref key [thunk (λ () (error 'dict-ref-key-not-found))]) + (hash-ref ($ref-payload ref) key)) + (define (dict-ref! ref key thunk) + (hash-ref! ($ref-payload ref) key thunk)) + (define (dict-set! ref key val) (hash-set! ($ref-payload ref) key val)) + (define (dict-update! ref key updater [failure-result (λ () (error 'update-no-key))]) + (hash-update! ($ref-payload ref) key updater failure-result))]) ;; params @@ -63,8 +61,6 @@ (define current-auto-first-page (make-parameter #t)) (define current-auto-helvetica (make-parameter #t)) -(define current-default-margins (make-parameter (margin 72 72 72 72))) - (define current-font (make-parameter #f)) (define current-font-size (make-parameter 12)) diff --git a/pitfall/pitfall/page-test.rkt b/pitfall/pitfall/page-test.rkt index 6c1acb6a..e5092d8d 100644 --- a/pitfall/pitfall/page-test.rkt +++ b/pitfall/pitfall/page-test.rkt @@ -8,9 +8,6 @@ "core.rkt" sugar/unstable/js) (define p (make-page)) -(check-equal? ($page-size p) "letter") -(check-equal? ($page-layout p) "portrait") -(check-equal? ($page-margins p) (margin 72 72 72 72)) (check-equal? ($page-height p) 792.0) (check-equal? ($page-width p) 612.0) (check-equal? (dict-ref ($page-resources p) 'ProcSet) '(PDF Text ImageB ImageC ImageI)) diff --git a/pitfall/pitfall/page.rkt b/pitfall/pitfall/page.rkt index bd61be2d..b6dbfd27 100644 --- a/pitfall/pitfall/page.rkt +++ b/pitfall/pitfall/page.rkt @@ -16,29 +16,21 @@ (define (add-content doc data) (page-write (current-page doc) data)) -(struct $page (page-parent options size layout dimensions width height content resources margins ref) +(struct $page (page-parent width height content resources ref) #:transparent #:mutable) -(define (make-page [page-parent #false] [options (mhasheq)]) - (define size (hash-ref options 'size "letter")) - (define layout (hash-ref options 'layout "portrait")) - (define dimensions (if (list? size) - size - (hash-ref page-sizes (string-upcase size)))) - (match-define (list width height) ((if (equal? layout "portrait") values reverse) dimensions)) +(define (make-page #:parent [page-parent #false] + #:width [width 612.0] + #:height [height 792.0]) (define content (make-ref)) (define resources (make-ref (mhash 'ProcSet '(PDF Text ImageB ImageC ImageI)))) - (define margins - (match (hash-ref options 'margin #f) - [(? number? margin-value) (margin margin-value margin-value margin-value margin-value)] - [_ (hash-ref options 'margins (current-default-margins))])) (define page-ref (make-ref (mhasheq 'Type 'Page 'Parent page-parent 'MediaBox (list 0 0 width height) 'Contents content 'Resources resources))) - ($page page-parent options size layout dimensions width height content resources margins page-ref)) + ($page page-parent width height content resources page-ref)) (define (page-fonts p) (dict-ref! ($page-resources p) 'Font (make-hasheq))) @@ -57,9 +49,6 @@ (dict-update! ($page-ref p) 'Annots (λ (val) (cons annot val)) null) (dict-ref! ($page-ref p) 'Annots null))) -(define (page-maxY p) - (- ($page-height p) (margin-bottom ($page-margins p)))) - (define (page-write p chunk) (ref-write ($page-content p) chunk)) diff --git a/pitfall/pitfall/pdf.rkt b/pitfall/pitfall/pdf.rkt index 6a75d12a..05b5b1df 100644 --- a/pitfall/pitfall/pdf.rkt +++ b/pitfall/pitfall/pdf.rkt @@ -17,10 +17,22 @@ (define (store-ref doc ref) (set-pdf-refs! doc (cons ref (pdf-refs doc)))) -(define (make-pdf [options (make-hasheq)] - #:output-path [output-path #f] +(define (make-pdf #:output-path [output-path #f] #:compress [compress? (current-compress-streams)] - #:auto-first-page [auto-first-page? (current-auto-first-page)]) + #:auto-first-page [auto-first-page? (current-auto-first-page)] + #:size [size "letter"] + #:orientation [orientation "portrait"] + #:width [width-arg 612.0] + #:height [height-arg 792.0]) + (match-define (list parsed-width parsed-height) + (sort + (if (list? size) + size + (hash-ref page-sizes (string-upcase size))) + ;; for portrait, shorter edge is width + (if (member orientation '("portrait" "tall")) < >))) + (define width (or width-arg parsed-width)) + (define height (or height-arg parsed-height)) ;; initial values (define pages null) @@ -28,8 +40,6 @@ (define info (mhasheq 'Producer "PITFALL" 'Creator "PITFALL" 'CreationDate (current-seconds))) - (for ([(key val) (in-hash (hash-ref options 'info (hasheq)))]) - (hash-set! info key val)) (define opacity-registry (make-hash)) (define current-fill-color '("black" 1)) (define ctm default-ctm-value) @@ -43,7 +53,8 @@ (define x 0) (define y 0) (define image-registry (make-hash)) - (define new-doc (pdf options + (define new-doc (pdf width + height pages refs 'dummy-root-value-that-will-be-replaced-below @@ -75,14 +86,15 @@ (when (current-auto-helvetica) (font new-doc "Helvetica")) new-doc) -(define (add-page doc [options-arg (pdf-options doc)]) +(define (add-page doc [width (pdf-width doc)] [height (pdf-height doc)]) ;; create a page object (define page-parent (dict-ref (pdf-root doc) 'Pages)) - (set-pdf-pages! doc (cons (make-page page-parent options-arg) (pdf-pages doc))) + (set-pdf-pages! doc (cons (make-page #:parent page-parent #:width width #:height height) (pdf-pages doc))) - ;; reset x and y coordinates - (set-pdf-x! doc (margin-left ($page-margins (current-page doc)))) - (set-pdf-y! doc (margin-right ($page-margins (current-page doc)))) + (when (test-mode) + ;; default values for tests + (set-pdf-x! doc 72) + (set-pdf-y! doc 72)) ;; flip PDF coordinate system so that the origin is in ;; the top left rather than the bottom left (set-pdf-ctm! doc default-ctm-value)