home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / source / oodleutl.cpt / oodles-of-utils / low-class-extensions / window-ce.lisp < prev   
Encoding:
Text File  |  1992-04-14  |  3.2 KB  |  79 lines
  1. (in-package :oou)
  2. (oou-provide :window-ce)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; window-ce.Lisp
  5. ;;
  6. ;; Copyright ⌐ 1992 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Michael S. Engber
  10. ;;
  11. ;; methods for the window class
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (oou-dependencies
  15.  :GDevice-u)
  16.  
  17. (export '(window-center-on-screen
  18.           ))
  19.  
  20. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21.  
  22. (defmethod window-center-on-screen ((w window) which-screen
  23.                                     &key
  24.                                     (upper-3rd-p t)
  25.                                     (move-now-p  t)
  26.                                     (GDevice     nil)
  27.                                     (point       nil))
  28.   (with-macptrs ((gd (ecase which-screen
  29.                        (:specified-GD     (if (handlep GDevice) GDevice (error "bad GDevice")))
  30.                        (:deepest          (get-max-device))
  31.                        (:main             (#_GetMainDevice))
  32.                        (:containing-mouse (find-GDevice-containing-point))
  33.                        (:containing-point (find-GDevice-containing-point point)))))
  34.     (let ((struct-topLeft)
  35.           (struct-botRight)
  36.           (content-topLeft))
  37.       (let ((shown-p   (window-shown-p w))
  38.             (old-w-pos (view-position w)))
  39.         (with-macptrs ((struct-rgn  (pref (wptr w) :WindowRecord.strucRgn))
  40.                        (content-rgn (pref (wptr w) :WindowRecord.contRgn)))
  41.           (unless shown-p
  42.             ;hidden windows have empty struct/content regions
  43.             ;so we temporarily show them (way the hell off screen)
  44.             (set-view-position w #@(16383 16383))
  45.             (#_ShowWindow (wptr w)))
  46.           
  47.           (setf struct-topLeft  (href struct-rgn  :Region.rgnBBox.topLeft)
  48.                 struct-botRight (href struct-rgn  :Region.rgnBBox.botRight)
  49.                 content-topLeft (href content-rgn :Region.rgnBBox.topLeft))
  50.           
  51.           (unless shown-p
  52.             (#_HideWindow (wptr w))
  53.             (set-view-position w old-w-pos))))
  54.       
  55.       
  56.       (let* ((mbar-hgt (if (eql gd (#_GetMainDevice)) (#_GetMBarHeight) 0))
  57.              (wind-hgt (- (point-v struct-botRight) (point-v struct-topLeft)))
  58.              (wind-wid (- (point-h struct-botRight) (point-h struct-topLeft)))
  59.              (scrn-hgt (- (href gd :GDevice.gdRect.bottom) (href gd :GDevice.gdRect.top) mbar-hgt))
  60.              (scrn-wid (- (href gd :GDevice.gdRect.right)  (href gd :GDevice.gdRect.left)))
  61.              (v-off    (max (+  mbar-hgt (floor (- scrn-hgt wind-hgt) (if upper-3rd-p 3 2))) mbar-hgt))
  62.              (h-off    (max (floor (- scrn-wid wind-wid) 2) 0))
  63.              (pos (add-points
  64.                    (add-points (href gd :GDevice.gdRect.topLeft) (make-point h-off v-off))
  65.                    (subtract-points content-topLeft struct-topLeft))))
  66.         
  67.         (when move-now-p (set-view-position w pos))
  68.         pos))))
  69.  
  70. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  71.  
  72. #|
  73.  
  74. (setf *test-w* (make-instance 'window))
  75.  
  76. (window-center-on-screen *test-w* :main)
  77. (window-center-on-screen *test-w* :deepest)
  78.  
  79. |#