[Openmcl-devel] Fwd: CCL Image I/O

[Ron Garret]

Try this:

;;; Binding Block
(defmacro bb (&rest body)
   (cond
    ((null (rst body)) (fst body))
    ((consp (1st body))
     `(progn ,(1st body) (bb ,@(rst body))))
    ((not (symbolp (1st body)))
     (error "~S is not a valid variable name" (1st body)))
    ((eq (1st body) ':mv)
     (if (symbolp (2nd body))
       `(let ((,(2nd body) (multiple-value-list ,(3rd body))))
          (bb ,@(rrrst body)))
       `(multiple-value-bind ,(2nd body) ,(3rd body)
          (bb ,@(rrrst body)))))
    ((eq (1st body) :db)
     `(destructuring-bind ,(2nd body) ,(3rd body)
        (declare (special ,@(find-specials (2nd body))))
        (bb ,@(rrrst body))))
    ; BUG: 1-arg assumption fails for with-slots
    ((eq (1st body) :with)
     `(,(intern (format nil "WITH-~A" (2nd body)) (symbol-package (2nd  
body)))
       ,(3rd body) (bb ,@(rrrst body))))
    ((keywordp (1st body))
     (error "~S is not a valid binding keyword" (1st body)))
    (t `(let ((,(1st body) ,(2nd body)))
          (declare (special ,@(find-specials (1st body))))
          (bb ,@(rrst body))))))

(defun image-from-url (url)
   (#/initWithContentsOfURL: (#/alloc ns:ns-image)
                             (#/URLWithString: ns:ns-url url)))

(defun image-from-file (filename)
   (#/initWithData: (#/alloc ns:ns-image)
                    (#/dataWithContentsOfFile: ns:ns-data filename)))

(defun image-bitmap (img)
   (or
    (loop
      with e = (#/objectEnumerator (#/representations img))
      as rep = (#/nextObject e)
      until (%null-ptr-p rep)
      if (typep rep ns:ns-bitmap-image-rep) return rep)
    (bb
     :with focused-image img
     :db (x . y) (image-size img)
     (#/initWithFocusedViewRect: (#/alloc ns:ns-bitmap-image-rep)
                                 (ns:make-ns-rect 0 0 x y)))))

(defun bitmap-pixels (rep)
   (bb
    :db (x . y) (image-size rep)
    ptr (#/bitmapData rep)
    bpr (#/bytesPerRow rep)  ; Could be padded
    bpp (/ (#/bitsPerPixel rep) 8)
    a (make-array (list y x bpp) :element-type '(unsigned-byte 8))
    (dotimes (i x a)
      (dotimes (j y)
        (dotimes (k bpp)
          (setf (aref a j i k) (%get-byte ptr (+ (* i bpp) (* j bpr)  
k))))))))

(defun image-pixels (img) (bitmap-pixels (image-bitmap img)))

(defun image2jpeg (img &optional (compression 0.9))
   (#/representationUsingType:properties:
    (image-bitmap img)
    #$NSJPEGFileType
    (#/dictionaryWithObject:forKey: ns:ns-dictionary
                                    (#/numberWithFloat: ns:ns-number  
compression)
                                    #&NSImageCompressionFactor)))

On Jun 3, 2008, at 12:59 PM, Andrew Shalit wrote:

> Anyone have time to put the following CCL utility together for  
> Russell Kirsch (http://home.comcast.net/~rakirsch/)?
>
>
> Begin forwarded message:
>
>> From: "Russell A. Kirsch" <rakirsch at acm.org>
>> ...
>> Please tell me how to do the following:
>> Read an image file (Tiff or Pict) from disk into a 2 dimensional  
>> array in CCL and then Output a processed two dimensional array to a  
>> Tiff or Pict file on the disk. In the CCL documentation I can only  
>> find description of one dimensional vector input.
>>
>> Russell
>>
> _______________________________________________
> Openmcl-devel mailing list
> Openmcl-devel at clozure.com
> http://clozure.com/mailman/listinfo/openmcl-devel

-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://lists.clozure.com/pipermail/openmcl-devel/attachments/20080603/dd141441/attachment.htm>