Re: window sizes

[hohmann@valais.csmil.umich.edu]

The following MCL 1.3.2 code will read in a cursor resource from
a resource file that was prepared by ResEdit.  The code to manipulate the 
resource file is from Michael S. Engbar.

I use this code to read in a cursor shaped like a running man,
to read in a sequence of cursors stored in an array, and
cursors shaped like hand.  Hope this helps.

  -- Luke

;;-> CURSORS --------------------------------------------------------------
;;
(defvar *hand-cursor*                    nil)
(defvar *running-man-cursor*             nil)
(defvar *world-cursor-array*             nil)
(defparameter *world-cursor-index*       nil)
(defparameter *world-cursor-lag-counter* nil)


(defun initialize-cursors ()
  (open-resource-file "SPADE;SPADE.rsrc")
  
  (setf *hand-cursor* (get-resource "CURS" 256))
  (_HNoPurge :a0 *hand-cursor*)
  (_DetachResource :ptr *hand-cursor*)
  
  (setf *running-man-cursor* (get-resource "CURS" 132))
  (_HNoPurge :a0 *running-man-cursor*)
  (_DetachResource :ptr *running-man-cursor*)

  (setf (aref *world-cursor-array* 0) (get-resource "CURS" 1021))
  (_HNoPurge :a0 (aref *world-cursor-array* 0))
  (_DetachResource :ptr (aref *world-cursor-array* 0))

  (setf (aref *world-cursor-array* 1) (get-resource "CURS" 1022))
  (_HNoPurge :a0 (aref *world-cursor-array* 1))
  (_DetachResource :ptr (aref *world-cursor-array* 1))

  (setf (aref *world-cursor-array* 2) (get-resource "CURS" 1023))
  (_HNoPurge :a0 (aref *world-cursor-array* 2))
  (_DetachResource :ptr (aref *world-cursor-array* 2))

  (setf (aref *world-cursor-array* 3) (get-resource "CURS" 1024))
  (_HNoPurge :a0 (aref *world-cursor-array* 3))
  (_DetachResource :ptr (aref *world-cursor-array* 3))

  (setf (aref *world-cursor-array* 4) (get-resource "CURS" 1025))
  (_HNoPurge :a0 (aref *world-cursor-array* 4))
  (_DetachResource :ptr (aref *world-cursor-array* 4))

  (setf (aref *world-cursor-array* 5) (get-resource "CURS" 1026))
  (_HNoPurge :a0 (aref *world-cursor-array* 5))
  (_DetachResource :ptr (aref *world-cursor-array* 5))

  (setf (aref *world-cursor-array* 6) (get-resource "CURS" 1027))
  (_HNoPurge :a0 (aref *world-cursor-array* 6))
  (_DetachResource :ptr (aref *world-cursor-array* 6))

  (setf (aref *world-cursor-array* 7) (get-resource "CURS" 1028))
  (_HNoPurge :a0 (aref *world-cursor-array* 7))
  (_DetachResource :ptr (aref *world-cursor-array* 7))

  (close-resource-file "SPADE;SPADE.rsrc"))
  

; this function makes the world cursors look like they are spinning
(defun spin-world ()
  (setf *world-cursor-index* 
        (mod (1+ *world-cursor-index*) 8))
  ; needed so that the cursor doesn't spin too fast
  (setf *world-cursor-lag-counter* 
        (mod (1+ *world-cursor-lag-counter*) 25))
  (if (eq 0 *world-cursor-lag-counter*)
    (set-cursor (aref *world-cursor-array* *world-cursor-index*))))
  
;;; -*- package: ccl -*-

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; resource-utils.Lisp
;;
;; Copyright ) 1990 Northwestern University Institute for the Learning Sciences
;; All Rights Reserved
;;
;; author: Michael S. Engber
;;
;; utilities for handling resources
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(require 'traps)

(in-package :ccl
            :use '(:lisp :ccl))

(export '(full-mac-namestring
          open-resource-file
          close-resource-file
          get-resource
          get-named-resource
          get-res-info
          install-rsrc-menu-utils))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; resource file utilities
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar *open-resource-files* nil
  "keeps track of open reseource files - (refNum pathstring pairs)")

