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