Re: color bitmaps?

[Bill St. Clair <bill>]

   Date: 1 Apr 91 17:12:46
   From: Gat <Gat@ai.jpl.nasa.gov>
   Subject: color bitmaps?
   To: info-macl@cambridge.apple.com
   
      Subject:      color bitmaps?
   I have a 700 by 700 array of bytes which I want to display as a grey scale
   image.  (Actually, what I really want to do is print it out, but if I can
   display it I can print it.)  Is there a FAST way to do this in MACL?  The
   obvious thing of doing a set-fore-color followed by a line-to for each pixel is
   painfully slow.  Is there such a thing as a color bitmap that I can just plop
   into a window using quickdraw?
   
   Thanks,
   E.
   
   
Here's some code that gives a start on what I think you were asking
for.  Note that it is NOT industrial strength.  If the Mac memory
manager decides that it is out of memory and needs to call the
GrowZone function, MACL will garbage-collect, and your array will move
right out from under _CopyBits.  This will look terrible if you're
copying from the array to the screen and will probably be fatal if
you're copying from the screen (or another pixmap) into the array.

Ciao.

---------------------------------------------------------------------------

; bitblt-arrays.lisp
;
; Treating a Lisp array as a pixmap.
; This code qualifies as something you should not "try at home", but
; sometimes it's what you need.
; Note that display-array will display garbage and fill-array-from-window
; will bomb horribly if MCL's growzone function is called, causing
; a GC.  It's probably a good idea to make a large pointer and dispose of it
; before calling either one of them.  This will cause the GC to happen at a
; safe time.

; This code assumes that the arrays passed to it are really 8-bit arrays.
; fill-array-from-window will not work unless the window being filled from
; has the system color table (and doesn't seem to work at all in
; System 7).

(eval-when (compile eval)
  (require :records)
  (require :traps))

#+:ccl-1
(progn
  (defmacro %null-ptr () nil)

  (defmacro %null-ptr-p (p) `(null ,p))

  (defun %address-of (x) (%ptr-to-int x))

  (defmacro with-macptrs (bindings &body body)
    `(let ,bindings ,@body))

  (defun array-data-and-offset (array)
    (let ((res array)
          (offset 0))
      (loop
        (multiple-value-bind (r o) (displaced-array-p res)
          (if r
            (setq res r offset (+ offset o))
            (return (values res offset)))))))          

  (defmacro array-data-ptr (array)
    `(%int-to-ptr (+ (array-data-address ,array) 8)))

  (defun wptr (w)
    (ask w (objvar ccl::wptr))))

#+:ccl-2
(defmacro array-data-ptr (array)
  `(%int-to-ptr (+ (array-data-address ,array) 7)))

(defun array-data-address (array)
  (multiple-value-bind (a o) (array-data-and-offset array)
    (+ (%address-of a) o)))

(defun make-8-bit-pixmap (h &optional v)
  (let* ((size (make-point h v))
         (h (point-h size))
         (res (_NewPixMap :ptr)))
    (rset res :PixMap.rowBytes (logior #x8000 h))   ; remember the flag bit
    (rset res :PixMap.pixelSize 8)
    (rset res :PixMap.cmpSize 8)
    (rset res :PixMap.bounds.topLeft #@(0 0))
    (rset res :PixMap.bounds.bottomRight size)
    (_DisposHandle :a0 (rref res #+ccl-2 :PixMap.pmTable #+:ccl-1 :PixMap.Table))
    (rset res 
          #+ccl-2 :PixMap.pmTable #+:ccl-1 :PixMap.Table
          (_GetCTable :word 8 :ptr))   ; system color table
    res))

(defun display-array (array window h &optional v)
  (let* ((width (array-dimension array 0))
         (height (array-dimension array 1))
         (size (make-point width height))
         (topleft (make-point h v))
         (botright (add-points topleft size))
         (pixmap (make-8-bit-pixmap size)))
    (unless (%null-ptr-p pixmap)
      (with-focused-view window
        (unwind-protect
          (rlet ((dstRect :rect :topleft topleft :bottomRight botright))
            (with-pointers ((pm pixmap))
              (rset pm :pixmap.baseaddr (array-data-ptr array) :storage :pointer)
              (_CopyBits :ptr pm
                         :ptr (rref (wptr window) :grafport.portbits)
                         :ptr (rref pm :PixMap.bounds :storage :pointer)
                         :ptr dstRect
                         :word (position :srcCopy *pen-modes*)
                         :ptr (%null-ptr))))
          (_DisposPixMap :ptr pixmap))))))

; You can make this copy the screen if you create hidden window
; and change (with-focused-view window ...) to (with-focused-view nil ...)
(defun fill-array-from-window (array window h &optional v)
  (let* ((width (array-dimension array 0))
         (height (array-dimension array 1))
         (size (make-point width height))
         (topleft (make-point h v))
         (botright (add-points topleft size))
         (pixmap (make-8-bit-pixmap size)))
    (unless (%null-ptr-p pixmap)
      (with-focused-view window
        (unwind-protect
          (rlet ((srcRect :rect :topleft topleft :bottomRight botright))
            (with-pointers ((pm pixmap))
              (rset pm :pixmap.baseaddr (array-data-ptr array) :storage :pointer)
              (_CopyBits :ptr (rref (wptr window) :grafport.portbits)
                         :ptr pm
                         :ptr (rref pm :PixMap.bounds :storage :pointer)
                         :ptr srcRect
                         :word (position :srcCopy *pen-modes*)
                         :ptr (%null-ptr))))
          (_DisposPixMap :ptr pixmap))))))

#|

; Here's the type of array that this code expects.
(defparameter *a* (make-array '(500 500) :element-type '(signed-byte 8)))

#+:ccl-1
(progn
  (defobject *color-window* *color-window-mixin* *window*)
  (defvar *w* (oneof *color-window*)))

#+:ccl-2
(defvar *w* (make-instance 'window :color-p t))

(fill-array-from-window *a* (front-window) 0)
(display-array *a* *w* 0)

|#