resume in test5: not getting output

pitfall/pitfall/document.rkt

@@ -14,6 +14,7 @@
          [pdf-version 1.3]
          [_pageBuffer null]
          [_offsets (mhash)] ; The PDF object store
+         [_ended #f]
          [_offset 0]
          [_root (ref this
                      (mhash 'Type "Catalog"
@@ -38,7 +39,7 @@
   (· this initVector)
   (· this initFonts)
   (· this initText)
-  ;(· this initImages)
+  (· this initImages)
 
   (as-methods
    addPage
@@ -100,7 +101,7 @@
 (define/contract (ref this [payload (mhash)])
   (() (hash?) . ->*m . (is-a?/c PDFReference))
   (define next-refid (add1 (length (hash-keys (· this _offsets)))))
-  (hash-set! (· this _offsets) next-refid #f)
+  (hash-set! (· this _offsets) next-refid 'missing-ref-offset)
   (make-object PDFReference this next-refid payload))
 
 
@@ -121,13 +122,15 @@
 
 (define/contract (offsets-missing? this)
   (->m boolean?)
-  ;; `boolean?` matches #f values
-  (positive? (length (filter boolean? (hash-values (· this _offsets))))))
+  (positive? (length (filter (λ (v) (eq? 'missing-ref-offset v)) (hash-values (· this _offsets))))))
 
 
 (define/contract (_refEnd this ref)
   ((is-a?/c PDFReference) . ->m . void?)
-  (hash-set! (· this _offsets) (· ref id) (· ref offset)))
+  (hash-set! (· this _offsets) (· ref id) (· ref offset))
+  (if (and (not (offsets-missing? this)) (· this _ended))
+      (· this _finalize)
+      (set-field! _ended this #f)))
 
 
 (define/contract (pipe this port)
@@ -150,32 +153,35 @@
   (· this _root end)
   (· this _root payload Pages end)
 
-  ;; generate xref
-  (define xref-offset (· this _offset))
-  (with-method ([this-write (this write)])
-    (define this-offsets (map cdr (sort (hash->list (· this _offsets)) < #:key car))) ; sort by refid
-    (this-write "xref")
-    (this-write (format "0 ~a" (add1 (length this-offsets))))
-    (this-write "0000000000 65535 f ")
-    (for ([offset (in-list this-offsets)])
-         (this-write @string-append{@(~r offset #:min-width 10 #:pad-string "0") 00000 n }))
-    (this-write "trailer") ;; trailer
-    (this-write (convert
-                 (mhash 'Size (add1 (length this-offsets))
-                        'Root (· this _root)
-                        'Info _info)))
-    (this-write "startxref")
-    (this-write (number xref-offset))
-    (this-write "%%EOF"))
+  (cond
+    [(offsets-missing? this) (set-field! _ended this #t)]
+    [else
+     ;; generate xref
+     (define xref-offset (· this _offset))
+     (with-method ([this-write (this write)])
+       (define this-offsets (map cdr (sort (hash->list (· this _offsets)) < #:key car))) ; sort by refid
+       (this-write "xref")
+       (this-write (format "0 ~a" (add1 (length this-offsets))))
+       (this-write "0000000000 65535 f ")
+       (for ([offset (in-list this-offsets)])
+            (this-write @string-append{@(~r offset #:min-width 10 #:pad-string "0") 00000 n }))
+       (this-write "trailer") ;; trailer
+       (this-write (convert
+                    (mhash 'Size (add1 (length this-offsets))
+                           'Root (· this _root)
+                           'Info _info)))
+       (this-write "startxref")
+       (this-write (number xref-offset))
+       (this-write "%%EOF"))
      
-  ;; end the stream
-  ;; in node you (@push null) which signals to the stream
-  ;; to copy to its output port
-  ;; here we'll do it manually
-  (define this-output-port (· this output-port))
-  (copy-port (open-input-bytes
-              (apply bytes-append (reverse (· this byte-strings)))) this-output-port)
-  (close-output-port this-output-port))
+     ;; end the stream
+     ;; in node you (@push null) which signals to the stream
+     ;; to copy to its output port
+     ;; here we'll do it manually
+     (define this-output-port (· this output-port))
+     (copy-port (open-input-bytes
+                 (apply bytes-append (reverse (· this byte-strings)))) this-output-port)
+     (close-output-port this-output-port)]))
 
 
 

pitfall/pitfall/image.rkt

@@ -1,17 +1,16 @@
 #lang pitfall/racket
 (require "jpeg.rkt" "png.rkt")
-(provide PDFImage)
+(provide PDFImage-open)
 
-(define PDFImage
+#;(define PDFImage
   (class object%
     (super-new)
 
     (as-methods
-     open)))
+     )))
 
-
-(define/contract (open this src label)
-  (any/c any/c . ->m . bytes?)
+(define/contract (PDFImage-open src label)
+  (any/c any/c . -> . (or/c (is-a?/c PNG)))
   (define data (cond
                  [(isBuffer? src) src]
                  ;;else if src instanceof ArrayBuffer
@@ -21,8 +20,8 @@
                  [else (file->bytes src)]))
   (cond
     [(equal? (subbytes data 0 2) (bytes #xff #xd8))
-     'doJpeg]
+     (error 'do-jpeg-unimplemented)]
     [(equal? (subbytes data 0 4) (apply bytes (cons #x89 (map char->integer '(#\P #\N #\G)))))
-     'doPNG]
+     (make-object PNG data label)]
     [else (raise-argument-error 'PDFImage-open "valid image format" src)]))
            

pitfall/pitfall/images.rkt

@@ -5,17 +5,109 @@
 (define (image-mixin [% mixin-tester%])
   (class %
     (super-new)
-    #;(field [_opacityRegistry #f]
-           [_opacityCount #f]
-           [_gradCount #f]
-           [_fillColor #f])
+    (field [_imageRegistry #f]
+           [_imageCount #f])
 
     (as-methods
-    )))
+     initImages
+     image
+     openImage
+     )))
 
     
-#;(define/contract (initColor this)
+(define/contract (initImages this)
   (->m void?)
-  (set-field! _opacityRegistry this (mhash))
-  (set-field! _opacityCount this 0)
-  (set-field! _gradCount this 0))
+  (set-field! _imageRegistry this (mhash))
+  (set-field! _imageCount this 0))
+
+
+(define/contract (image this src [x #f] [y #f] [options mhash])
+  ((any/c) ((or/c number? #f) (or/c number? #f) hash?) . ->*m . object?)
+  (set! x (or x (· options x) (· this x)))
+  (set! y (or y (· options y) (· this y)))
+
+  (define image (cond
+                  [(and (string? src) (hash-ref (· this _imageRegistry) src #f))]
+                  [(and (object? src) (· src width) (· src height)) src]
+                  [else (send this openImage src)]))
+
+  (unless (· image obj) (send image embed this))
+  
+  (hash-ref! (· this page xobjects) (· image label) (· image obj))
+  
+  (define w (or (hash-ref options 'width #f) (· image width)))
+  (define h (or (hash-ref options 'height #f) (· image height)))
+  (define wp #f)
+  (define hp #f)
+  (define bp #f)
+  (define ip #f)
+  (define bw #f)
+  (define bh #f)
+
+  (cond
+    [(and (hash-ref options 'width #f) (not (hash-ref options 'height #f)))
+     (set! wp (/ w (· image width)))
+     (set! w (* (· image width) wp))
+     (set! h (* (· image height) wp))]
+    [(and (hash-ref options 'height #f) (not (hash-ref options 'width #f)))
+     (set! hp (/ h (· image width)))
+     (set! w (* (· image width) hp))
+     (set! h (* (· image height) hp))]
+    [(hash-ref options 'scale #f)
+     (set! w (* (· image width) (· options scale)))
+     (set! h (* (· image height) (· options scale)))]
+    [(hash-ref options 'fit #f)
+     (match-define (list bw bh) (· options fit))
+     (set! bp (/ bw bh))
+     (set! ip (/ (· image width) (· image height)))
+     (cond
+       [(> ip bp)
+        (set! w bw)
+        (set! h (/ bw ip))]
+       [else
+        (set! h bh)
+        (set! w (* bh ip))])]
+    [(hash-ref options 'cover #f)
+     (match-define (list bw bh) (· options cover))
+     (set! bp (/ bw bh))
+     (set! ip (/ (· image width) (· image height)))
+     (cond
+       [(> ip bp)
+        (set! h bh)
+        (set! w (* bh ip))]
+       [else
+        (set! w bw)
+        (set! h (/ bw ip))])])
+
+  (when (or (hash-ref options 'fit #f) (hash-ref options 'cover #f))
+    (cond
+      [(equal? (hash-ref options 'align #f) "center")
+       (set! x (+ x (/ bw 2) (- (/ w 2))))]
+      [(equal? (hash-ref options 'align #f) "right")
+       (set! x (+ x bw - w))])
+
+    (cond
+      [(equal? (hash-ref options 'valign #f) "center")
+       (set! y (+ y (/ bh 2) (- (/ h 2))))]
+      [(equal? (hash-ref options 'valign #f) "bottom")
+       (set! y (+ y bh - h))]))
+
+  ;; Set the current y position to below the image if it is in the document flow
+  (when (equal? (· this y) y) (increment-field! y this h))
+
+  (· this save)
+  (send this transform w 0 0 (- h) x (+ y h))
+  (send this addContent (format "/~a Do" (· image label)))
+  (· this restore)
+  this
+  #;(error 'stop-in-images:image))
+
+(define/contract (openImage this src)
+  (any/c . ->m . object?)
+  (cond
+    [(and (string? src) (hash-ref (· this _imageRegistry) src #f))]
+    [else
+     (define new-image
+       (PDFImage-open src (format "I~a" (increment-field! _imageCount this))))
+     (when (string? src) (hash-set! (· this _imageRegistry) src new-image))
+     new-image]))

pitfall/pitfall/pdftest.rkt

@@ -24,13 +24,14 @@
   (check-equal? (bytes-length (file->bytes this))
                 (bytes-length (file->bytes (this->pdfkit-control this)))))
 
-(define (make-doc ps compress? [proc (λ (doc) doc)])
+(define (make-doc ps compress? [proc (λ (doc) doc)] #:test [test? #t])
   (define doc (make-object PDFDocument (hash 'compress compress?)))
   (send doc pipe (open-output-file ps #:exists 'replace))
   (proc doc)
   (send doc end)
-  (check-copy-equal? ps)
-  (check-pdfkit? ps))
+  (when test?
+    (check-copy-equal? ps)
+    (check-pdfkit? ps)))
 
 
 (module reader syntax/module-reader

pitfall/pitfall/png.rkt

@@ -1,8 +1,56 @@
 #lang pitfall/racket
-(require racket/draw/unsafe/png)
+(require racket/draw/unsafe/png racket/draw/private/bitmap)
+(provide PNG)
+
+(define-subclass object% (PNG data label)
+  (super-new)
+  
+  (field [image (make-object bitmap% (open-input-bytes data) 'png)]
+         [width (· image get-width)]
+         [height (· image get-height)]
+         [imgData data]
+         [obj #f]
+         [document #f]) ; for `embed`
+
+  (as-methods
+   embed))
+
+
+(define png-grayscale 1)
+(define png-color 3)
+(define/contract (embed this doc-in)
+  (object? . ->m . void?)
+  (set-field! document this doc-in)
+  
+  (unless (· this obj)
+    (set-field! obj this
+                (send (· this document) ref
+                      (mhash 'Type "XObject"
+                             'Subtype "Image"
+                             'BitsPerComponent: (· this image get-depth)
+                             'Width (· this width)
+                             'Height (· this height)
+                             'Filter "FlateDecode")))
+
+    (define params (mhash))
+    (unless (· this image has-alpha-channel?)
+      (set! params (send (· this document) ref (mhash 'Predictor 15
+                                                      'Colors (· this image get-depth)
+                                                      ;; or maybe
+                                                      #;(if (· this image is-color?)
+                                                            png-color
+                                                            png-grayscale)
+                                                      'BitsPerComponent (· this image get-depth)
+                                                      'Columns (· this width)))))
+
+  
+    (hash-set! (· this obj payload) 'DecodeParms params)
+    (send params end)
+
+    #;(error 'stop-in-png:embed)))
+
+#;(module+ test
+    (define data (file->bytes "test/assets/test.png"))
+    (define bm (make-object bitmap% (open-input-bytes data) 'png))
+    bm)
 
-(define PNGImage
-  (class object%
-    (init-field data label)
-    (field [image 'newPngobject]
-           [width '()])))

pitfall/pitfall/test/test5.rkt

@@ -6,11 +6,11 @@
   [fontSize 25]
   [text "Some text with an embedded font!" 100 100 (hash 'lineBreak #f)]
   [image "assets/test.png" 100 160 (hash 'width 412)]
-  [image "assets/test.jpeg" 190 400 (hash 'height 300)]))
+  #;[image "assets/test.jpeg" 190 400 (hash 'height 300)]))
 
 (define-runtime-path this "test5rkt.pdf")
-(make-doc this #f proc)
+(make-doc this #f proc #:test #f)
 
-(define-runtime-path that "test5crkt.pdf")
-(make-doc that #t proc)
+#;(define-runtime-path that "test5crkt.pdf")
+#;(make-doc that #t proc)