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

Modified Files: images.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/renderer/images.lisp 2005/07/17 09:38:54 1.3 +++ /project/closure/cvsroot/closure/src/renderer/images.lisp 2007/01/03 15:39:29 1.4 @@ -111,128 +111,14 @@ ((eq mime-type (netlib:find-mime-type "image/png")) (png:png-stream->aimage input)) ((eq mime-type (netlib:find-mime-type "image/gif")) - (let ((*print-array* nil)) - (gif-stream->aimage input))) - - ;; The rest simply goes to the appropriate ->ppm filters. + (imagelib:gif-stream->aimage input)) ((eq mime-type (netlib:find-mime-type "image/jpeg")) - (any->aimage-by-filter "djpeg" input)) + (imagelib:jpeg-stream->aimage input)) + ;; The rest simply goes to the appropriate ->ppm filters. ((eq mime-type (netlib:find-mime-type "image/x-xbitmap")) - (any->aimage-by-filter "xbmtopbm" input)) + (imagelib:any->aimage-by-filter "xbmtopbm" input)) ((eq mime-type (netlib:find-mime-type "image/x-xpixmap")) - (any->aimage-by-filter "xpmtoppm" input)) + (imagelib:any->aimage-by-filter "xpmtoppm" input)) ((eq mime-type (netlib:find-mime-type "image/tiff")) - (any->aimage-by-filter "tifftopnm" input)))) - -(defun gif-stream->aimage (input) - (with-temporary-file (temp-filename) - (let ((png-filename (merge-pathnames (make-pathname :type "png") - temp-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))))) - (unwind-protect - (progn - (run-unix-shell-command - (format nil "gif2png -r ~A >/dev/null 2>/dev/null" - (namestring (truename temp-filename)))) - (with-open-file (input png-filename - :direction :input - :element-type '(unsigned-byte 8)) - (let ((i (make-instance 'cl-byte-stream :cl-stream input))) - (png:png-stream->aimage i)))) - (ignore-errors - (mapc #'(lambda (x) (ignore-errors (delete-file x))) - (directory (merge-pathnames (make-pathname :type :wild) - temp-filename)))) )))) - -#+NIL -(defun gif-stream->aimage (input) - (imagelib.gif::read-gif-image input)) - -(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)))))) + (imagelib:any->aimage-by-filter "tifftopnm" input))))

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