Re: pict-scrap

["Mark A. Tapia" <markt@dgp.toronto.edu>]

Greg Wilcox (wilcox@cmns.think.com) writes:
  has anyone updated pict-scrap.lisp to work under MCL2.0?

The new version of MCL2.0f3 has a complete example in the Examples
folder in pict-scrap.lisp. Note: you'll need to use the following 
own interface to #_copyHandle since the format of the trap
call has changed (see the code at the end of this file supplied
by Bill St. Calir (binn@cambridge.apple.com)):

(in-package ccl)
(export '(copy-handle))
;; wrapper for handToHand trap call
(defun copy-handle (handle)
  "returns a handle whose contents is a copy of the input handle's contents"
    (rlet ((var :ptr))
	(ccl::%set-ptr var handle)
	    (let ((errcode (#_HandToHand var)))
		  (unless (eql 0 errcode)
			  (ccl::%err-disp errcode))
				(%get-ptr var))))

Here is a version of pict-scrap.lisp which runs under MCL2.0b1p3:
------>
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;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
;;
;; mat 1991.08.8 converted to support CLOS

(defpackage "CCL" (:use "COMMON-LISP" "CCL"))
(in-package "CCL")

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

(defvar *this*)
(defconstant $ApplScratch  #xA78)

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

(defmethod set-internal-scrap ((self pict-scrap-handler) scrap)
  (with-slots (internal-scrap) self
    (let* ((old-pict 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 ((self pict-scrap-handler))
  (with-slots (internal-scrap) self
    (let* ((the-pict internal-scrap)
           (size (#_GetHandleSize the-pict)))
      (when the-pict
        (with-dereferenced-handles
          ((the-pict the-pict))
          (#_PutScrap :long size :ostype :pict :ptr the-pict)
          )
        ))))

(defmethod internalize-scrap ((self pict-scrap-handler))
  (with-slots (internal-scrap) self
  (let ((the-pict (#_NewHandle 0)))
    (#_GetScrap :ptr the-pict
               :ostype :pict
               :long $ApplScratch)
    (setf internal-scrap the-pict))))

;; make the scrap handler for pictures available to the general handler

(let ((this (make-instance 'pict-scrap-handler)))
  (pushnew `(:pict . ,this)
           *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.

(defpackage "CCL" (:use "COMMON-LISP" "CCL"))
(in-package "CCL")

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

(defclass pict-window (window) ((picture :initform nil :accessor picture)))

(defmethod paste ((self pict-window))
  (with-slots (wptr) self
    (let* ((pict (get-scrap :pict)))
      (when pict
        (with-port wptr
          (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)))))))

(defmethod copy ((self pict-window))
  (with-slots (wptr) self
  (let ((rect (rref wptr window.portrect)))
    (with-port wptr
      (#_cliprect :ptr rect)
      (let* ((pict (#_OpenPicture :ptr rect :ptr))
             (bits (rref wptr :window.portbits)))
        (#_CopyBits :ptr bits
                   :ptr bits
                   :ptr rect
                   :ptr rect
                   :word 0        ;transfer mode
                   :ptr (%null-ptr))
        (#_ClosePicture)
        (put-scrap :pict pict))))))

(defmethod clear ((self pict-window))
  (with-slots (wptr) self
  (with-port wptr
    (#_EraseRect :ptr (rref wptr :window.portrect)))))

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

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

|#