diff --git a/pitfall/pitfall/image.rkt b/pitfall/pitfall/image.rkt index 2d660d46..193f6aee 100644 --- a/pitfall/pitfall/image.rkt +++ b/pitfall/pitfall/image.rkt @@ -10,8 +10,10 @@ [(bytes? src) (open-input-bytes src)] [(regexp-match #rx"^data:.+;base64,(.*)$" src) (void)] ;; base64 ; todo [else (open-input-file src)])) - (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)] + (define img-constructor + (cond + [(equal? (peek-bytes 2 0 data) (bytes #xff #xd8)) make-jpeg] + [(equal? (peek-bytes 4 0 data) (apply bytes (map char->integer '(#\u0089 #\P #\N #\G)))) make-png] [else (raise-argument-error 'PDFImage-open "valid image format" src)])) + (img-constructor data label)) diff --git a/pitfall/pitfall/jpeg.rkt b/pitfall/pitfall/jpeg.rkt index 465fe0d9..4056f49d 100644 --- a/pitfall/pitfall/jpeg.rkt +++ b/pitfall/pitfall/jpeg.rkt @@ -3,6 +3,7 @@ racket/class racket/match "reference.rkt" + "core.rkt" racket/dict sugar/unstable/dict) @@ -10,58 +11,61 @@ https://github.com/mbutterick/pdfkit/blob/master/lib/image/jpeg.coffee |# -(provide JPEG) +(provide make-jpeg (struct-out $jpeg)) (define MARKERS '(#xffc0 #xffc1 #xffc2 #xffc3 #xffc5 #xffc6 #xffc7 #xffc8 #xffc9 #xffca #xffcb #xffcc #xffcd #xffce #xffcf)) -(define JPEG - (class object% - (super-new) - (init-field [(@data data)] [(@label label) #f]) - - (define jpeg-ip (if (input-port? @data) @data (open-input-bytes @data))) - (unless (= (read-16bit-integer jpeg-ip) #xffd8) - (error 'JPEG "Start of input marker byte not found")) - (define marker (let loop ([skip 0]) - (read-bytes skip jpeg-ip) - (define m (read-16bit-integer jpeg-ip)) - (if (memv m MARKERS) - m - (loop (read-16bit-integer (peek-bytes 2 0 jpeg-ip)))))) - (read-16bit-integer jpeg-ip) - (field [(@bits bits) (read-byte jpeg-ip)] - [(@height height) (read-16bit-integer jpeg-ip)] - [(@width width) (read-16bit-integer jpeg-ip)] - [(@channels channels) (read-byte jpeg-ip)] - [(@colorSpace colorSpace) (case @channels - [(1) 'DeviceGray] - [(3) 'DeviceRGB] - [(4) 'DeviceCMYK])] - [(@obj obj) #f]) +(struct $jpeg $img (bits channels colorSpace) + #:transparent #:mutable) + +(define (make-jpeg data [label #f]) + + (define jpeg-ip (if (input-port? data) data (open-input-bytes data))) + (unless (= (read-16bit-integer jpeg-ip) #xffd8) + (error 'JPEG "Start of input marker byte not found")) + (define marker (let loop ([skip 0]) + (read-bytes skip jpeg-ip) + (define m (read-16bit-integer jpeg-ip)) + (if (memv m MARKERS) + m + (loop (read-16bit-integer (peek-bytes 2 0 jpeg-ip)))))) + (read-16bit-integer jpeg-ip) + (define bits (read-byte jpeg-ip)) + (define height (read-16bit-integer jpeg-ip)) + (define width (read-16bit-integer jpeg-ip)) + (define channels (read-byte jpeg-ip)) + (define colorSpace (case channels + [(1) 'DeviceGray] + [(3) 'DeviceRGB] + [(4) 'DeviceCMYK])) + (define obj #f) + ($jpeg data label width height obj jpeg-embed bits channels colorSpace)) + - (define/public (embed) - (unless @obj - (set! @obj (make-ref +(define (jpeg-embed jpeg) + (unless ($img-obj jpeg) + (set-$img-obj! jpeg + (make-ref (mhash 'Type 'XObject 'Subtype 'Image - 'BitsPerComponent @bits - 'Width @width - 'Height @height - 'ColorSpace @colorSpace + 'BitsPerComponent ($jpeg-bits jpeg) + 'Width ($img-width jpeg) + 'Height ($img-height jpeg) + 'ColorSpace ($jpeg-colorSpace jpeg) 'Filter 'DCTDecode))) - ;; add extra decode params for CMYK images. By swapping the - ;; min and max values from the default, we invert the colors. See - ;; section 4.8.4 of the spec. - (when (eq? @colorSpace 'DeviceCMYK) - (dict-set! @obj 'Decode '(1.0 0.0 1.0 0.0 1.0 0.0 1.0 0.0))) - (file-position @data 0) - (ref-write @obj @data) - (ref-end @obj))))) + ;; add extra decode params for CMYK images. By swapping the + ;; min and max values from the default, we invert the colors. See + ;; section 4.8.4 of the spec. + (when (eq? ($jpeg-colorSpace jpeg) 'DeviceCMYK) + (dict-set! ($img-obj jpeg) 'Decode '(1.0 0.0 1.0 0.0 1.0 0.0 1.0 0.0))) + (file-position ($img-data jpeg) 0) + (ref-write ($img-obj jpeg) ($img-data jpeg)) + (ref-end ($img-obj jpeg)))) (define (read-16bit-integer ip-or-bytes) (define signed #f) (define big-endian #t) @@ -70,8 +74,11 @@ https://github.com/mbutterick/pdfkit/blob/master/lib/image/jpeg.coffee [ip ip])) signed big-endian)) - (module+ test (require rackunit) (check-equal? (number->string (read-16bit-integer (bytes #x12 #x34 #x56)) 16) "1234") - (make-object JPEG (open-input-file "../ptest/assets/test.jpeg"))) \ No newline at end of file + (define my-jpeg (make-jpeg (open-input-file "../ptest/assets/test.jpeg"))) + (check-equal? ($img-height my-jpeg) 533) + (check-equal? ($img-width my-jpeg) 400) + (check-equal? ($jpeg-channels my-jpeg) 3) + (check-equal? ($jpeg-colorSpace my-jpeg) 'DeviceRGB)) \ No newline at end of file diff --git a/pitfall/pitfall/png.rkt b/pitfall/pitfall/png.rkt index 179debfc..ad1ca0eb 100644 --- a/pitfall/pitfall/png.rkt +++ b/pitfall/pitfall/png.rkt @@ -28,89 +28,89 @@ https://github.com/mbutterick/pdfkit/blob/master/lib/image/png.coffee ($png data label width height obj png-embed image pixel-bit-length img-data alpha-channel)) (define (png-embed png) - (unless ($img-obj png) - (set-$img-obj! png - (make-ref - (mhash 'Type 'XObject - 'Subtype 'Image - 'BitsPerComponent (hash-ref ($png-image png) 'bits) - 'Width ($img-width png) - 'Height ($img-height png) - 'Filter 'FlateDecode))) + (unless ($img-obj png) + (set-$img-obj! png + (make-ref + (mhash 'Type 'XObject + 'Subtype 'Image + 'BitsPerComponent (hash-ref ($png-image png) 'bits) + 'Width ($img-width png) + 'Height ($img-height png) + 'Filter 'FlateDecode))) - (unless (hash-ref ($png-image png) 'hasAlphaChannel #f) - (define params (make-ref - (mhash 'Predictor 15 - '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)) + (unless (hash-ref ($png-image png) 'hasAlphaChannel #f) + (define params (make-ref + (mhash 'Predictor 15 + '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? ($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 ($png-image png) 'palette)) - (ref-end palette-ref) - ;; build the color space array for the image - (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-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 ($png-image png) 'palette)) + (ref-end palette-ref) + ;; build the color space array for the image + (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 ($png-image png) 'transparency #f) - (cond - [(hash-ref (hash-ref ($png-image png) 'transparency) 'grayscale #f) - (error 'transparency-grayscale-not-implemented)] - [(hash-ref (hash-ref ($png-image png) 'transparency) 'rgb #f) - (error 'transparency-rgb-not-implemented)] - [(hash-ref (hash-ref ($png-image png) 'transparency) 'indexed #f) - (error 'transparency-indexed-not-implemented)])] - [(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-$png-img-data! png (deflate img-bytes)) - (set-$png-alpha-channel! png (deflate alpha-bytes))])) + (cond + [(hash-ref ($png-image png) 'transparency #f) + (cond + [(hash-ref (hash-ref ($png-image png) 'transparency) 'grayscale #f) + (error 'transparency-grayscale-not-implemented)] + [(hash-ref (hash-ref ($png-image png) 'transparency) 'rgb #f) + (error 'transparency-rgb-not-implemented)] + [(hash-ref (hash-ref ($png-image png) 'transparency) 'indexed #f) + (error 'transparency-indexed-not-implemented)])] + [(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 png)) + (set-$png-img-data! png (deflate img-bytes)) + (set-$png-alpha-channel! png (deflate alpha-bytes))])) - (when ($png-alpha-channel png) - (define sMask-ref - (make-ref - (mhash 'Type 'XObject - 'Subtype 'Image - 'Height ($img-height png) - 'Width ($img-width png) - 'BitsPerComponent 8 - 'Filter 'FlateDecode - 'ColorSpace 'DeviceGray - 'Decode '(0 1)))) - (ref-write sMask-ref ($png-alpha-channel png)) - (ref-end sMask-ref) - (dict-set! ($img-obj png) 'SMask sMask-ref)) + (when ($png-alpha-channel png) + (define sMask-ref + (make-ref + (mhash 'Type 'XObject + 'Subtype 'Image + 'Height ($img-height png) + 'Width ($img-width png) + 'BitsPerComponent 8 + 'Filter 'FlateDecode + 'ColorSpace 'DeviceGray + 'Decode '(0 1)))) + (ref-write sMask-ref ($png-alpha-channel png)) + (ref-end sMask-ref) + (dict-set! ($img-obj png) 'SMask sMask-ref)) - ;; embed the actual image data - (ref-write ($img-obj png) ($png-img-data png)) - (ref-end ($img-obj png))) + ;; embed the actual image data + (ref-write ($img-obj png) ($png-img-data png)) + (ref-end ($img-obj png))) - (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 ($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))) - (define alpha-bytes (make-bytes argb-len)) - (for ([argb-bytes (in-port (λ (p) (read-bytes 4 p)))] - [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))) +(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 ($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))) + (define alpha-bytes (make-bytes argb-len)) + (for ([argb-bytes (in-port (λ (p) (read-bytes 4 p)))] + [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))) ;; test files