Re: copying pixmaps

[alanr@chopin.media.mit.edu]

	I am trying to write a program that copy images between the screen and
	an offscreen pixmap.  I have successfully created an offscreen world using
	the new routines in 32bit quickdraw but I can't seem to make copybits work.
	I use the pixmap from the new offscreen world and have verified that it is
	a pixmap, and the screens pixmap, the portrect from the screen as both
	rectangles, 0 for the copy mode and no mask region.  A call to copybits with
	these parameters seems to do nothing.  Any ideas?
	
	Allen

Here is what I have used: hope it helps. There are two files:
color-pixmaps.lisp, and screensnap.lisp, which does a grab off the main
screen. I'm not sure this is the "right" way to do it. I've left it in the
package I'm used to, you'll probably have to change it to suit your environment.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;color-pixmaps.lisp
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package 'mlcl)
;; use *color-window* instead of *window* as window base for this stuff to work
;; example at bottom


;; make a pixmap which can save bits from this window.
(defobfun (make-pixmap *color-window-mixin*) (left &optional top right bottom
                                                  &aux rowbytes pm bytes)
  (with-port (objvar wptr)
    (ccl::with-rectangle-arg 
     (r left top right bottom)
     (setq pm (_newpixmap :ptr))
     (_copypixmap :ptr (rref (rref wptr window.port) cgrafport.portpixmap) :ptr pm)
     (let ((depth (rref pm pixmap.pixelsize))
           (right (rref r rect.right))
           (left (rref r rect.left)))
       (setq rowbytes 
             (* 2 (ceiling (ceiling (* (- right left) depth) 8) 2)))
       (setq bytes
             (_newptr :errchk 
                      :d0 (* rowbytes (- (rref r rect.bottom) (rref r rect.top)))
                      :a0))
       (rset pm pixmap.bounds r)
       (rset pm pixmap.rowbytes (logior rowbytes #x8000) )
       (rset pm pixmap.baseaddr bytes))))
  pm)

;; release the memory used for the pixmap
(defobfun (release-pixmap *color-window-mixin*) (pixmap)
  (_disposptr :errchk :a0 (rref pixmap pixmap.baseaddr))
  (_dispospixmap :ptr pixmap))

  
;; make a pixmap which has a copy of the current window bits
(defobfun (make-window-copy-pixmap *color-window-mixin*) ()
  (let ((top 0) (left 0) (bottom (point-v (window-size))) (right (point-h (window-size))))
    (ccl::with-rectangle-arg 
     (r left top right bottom)
     (let ((pixmap (make-pixmap r)))
       (with-dereferenced-handles ((pixmap pixmap)
                                   (wpix (rref (rref wptr window.port) cgrafport.portpixmap)))
         (copy-bits wpix pixmap r r))
       pixmap))))

;; copy a pixmap to the window. default source and dest are the same as the pixmap bounds
(defobfun (draw-pixmap *color-window-mixin*) (pixmap &optional (source-rect (%inc-ptr (%get-ptr pixmap) 6))
                                               (dest-rect source-rect))
  (with-dereferenced-handles ((pixmap pixmap)
                              (wpix (rref (rref wptr window.port) cgrafport.portpixmap)))
    (without-interrupts
     (copy-bits pixmap wpix source-rect dest-rect))))


#||
;; beware: bitmaps take a bunch of space. In this example, they take 100k each.
;; a simple example of saving up windows for later animation
(defun test  (&optional (size 300))
  (let ((a (oneof (*color-window-mixin* *window*) :window-size (make-point size size))))
    (ask a
      (set-fore-color (make-color 60000 0 0))
      (let (stages)
        (unwind-protect 
          (progn
            (setq stages  (loop for i below 10 do
                                (set-fore-color (make-color (-  60000 (* i 6000)) (* i 6000) (* i 6000)))
                                (paint-rect 0 0 size size)
                                (set-fore-color (make-color (* i 6000) (-  60000 (* i 6000)) (* i 6000)))
                                (paint-rect 0 0  (* i (floor size 10))  (* i (floor size 10)))
                                collecting (make-window-copy-pixmap)))
            (loop for i below 10
                  do
                  (loop for p in stages
                        do (draw-pixmap p) (sleep .02))
                  (loop for p in (reverse stages)
                        do (draw-pixmap p) (sleep .02))))
          (loop for p in stages do (release-pixmap p)))))))
||#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; screensnap.lisp
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package 'mlcl)
(require 'quickdraw)
(import 'ccl::with-rectangle-arg)
(require 'color-pixmaps)

;; to use do (oneof *screensnap-window*), then drag a rectangle to select the part you want.
;; the window is resizeable. To set to original size, doubleclick on the window

(defobject *screen-window* *color-window-mixin* *window*)
                    
(defobfun (exist *screen-window*) (args)
  (ccl::debind (&key (window-title "Color Window")
                     (window-size #@(300 300))
                     (window-position #@(100 50))
                     wptr
                     (window-show t) (window-layer 0))
               args
  (ignore wptr)               
  (have 'wptr    
        (%stack-block ((p 4))
          (_getcwmgrport :ptr p)
          (%get-ptr p)))))

(defobfun (get-dragged-rectangle *screen-window*) (&aux old topleft)
  (with-port wptr  
    (_cliprect :ptr (rref wptr cgrafport.portrect))
    (without-interrupts
     (set-pen-mode :patxor)
     (set-pen-pattern *gray-pattern*)
     (set-pen-size #@(2 2))
     (rlet ((r :rect :topleft #@(0 0) :bottomright #@(0 0)))
       (with-cursor *cross-hair-cursor*
         (loop until (mouse-down-p))
         (setq topleft (window-mouse-position))
         (rset r rect.topleft  topleft)
         (loop until (not (mouse-down-p))
               for p = (window-mouse-position)
               do
               (unless (eql p old)
                 (when old (rset r rect.bottomright old))
                 (_framerect :ptr r)
                 (setq old (window-mouse-position))
                 (rset r rect.bottomright old)
                 (_framerect :ptr r))
               finally 
               (_framerect :ptr r)
               (return-from get-dragged-rectangle (values (rref r rect.topleft) (rref r rect.bottomright)))
               ))))))


(defobfun (get-screensnap *screen-window*) ()
  (multiple-value-bind (topleft bottomright) (get-dragged-rectangle)
    (let ((pixmap (make-pixmap #@(0 0) (subtract-points bottomright topleft))))
      (with-dereferenced-handles ((pixmap pixmap)
                                  (wpix (rref (rref wptr window.port) cgrafport.portpixmap)))
        (with-rectangle-arg (rs topleft bottomright)
          (with-rectangle-arg (rd #@(0 0) (subtract-points bottomright topleft))
            (copy-bits wpix pixmap rs rd)
            )))
      pixmap)))
                       

(defun pixmap-size (pixmap)
  (subtract-points (rref pixmap pixmap.bounds.bottomright) (rref pixmap pixmap.bounds.topleft)))

(defobject *screensnap-window* *color-window-mixin* *window*)

(defobfun  (exist *screensnap-window*) (args)
  (have 'snap (ask (oneof *screen-window*) (get-screensnap)))
  (usual-exist (append (list :window-size (pixmap-size snap) :window-title "Screensnap"
                             :window-type :document-with-zoom) args))
  )

(defobfun (view-draw-contents *screensnap-window*) ()
  (with-rectangle-arg (rs #@(0 0) (pixmap-size snap))
    (with-rectangle-arg (rd #@(0 0) (window-size))
      (draw-pixmap snap rs rd))))


(defobfun (window-close *screensnap-window*) ()
  (release-pixmap snap)
  (usual-window-close))
          
(defobfun (set-window-size *screensnap-window*) (size)
  (usual-set-window-size size)
  (view-draw-contents))

(defobfun (window-click-event-handler *screensnap-window*) (&rest ignore)
  (and (double-click-p) (set-window-size (pixmap-size snap))))