"CR" == Christophe Rhodes csr21@cam.ac.uk writes:
CR> Can you try the attached?
Thanks, except for a few typos it seems to work. Here's a fixed version of the patch:
--- image.lisp.orig 2005-02-18 10:30:08.000000000 +0100 +++ image.lisp 2005-02-18 10:20:09.000000000 +0100 @@ -108,12 +108,13 @@ `(the (unsigned-byte 8) (logand ,pixel 255)))
(defmethod write-pnm ((image truecolor-image) filename output-format) - (with-open-file (stream filename :direction :output :if-exists :supersede) - (if (eq output-format :ascii) - (write-ppm-p3 stream (image-pixels image)) + (with-open-file (stream filename + :direction :output :if-exists :supersede + :element-type '(unsigned-byte 8)) + (if (eq output-format :ascii) + (write-ppm-p3 stream (image-pixels image)) (write-ppm-p6 stream (image-pixels image)))))
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; colormap image @@ -149,9 +150,11 @@ 0)
(defmethod write-pnm ((image 256-gray-level-image) filename output-format) - (with-open-file (stream filename :direction :output :if-exists :supersede) - (if (eq output-format :ascii) - (write-pgm-p2 stream (image-pixels image)) + (with-open-file (stream filename + :direction :output :if-exists :supersede + :element-type '(unsigned-byte 8)) + (if (eq output-format :ascii) + (write-pgm-p2 stream (image-pixels image)) (write-pgm-p5 stream (image-pixels image)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -167,9 +170,11 @@ (make-instance 'binary-image :pixels pixels))
(defmethod write-pnm ((image binary-image) filename output-format) - (with-open-file (stream filename :direction :output :if-exists :supersede) - (if (eq output-format :ascii) - (write-pbm-p1 stream (image-pixels image)) + (with-open-file (stream filename + :direction :output :if-exists :supersede + :element-type '(unsigned-byte 8)) + (if (eq output-format :ascii) + (write-pbm-p1 stream (image-pixels image)) (write-pbm-p4 stream (image-pixels image)))))
@@ -179,46 +184,48 @@
(defmacro with-write-pnm-loop ((magic-number max-value) &body body) `(let ((height (car (array-dimensions picture))) - (width (cadr (array-dimensions picture)))) - (format stream "P~A~%" ,magic-number) - (format stream "~A ~A~%" width height) - (when ,max-value - (format stream "~A~%" ,max-value)) + (width (cadr (array-dimensions picture)))) + (map nil (lambda (x) (write-byte (char-code x) stream)) + (format nil "P~A~%~A~%~A~%~@[~A~%~]" + ,magic-number width height ,max-value)) (loop for r from 0 below height do - (loop for c from 0 below width do - ,@body)) + (loop for c from 0 below width do + ,@body)) nil))
(defun write-pbm-p1 (stream picture) (with-write-pnm-loop (1 nil) - (format stream "~A~%" (aref picture r c)))) + (map nil (lambda (x) (write-byte (char-code x) stream)) + (format nil "~A~%" (aref picture r c)))))
(defun write-pbm-p4 (stream picture) ; bad! (with-write-pnm-loop (4 nil) - (write-char (code-char (aref picture r c)) stream))) + (write-byte (aref picture r c) stream)))
(defun write-pgm-p2 (stream picture) (with-write-pnm-loop (2 255) - (format stream "~A~%" (aref picture r c)))) + (map nil (lambda (x) (write-byte (char-code x) stream)) + (format nil "~A~%" (aref picture r c)))))
(defun write-pgm-p5 (stream picture) (with-write-pnm-loop (5 255) - (write-char (code-char (aref picture r c)) stream))) + (write-byte (aref picture r c) stream)))
(defun write-ppm-p3 (stream picture) (with-write-pnm-loop (3 255) (let ((rgb (aref picture r c))) - (format stream "~A ~A ~A~%" - (red-component rgb) - (green-component rgb) - (blue-component rgb))))) + (map nil (lambda (x) (write-byte (char-code x) stream)) + (format nil "~A ~A ~A~%" + (red-component rgb) + (green-component rgb) + (blue-component rgb))))))
(defun write-ppm-p6 (stream picture) (with-write-pnm-loop (6 255) (let ((rgb (aref picture r c))) - (write-char (code-char (red-component rgb)) stream) - (write-char (code-char (green-component rgb)) stream) - (write-char (code-char (blue-component rgb)) stream)))) + (write-byte (red-component rgb) stream) + (write-byte (green-component rgb) stream) + (write-byte (blue-component rgb) stream))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
CR> Maybe if someone who uses it attempts to document it, it will CR> make more sense?
Well, I attempted to add documentation strings to the objects I use. Here's an additional patch to the previous one:
--- image.lisp.orig 2005-02-18 10:31:42.000000000 +0100 +++ image.lisp 2005-02-18 11:03:44.000000000 +0100 @@ -50,7 +50,13 @@ (defgeneric (setf image-pixel) (x y pixel image)) (defgeneric image-color (image x y)) (defgeneric (setf image-color) (x y pixel color image)) -(defgeneric write-pnm (image filename output-format)) +(defgeneric write-pnm (image filename output-format) + (:documentation + "Write IMAGE to FILENAME. +IMAGE must be an IMAGE class instance. +If OUTPUT-FORMAT is present and its value is the symbol :ASCII, then the PNM +image is written in ASCII format, otherwise it is written in the binary +format."))
(defmethod image-width ((image image)) (cadr (array-dimensions (image-pixels image)))) @@ -87,6 +93,13 @@ (max-level :initarg :max-level :type card-8 :reader image-max-level)))
(defun make-truecolor-image (pixels max-value) + "Create and return a TRUECOLOR-IMAGE instance. +PIXELS must be a two dimensional array of dimensions (HEIGHT WIDTH) +corresponding to image height and width in pixels, with integer image pixels +values as its elements. +MAX-VALUE is used to initialize the MAX-LEVEL slot of the resulting +TRUECOLOR-IMAGE instance, without any known actual later use; you can use 255 +as the argument value without triggering a type error." (make-instance 'truecolor-image :pixels pixels :max-level max-value))
(defmethod color-image-max-level ((image truecolor-image)) @@ -373,5 +386,10 @@ (t (error "unknown file format ~A" byte1))))))
(defun read-image-file (filename &key (format :pnm)) + "Read image data from a PNM file FILENAME. +Return a two dimensional array of dimensions (HEIGHT WIDTH) corresponding to +image height and width in pixels, with integer image pixel values as its +elements. +The FORMAT argument is currently ignored." (declare (ignore format)) (read-pnm-file filename))
Regards,
Milan Zamazal