typesetting/pitfall/pitfall/document.rkt

#lang debug racket/base
(require
  "param.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"
  "page.rkt"
  "vector.rkt"
  "color.rkt"
  "fonts.rkt"
  "text.rkt"
  "images.rkt"
  "annotations.rkt")
(provide PDFDocument)

(define mixed% (annotation-mixin (image-mixin (text-mixin (fonts-mixin (color-mixin (vector-mixin object%)))))))

(define-subclass mixed% (PDFDocument [options (mhash)])  
  (field [@pageBuffer null]
         [@offsets (mhasheqv)] ; The PDF object store
        
         [ref-gen (generator ()
                             (let loop ([refid 1])
                               (hash-set! @offsets refid 'missing-ref-offset)
                               (yield refid)
                               (loop (add1 refid))))]
         [(@root _root) (ref (mhasheq 'Type "Catalog"
                                      'Pages (ref (mhasheq 'Type "Pages"
                                                           'Count 0
                                                           'Kids empty))))] ; top object
         [(@page page) #f] ; The current page
         [(@x x) 0]
         [(@y y) 0]
         [(@info info) (mhasheq
                        'Producer "PITKIT"
                        'Creator "PITKIT"
                        'CreationDate (seconds->date (if (test-mode)
                                                         0
                                                         (current-seconds)) #f))])  ; Initialize the metadata

  ;; Initialize mixins
  (· this initColor)
  (· this initVector)
  (· this initFonts)
  (inherit-field _fontFamilies)
  (· this initText)
  (· this initImages)

  ;; initialize params
  (current-compress-streams? (hash-ref options 'compress #t))
  (current-auto-first-page (hash-ref options 'autoFirstPage #t))
  (current-doc-offset 0)

  (define/public (ref [payload (mhash)])
    (make-object PDFReference this (ref-gen) payload))

  (define/public (write x)
    (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])
    ;; end the current page if needed
    (unless (hash-ref options 'bufferPages #f)
      (flushPages))

    ;; create a page object
    (set! @page (make-object PDFPage this options-arg))
    (set! @pageBuffer (cons @page @pageBuffer))
  
    ;; in Kids, store page dictionaries in correct order
    ;; this determines order in document
    (define pages (· @root payload Pages payload))
    (hash-update! pages 'Kids (λ (val) (append val (list (· @page dictionary)))))
    (hash-set! pages 'Count (length (hash-ref pages 'Kids)))

    ;; reset x and y coordinates
    (set! @x (· @page margins left))
    (set! @y (· @page margins top))
    ;; flip PDF coordinate system so that the origin is in
    ;; the top left rather than the bottom left
    (set-field! _ctm this default-ctm-value)
    (send this transform 1 0 0 -1 0 (· @page height))
    this)

  (define/public (flushPages)
    (for-each (λ (p) (· p end)) @pageBuffer)
    (set! @pageBuffer empty))

  (define/public (addContent data)
    (send @page write data)
    this)

  (define/public (_refEnd aref)
    (hash-set! @offsets (· aref id) (· aref offset)))

  (define/public (end) ; called from source file to finish doc
    ;; Write the header
    (write (format "%PDF-~a" (current-pdf-version))) ;  PDF version
    (write (string-append "%" (list->string (map integer->char (make-list 4 #xFF))))) ; 4 binary chars, as recommended by the spec
    
    (flushPages)
    (define _info (ref))
    (for ([(key val) (in-hash @info)])
      ;; upgrade string literal to String struct
      (hash-set! (· _info payload) key (if (string? val) (String val) val)))
    (· _info end)
    
    (for ([font (in-hash-values _fontFamilies)])
      (· font finalize))
    (· @root end)
    (· @root payload Pages end)

    (define xref-offset (current-doc-offset))
    (match-define (list this-idxs this-offsets)
      (match (sort (hash->list @offsets) < #:key car) ; sort by refid
        [(list (cons idxs offsets) ...) (list idxs offsets)]))
    (write "xref")
    (write (format "0 ~a" (add1 (length this-offsets))))
    (write "0000000000 65535 f ")
    (let ([missing-offsets (for/list ([offset (in-list this-offsets)]
                                      [idx (in-list this-idxs)]
                                      #:unless (number? offset))
                             idx)])
      (unless (empty? missing-offsets)
        (raise-argument-error 'document:end "numerical offsets" missing-offsets)))
    (for ([offset (in-list this-offsets)]
          [idx (in-list this-idxs)])
      (write (string-append (~r offset #:min-width 10 #:pad-string "0") " 00000 n ")))
    
    (write "trailer")
    (write (convert
            (mhash 'Size (add1 (length this-offsets))
                   'Root @root
                   'Info _info)))
    (write "startxref")
    (write (number xref-offset))
    (write "%%EOF"))

  ; if no 'info key, nothing will be copied from (hash)
  (for ([(key val) (in-hash (hash-ref options 'info (hash)))]) 
    (hash-set! @info key val))

  ;; Add the first page
  (when (current-auto-first-page) (addPage)))

(module+ test
  (define d (new PDFDocument)))