How does one put PICTs on the Scrap in MCL2.0B1?

[Henry Lieberman <lieber@media-lab.media.mit.edu>]

Here is the code I've been using, feel free to post/distribute:

Henry Lieberman
-------------------Cut Here---------------------
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;Pict-Scrap.Lisp
;;
;;Copyright ) 1989, Apple Computer, Inc
;;
;;
;;  This file a scrap-handler for scraps of type PICT
;;
;;  Once this is installed, windows which copy and paste PICTs will
;;  be able to share their work with other applications
;;
;; Modified for 2.0 by Henry Lieberman


(in-package :ccl)

(eval-when (eval compile)
  (require 'traps)
  ;; (require 'records)
  )

(defconstant $ApplScratch  #xA78)

(defclass pict-scrap-handler (scrap-handler) ())

(defmethod set-internal-scrap ((self pict-scrap-handler) scrap)
  (let* ((old-pict (slot-value self 'internal-scrap)))
    (when (handlep old-pict)
      (_KillPicture :ptr old-pict)))  ;dispose of the old pict before we
                                      ;put a new one in its place
                                      ;this will crash if your program has
                                      ;other pointers to the pict, so
                                      ;always make sure cut/copy really do
                                      ;-copy- the pict
  (call-next-method self scrap)
  (when scrap (pushnew :pict *scrap-state*)))

(defmethod externalize-scrap ((pict-scrap-handler pict-scrap-handler))
  (let* ((the-pict (slot-value pict-scrap-handler 'internal-scrap))
         (size (_GetHandleSize :a0 the-pict :d0)))
    (when the-pict
      (with-dereferenced-handles
        ((pict-ptr the-pict))
        (_PutScrap :long size :ostype :pict :ptr pict-ptr)))))

(defmethod internalize-scrap ((pict-scrap-handler pict-scrap-handler))
  (let* ((the-pict (_NewHandle :d0 0 :a0)))
    (_GetScrap :ptr the-pict
               :ostype :pict
               :long $ApplScratch)
    (setf (slot-value pict-scrap-handler 'internal-scrap) the-pict)))


(defmethod get-internal-scrap ((pict-scrap-handler pict-scrap-handler))
  (slot-value pict-scrap-handler 'internal-scrap))

(pushnew `(:pict . ,(make-instance 'pict-scrap-handler))
         *scrap-handler-alist*
         :test #'equal)

;;;;;;;;;;;;;;;;;;;;;
;;
;; a simple window, supporting cut and paste with picts
;;
;; because it doesn't remember the picts which it pastes,
;; it can only cut a pseudo-pict, that is, a pict which
;; contains the window's current contents as a bitmap.

(eval-when (eval compile)
  (require 'traps)
  (require 'records)
  (require 'quickdraw))

(defclass pict-window (window) 
  ((saved-pict :initarg saved-pict :accessor saved-pict :initform nil))
  (:default-initargs 
    :color-p t
    :window-title "A Pict Window"))

(defmethod paste ((pict-window pict-window))
  (let* ((pict (get-scrap :pict)))
    (setf (slot-value pict-window 'saved-pict) pict)
    (draw-picture pict-window pict)))

#||
(defun draw-pict-picture (pict-window pict) 
  ;; This any different than DRAW-PICTURE supplied with the system?
  (when pict
    (with-port (wptr pict-window)
      (rlet ((r :rect))
        (with-dereferenced-handles ((pict-point pict))
          (copy-record (rref pict-point :picture.picframe
                             :storage :pointer)
                       :rect
                       r))
        (_DrawPicture :ptr pict :ptr r)
        pict))))
||#

(defmethod view-draw-contents ((pict-window pict-window))
  (and (slot-value pict-window 'saved-pict)
       (draw-picture pict-window (slot-value pict-window 'saved-pict)))
  (call-next-method pict-window))


#|

The rectangle used by COPY includes the resize box in the lower left
hand corner.  It should just be the inset drawing area, or better still,
just the "actually drawn" area.

|#

(defmethod copy ((pict-window pict-window))
  (let* ((wptr (wptr pict-window)))
    (rlet ((rect :rect 
                 :left (rref wptr windowrecord.portrect.left)
                 :top (rref wptr windowrecord.portrect.top)
                 :right (rref wptr windowrecord.portrect.right)
                 :bottom (rref wptr windowrecord.portrect.bottom)))
      (with-port wptr
        (_cliprect :ptr rect)
        (let* ((pict (_OpenPicture :ptr rect :ptr))
               (bits (rref wptr :windowrecord.portbits)))
          (_CopyBits :ptr bits
                     :ptr bits
                     :ptr rect
                     :ptr rect
                     :word 0        ;transfer mode
                     :ptr (%null-ptr))
          (_ClosePicture)
          (put-scrap :pict pict))))))

(defmethod clear ((pict-window pict-window))
  (let ((wptr (wptr pict-window)))
    (with-port wptr
      (_EraseRect :ptr (rref wptr :windowrecord.portrect)))))

(defmethod cut ((pict-window pict-window))
  (copy pict-window)
  (clear pict-window))

#||

(setq pw (make-instance 'pict-window))

||#