[mcclim-cvs] CVS mcclim/Extensions/Bitmap-formats

[rstrandh]

Update of /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats
In directory cl-net:/tmp/cvs-serv2246

Modified Files:
	jpeg.lisp 
Log Message:
Patch from Cyrus Harmon to make it possible to read grayscale jpeg
files.


--- /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats/jpeg.lisp	2008/04/14 16:46:30	1.1
+++ /project/mcclim/cvsroot/mcclim/Extensions/Bitmap-formats/jpeg.lisp	2009/06/07 06:56:49	1.2
@@ -23,22 +23,32 @@
 (in-package :clim-internals)
 
 (define-bitmap-file-reader :jpeg (pathname)
-  (with-open-file (stream pathname :direction :input)
-    (multiple-value-bind (rgb height width)
-        (jpeg::decode-image stream)
-      (let* ((array (make-array (list height width)
-                     :element-type '(unsigned-byte 32))))
-        (dotimes (x width)
-          (dotimes (y height)
-            (let ((blue (aref rgb (+ (* x 3) (* y width 3))))
-                  (green (aref rgb (+ (* x 3) (* y width 3) 1)))
-                  (red (aref rgb (+ (* x 3) (* y width 3) 2))))
-              (setf (aref array y x)
-                    (dpb red (byte 8 0)
-                         (dpb green (byte 8 8)
-                              (dpb blue (byte 8 16)
-                                   (dpb (- 255 0) (byte 8 24) 0))))))))
-        array))))
+  (multiple-value-bind (rgb height width ncomp)
+      (jpeg:decode-image pathname)
+    (let* ((array (make-array (list height width)
+                              :element-type '(unsigned-byte 32))))
+      (case ncomp
+        (3
+         (dotimes (x width)
+           (dotimes (y height)
+             (let ((blue (aref rgb (+ (* x 3) (* y width 3))))
+                   (green (aref rgb (+ (* x 3) (* y width 3) 1)))
+                   (red (aref rgb (+ (* x 3) (* y width 3) 2))))
+               (setf (aref array y x)
+                     (dpb red (byte 8 0)
+                          (dpb green (byte 8 8)
+                               (dpb blue (byte 8 16)
+                                    (dpb (- 255 0) (byte 8 24) 0)))))))))
+        (1
+         (dotimes (x width)
+           (dotimes (y height)
+             (let ((gray (aref rgb (+ x (* y width)))))
+               (setf (aref array y x)
+                     (dpb gray (byte 8 0)
+                          (dpb gray (byte 8 8)
+                               (dpb gray (byte 8 16)
+                                    (dpb (- 255 0) (byte 8 24) 0))))))))))
+      array)))
 
 (define-bitmap-file-reader :jpg (pathname)
   (read-bitmap-file pathname :format :jpeg))