;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: GB-PNG; -*- ;;; --------------------------------------------------------------------------- ;;; Title: Reading .png Files ;;; Created: 1997-04-24 ;;; Author: Gilbert Baumann ;;; License: GPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1997-1998,2001 by Gilbert Baumann ;;; This program is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 2 of the License, or ;;; (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;;; NOTES ;; - This code is unbearable slow since passing data through the ;; inflator done in a far from optimal way. ;;;; Adler32 ? (defpackage :png (:use :common-lisp)) (in-package :png) #+NIL (defparameter *f* "clim:res;cross-20-b.png") ;;; Image formats to support: ;;; ;;; Color Allowed Interpretation ;;; Type Bit Depths ;;; ;;; 0 1,2,4,8,16 Each pixel is a grayscale sample. ;;; 2 8,16 Each pixel is an R,G,B triple. ;;; 3 1,2,4,8 Each pixel is a palette index; a PLTE chunk must appear. ;;; 4 8,16 Each pixel is a grayscale sample, followed by an alpha sample. ;;; 6 8,16 Each pixel is an R,G,B triple, followed by an alpha sample. ;;; (defvar *png-magic* '#(137 80 78 71 13 10 26 10) "The first eight bytes of a png file.") (defstruct png-image ihdr idat plte transparent-color ;either nil or ; color model 0: a gray scale sample ; color model 2: #(r g b) ) (defstruct ihdr width height bit-depth color-type compression-method filter-method interlace-method) ;; CODE DUPLICATION ALERT! killed+yanked from images.lisp (defun full-read-sequence (sequence input &key (start 0) (end (length sequence))) (unless (<= end start) (do ((i 0 n) (n (read-sequence sequence input :start 0) (read-sequence sequence input :start n))) ((or (= i n) (>= n end)) (when (= i n) (error "EOF during ~S." 'full-read-sequence)))))) (defun read-png-signature-p (source) "Checks for PNG signature." ;; Returns non-NIL if the first eight bytes read from 'source' is the valid PNG header, NIL otherwise. ;; If eof occurs while reading from source NIL is returned (dotimes (i (length *png-magic*) t) (when (not (eql (read-byte source nil 256) (aref *png-magic* i))) (return nil)))) (defun read-fixed-string (source n) "Read exactly 'n' bytes from 'source' and makeup an iso-latin-1 string." ;;Bug: iso-latin-1 encoding of chars expected (let ((temp (make-array n :element-type '(unsigned-byte 8)))) (full-read-sequence temp source) (map 'string #'code-char temp) )) (defun read-chunk (source) "Read a PNG chunk from 'source' and return the chunk type, a four character string, and a vector containing the data bytes. The CRC is not included into the data bytes. If eof occurs return NIL." ;;TODO: check for CRC errors (let ((length (read-unsigned-byte-32/be source nil nil))) (cond (length (let* ((type (read-fixed-string source 4)) (data (make-array length :element-type '(unsigned-byte 8) :initial-element 0))) (full-read-sequence data source) (read-unsigned-byte-32/be source);the crc (values type data) )) (t nil) ))) (defun read-unsigned-byte-32/be (source &optional (eof-error-p t) eof-value) "Reads unsigned byte 32 from an byte stream in network order" ;; TODO: correct handling of eof-error-p (logior (ash (read-byte source eof-error-p eof-value) 24) (ash (read-byte source eof-error-p eof-value) 16) (ash (read-byte source eof-error-p eof-value) 8) (ash (read-byte source eof-error-p eof-value) 0))) (defun decode-unsigned-byte-32 (data offset) "Decode an (unsigned-byte 32) from the byte vector 'data' starting at 'offset' in network order." (declare (type (vector (unsigned-byte 8)) data) (type fixnum offset)) (logior (ash (aref data (+ offset 0)) 24) (ash (aref data (+ offset 1)) 16) (ash (aref data (+ offset 2)) 8) (ash (aref data (+ offset 3)) 0))) (defun decode-unsigned-byte-16 (data offset) "Decode an (unsigned-byte 16) from the byte vector 'data' starting at 'offset' in network order." (declare (type (vector (unsigned-byte 8)) data) (type fixnum offset)) (logior (ash (aref data (+ offset 0)) 8) (ash (aref data (+ offset 1)) 0))) (defun encode-unsigned-byte-32 (byte &optional target (offset 0)) (let ((target (or target (make-array 4 :element-type '(unsigned-byte 8))))) (setf (aref target (+ offset 0)) (ldb (byte 8 24) byte) (aref target (+ offset 1)) (ldb (byte 8 16) byte) (aref target (+ offset 2)) (ldb (byte 8 8) byte) (aref target (+ offset 3)) (ldb (byte 8 0) byte)) (values target (+ 4 offset)))) (defun decode-ihdr (data) "Decode an IHDR chunk from data." (declare (type (vector (unsigned-byte 8)) data)) (make-ihdr :width (decode-unsigned-byte-32 data 0) :height (decode-unsigned-byte-32 data 4) :bit-depth (aref data 8) :color-type (aref data 9) :compression-method (aref data 10) :filter-method (aref data 11) :interlace-method (aref data 12))) (defun decode-plte (data) "Decode a PLTE chunk from the byte vector 'data'." (declare (type (vector (unsigned-byte 8)) data)) (assert (zerop (mod (length data) 3))) (let* ((len (floor (length data) 3)) (palette (make-array len))) (loop for i from 0 to (1- len) do (setf (aref palette i) (vector (aref data (+ (* i 3) 0)) (aref data (+ (* i 3) 1)) (aref data (+ (* i 3) 2)) 255)) ) palette)) (defun decode-trns (palette data) (when palette (dotimes (i (length data)) (setf (svref (aref palette i) 3) (aref data i)))) (let ((*print-array* t)) (print palette))) (defun read-png-image (input) (unless (read-png-signature-p input) (error "~A is probably no PNG file." input)) (let ((idat '#()) (plte nil) (ihdr nil) (transparent-color nil)) (do ((x (multiple-value-list (read-chunk input)) (multiple-value-list (read-chunk input)))) ((or (null (car x)) (string= (car x) "IEND")) (cond ((null (car x)) (error "png file lacks an IEND chunk")))) (let ((data (cadr x)) (type (car x))) (let ((*print-array* nil)) (cond ((string= type "IHDR") (setq ihdr (decode-ihdr data)) ) ((string= type "PLTE") (setq plte (decode-plte data)) ) ;; ((string= type "tRNS") (cond ((null ihdr) (warn "tRNS chunk without IHDR ignored")) ((case (ihdr-color-type ihdr) (3 (if plte (decode-trns plte data) (warn "tRNS chunk without PLTE."))) (2 (setf transparent-color (vector (decode-unsigned-byte-16 data 0) (decode-unsigned-byte-16 data 2) (decode-unsigned-byte-16 data 4)))) (0 (setf transparent-color (decode-unsigned-byte-16 data 0))) (otherwise (warn "tRNS chunk with color model ~D ignored." (ihdr-color-type ihdr))) )))) ;; ((string= type "tEXt") (let ((p (position 0 data))) (format nil "~%;Text: `~A' = `~A'." (map 'string #'code-char (subseq data 0 p)) (map 'string #'code-char (subseq data (+ p 1)))))) #+NIL ((string= type "zTXt") (let ((p (position 0 data))) (format nil "~%;zText: `~A' = `~A'." (map 'string #'code-char (subseq data 0 p)) (map 'string #'code-char (png::rfc1951-uncompress-octects (subseq data (+ p 4))) )))) ((string= type "IDAT") ;; ### (setf idat (concatenate '(simple-array (unsigned-byte 8) (*)) idat data))) (t (warn "Unprocessed chunk of type ~S / ~S." type data)) )))) (make-png-image :plte plte :idat (rfc1951-uncompress-octects idat :start 2) :ihdr ihdr :transparent-color transparent-color) )) (defun png-image-row-length (im) (let ((width (ihdr-width (png-image-ihdr im))) (bit-depth (ihdr-bit-depth (png-image-ihdr im))) (color-type (ihdr-color-type (png-image-ihdr im)))) (+ 1 (ceiling (* width (ecase color-type (0 bit-depth) (2 (* 3 bit-depth)) (3 bit-depth) (4 (* 2 bit-depth)) (6 (* 4 bit-depth)))) 8)) )) (defun paeth-predictor (a b c) (let* ((p (- (+ a b) c)) ;initial estimate (pa (abs (- p a))) ;distances to a, b, c (pb (abs (- p b))) (pc (abs (- p c)))) ;; return nearest of a,b,c, ;; breaking ties in order a,b,c. (cond ((and (<= pa pb) (<= pa pc)) a) ((<= pb pc) b) (t c) ) )) (defun apply-png-filter (filter data j j0 len bpp) (dotimes (x len) (let ((raw (aref data (+ j x))) (above (if j0 (aref data (+ j0 x)) 0)) (left (if (>= (- x bpp) 0) (aref data (+ j x (- bpp))) 0)) (left-above (if (and j0 (>= (- x bpp) 0)) (aref data (+ j0 x (- bpp))) 0))) (setf (aref data (+ j x)) (ecase filter (0 raw) (1 (logand #xFF (+ raw left))) (2 (logand #xFF (+ raw above))) (3 (logand #xFF (+ raw (floor (+ left above) 2)))) (4 (logand #xFF (+ raw (paeth-predictor left above left-above)) ))))))) (defun png-image-bits-per-pixel (im) (let ((bit-depth (ihdr-bit-depth (png-image-ihdr im))) (color-type (ihdr-color-type (png-image-ihdr im)))) (ecase color-type (0 bit-depth) (2 (* 3 bit-depth)) (3 bit-depth) (4 (* 2 bit-depth)) (6 (* 4 bit-depth))))) (defun png-image-bytes-per-pixel (im) (ceiling (png-image-bits-per-pixel im) 8)) (defun get-sample (data i j bit-depth) (ecase bit-depth (1 (ldb (byte 1 (- 7 (mod i 8))) (aref data (+ (floor i 8) j)))) (2 (ldb (byte 2 (* 2 (- 3 (mod i 4)))) (aref data (+ (floor i 4) j)))) (4 (ldb (byte 4 (* 4 (- 1 (mod i 2)))) (aref data (+ (floor i 2) j)))) (8 (aref data (+ i j))) (16 (logior (ash (aref data (+ (* 2 i) j)) 8) (aref data (+ (* 2 i) 1 j)))) )) (defun get-sample* (data i j bit-depth) (ecase bit-depth (1 (* 255 (get-sample data i j bit-depth))) (2 (* 85 (get-sample data i j bit-depth))) (4 (* 17 (get-sample data i j bit-depth))) (8 (get-sample data i j bit-depth)) (16 (ldb (byte 8 8) (get-sample data i j bit-depth))) )) (defun render-filtered-row (im bit-depth color-type transparent-color data j y x0 dx width pw ph put-pixel) (do ((x x0 (+ x dx)) (i 0 (+ i 1))) ((>= x width)) (ecase color-type (0 (if (and transparent-color (= transparent-color (get-sample data i (+ j 1) bit-depth))) (funcall put-pixel x y 0 0 0 0 pw ph) (let ((v (get-sample* data i (+ j 1) bit-depth))) (funcall put-pixel x y v v v 255 pw ph)))) (2 (if (and (not (null transparent-color)) (let ((rsample (get-sample data (+ 0 (* 3 i)) (+ j 1) bit-depth)) (gsample (get-sample data (+ 1 (* 3 i)) (+ j 1) bit-depth)) (bsample (get-sample data (+ 2 (* 3 i)) (+ j 1) bit-depth))) (and (eql rsample (aref transparent-color 0)) (eql gsample (aref transparent-color 1)) (eql bsample (aref transparent-color 2))))) (funcall put-pixel x y 0 0 0 0 pw ph) (let ((r (get-sample* data (+ 0 (* 3 i)) (+ j 1) bit-depth)) (g (get-sample* data (+ 1 (* 3 i)) (+ j 1) bit-depth)) (b (get-sample* data (+ 2 (* 3 i)) (+ j 1) bit-depth))) (funcall put-pixel x y r g b 255 pw ph)))) (3 (let* ((i (get-sample data i (+ j 1) bit-depth)) (p (aref (png-image-plte im) i))) (funcall put-pixel x y (aref p 0) (aref p 1) (aref p 2) (aref p 3) pw ph))) (4 (let ((v (get-sample* data (+ 0 (* i 2)) (+ j 1) bit-depth)) (a (get-sample* data (+ 1 (* i 2)) (+ j 1) bit-depth))) (funcall put-pixel x y v v v a pw ph))) (6 (let ((r (get-sample* data (+ 0 (* 4 i)) (+ j 1) bit-depth)) (g (get-sample* data (+ 1 (* 4 i)) (+ j 1) bit-depth)) (b (get-sample* data (+ 2 (* 4 i)) (+ j 1) bit-depth)) (a (get-sample* data (+ 3 (* 4 i)) (+ j 1) bit-depth))) (funcall put-pixel x y r g b a pw ph))) ) )) (defun render-png-image (im) (let* ((bpp (png-image-bytes-per-pixel im)) (data (png-image-idat im)) (bit-depth (ihdr-bit-depth (png-image-ihdr im))) (width (ihdr-width (png-image-ihdr im))) (height (ihdr-height (png-image-ihdr im))) (color-type (ihdr-color-type (png-image-ihdr im))) (res (make-array (list height width 4) :element-type '(unsigned-byte 8))) (transparent-color (png-image-transparent-color im))) (labels ((put-pixel (x y r g b a pw ph) pw ph a (setf (aref res y x 0) r (aref res y x 1) g (aref res y x 2) b (aref res y x 3) a))) (case (ihdr-interlace-method (png-image-ihdr im)) (0 (let ((row-len (png-image-row-length im))) (do ((y 0 (+ y 1)) (j 0 (+ j row-len)) (j0 nil j)) ((>= j (length data))) (apply-png-filter (aref data j) data (+ j 1) (if j0 (+ j0 1) nil) (1- row-len) bpp) (render-filtered-row im bit-depth color-type transparent-color data j y 0 1 width 1 1 #'put-pixel)))) (1 (let (j0 (j 0)) (do ((pass 7 (- pass 1))) ((< pass 1)) (let* ((y0 (aref '#(0 1 0 2 0 4 0 0) pass)) (x0 (aref '#(0 0 1 0 2 0 4 0) pass)) (dy (aref '#(1 2 2 4 4 8 8 8) pass)) (ph (aref '#(1 1 2 2 4 4 8 8) pass)) (dx (aref '#(1 1 2 2 4 4 8 8) pass)) (pw (aref '#(1 1 1 2 2 4 4 8) pass)) ) (let ((row-len (+ 1 (ceiling (* (png-image-bits-per-pixel im) (ceiling (- width x0) dx)) 8)))) (setf j0 nil) (when (> row-len 1) (do ((y y0 (+ y dy))) ((>= y height)) (apply-png-filter (aref data j) data (+ j 1) (if j0 (+ j0 1) nil) (1- row-len) bpp) (render-filtered-row im bit-depth color-type transparent-color data j y x0 dx width pw ph #'put-pixel) (psetf j (+ j row-len) j0 j)))))) (assert (= j (length data))) )) (t (error "Unknown interlace method: ~D." (ihdr-interlace-method (png-image-ihdr im)))) )) res)) (defun read-png-file (pathname) (with-open-file (input pathname :direction :input :element-type '(unsigned-byte 8)) (read-png-stream input))) (defun read-png-stream (input) (render-png-image (read-png-image input))) ;;;; -- RFC1951 decompression ----------------------------------------------------------------- ;; RFC1951-UNCOMPRESS-OCTECTS octects &key (start 0) ;;;; Note: This implementation is inherently sloooow. ;;;; On the other hand it is safe and complete and easily verify-able. ;;;; (defconstant *length-encoding* '#((0 3) (0 4) (0 5) (0 6) (0 7) (0 8) (0 9) (0 10) (1 11) (1 13) (1 15) (1 17) (2 19) (2 23) (2 27) (2 31) (3 35) (3 43) (3 51) (3 59) (4 67) (4 83) (4 99) (4 115) (5 131) (5 163) (5 195) (5 227) (0 258) )) (defconstant *dist-encoding* '#( (0 1) (0 2) (0 3) (0 4) (1 5) (1 7) (2 9) (2 13) (3 17) (3 25) (4 33) (4 49) (5 65) (5 97) (6 129) (6 193) (7 257) (7 385) (8 513) (8 769) (9 1025) (9 1537) (10 2049) (10 3073) (11 4097) (11 6145) (12 8193) (12 12289) (13 16385) (13 24577))) (defconstant *fixed-huffman-code-lengths* (let ((res (make-array 288))) (loop for i from 0 to 143 do (setf (aref res i) 8)) (loop for i from 144 to 255 do (setf (aref res i) 9)) (loop for i from 256 to 279 do (setf (aref res i) 7)) (loop for i from 280 to 287 do (setf (aref res i) 8)) res)) (defstruct bit-stream (octets nil :type (vector (unsigned-byte 8))) ;a vector of octects (pos 0 :type fixnum)) ;bit position within octect stream (declaim (inline bit-stream-read-bit)) (declaim (inline bit-stream-read-byte)) (defmacro bit-stream-read-bit (source) (let ((g (gensym))) `(let ((,g ,source)) (prog1 (ldb (byte 1 (mod (bit-stream-pos ,g) 8)) (aref (bit-stream-octets ,g) (floor (bit-stream-pos ,g) 8))) (incf (bit-stream-pos ,g)) )) )) (defmacro bit-stream-read-byte (source n) "Read one unsigned byte of width 'n' from the bit stream 'source'." `(let ((source ,source) (n ,n) (res 0)) (dotimes (k n res) (setf res (logior res (ash (bit-stream-read-bit source) k))) ))) (defmacro bit-stream-read-reversed-byte (source n) "Read one unsigned byte of width 'n' from the bit stream 'source'." `(let ((source ,source) (n ,n) (res 0)) (dotimes (k n res) (setf res (logior res (ash (bit-stream-read-bit source) (1- (- n k))))) ))) (defun bit-stream-skip-to-byte-boundary (bs) (setf (bit-stream-pos bs) (* 8 (floor (+ 7 (bit-stream-pos bs)) 8)))) (defun bit-stream-read-symbol (source tree) "Read one symbol (code) from the bit-stream source using the huffman code provided by 'tree'." (do () ((atom tree) tree) (setf tree (if (zerop (bit-stream-read-bit source)) (car tree) (cdr tree))))) (defun build-huffman-tree (lengthen) "Build up a huffman tree given a vector of code lengthen as described in RFC1951." (let* ((max-bits (reduce #'max (map 'list #'identity lengthen))) (max-symbol (1- (length lengthen))) (bl-count (make-array (+ 1 max-bits) :initial-element 0)) (next-code (make-array (+ 1 max-bits) :initial-element 0)) (ht nil)) (loop for x across lengthen do (unless (zerop x) (incf (aref bl-count x)))) (let ((code 0)) (loop for bits from 1 to max-bits do (progn (setf code (ash (+ code (aref bl-count (1- bits))) 1)) (setf (aref next-code bits) code)))) (loop for n from 0 to max-symbol do (let ((len (aref lengthen n))) (unless (zerop len) (setf ht (huffman-insert ht len (aref next-code len) n)) (incf (aref next-code len)) ))) ht )) (defun huffman-insert (ht len code sym) (cond ((= 0 len) (assert (null ht)) sym) ((logbitp (- len 1) code) (unless (consp ht) (setq ht (cons nil nil))) (setf (cdr ht) (huffman-insert (cdr ht) (1- len) code sym)) ht) (t (unless (consp ht) (setq ht (cons nil nil))) (setf (car ht) (huffman-insert (car ht) (1- len) code sym)) ht) )) (defun rfc1951-read-huffman-code-lengthen (source code-length-huffman-tree number) (let ((res (make-array number :initial-element 0)) (i 0)) (do () ((= i number)) (let ((qux (bit-stream-read-symbol source code-length-huffman-tree))) (case qux (16 (let ((cnt (+ 3 (bit-stream-read-byte source 2)))) (dotimes (k cnt) (setf (aref res (+ i k)) (aref res (- i 1)))) (incf i cnt))) (17 (let ((cnt (+ 3 (bit-stream-read-byte source 3)))) (dotimes (k cnt) (setf (aref res (+ i k)) 0)) (incf i cnt))) (18 (let ((cnt (+ 11 (bit-stream-read-byte source 7)))) (dotimes (k cnt) (setf (aref res (+ i k)) 0)) (incf i cnt))) (otherwise (setf (aref res i) qux) (incf i)) ))) res)) (defun rfc1951-read-length-dist (source code hdists-ht) (values (+ (cadr (aref *length-encoding* (- code 257))) (bit-stream-read-byte source (car (aref *length-encoding* (- code 257))))) (let ((dist-sym (if hdists-ht (bit-stream-read-symbol source hdists-ht) (bit-stream-read-reversed-byte source 5) ))) (+ (cadr (aref *dist-encoding* dist-sym)) (bit-stream-read-byte source (car (aref *dist-encoding* dist-sym)))) ) )) (defun rfc1951-uncompress-octects (octects &key (start 0)) (let ((res (make-array (length octects) :fill-pointer 0 :adjustable t))) (rfc1951-uncompress-bit-stream (make-bit-stream :octets octects :pos (* 8 start)) res) res)) (defun rfc1951-uncompress-bit-stream (bs res) (let (final? ctype) (setf final? (= (bit-stream-read-bit bs) 1) ctype (bit-stream-read-byte bs 2)) (ecase ctype (0 ;; no compression (bit-stream-skip-to-byte-boundary bs) (let ((len (bit-stream-read-byte bs 16)) (nlen (bit-stream-read-byte bs 16))) (assert (= (lognot nlen) len)) (dotimes (k len) (vector-push-extend (bit-stream-read-byte bs 8) res 4096)))) (1 ;; compressed with fixed Huffman code (let ((literal-ht (build-huffman-tree *fixed-huffman-code-lengths*))) (do ((x (bit-stream-read-symbol bs literal-ht) (bit-stream-read-symbol bs literal-ht))) ((= x 256)) (cond ((<= 0 x 255) (vector-push-extend x res 4096)) (t (multiple-value-bind (length dist) (rfc1951-read-length-dist bs x nil) (dotimes (k length) (vector-push-extend (aref res (- (fill-pointer res) dist)) res 4096)))) )) )) (2 ;; compressed with dynamic Huffman codes (let* ((hlit (+ 257 (bit-stream-read-byte bs 5))) ;number of literal code lengths (hdist (+ 1 (bit-stream-read-byte bs 5))) ;number of distance code lengths (hclen (+ 4 (bit-stream-read-byte bs 4))) ;number of code lengths for code (hclens (make-array 19 :initial-element 0)) ; length huffman tree literal-ht distance-ht code-len-ht) ;; slurp the code lengths code lengths (loop for i from 1 to hclen for j in '(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15) do (setf (aref hclens j) (bit-stream-read-byte bs 3))) ;; slurp the huffman trees for literals and distances (setf code-len-ht (build-huffman-tree hclens)) (setf literal-ht (build-huffman-tree (rfc1951-read-huffman-code-lengthen bs code-len-ht hlit)) distance-ht (build-huffman-tree (rfc1951-read-huffman-code-lengthen bs code-len-ht hdist))) ;; actually slurp the contents (do ((x (bit-stream-read-symbol bs literal-ht) (bit-stream-read-symbol bs literal-ht))) ((= x 256)) (cond ((<= 0 x 255) (vector-push-extend x res 4096)) (t (multiple-value-bind (length dist) (rfc1951-read-length-dist bs x distance-ht) (dotimes (k length) (vector-push-extend (aref res (- (fill-pointer res) dist)) res 4096)))) )) )) ) (unless final? (rfc1951-uncompress-bit-stream bs res)) )) (defun read-png-chunks (stream &aux res) (unless (read-png-signature-p stream) (error "~A is probably no PNG file." stream)) (do ((x (multiple-value-list (read-chunk stream)) (multiple-value-list (read-chunk stream)))) ((null (car x))) (push x res)) (reverse res)) (defun read-png-chunks (input &aux res) (unless (read-png-signature-p input) (error "~A is probably no PNG file." input)) (let () (do ((x (multiple-value-list (read-chunk input)) (multiple-value-list (read-chunk input)))) ((or (null (car x)) (string= (car x) "IEND")) (cond ((null (car x)) (error "png file lacks an IEND chunk"))) (push x res) (reverse res)) (push x res)))) (defun write-png-signature (stream) (write-sequence *png-magic* stream)) (defun write-unsigned-byte-32/be (byte stream) (write-byte (ldb (byte 8 24) byte) stream) (write-byte (ldb (byte 8 16) byte) stream) (write-byte (ldb (byte 8 8) byte) stream) (write-byte (ldb (byte 8 0) byte) stream)) (declaim (type (simple-array (unsigned-byte 32) (256)) *crc-table*)) (defvar *crc-table* (let ((res (make-array 256 :element-type '(unsigned-byte 32)))) (dotimes (n 256) (let ((c n)) (dotimes (k 8) (if (logbitp 0 c) (setf c (logxor #xEDB88320 (ash c -1))) (setf c (ash c -1)))) (setf (aref res n) c))) res) "Table of CRCs of all 8-bit messages") ;; Update a running CRC with the bytes buf[0..len-1]--the CRC ;; should be initialized to all 1's, and the transmitted value ;; is the 1's complement of the final running CRC (see the ;; crc() routine below)). (defun update-crc (crc buf &optional (start 0) (end (length buf))) (declare (type fixnum start end) (type (unsigned-byte 32) crc) (type (simple-array (unsigned-byte 8) (*)) buf)) (let ((table *crc-table*)) (declare (type (simple-array (unsigned-byte 32) (256)) *crc-table*)) (setf crc (logxor #xFFFFFFFF crc)) (do ((i start (+ i 1))) ((>= i end) (logxor #xFFFFFFFF crc)) (declare (type fixnum i)) (setf crc (logxor (aref table (logand #xFF (logxor crc (aref buf i)))) (ash crc -8)))))) ;; (defun write-chunk (type data stream) (let ((chunk-type (map '(simple-array (unsigned-byte 8) (*)) #'char-code type)) (crc 0)) (assert (= 4 (length chunk-type))) (write-unsigned-byte-32/be (length data) stream) (write-sequence chunk-type stream) (write-sequence data stream) (setf crc (update-crc crc chunk-type) crc (update-crc crc data)) (write-unsigned-byte-32/be crc stream))) #+(or) (defun foo () (let ((cs (with-open-file (i "home:lisp.png" :direction :input :element-type '(unsigned-byte 8)) (read-png-chunks i)))) (loop for c in cs for (type data) in cs do (when (equal "tEXt" type) (print (map 'string #'code-char data))) (when (equal "gAMA" type) (setf (cadr c) (encode-unsigned-byte-32 (round (* (/ 2.4) 100000.0)))) (setf data (cadr c)) (print (decode-unsigned-byte-32 data 0)) (print `(:gamma ,(/ 100000.0 (decode-unsigned-byte-32 data 0)))) (print (coerce data 'list)))) '(setq cs (remove "gAMA" cs :key #'car :test #'equal)) (print cs) (with-open-file (o "home:lisp-gamma-24.png" :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede) (write-png-signature o) (loop for c in cs do (write-chunk (car c) (cadr c) o))))) #+(or) (defun bar (filename) (let ((cs (with-open-file (i filename :direction :input :element-type '(unsigned-byte 8)) (read-png-chunks i)))) (loop for (type data) in cs do (when (equal "tEXt" type) (print (map 'string #'code-char data))) (when (equal "gAMA" type) (print `(:gamma ,(/ 100000.0 (decode-unsigned-byte-32 data 0)))))) cs))