diff --git a/pitfall/pitfall/core.rkt b/pitfall/pitfall/core.rkt index 610ff399..113d7107 100644 --- a/pitfall/pitfall/core.rkt +++ b/pitfall/pitfall/core.rkt @@ -4,6 +4,8 @@ ;; structs +(struct $img (data label width height obj embed-proc) #:transparent #:mutable) + (struct $ref (id payload offset port) #:transparent #:mutable #:methods gen:dict [(define (dict-ref $ key [thunk (λ () (error 'dict-ref-key-not-found))]) diff --git a/pitfall/pitfall/image.rkt b/pitfall/pitfall/image.rkt index 6c5d0473..2d660d46 100644 --- a/pitfall/pitfall/image.rkt +++ b/pitfall/pitfall/image.rkt @@ -10,10 +10,8 @@ [(bytes? src) (open-input-bytes src)] [(regexp-match #rx"^data:.+;base64,(.*)$" src) (void)] ;; base64 ; todo [else (open-input-file src)])) - (define image-class - (cond - [(equal? (peek-bytes 2 0 data) (bytes #xff #xd8)) JPEG] - [(equal? (peek-bytes 4 0 data) (apply bytes (map char->integer '(#\u0089 #\P #\N #\G)))) PNG] + (cond + [(equal? (peek-bytes 2 0 data) (bytes #xff #xd8)) (make-object JPEG data label)] + [(equal? (peek-bytes 4 0 data) (apply bytes (map char->integer '(#\u0089 #\P #\N #\G)))) (make-png data label)] [else (raise-argument-error 'PDFImage-open "valid image format" src)])) - (make-object image-class data label)) diff --git a/pitfall/pitfall/images.rkt b/pitfall/pitfall/images.rkt index 051eb85a..410b6e71 100644 --- a/pitfall/pitfall/images.rkt +++ b/pitfall/pitfall/images.rkt @@ -4,6 +4,7 @@ racket/match sugar/unstable/dict "image.rkt" + "core.rkt" "page.rkt") (provide image-mixin) @@ -21,14 +22,15 @@ (define image (cond [(and (string? src) (hash-ref @image-registry src #f))] - [(and (object? src) (get-field width src) (get-field height src)) src] + [(and (object? src) ($img-width src) ($img-height src)) src] + [(and ($img? src) ($img-width src) ($img-height src)) src] [else (send this open-image src)])) - (unless (get-field obj image) (send image embed)) + (unless ($img-obj image) (($img-embed-proc image) image)) - (hash-ref! (page-xobjects (page)) (get-field label image) (get-field obj image)) + (hash-ref! (page-xobjects (page)) ($img-label image) ($img-obj image)) - (define image-width (get-field width image)) - (define image-height (get-field height image)) + (define image-width ($img-width image)) + (define image-height ($img-height image)) (define options-width (hash-ref options 'width #f)) (define options-height (hash-ref options 'height #f)) (define w (or options-width image-width)) @@ -90,7 +92,7 @@ (when (= @y y) (set! y (+ y h))) (send this save) (send this transform w 0 0 (- h) x (+ y h)) - (send this add-content (format "/~a Do" (get-field label image))) + (send this add-content (format "/~a Do" ($img-label image))) (send this restore) this) diff --git a/pitfall/pitfall/png.rkt b/pitfall/pitfall/png.rkt index 050a9bbe..179debfc 100644 --- a/pitfall/pitfall/png.rkt +++ b/pitfall/pitfall/png.rkt @@ -2,6 +2,7 @@ (require racket/class "reference.rkt" + "core.rkt" racket/dict racket/draw sugar/unstable/dict) @@ -9,98 +10,98 @@ #| https://github.com/mbutterick/pdfkit/blob/master/lib/image/png.coffee |# - (require "png-reader.rkt" "zlib.rkt") -(provide PNG) -(define PNG - (class object% - (super-new) - (init-field [(@data data)] [label #f]) - - (field [(@image image) (read-png @data)] ; `image` is a hash - [pixel-bit-length (hash-ref @image 'pixelBitlength)] - [(@width width) (hash-ref @image 'width)] - [(@height height) (hash-ref @image 'height)] - [(@img-data img-data) (hash-ref @image 'imgData)] - [(@alpha-channel alpha-channel) #f] - [(@obj obj) #f]) +(provide (all-defined-out)) + +(struct $png $img (image pixel-bit-length img-data alpha-channel) + #:transparent #:mutable) + +(define (make-png data [label #f]) + (define image (read-png data)) + (define pixel-bit-length (hash-ref image 'pixelBitlength)) + (define width (hash-ref image 'width)) + (define height (hash-ref image 'height)) + (define img-data (hash-ref image 'imgData)) + (define alpha-channel #f) + (define obj #f) + ($png data label width height obj png-embed image pixel-bit-length img-data alpha-channel)) - (define/public (embed) - (unless @obj - (set! @obj +(define (png-embed png) + (unless ($img-obj png) + (set-$img-obj! png (make-ref (mhash 'Type 'XObject 'Subtype 'Image - 'BitsPerComponent (hash-ref @image 'bits) - 'Width @width - 'Height @height + 'BitsPerComponent (hash-ref ($png-image png) 'bits) + 'Width ($img-width png) + 'Height ($img-height png) 'Filter 'FlateDecode))) - (unless (hash-ref @image 'hasAlphaChannel #f) + (unless (hash-ref ($png-image png) 'hasAlphaChannel #f) (define params (make-ref (mhash 'Predictor 15 - 'Colors (hash-ref @image 'colors) - 'BitsPerComponent (hash-ref @image 'bits) - 'Columns @width))) - (dict-set! @obj 'DecodeParms params) + 'Colors (hash-ref ($png-image png) 'colors) + 'BitsPerComponent (hash-ref ($png-image png) 'bits) + 'Columns ($img-width png)))) + (dict-set! ($img-obj png) 'DecodeParms params) (ref-end params)) (cond - [(hash-has-key? @image 'palette) + [(hash-has-key? ($png-image png) 'palette) ;; embed the color palette in the PDF as an object stream (define palette-ref (make-ref)) - (ref-write palette-ref (hash-ref @image 'palette)) + (ref-write palette-ref (hash-ref ($png-image png) 'palette)) (ref-end palette-ref) ;; build the color space array for the image - (dict-set! @obj 'Colorspace - (list 'Indexed 'DeviceRGB (sub1 (/ (bytes-length (hash-ref @image 'palette)) 3)) palette-ref))] - [else (dict-set! @obj 'ColorSpace 'DeviceRGB)]) + (dict-set! ($img-obj png) 'Colorspace + (list 'Indexed 'DeviceRGB (sub1 (/ (bytes-length (hash-ref ($png-image png) 'palette)) 3)) palette-ref))] + [else (dict-set! ($img-obj png) 'ColorSpace 'DeviceRGB)]) (cond - [(hash-ref @image 'transparency #f) + [(hash-ref ($png-image png) 'transparency #f) (cond - [(hash-ref (hash-ref @image 'transparency) 'grayscale #f) + [(hash-ref (hash-ref ($png-image png) 'transparency) 'grayscale #f) (error 'transparency-grayscale-not-implemented)] - [(hash-ref (hash-ref @image 'transparency) 'rgb #f) + [(hash-ref (hash-ref ($png-image png) 'transparency) 'rgb #f) (error 'transparency-rgb-not-implemented)] - [(hash-ref (hash-ref @image 'transparency) 'indexed #f) + [(hash-ref (hash-ref ($png-image png) 'transparency) 'indexed #f) (error 'transparency-indexed-not-implemented)])] - [(hash-ref @image 'hasAlphaChannel #f) + [(hash-ref ($png-image png) 'hasAlphaChannel #f) ;; For PNG color types 4 and 6, the transparency data is stored as a alpha ;; channel mixed in with the main image data. Separate this data out into an ;; SMask object and store it separately in the PDF.] (define-values (img-bytes alpha-bytes) (split-alpha-channel)) - (set! @img-data (deflate img-bytes)) - (set! @alpha-channel (deflate alpha-bytes))])) + (set-$png-img-data! png (deflate img-bytes)) + (set-$png-alpha-channel! png (deflate alpha-bytes))])) - (when @alpha-channel + (when ($png-alpha-channel png) (define sMask-ref (make-ref (mhash 'Type 'XObject 'Subtype 'Image - 'Height @height - 'Width @width + 'Height ($img-height png) + 'Width ($img-width png) 'BitsPerComponent 8 'Filter 'FlateDecode 'ColorSpace 'DeviceGray 'Decode '(0 1)))) - (ref-write sMask-ref @alpha-channel) + (ref-write sMask-ref ($png-alpha-channel png)) (ref-end sMask-ref) - (dict-set! @obj 'SMask sMask-ref)) + (dict-set! ($img-obj png) 'SMask sMask-ref)) ;; embed the actual image data - (ref-write @obj @img-data) - (ref-end @obj)) + (ref-write ($img-obj png) ($png-img-data png)) + (ref-end ($img-obj png))) - (define/public (split-alpha-channel) - (define ip @data) + (define (split-alpha-channel png) + (define ip ($img-data png)) (file-position ip 0) (define bmap (read-bitmap ip 'png/alpha)) - (define pixels (make-bytes (* 4 @width @height))) - (send bmap get-argb-pixels 0 0 @width @height pixels) + (define pixels (make-bytes (* 4 ($img-width png) ($img-height png)))) + (send bmap get-argb-pixels 0 0 ($img-width png) ($img-height png) pixels) (parameterize ([current-input-port (open-input-bytes pixels)]) (define argb-len (/ (bytes-length pixels) 4)) (define img-bytes (make-bytes (* argb-len 3))) @@ -109,11 +110,11 @@ https://github.com/mbutterick/pdfkit/blob/master/lib/image/png.coffee [i (in-range argb-len)]) (bytes-copy! alpha-bytes i argb-bytes 0 1) (bytes-copy! img-bytes (* i 3) argb-bytes 1 4)) - (values img-bytes alpha-bytes))))) + (values img-bytes alpha-bytes))) ;; test files ;; http://www.libpng.org/pub/png/png-sitemap.html#images (module+ test - (define pic (make-object PNG (open-input-file "../ptest/assets/death-alpha.png"))) - (define-values (img alpha) (send pic split-alpha-channel))) \ No newline at end of file + (define pic (make-png (open-input-file "../ptest/assets/death-alpha.png"))) + (define-values (img alpha) (split-alpha-channel pic))) \ No newline at end of file