Permalink
Browse files

added new gf coerce-image and use this in preference to the old conve…

…rt-image-... functions
  • Loading branch information...
1 parent f9e7057 commit 560f72db2f2bb393270c609fbf5ba29709e177ca @slyrus slyrus committed Mar 15, 2011
Showing with 207 additions and 177 deletions.
  1. +200 −0 coerce.lisp
  2. +1 −0 opticl.asd
  3. +0 −177 opticl.lisp
  4. +6 −0 package.lisp
View
@@ -0,0 +1,200 @@
+
+(in-package :opticl)
+
+(defun mean (&rest numbers)
+ (/ (apply #'+ numbers) (length numbers)))
+
+(defgeneric coerce-image (image type &key &allow-other-keys)
+ (:documentation "attempts to coerce a given image into the specified type."))
+
+(defmethod coerce-image (image (type (eql '8-bit-gray-image)) &rest args)
+ ;; work around ABCL etypecase bug
+ (declare (ignore args))
+
+ #-abcl
+ (etypecase image
+ (8-bit-gray-image image)
+ (1-bit-gray-image
+ (with-image-bounds (y x)
+ image
+ (let* ((gray-image (make-8-bit-gray-image y x)))
+ (do-pixels (i j) image
+ (setf (pixel gray-image i j)
+ (if (plusp (pixel image i j)) 255 0)))
+ gray-image)))
+ ((or rgb-image rgba-image)
+ (with-image-bounds (y x channels)
+ image
+ (let* ((type (array-element-type image))
+ (gray-image (make-8-bit-gray-image y x)))
+ (if (subtypep type 'integer)
+ (do-pixels (i j)
+ image
+ (multiple-value-bind (r g b)
+ (pixel image i j)
+ (setf (pixel gray-image i j)
+ (round (mean r g b)))))
+ (do-pixels (i j)
+ image
+ (multiple-value-bind (r g b)
+ (pixel image i j)
+ (setf (pixel gray-image i j)
+ (coerce (round (mean r g b)) type)))))
+ gray-image))))
+
+ ;; work around ABCL etypecase bug
+ #+abcl
+ (cond
+ ((typep image '8-bit-gray-image) image)
+
+ ((typep image '1-bit-gray-image)
+ (with-image-bounds (y x)
+ image
+ (let* ((gray-image (make-8-bit-gray-image y x)))
+ (do-pixels (i j) image
+ (setf (pixel gray-image i j)
+ (if (plusp (pixel image i j)) 255 0)))
+ gray-image)))
+
+ ((or (typep image 'rgb-image)
+ (typep image 'rgba-image))
+ (with-image-bounds (y x channels)
+ image
+ (let* ((type (array-element-type image))
+ (gray-image (make-8-bit-gray-image y x)))
+ (if (subtypep type 'integer)
+ (do-pixels (i j)
+ image
+ (multiple-value-bind (r g b)
+ (pixel image i j)
+ (setf (pixel gray-image i j)
+ (round (mean r g b)))))
+ (do-pixels (i j)
+ image
+ (multiple-value-bind (r g b)
+ (pixel image i j)
+ (setf (pixel gray-image i j)
+ (coerce (round (mean r g b)) type)))))
+ gray-image)))))
+
+(defmethod coerce-image (image (type (eql 'gray-image)) &key preserve-luminance &allow-other-keys)
+ (if preserve-luminance
+ (etypecase image
+ (gray-image image)
+ ((or rgb-image rgba-image)
+ (with-image-bounds (y x channels)
+ image
+ (let* ((type (array-element-type image))
+ (gray-image (make-array (list y x) :element-type type)))
+ (if (subtypep type 'integer)
+ (do-pixels (i j)
+ image
+ (multiple-value-bind (r g b)
+ (pixel image i j)
+ (setf (pixel gray-image i j)
+ (round
+ (+ (* r 0.2989)
+ (* g 0.5870)
+ (* b 0.1140))))))
+ (do-pixels (i j)
+ image
+ (multiple-value-bind (r g b)
+ (pixel image i j)
+ (setf (pixel gray-image i j)
+ (coerce (round
+ (+ (* r 0.2989)
+ (* g 0.5870)
+ (* b 0.1140))) type)))))
+ gray-image))))
+ (etypecase image
+ (gray-image image)
+ ((or rgb-image rgba-image)
+ (with-image-bounds (y x channels)
+ image
+ (let* ((type (array-element-type image))
+ (gray-image (make-array (list y x) :element-type type)))
+ (if (subtypep type 'integer)
+ (do-pixels (i j)
+ image
+ (multiple-value-bind (r g b)
+ (pixel image i j)
+ (setf (pixel gray-image i j)
+ (round (mean r g b)))))
+ (do-pixels (i j)
+ image
+ (multiple-value-bind (r g b)
+ (pixel image i j)
+ (setf (pixel gray-image i j)
+ (coerce (round (mean r g b)) type)))))
+ gray-image))))))
+
+(defmethod coerce-image (image (type (eql 'rgb-image)) &rest args)
+ (declare (ignore args))
+ (etypecase image
+ (gray-image
+ (with-image-bounds (y x channels)
+ image
+ (let* ((type (array-element-type image))
+ (rgb-image (make-array (list y x 3) :element-type type)))
+ (do-pixels (i j)
+ image
+ (let ((val (pixel image i j)))
+ (setf (pixel rgb-image i j)
+ (values val val val))))
+ rgb-image)))
+ (rgb-image image)
+ (rgba-image
+ (with-image-bounds (y x channels)
+ image
+ (let* ((type (array-element-type image))
+ (rgb-image (make-array (list y x 3) :element-type type)))
+ (do-pixels (i j)
+ image
+ (setf (pixel rgb-image i j)
+ (pixel image i j)))
+ rgb-image)))))
+
+(defmethod coerce-image (image (type (eql 'rgba-image)) &rest args)
+ (declare (ignore args))
+ (etypecase image
+ (gray-image
+ (with-image-bounds (y x channels)
+ image
+ (let* ((type (array-element-type image))
+ (rgba-image (make-array (list y x 4) :element-type type)))
+ (do-pixels (i j)
+ image
+ (let ((val (pixel image i j)))
+ (setf (pixel rgba-image i j)
+ (values val val val 255))))
+ rgba-image)))
+ (rgb-image
+ (with-image-bounds (y x channels)
+ image
+ (let* ((type (array-element-type image))
+ (rgba-image (make-array (list y x 4) :element-type type)))
+ (do-pixels (i j)
+ image
+ (setf (pixel* rgba-image i j)
+ (append (multiple-value-list (pixel image i j))
+ (list 255))))
+ rgba-image)))
+ (rgba-image image)))
+
+;;;
+;;; deprecated convert functions
+(defun convert-image-to-8-bit-grayscale (image)
+ (coerce image '8-bit-gray-image))
+
+(defun convert-image-to-grayscale (image)
+ (coerce-image image 'gray-image))
+
+(defun convert-image-to-grayscale-luminance (image)
+ (coerce-image image 'gray-image :preserve-luminance t))
+
+(defun convert-image-to-rgb (image)
+ (coerce-image image 'rgb-image))
+
+(defun convert-image-to-rgba (image)
+ (coerce-image image 'rgba-image))
+
View
@@ -11,6 +11,7 @@
(:static-file "COPYRIGHT")
(:file "package")
(:file "opticl")
+ (:file "coerce")
(:file "colors")
(:file "imageops")
(:file "invert")
View
@@ -304,180 +304,3 @@ function does that.")
(setf (pixel image i j) 0))))
image)
-(defun mean (&rest numbers)
- (/ (apply #'+ numbers) (length numbers)))
-
-;;; work around ABCL etypecase bug
-#-abcl
-(defun convert-image-to-8-bit-grayscale (image)
- (etypecase image
- (8-bit-gray-image image)
- (1-bit-gray-image
- (with-image-bounds (y x)
- image
- (let* ((gray-image (make-8-bit-gray-image y x)))
- (do-pixels (i j) image
- (setf (pixel gray-image i j)
- (if (plusp (pixel image i j)) 255 0)))
- gray-image)))
- ((or rgb-image rgba-image)
- (with-image-bounds (y x channels)
- image
- (let* ((type (array-element-type image))
- (gray-image (make-8-bit-gray-image y x)))
- (if (subtypep type 'integer)
- (do-pixels (i j)
- image
- (multiple-value-bind (r g b)
- (pixel image i j)
- (setf (pixel gray-image i j)
- (round (mean r g b)))))
- (do-pixels (i j)
- image
- (multiple-value-bind (r g b)
- (pixel image i j)
- (setf (pixel gray-image i j)
- (coerce (round (mean r g b)) type)))))
- gray-image)))))
-
-;;; work around ABCL etypecase bug
-#+abcl
-(defun convert-image-to-8-bit-grayscale (image)
- (cond
- ((typep image '8-bit-gray-image) image)
-
- ((typep image '1-bit-gray-image)
- (with-image-bounds (y x)
- image
- (let* ((gray-image (make-8-bit-gray-image y x)))
- (do-pixels (i j) image
- (setf (pixel gray-image i j)
- (if (plusp (pixel image i j)) 255 0)))
- gray-image)))
-
- ((or (typep image 'rgb-image)
- (typep image 'rgba-image))
- (with-image-bounds (y x channels)
- image
- (let* ((type (array-element-type image))
- (gray-image (make-8-bit-gray-image y x)))
- (if (subtypep type 'integer)
- (do-pixels (i j)
- image
- (multiple-value-bind (r g b)
- (pixel image i j)
- (setf (pixel gray-image i j)
- (round (mean r g b)))))
- (do-pixels (i j)
- image
- (multiple-value-bind (r g b)
- (pixel image i j)
- (setf (pixel gray-image i j)
- (coerce (round (mean r g b)) type)))))
- gray-image)))))
-
-
-(defun convert-image-to-grayscale (image)
- (etypecase image
- (gray-image image)
- ((or rgb-image rgba-image)
- (with-image-bounds (y x channels)
- image
- (let* ((type (array-element-type image))
- (gray-image (make-array (list y x) :element-type type)))
- (if (subtypep type 'integer)
- (do-pixels (i j)
- image
- (multiple-value-bind (r g b)
- (pixel image i j)
- (setf (pixel gray-image i j)
- (round (mean r g b)))))
- (do-pixels (i j)
- image
- (multiple-value-bind (r g b)
- (pixel image i j)
- (setf (pixel gray-image i j)
- (coerce (round (mean r g b)) type)))))
- gray-image)))))
-
-(defun convert-image-to-grayscale-luminance (image)
- (etypecase image
- (gray-image image)
- ((or rgb-image rgba-image)
- (with-image-bounds (y x channels)
- image
- (let* ((type (array-element-type image))
- (gray-image (make-array (list y x) :element-type type)))
- (if (subtypep type 'integer)
- (do-pixels (i j)
- image
- (multiple-value-bind (r g b)
- (pixel image i j)
- (setf (pixel gray-image i j)
- (round
- (+ (* r 0.2989)
- (* g 0.5870)
- (* b 0.1140))))))
- (do-pixels (i j)
- image
- (multiple-value-bind (r g b)
- (pixel image i j)
- (setf (pixel gray-image i j)
- (coerce (round
- (+ (* r 0.2989)
- (* g 0.5870)
- (* b 0.1140))) type)))))
- gray-image)))))
-
-(defun convert-image-to-rgb (image)
- (etypecase image
- (gray-image
- (with-image-bounds (y x channels)
- image
- (let* ((type (array-element-type image))
- (rgb-image (make-array (list y x 3) :element-type type)))
- (do-pixels (i j)
- image
- (let ((val (pixel image i j)))
- (setf (pixel rgb-image i j)
- (values val val val))))
- rgb-image)))
- (rgb-image image)
- (rgba-image
- (with-image-bounds (y x channels)
- image
- (let* ((type (array-element-type image))
- (rgb-image (make-array (list y x 3) :element-type type)))
- (do-pixels (i j)
- image
- (setf (pixel rgb-image i j)
- (pixel image i j)))
- rgb-image)))))
-
-(defun convert-image-to-rgba (image)
- (declare (optimize (debug 3)))
- (etypecase image
- (gray-image
- (with-image-bounds (y x channels)
- image
- (let* ((type (array-element-type image))
- (rgba-image (make-array (list y x 4) :element-type type)))
- (do-pixels (i j)
- image
- (let ((val (pixel image i j)))
- (setf (pixel rgba-image i j)
- (values val val val 255))))
- rgba-image)))
- (rgb-image
- (with-image-bounds (y x channels)
- image
- (let* ((type (array-element-type image))
- (rgba-image (make-array (list y x 4) :element-type type)))
- (do-pixels (i j)
- image
- (setf (pixel* rgba-image i j)
- (append (multiple-value-list (pixel image i j))
- (list 255))))
- rgba-image)))
- (rgba-image image)))
-
Oops, something went wrong.

0 comments on commit 560f72d

Please sign in to comment.