Update of /project/mcclim/cvsroot/mcclim/Extensions/Images In directory clnet:/tmp/cvs-serv2033/Extensions/Images
Modified Files: gif.lisp image-viewer.lisp images.lisp jpeg.lisp package.lisp xpm.lisp Log Message: Changed MCCLIM-IMAGES:LOAD-IMAGE to create an instance of an image class containing size information. Fixex JPEG reading.
--- /project/mcclim/cvsroot/mcclim/Extensions/Images/gif.lisp 2008/01/09 10:20:23 1.3 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/gif.lisp 2008/01/11 06:00:06 1.4 @@ -23,10 +23,11 @@ (define-image-reader "gif" (image-pathname &key) (let* ((data-stream (skippy:load-data-stream image-pathname)) (first-image (aref (skippy:images data-stream) 0)) - (pattern-array (make-array (list (skippy:height first-image) - (skippy:width first-image)))) + (image-height (skippy:height first-image)) + (image-width (skippy:width first-image)) + (pattern-array (make-array (list image-height image-width))) (designs (coerce (loop with color-table = (skippy:color-table data-stream) - with transparency-index = (skippy:transparency-index first-image) + with transparency-index = (skippy:transparency-index first-image) for i below (skippy:color-table-size color-table) when (and transparency-index (= i transparency-index)) collect +transparent-ink+ @@ -35,7 +36,8 @@ (skippy:color-rgb (skippy:color-table-entry color-table i)) (make-rgb-color (/ r 255) (/ g 255) (/ b 255)))) 'vector))) - (dotimes (y (array-dimension pattern-array 0)) - (dotimes (x (array-dimension pattern-array 1)) + (dotimes (y image-height) + (dotimes (x image-width) (setf (aref pattern-array y x) (skippy:pixel-ref first-image x y)))) - (make-pattern pattern-array designs))) + (make-image (make-pattern pattern-array designs) + image-height image-width))) --- /project/mcclim/cvsroot/mcclim/Extensions/Images/image-viewer.lisp 2008/01/09 19:27:39 1.1 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/image-viewer.lisp 2008/01/11 06:00:06 1.2 @@ -45,6 +45,10 @@ ;; Clear the old image. (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane) (draw-rectangle* (sheet-medium pane) x1 y1 x2 y2 :ink +background-ink+)) - ;; Draw the new one, if there is one. (when (gadget-value pane) - (draw-design pane (gadget-value pane)))) + ;; Try to ensure there is room for the new image. + (change-space-requirements pane + :height (image-height (gadget-value pane)) + :width (image-width (gadget-value pane))) + ;; Draw the new one, if there is one. + (draw-image pane (gadget-value pane)))) --- /project/mcclim/cvsroot/mcclim/Extensions/Images/images.lisp 2008/01/06 08:36:57 1.1 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/images.lisp 2008/01/11 06:00:06 1.2 @@ -27,7 +27,7 @@ file to be read, and any keyword arguments provided by the user.")
-(defun image-format-supported (format) +(defun image-format-supported-p (format) "Return true if `format' is supported by `load-image'." (not (null (gethash format *image-readers*))))
@@ -49,18 +49,42 @@ image format `format'." (error 'unsupported-image-format :image-format format))
+(defclass image () + ((%image-design :reader image-design + :initarg :image-design + :initform (error "A design must be provided for the image")) + (%width :reader image-width + :initarg :image-width + :initform (error "A width must be provided for the image")) + (%height :reader image-height + :initarg :image-height + :initform (error "A width must be provided for the image")))) + +(defun make-image (design height width) + "Make and return an instance of `image' with the specified +`design', `width' and `height'." + (make-instance 'image :image-design design + :image-height height + :image-width width)) + +(defun draw-image (stream image) + "Draw `image' to `stream'. `Stream' must be a sufficiently +powerful output stream (probably an `extended-output-stream')." + (draw-design stream (image-design image))) + (defun load-image (image-pathname &rest args &key) "Load an image from `image-pathname', with the format of the -image being the pathname-type of `image-pathname'. `Args' can be -any keyword-arguments, they will be passed on to the image reader -function for the relevant image format. If the image format is -not recognised, an error of type `unsupprted-image-format' will -be signalled." +image being the pathname-type of `image-pathname'. Returns an +instance of class `image'. `Args' can be any keyword-arguments, +they will be passed on to the image reader function for the +relevant image format. If the image format is not recognised, an +error of type `unsupprted-image-format' will be signalled." (apply #'load-image-of-format (pathname-type image-pathname) image-pathname args))
(defun load-image-of-format (format image-pathname &rest args &key) - "Load an image of format `format' from `image-pathname'. `Args' + "Load an image of format `format' from +`image-pathname'. Returns an instance of class `image'. `Args' can be any keyword-arguments, they will be passed on to the image reader function for `format'. If the image format is not recognised, an error of type `unsupprted-image-format' will be --- /project/mcclim/cvsroot/mcclim/Extensions/Images/jpeg.lisp 2008/01/07 12:54:02 1.2 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/jpeg.lisp 2008/01/11 06:00:06 1.3 @@ -31,15 +31,18 @@ (rgb-image (make-instance 'clim-internals::rgb-image :width width :height height :alphap nil :data rgb-image-data))) - (loop for y from (1- height) downto 0 do - (loop for x from (1- width) downto 0 do - (let ((grey (svref rgb (+ x (* y width))))) - (setf (aref rgb-image-data y x) - (dpb grey (byte 8 0) - (dpb grey (byte 8 8) - (dpb grey (byte 8 16) - (dpb (- 255 0) (byte 8 24) 0)))))))) - (clim-internals::make-rgb-image-design rgb-image))))) + (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 rgb-image-data y x) + (dpb red (byte 8 0) + (dpb green (byte 8 8) + (dpb blue (byte 8 16) + (dpb (- 255 0) (byte 8 24) 0)))))))) + (make-image (clim-internals::make-rgb-image-design rgb-image) + height width)))))
(define-image-reader "jpg" (pathname) (load-image-of-format "jpeg" pathname)) --- /project/mcclim/cvsroot/mcclim/Extensions/Images/package.lisp 2008/01/09 19:27:39 1.2 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/package.lisp 2008/01/11 06:00:06 1.3 @@ -22,7 +22,9 @@
(defpackage :mcclim-images (:use :clim-lisp :clim) - (:export :export #:image-format-supported + (:export #:image-format-supported-p + #:image #:image-width #:image-height + #:draw-image #:load-image #:load-image-of-format #:unsupported-image-format #:image-format #:image-viewer #:image-viewer-pane)) --- /project/mcclim/cvsroot/mcclim/Extensions/Images/xpm.lisp 2008/01/06 08:36:57 1.1 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/xpm.lisp 2008/01/11 06:00:06 1.2 @@ -442,7 +442,10 @@
(define-image-reader "xpm" (pathname &key) (with-open-file (input pathname :element-type '(unsigned-byte 8)) - (xpm-parse-stream input))) + (let ((pattern (xpm-parse-stream input))) + (make-image pattern + (pattern-height pattern) + (pattern-width pattern)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;