[closure-cvs] CVS closure/src/renderer

[emarsden]

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