[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Re: newgworld

	I'm trying to create an offscreen drawing environment from Lisp.  I've
	been trying to use #_newgworld but no matter how I call it it doesn't
	seem to work.  The arguments are a VAR grafptr, an integer (pixel depth),
	a bounding rect, a ctable, a device ptr, and a gworldflags byte.  I am
	almost positive that I am using the arguments correctly but I get a -50
	(incorrect arguments), or the machine freezes.  I have used newgworld
	successfully from C.  Is this possibly a Lisp problem?

There may a patch to newgworld that has not found its way into the release.
The problem is that the flags parameter is a long, not a byte.

Try this: 
(deftrap traps::_newgworld ((offscreengworld (:pointer (:pointer cgrafport))) 
                       (pixeldepth :signed-integer) (boundsrect :rect)
                       (ctable (:handle colortable)) (agdevice (:handle gdevice)) (flags :long))
    (:stack :signed-integer)
    (:stack-trap #xAB1D :d0 (+ (ash 22 16) 0) offscreengworld pixeldepth
                 boundsrect ctable agdevice flags))

(deftrap traps::_updategworld ((offscreengworld (:pointer (:pointer cgrafport))) 
                          (pixeldepth :signed-integer) (boundsrect :rect) 
                          (ctable (:handle colortable)) (agdevice (:handle gdevice)) (flags :long))
    (:stack :unsigned-byte)
    (:stack-trap #xAB1D :d0 (+ (ash 22 16) 3) offscreengworld pixeldepth
                 boundsrect ctable agdevice flags)

There are other problems associated with using gworlds in the current
lisp.  First, focus-view doesn't set the gworld to the screen, it only
sets the port.  Thus if the system draws something while you are
setgworld to something you create, nothing gets drawn (or you crash,
or whatever...)

So for now, surround the code which sets the gworld and does the drawing with
a without-interrupts.

The only problem now is with errors. If you get an error while the gworld
is set to something else you also lose. Workaround: 1) advise error to set the
gworld to the default screen gworld. 2) Surround your code with ignore-errors.


Here is some code I use to create gworlds which does work. (this
is meant as an example. I'm not sending the has-pixmap mixin). If you are
interested in the rest of my (evolving) code, I'd be glad to send it.

(defclass gworld (has-pixmap)
  ((pixmap-handle :initarg :pixmap-handle :initform nil :accessor pixmap-handle)
   (gworld :initarg :gworld :initform nil :accessor gworld)
   (depth :initarg :depth :initform 8 :accessor depth)
   (gdevice :initarg :gdevice :initform (%null-ptr) :accessor gdevice)
   (colortable :initarg :colortable :initform nil :accessor colortable)
   (gray? :initarg :gray? :initform nil :accessor gray?)
   (size :initarg :size :initform #@(100 100) :accessor size)
   (temporary? :initarg :temporary? :initform nil :accessor temporary?)))

(defmethod initialize-instance ((g gworld) &key)
  (shared-initialize g t)
  (assert (member (depth g) '(1 2 4 8 16 32) :test 'eql) ((depth g))
          "depth of a gworld needs to be a power of 2")  
  (unless (colortable g)
    (default-colortable g))
  (unless (gworld g)
    (allocate-gworld g))

(defmethod default-colortable ((g gworld))
  (setf (colortable g)
        (if (gray? g)
          (#_getctable (case (depth g)
                         (2 34)
                         (4 36)
                         (8 40)
                         ((1 16 32) (%null-ptr))))
          (#_getctable (case (depth g)
                         (2 2)
                         (4 4)
                         (8 8)
                         ((1 16 32) (%null-ptr)))))))
(defmethod allocate-gworld ((g gworld))
  (rlet ((gw :pointer))
    (let ((result
           (#_newgworld gw
            (depth g) 
            (rect (size g))
            (colortable g)
            (gdevice g)
            (if (temporary? g) 4 0))))
      (assert (zerop result) () "Error creating gworld"))
    (setf (gworld g) (%get-ptr gw))))

(defmethod update-gworld ((g gworld) &key colortable depth size gdevice)
  (rlet ((gw :pointer))
    (%put-ptr gw (gworld g))
    (if (minusp 
         (#_updategworld gw
          (setf (depth g) (or depth (depth g)))
          (rect (setf (size g) (or size (size g))))
          (setf (colortable g) (or colortable (colortable g)))
          (setf (gdevice g) (or gdevice (gdevice g)))
          (gworld-update-method g)))
      (error "updategworld failed!")
      (setf (gworld g) (%get-ptr gw)))))

(defmethod dispose ((g gworld))
  (#_disposegworld (gworld g))
  (setf (gworld g) nil)
(defmethod gworld-update-method ((v gworld))
  (ash 1 #$clippix))