home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / source / oodleutl.cpt / oodles-of-utils / brutal-utils / GDevice-u.lisp next >
Encoding:
Text File  |  1992-04-03  |  2.4 KB  |  66 lines
  1. (in-package  :oou)
  2. (oou-provide :GDevice-u)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; GDevice-u.Lisp
  5. ;;
  6. ;; Copyright ⌐ 1992 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Michael S. Engber
  10. ;;
  11. ;; utilities for woring with g-devices
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (export '(get-max-device mapc-GDevices find-GDevice-containing-point
  15.           with-GDevice with-gd-SearchProc))
  16.  
  17. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18.  
  19. (eval-when (:compile-toplevel :load-toplevel :execute)
  20.   
  21.   (defmacro with-GDevice (gdh &body body)
  22.     (let ((old-gd (gensym)))
  23.       `(with-macptrs ((,old-gd (require-trap #_GetGDevice)))
  24.          (unwind-protect
  25.            (progn
  26.              (require-trap #_SetGDevice ,gdh)
  27.              ,@body)
  28.            (require-trap #_SetGDevice,old-gd)))))
  29.  
  30.   (defmacro with-gd-SearchProc ((gdh searchProc) &body body)
  31.     `(unwind-protect
  32.        (progn
  33.          (with-GDevice ,gdh
  34.            (require-trap #_AddSearch ,searchProc))
  35.          ,@body)
  36.        (with-GDevice, gdh
  37.          (require-trap #_DelSearch ,searchProc))))
  38.   
  39.   )
  40.  
  41. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  42.  
  43.  
  44. (defun get-max-device (&optional globalRect)
  45.   (if globalRect
  46.     (#_GetMaxDevice globalRect)
  47.     (with-dereferenced-handles ((GrayRgn_p (%get-ptr (%int-to-ptr #$GrayRgn))))
  48.       (#_GetMaxDevice (pref GrayRgn_p :Region.rgnBBox)))))
  49.  
  50. (defun mapc-GDevices (fn &optional (active-screens-only-p t))
  51. ;;Maps fn over the GDevice list. fn should accept one parameter, a GDHandle
  52.   (do ((gd (#_GetDeviceList) (#_GetNextDevice gd)))
  53.       ((%null-ptr-p gd))
  54.     (when (or (and (#_TestDeviceAttribute gd #$screenDevice)
  55.                    (#_TestDeviceAttribute gd #$screenActive))
  56.               (not active-screens-only-p))
  57.       (funcall fn gd))))
  58.  
  59. (defun find-GDevice-containing-point (&optional (where (%stack-block ((p 4))
  60.                                                          (#_GetMouse :ptr p)
  61.                                                          (#_LocalToGlobal :ptr p)
  62.                                                          (%get-long p))))
  63.   (mapc-GDevices #'(lambda (gd)
  64.                      (with-dereferenced-handles ((gd_p gd))
  65.                        (when (#_PtInRect where (pref gd_p :GDevice.gdRect))
  66.                          (return-from find-GDevice-containing-point gd))))))