mbutterick
/
typesetting
2
1
Fork 0
Code Issues 13 Pull Requests Projects Releases Wiki Activity

structify png

Browse Source
main
Matthew Butterick 5 years ago
parent e5abd44d7d
commit 7a4caade84
4 changed files with 65 additions and 62 deletions
Show Stats Download Patch File Download Diff File

2
pitfall/pitfall/core.rkt
Unescape Escape View File

@ -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))])

8
pitfall/pitfall/image.rkt
Unescape Escape View File

@ -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))

14
pitfall/pitfall/images.rkt
Unescape Escape View File

@ -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)

103
pitfall/pitfall/png.rkt
Unescape Escape View File

@ -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)))
(define pic (make-png (open-input-file "../ptest/assets/death-alpha.png")))
(define-values (img alpha) (split-alpha-channel pic)))
Write Preview
Loading…
Cancel
Save