[mcclim-cvs] CVS mcclim/Extensions/Images
thenriksen
thenriksen at common-lisp.net
Fri Jan 11 06:00:07 UTC 2008
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)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
More information about the Mcclim-cvs
mailing list