You cannot select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
typesetting/pitfall/pitfall/png.rkt

108 lines
3.9 KiB
Racket

This file contains invisible Unicode characters!

This file contains invisible Unicode characters that may be processed differently from what appears below. If your use case is intentional and legitimate, you can safely ignore this warning. Use the Escape button to reveal hidden characters.

#lang racket/base
(require "racket.rkt")
(require "png-reader.rkt" "zlib.rkt")
(provide PNG)
(define-subclass object% (PNG data [label #f])
(field [image (read-png data)]
[pixelBitlength (· image pixelBitlength)]
[width (· image width)]
[height (· image height)]
[imgData (· image imgData)]
[document #f]
[alphaChannel #f]
[obj #f])
(as-methods
embed
splitAlphaChannel))
(define/contract (embed this doc-in)
(object? . ->m . void?)
(set-field! document this doc-in)
(unless (· this obj)
(set-field! obj this
(send doc-in ref
(mhash 'Type "XObject"
'Subtype "Image"
'BitsPerComponent (· this image bits)
'Width (· this width)
'Height (· this height)
'Filter "FlateDecode")))
(unless (· this image hasAlphaChannel)
(define params (send doc-in ref (mhash 'Predictor 15
'Colors (· this image colors)
'BitsPerComponent (· this image bits)
'Columns (· this width))))
(hash-set! (· this obj payload) 'DecodeParms params)
(send params end))
(cond
[(hash-ref (· this image) 'palette #f)
;; embed the color palette in the PDF as an object stream
(define palette-ref (· doc-in ref))
(send palette-ref end (· this image palette))
;; build the color space array for the image
(hash-set! (· this object payload) 'Colorspace
(list "Indexed" "DeviceRGB" (sub1 (bytes-length (· this image palette))) palette-ref))]
[else (hash-set! (· this obj payload) 'ColorSpace "DeviceRGB")])
(cond
[(hash-ref (· this image) 'transparency #f)
(cond
[(hash-ref (hash-ref (· this image) 'transparency) 'grayscale #f)
(error 'transparency-grayscale-not-implemented)]
[(hash-ref (hash-ref (· this image) 'transparency) 'rgb #f)
(error 'transparency-rgb-not-implemented)]
[(hash-ref (hash-ref (· this image) 'transparency) 'indexed #f)
(error 'transparency-indexed-not-implemented)])]
[(hash-ref (· this image) '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.]
(· this splitAlphaChannel)]))
(when (· this alphaChannel)
(define sMask
(send (· this document) ref
(mhash 'Type "XObject"
'Subtype "Image"
'Height (· this height)
'Width (· this width)
'BitsPerComponent 8
'Filter "FlateDecode"
'ColorSpace "DeviceGray"
'Decode '(0 1))))
(send sMask end (· this alphaChannel))
(hash-set! (· this obj payload) 'SMask sMask))
;; embed the actual image data
(send (· this obj) end (· this imgData)))
(define/contract (splitAlphaChannel this)
(->m void?)
(define pixels
(decodePixels (· this imgData) (· this pixelBitlength) (· this width) (· this height)))
(define-values (imgBytes alphaBytes)
(for/fold ([img-bytes empty]
[alpha-bytes empty])
([b (in-bytes pixels)]
[which (in-cycle '(img img img alpha))])
(if (eq? which 'alpha)
(values img-bytes (cons b alpha-bytes))
(values (cons b img-bytes) alpha-bytes))))
(set-field! imgData this (deflate (apply bytes (reverse imgBytes))))
(set-field! alphaChannel this (deflate (apply bytes (reverse alphaBytes)))))
#;(module+ test
(define pic (make-object PNG (file->bytes "test/assets/test.png")))
(splitAlphaChannel pic))