re: changing cursor

[derek@cambridge.apple.com]

This seems to work for me:

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;      animated-cursor.lisp
;;
;;      3/9/93 Derek White
;;
;;      'acur' resources specify a sequence of cursors to cycle through
;;      to get spinning ball cursors, etc.
;;      'acur' resources are documented in the MPW manuals (they are 
;;      essentially a count followed by an array of 'CURS' resource ids)
;;      The 'acur' reource and the 'CURS' resources it refers to must exist
;;      in an open resource file.
;;
;;      The finder seems to use 'acur' #6500, so you could copy it to your
;;      resource file.
;;
;;      with-animated-cursor id-or-object       &body           [macro]
;;      This form automatically spins the cursor according to id-or-object.
;;      (Use this like with-cursor).
;;      Cursor spins when update-cursor is called and null-event-handlers
;;      call update-cursor.  This happens a little slowly, so you may want
;;      call (update-cursor) or event-dispatch yourself.
;;
;;      id-or-object    Can be an integer specifying the id of the 'acur'
;;                      resource to use, or it can be an animated-cursor
object you
;;                      may have gotten with make-animated-cursor.
;;
;;      make-animated-cursor id                 [function]
;;      id      An integer specifying the id of the 'acur'
;;              resource to use.
;;
;;      This file is stand alone (no dependencies on my world, etc.)

(in-package ccl)

(export '( with-animated-cursor
           make-animated-cursor
           ))

(defrecord (acur :handle)
  (count :integer)
  (pad :integer)
  ; Array is [id-0, pad, id-1, pad,...], so multiply n by 2 to get the nth id.
  (array (array :integer 40))) ; the array is actually variable.

(defclass animated-cursor ()
  ((count :reader animated-cursor-count :initarg :count)
   (stamp :accessor animated-cursor-stamp :initform 0)
   (index :accessor animated-cursor-index :initarg :index)
   (ids :reader animated-cursor-ids :initarg :ids)))

(defun make-animated-cursor (acur-id)
  ; Make an animated-cursor corresponding to the 'acur' resource.
  ; This gets and releases the resource.
  (let ((acur-hdl nil))
    (check-type acur-id integer)
    (unwind-protect
      (progn
        (setf acur-hdl (#_GetResource :|acur| acur-id))
        (let ((err (#_ResError)))
          (unless (eql 0 err)
            (%err-disp err)))
        (when (%null-ptr-p acur-hdl)
          (error "'acur' resource #~d does not exist." acur-id))
        (let* ((count (href acur-hdl :acur.count))
               (ids (make-array count :element-type 'integer)))
          (dotimes (n count)
            (setf (svref ids n) (href acur-hdl (acur.array (* n 2)))))
          (make-instance 'animated-cursor
            :count count
            :ids ids
            :index (aref ids 0))))
      (when (and acur-hdl (not (%null-ptr-p acur-hdl)))
        (#_ReleaseResource acur-hdl)))))

(defconstant $rotate-delay 120)

(defun rotate-animated-cursor (animated-cursor)
  (without-interrupts
   (let ((new-stamp (get-internal-real-time)))
     (when (> new-stamp (+ $rotate-delay (animated-cursor-stamp
animated-cursor)))
       (setf (animated-cursor-stamp animated-cursor) new-stamp)
       (let ((index (+ 1 (animated-cursor-index animated-cursor))))
         (when (>= index (animated-cursor-count animated-cursor))
           (setf index 0))
         (setf (animated-cursor-index animated-cursor) index)
         (set-cursor (aref (animated-cursor-ids animated-cursor) index)))))))

(defmacro with-animated-cursor (id-or-object &body body)
  ; id-or-object is usually the 'acur' resource id to use,
  ; but it can be an animated-cursor object. 
  ; During the execution of body, the cursor will cycle through the 
  ; cursors specified by the 'acur' resource.
  (let ((var (gensym)))
    `(let ((,var ,id-or-object))
       (when (integerp ,var)
         (setf ,var (make-animated-cursor ,var)))
       (with-cursor #'(lambda ()
                        (rotate-animated-cursor ,var))
         ,@body))))

#| - tests:

(with-animated-cursor 1000
  (let ((x 10))
    (dotimes (i 9999999999999)
      ; (update-cursor)
      (setf x (+ x i))
      (when (> x 9999)
        (setf x 0)))))

(with-animated-cursor 9000
  )
   (make-animated-cursor 1000)
|#
----------------------------------------
Derek White      	      (-ex Mr. Pascal)
ATG/East        	       (AppleLink: DEREK)