(defun full-mac-namestring (filename)
  "filename
Like mac-namestring, but returns the full path string to the specified file."
  (let ((dir (mac-directory filename))
        (fn (mac-filename filename)))
    (if (string= dir "") (setf dir (mac-namestring (mac-default-directory))))
    (concatenate 'string dir fn)))
  

(defun open-resource-file (filename)
  "filename
Opens the resource fork of the the specified file.
Returns the refNum of the file, -1 if error."
  (setf filename (full-mac-namestring filename))
  (with-pstrs ((res_file filename))
    (let ((refNum (_openresfile :ptr res_file :word)))
      (pushnew (list refNum filename) *open-resource-files* :key #'first)
      refNum)))

(defun close-resource-file (fileSpec)
  "fileSpec
Close the resource fork of the specified file.
Files may be specified as a filename or a refNum.
Only files opened with open-resource-file may be closed."
  (let ((refNum nil))
    (cond 
     ((fixnump fileSpec) (setf refNum (car (find fileSpec *open-resource-files* :key #'car))))
     ((or (stringp fileSpec) (pathnamep fileSpec))
      (setf refNum (car (find (full-mac-namestring fileSpec) *open-resource-files*
                              :key #'second :test #'string=))))
     ((listp fileSpec) (dolist (fs fileSpec) (close-resource-file fs)))
     (t (error "bad file specification ~S" fileSpec)))
    (when (fixnump refNum)
      (_closeresfile :word refNum)
      (setf *open-resource-files* (delete refNum *open-resource-files* :key #'car)))
    (fixnump refNum)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; resource reading utilities
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro get-resource (ResType rsrcID)
  "ResType rsrcID
Returns a handle to the specified resource.
ResType is an ostype keyword, e.g. :ICON, \"CURS\".
rsrcID is the resource's number."
    `(_GetResource :ostype ,ResType :word ,rsrcID :ptr))

(defmacro get-named-resource (ResType rsrcName)
  "ResType rsrcName
Returns a handle to the specified resource.
ResType is an ostype keyword, e.g. :ICON, \"CURS\".
rsrcName is the resource's name, a string."
  `(with-pstrs ((name ,rsrcName))
     (_GetNamedResource :ostype ,ResType :ptr name :ptr)))

(defmacro get-res-info (theResource)
  "theResource
Returns three values - the specified resource's id, type, and name.
theResource is a handle to the resource. On error, nil is returned."
  `(without-interrupts
    (%stack-block ((rsrcID 2) (rsrcType 4) (rsrcName 256))
      (_GetResInfo :ptr ,theResource :ptr rsrcID :ptr rsrcType :ptr rsrcName)
      (if (zerop (_ResError :word))
        (values (%get-word rsrcID) (%get-ostype rsrcType) (%get-string rsrcName))
        nil))))
    

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; open/close resource file utilities for File menu
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun install-rsrc-menu-utils ()
  "void
Changes the Open/Close menus so that holding down shift lets you open/close
resource files."
  (require 'menu-utils)
  
  ;; holding shift down when selecting Open from the File menu
  ;;  changes Open to Open Resource File
  (let ((new-item (oneof *menu-item*
                         :menu-item-title "OpenI"
                         :command-key #\O
                         :menu-item-action #'(lambda ()
                                               (if (shift-key-p)
                                                 (open-resource-file (choose-file-dialog))
                                                 (ccl::edit-select-file))))))
    (ask new-item
      (fhave 'menu-item-update
             #'(lambda () (set-menu-item-title (if (shift-key-p) "Open Resource FileI" "OpenI")))))
    (ask (find-menu "File")
      (replace-menu-item new-item (find-menu-item "OpenI"))))
  
  
  ;; holding shift down when selecting Close from the File menu
  ;;  changes Close to Close Resource File
  (let ((new-item (oneof *menu-item*
                         :menu-item-title "Close"
                         :command-key #\W
                         :menu-item-action #'(lambda ()
                                               (if (shift-key-p)
                                                 (close-resource-file (select-item-from-list
                                                                       (mapcar #'second *open-resource-files*)
                                                                       :window-title "Select an Open Resource File to Close"
                                                                       :selection-type :disjoint))
                                                 (ask (front-window *window* t)
                                                   (when (fboundp 'window-close) (window-close))))))))
    
    (ask new-item
      (fhave 'menu-item-update
             #'(lambda () (set-menu-item-title (if (shift-key-p) "Close Resource FileI" "Close")))))
    (ask (find-menu "File")
      (replace-menu-item new-item (find-menu-item "Close")))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(provide 'resource-utils)
(pushnew :resource-utils *features*)