Update of /project/closure/cvsroot/closure/src/imagelib In directory clnet:/tmp/cvs-serv29995/src/imagelib

Modified Files: package.lisp basic.lisp Log Message: Load GIF images using the Skippy library, instead of the external application gif2png. Reorganize the image code in the process.

--- /project/closure/cvsroot/closure/src/imagelib/package.lisp 2006/12/31 11:48:18 1.4 +++ /project/closure/cvsroot/closure/src/imagelib/package.lisp 2007/01/03 15:39:29 1.5 @@ -39,10 +39,10 @@ #:aimage-plist #:make-aimage #:scale-aimage - #:pnm-stream->aimage)) - -(defpackage :imagelib.gif - (:use :cl :glisp :imagelib)) + #:gif-stream->aimage + #:jpeg-stream->aimage + #:pnm-stream->aimage + #:any->aimage-by-filter))

(defpackage :png (:use :cl :glisp :imagelib) --- /project/closure/cvsroot/closure/src/imagelib/basic.lisp 2005/03/13 18:02:00 1.3 +++ /project/closure/cvsroot/closure/src/imagelib/basic.lisp 2007/01/03 15:39:29 1.4 @@ -297,3 +297,83 @@ :alpha-p nil)))

+(defun any->aimage-by-filter (filter-name input) + (with-temporary-file (temp-filename) + (with-temporary-file (pnm-filename) + (with-open-file (sink temp-filename + :direction :output + :if-exists :overwrite + :element-type '(unsigned-byte 8)) + (let ((sink (make-instance 'glisp:cl-byte-stream :cl-stream sink))) + (let ((tmp (make-array 4096 :element-type '(unsigned-byte 8)))) + (do ((n (g/read-byte-sequence tmp input) + (g/read-byte-sequence tmp input))) + ((= n 0)) + (g/write-byte-sequence tmp sink :end n))))) + (let ((cmd (format nil "~A <~A >~A" filter-name + (namestring (truename temp-filename)) + (namestring pnm-filename)))) + (format *debug-io* "~%;; running: ~A" cmd) + (run-unix-shell-command cmd)) + (progn ;ignore-errors + (with-open-file (input pnm-filename + :direction :input + :element-type '(unsigned-byte 8)) + (pnm-stream->aimage + (make-instance 'cl-byte-stream :cl-stream input)))) ))) + + +;;; Image writers + +(defun write-ppm-image (aimage sink) + ;; We write P3/P6 images + (let ((binary-p (subtypep (stream-element-type sink) '(unsigned-byte 8)))) + (let ((header + (with-output-to-string (bag) + (format bag "~A~%" (if binary-p "P6" "P3")) + (format bag "~D ~D ~D" (aimage-width aimage) (aimage-height aimage) 255)))) + (if binary-p + (write-sequence (map '(array (unsigned-byte 8) (*)) #'char-code header) sink) + (write-string header sink)) + (cond (binary-p + (write-byte 10 sink) + (let ((buffer (make-array (* 3 (aimage-width aimage)) :element-type '(unsigned-byte 8))) + (width (aimage-width aimage)) + (data (aimage-data aimage)) + (i 0)) + (declare (type (simple-array (unsigned-byte 8) (*)) buffer) + (type (array (unsigned-byte 32) (* *)) data) + (type fixnum width) + (type fixnum i)) + (dotimes (y (aimage-height aimage)) + (setf i 0) + (do ((x 0 (the fixnum (+ x 1)))) + ((= x width)) + (declare (type fixnum x)) + (let ((byte (aref data y x))) + (declare (type (unsigned-byte 8) byte)) + (setf (aref buffer i) (ldb (byte 8 0) byte)) + (setf i (the fixnum (+ i 1))) + (setf (aref buffer i) (ldb (byte 8 8) byte)) + (setf i (the fixnum (+ i 1))) + (setf (aref buffer i) (ldb (byte 8 16) byte)) + (setf i (the fixnum (+ i 1))))) + (write-sequence buffer sink)))) + (t + (dotimes (y (aimage-height aimage)) + (dotimes (x (aimage-width aimage)) + (when (= (mod x 4) 0) + (terpri sink)) + (let ((byte (aref (aimage-data aimage) y x))) + (format sink " ~D ~D ~D" + (ldb (byte 8 0) byte) + (ldb (byte 8 8) byte) + (ldb (byte 8 16) byte)) ))) + (terpri sink)))))) + +(defun blu (aimage) + (with-open-file (sink "/tmp/a.ppm" + :direction :output + :if-exists :new-version + :element-type '(unsigned-byte 8)) + (write-ppm-image aimage sink)))