gingerly

pitfall/pitfall/annotations.rkt

@@ -1,6 +1,6 @@
 #lang racket/base
 (require
-  "struct.rkt"
+  "core.rkt"
   racket/class
   racket/match
   racket/contract

pitfall/pitfall/core.rkt

@@ -0,0 +1,28 @@
+#lang racket/base
+(provide (all-defined-out))
+
+;; structs
+
+(struct String (string) #:transparent)
+
+;; for JPEG and PNG
+(struct image (label width height obj) #:transparent #:mutable)
+
+;; params
+
+(define test-mode (make-parameter #f))
+(define current-compress-streams? (make-parameter #f))
+
+(define current-pdf-version (make-parameter 1.3))
+(define current-auto-first-page (make-parameter #t))
+(define current-doc-offset (make-parameter 'doc-offset-not-initialized))
+
+;; helpers
+
+(define (numberizer x #:round [round? #true])
+  (unless (and (number? x) (< -1e21 x 1e21))
+    (raise-argument-error 'number "valid number" x))
+  (let ([x (if round? (/ (round (* x 1e6)) 1e6) x)])
+    (number->string (if (integer? x)
+                        (inexact->exact x)
+                        x))))

pitfall/pitfall/document.rkt

@@ -1,14 +1,11 @@
 #lang debug racket/base
 (require
-  "param.rkt"
+  "core.rkt"
-  "struct.rkt"
   racket/class
   racket/format
   racket/generator
   racket/match
   racket/list
-  sugar/unstable/class
-  sugar/unstable/js
   sugar/unstable/dict
   "reference.rkt"
   "object.rkt"
@@ -21,136 +18,135 @@
   "annotations.rkt")
 (provide PDFDocument)
 
-(define mixed% (annotation-mixin (image-mixin (text-mixin (fonts-mixin (color-mixin (vector-mixin object%)))))))
+(define PDFDocument
-
+  (class (annotation-mixin (image-mixin (text-mixin (fonts-mixin (color-mixin (vector-mixin object%))))))
-(define-subclass mixed% (PDFDocument [options (mhash)])  
+    (super-new)
-  (field [@pageBuffer null]
+    (init-field [(@options options) (mhasheq)])  
-         [@offsets (mhasheqv)] ; The PDF object store
+    (field [@pages null]
-        
+           [@offsets (mhasheqv)] ; The PDF object stores
-         [ref-gen (generator ()
+           [ref-gen (generator ()
-                             (let loop ([refid 1])
+                               (let loop ([refid 1])
-                               (hash-set! @offsets refid 'missing-ref-offset)
+                                 (hash-set! @offsets refid #f)
-                               (yield refid)
+                                 (yield refid)
-                               (loop (add1 refid))))]
+                                 (loop (add1 refid))))]
-         [(@root _root) (ref (mhasheq 'Type "Catalog"
+           [(@root _root) (ref (mhasheq 'Type "Catalog"
-                                      'Pages (ref (mhasheq 'Type "Pages"
+                                        'Pages (ref (mhasheq 'Type "Pages"
-                                                           'Count 0
+                                                             'Count 0
-                                                           'Kids empty))))] ; top object
+                                                             'Kids empty))))] ; top object
-         [(@page page) #f] ; The current page
+           [(@x x) 0]
-         [(@x x) 0]
+           [(@y y) 0]
-         [(@y y) 0]
+           [(@info info) (mhasheq
-         [(@info info) (mhasheq
+                          'Producer "PITFALL"
-                        'Producer "PITKIT"
+                          'Creator "PITFALL"
-                        'Creator "PITKIT"
+                          'CreationDate (seconds->date (if (test-mode)
-                        'CreationDate (seconds->date (if (test-mode)
+                                                           0
-                                                         0
+                                                           (current-seconds)) #f))])  ; Initialize the metadata
-                                                         (current-seconds)) #f))])  ; Initialize the metadata
+
-
+    ;; Initialize mixins
-  ;; Initialize mixins
+    (send this initColor)
-  (· this initColor)
+    (send this initVector)
-  (· this initVector)
+    (inherit-field _ctm)
-  (· this initFonts)
+    (send this initFonts)
-  (inherit-field _fontFamilies)
+    (inherit-field @font-families)
-  (· this initText)
+    (send this initText)
-  (· this initImages)
+    (send this initImages)
-
+
-  ;; initialize params
+    ;; initialize params
-  (current-compress-streams? (hash-ref options 'compress #t))
+    (current-compress-streams? (hash-ref @options 'compress #t))
-  (current-auto-first-page (hash-ref options 'autoFirstPage #t))
+    (current-auto-first-page (hash-ref @options 'autoFirstPage #t))
-  (current-doc-offset 0)
+    (current-doc-offset 0)
-
+
-  (define/public (ref [payload (mhash)])
+    (define/public (page) (first @pages))
-    (make-object PDFReference this (ref-gen) payload))
+
-
+    (define/public (ref [payload (mhasheq)])
-  (define/public (write x)
+      (make-object PDFReference this (ref-gen) payload))
-    (define bstr (if (bytes? x) x (string->bytes/latin-1 (string-append x "\n"))))
+
-    (write-bytes bstr)
+    (define/public (write x)
-    (current-doc-offset (file-position (current-output-port))))
+      (define bstr (if (bytes? x) x (string->bytes/latin-1 (string-append x "\n"))))
+      (write-bytes bstr)
+      (current-doc-offset (file-position (current-output-port))))
       
-  (define/public (addPage [options-arg options])
+    (define/public (addPage [options-arg @options])
-    ;; end the current page if needed
+      ;; end the current page if needed
-    (unless (hash-ref options 'bufferPages #f)
+      (unless (hash-ref @options 'bufferPages #f)
-      (flushPages))
+        (flush-pages))
-
+
-    ;; create a page object
+      ;; create a page object
-    (set! @page (make-object PDFPage this options-arg))
+      (set! @pages (cons (make-object PDFPage this options-arg) @pages))
-    (set! @pageBuffer (cons @page @pageBuffer))
   
-    ;; in Kids, store page dictionaries in correct order
+      ;; in Kids, store page dictionaries in correct order
-    ;; this determines order in document
+      ;; this determines order in document
-    (define pages (· @root payload Pages payload))
+      (define pages (get-field payload (hash-ref (get-field payload @root) 'Pages)))
-    (hash-update! pages 'Kids (λ (val) (append val (list (· @page dictionary)))))
+      (hash-update! pages 'Kids (λ (val) (append val (list (get-field dictionary (page))))))
-    (hash-set! pages 'Count (length (hash-ref pages 'Kids)))
+      (hash-set! pages 'Count (length (hash-ref pages 'Kids)))
-
+
-    ;; reset x and y coordinates
+      ;; reset x and y coordinates
-    (set! @x (· @page margins left))
+      (set! @x (hash-ref (get-field margins (page)) 'left))
-    (set! @y (· @page margins top))
+      (set! @y (hash-ref (get-field margins (page)) 'top))
-    ;; flip PDF coordinate system so that the origin is in
+      ;; flip PDF coordinate system so that the origin is in
-    ;; the top left rather than the bottom left
+      ;; the top left rather than the bottom left
-    (set-field! _ctm this default-ctm-value)
+      (set! _ctm default-ctm-value)
-    (send this transform 1 0 0 -1 0 (· @page height))
+      (send this transform 1 0 0 -1 0 (get-field height (page)))
-    this)
+      this)
-
+
-  (define/public (flushPages)
+    (define/public (flush-pages)
-    (for-each (λ (p) (· p end)) @pageBuffer)
+      (for-each (λ (p) (send p end)) @pages)
-    (set! @pageBuffer empty))
+      (set! @pages empty))
-
+
-  (define/public (addContent data)
+    (define/public (addContent data)
-    (send @page write data)
+      (send (page) write data)
-    this)
+      this)
-
+
-  (define/public (_refEnd aref)
+    (define/public (_refEnd aref)
-    (hash-set! @offsets (· aref id) (· aref offset)))
+      (hash-set! @offsets (get-field id aref) (get-field offset aref)))
-
+
-  (define/public (end) ; called from source file to finish doc
+    (define/public (end) ; called from source file to finish doc
-    ;; Write the header
+      (write (format "%PDF-~a" (current-pdf-version)))
-    (write (format "%PDF-~a" (current-pdf-version))) ;  PDF version
+      (write (string-append "%" (list->string (map integer->char (make-list 4 #xFF)))))
-    (write (string-append "%" (list->string (map integer->char (make-list 4 #xFF))))) ; 4 binary chars, as recommended by the spec
+      (flush-pages)
-    
+      (define doc-info (ref))
-    (flushPages)
+      (for ([(key val) (in-hash @info)])
-    (define _info (ref))
+        ;; upgrade string literal to String struct
-    (for ([(key val) (in-hash @info)])
+        (hash-set! (get-field payload doc-info) key (if (string? val) (String val) val)))
-      ;; upgrade string literal to String struct
+      (send doc-info end)
-      (hash-set! (· _info payload) key (if (string? val) (String val) val)))
-    (· _info end)
     
-    (for ([font (in-hash-values _fontFamilies)])
+      (for ([font (in-hash-values @font-families)])
-      (· font finalize))
+        (send font finalize))
-    (· @root end)
+      (send @root end)
-    (· @root payload Pages end)
+      (send (hash-ref (get-field payload @root) 'Pages) end)
-
+
-    (define xref-offset (current-doc-offset))
+      (define xref-offset (current-doc-offset))
-    (match-define (list this-idxs this-offsets)
+      (match-define (list this-idxs this-offsets)
-      (match (sort (hash->list @offsets) < #:key car) ; sort by refid
+        (match (sort (hash->list @offsets) < #:key car) ; sort by refid
-        [(list (cons idxs offsets) ...) (list idxs offsets)]))
+          [(list (cons idxs offsets) ...) (list idxs offsets)]))
-    (write "xref")
+      (write "xref")
-    (write (format "0 ~a" (add1 (length this-offsets))))
+      (write (format "0 ~a" (add1 (length this-offsets))))
-    (write "0000000000 65535 f ")
+      (write "0000000000 65535 f ")
-    (let ([missing-offsets (for/list ([offset (in-list this-offsets)]
+      (let ([missing-offsets (for/list ([offset (in-list this-offsets)]
-                                      [idx (in-list this-idxs)]
+                                        [idx (in-list this-idxs)]
-                                      #:unless (number? offset))
+                                        #:unless (number? offset))
-                             idx)])
+                               idx)])
-      (unless (empty? missing-offsets)
+        (unless (empty? missing-offsets)
-        (raise-argument-error 'document:end "numerical offsets" missing-offsets)))
+          (raise-argument-error 'document:end "numerical offsets" missing-offsets)))
-    (for ([offset (in-list this-offsets)]
+      (for ([offset (in-list this-offsets)]
-          [idx (in-list this-idxs)])
+            [idx (in-list this-idxs)])
-      (write (string-append (~r offset #:min-width 10 #:pad-string "0") " 00000 n ")))
+        (write (string-append (~r offset #:min-width 10 #:pad-string "0") " 00000 n ")))
     
-    (write "trailer")
+      (write "trailer")
-    (write (convert
+      (write (convert
-            (mhash 'Size (add1 (length this-offsets))
+              (mhash 'Size (add1 (length this-offsets))
-                   'Root @root
+                     'Root @root
-                   'Info _info)))
+                     'Info doc-info)))
-    (write "startxref")
+      (write "startxref")
-    (write (number xref-offset))
+      (write (numberizer xref-offset))
-    (write "%%EOF"))
+      (write "%%EOF"))
-
+
-  ; if no 'info key, nothing will be copied from (hash)
+    ; if no 'info key, nothing will be copied from (hash)
-  (for ([(key val) (in-hash (hash-ref options 'info (hash)))]) 
+    (for ([(key val) (in-hash (hash-ref @options 'info (hash)))]) 
-    (hash-set! @info key val))
+      (hash-set! @info key val))
-
+
-  ;; Add the first page
+    ;; Add the first page
-  (when (current-auto-first-page) (addPage)))
+    (when (current-auto-first-page) (addPage))))
-
+
-(module+ test
+  (module+ test
-  (define d (new PDFDocument)))
+    (define d (new PDFDocument)))

pitfall/pitfall/embedded.rkt

@@ -1,8 +1,7 @@
 #lang debug racket/base
 (require
   (for-syntax racket/base)
-  "param.rkt"
+  "core.rkt"
-  "struct.rkt"
   racket/class
   racket/match
   racket/string

pitfall/pitfall/fonts.rkt

@@ -13,7 +13,7 @@
   (class %
     (super-new)
     ;; Lookup table for embedded fonts
-    (field [_fontFamilies #f]
+    (field [@font-families #f]
            [_fontCount #f]
            
            ;; Font state
@@ -31,7 +31,7 @@
 
 (define/contract (initFonts this)
   (->m void?)
-  (set-field! _fontFamilies this (mhash))
+  (set-field! @font-families this (mhash))
   (set-field! _fontCount this 0)
 
   (set-field! _fontSize this 12)
@@ -66,7 +66,7 @@
 
   ;; fast path: check if the font is already in the PDF
   (cond
-    [(hash-ref (· this _fontFamilies) cacheKey #f) =>
+    [(hash-ref (· this @font-families) cacheKey #f) =>
                                                    (λ (val)
                                                      (set-field! _font this val))]
     ;; load the font
@@ -77,7 +77,7 @@
      
      ;; check for existing font familes with the same name already in the PDF
      ;; useful if the font was passed as a buffer
-     (let* ([this-ff (· this _fontFamilies)]
+     (let* ([this-ff (· this @font-families)]
             [this-f (· this _font)]
             [font (hash-ref this-ff (· this-f name) #f)])
        (cond

pitfall/pitfall/jpeg-structy.rkt

@@ -1,6 +1,6 @@
 #lang debug racket/base
 (require
-  "struct.rkt"
+  "core.rkt"
   racket/class
   racket/contract
   sugar/unstable/class

pitfall/pitfall/object.rkt

@@ -1,6 +1,6 @@
 #lang racket/base
 (require
-  "struct.rkt"
+  "core.rkt"
   racket/class
   racket/string
   racket/contract

pitfall/pitfall/old/parse.rkt

@@ -1,5 +1,5 @@
 #lang at-exp br/quicklang
-(require "parser.rkt" "tokenizer.rkt" "struct.rkt" gregor racket/bytes)
+(require "parser.rkt" "tokenizer.rkt" "core.rkt" gregor racket/bytes)
 (provide (matching-identifiers-out #rx"pf-" (all-defined-out)))
 
 (module+ test (require rackunit))

pitfall/pitfall/param.rkt

@@ -1,8 +0,0 @@
-#lang racket/base
-(provide (all-defined-out))
-(define test-mode (make-parameter #f))
-(define current-compress-streams? (make-parameter #f))
-
-(define current-pdf-version (make-parameter 1.3))
-(define current-auto-first-page (make-parameter #t))
-(define current-doc-offset (make-parameter 'doc-offset-not-initialized))

pitfall/pitfall/pdftest.rkt

@@ -1,7 +1,7 @@
 #lang racket/base
 (require
   (for-syntax racket/base)
-  "param.rkt"
+  "core.rkt"
   racket/class
   racket/string
   br/define
@@ -35,13 +35,12 @@
 
 (define (make-doc ps [compress? #false] [proc (λ (doc) doc)] #:test [test? #t] #:pdfkit [pdfkit? #t])
   (time
-   (let ()
+   (with-output-to-file ps
-     (define f (open-output-file ps #:exists 'replace))
+     (λ ()
-     (parameterize ([current-output-port f])
        (define doc (make-object PDFDocument (hash 'compress compress?)))
        (proc doc)
        (send doc end))
-     (close-output-port f)))
+     #:exists 'replace))
   (when test?
     (check-pdfs-equal? ps (this->control ps))
     (when pdfkit?

pitfall/pitfall/reference.rkt

@@ -2,7 +2,7 @@
 (require racket/class
          racket/match
          racket/port
-         "param.rkt"
+         "core.rkt"
          "object.rkt"
          "zlib.rkt")
 (provide PDFReference)

pitfall/pitfall/struct.rkt

@@ -1,9 +0,0 @@
-#lang racket/base
-(provide (all-defined-out))
-
-;; use structs to sub for missing node types
-
-(struct String (string) #:transparent)
-
-;; for JPEG and PNG
-(struct image (label width height obj) #:transparent #:mutable)