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

[Ron Garret]

Just realized this produces JPGs, not TIFFs.  If you really need TIFFs  
I think you just need to do:

(defun image2tiff (img) (#/TIFFRepresentation img))

but I haven't actually tried this.  In any case, the following doc  
pages might be helpful:

http://developer.apple.com/documentation/Cocoa/Reference/ApplicationKit/Classes/NSImage_Class/Reference/Reference.html#/ 
/apple_ref/occ/instm/NSImage/TIFFRepresentation

http://developer.apple.com/documentation/Cocoa/Reference/ApplicationKit/Classes/NSBitmapImageRep_Class/Reference/Reference.html#/ 
/apple_ref/occ/instm/NSBitmapImageRep/TIFFRepresentation

rg

On Jun 3, 2008, at 1:48 PM, Ron Garret wrote:

> 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
>
> _______________________________________________
> Openmcl-devel mailing list
> Openmcl-devel at clozure.com
> http://clozure.com/mailman/listinfo/openmcl-devel