home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / source / oodleutl.cpt / oodles-of-utils / work-in-progress / defproc-u.lisp next >
Encoding:
Text File  |  1992-03-04  |  9.6 KB  |  274 lines
  1. (in-package :oou)
  2. (oou-provide :defproc-u)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; defproc-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 creating defininition procedure within MCL 
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (oou-dependencies :Records-u
  15.                   :Resources-u
  16.                   :QuickDraw-u)
  17.  
  18. (export '(def-MDEF MDEF-menu MDEF-install-defproc))
  19.  
  20. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  21.  
  22.  (eval-when (:compile-toplevel :load-toplevel :execute)
  23.    
  24.    (defvar *defproc-rsrc-file* "oou:work-in-progress;defproc.rsrc")
  25.    (defconstant JMP-instruction #x4EF9)
  26.    
  27.    (defrecord (fake-defproc :pointer)
  28.      (jmpInst      :word)
  29.      (defproc-addr :pointer))
  30.    
  31.    (defmacro def-MDEF (MDEF-name (&rest arglist) &body body)
  32.      `(progn
  33.         (defpascal ,MDEF-name ,arglist ,@body)
  34.         (install-defproc "MDEF" (symbol-name ',MDEF-name) ,MDEF-name)))
  35.  
  36.    )
  37.  
  38. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  39.  
  40. (defun install-defproc (defproc-type fake-defproc-id-or-name defproc-addr)
  41.   (with-res-file (*defproc-rsrc-file* :if-not-open :leave-open)
  42.     (let ((defproc_h (get-resource defproc-type fake-defproc-id-or-name :errorp nil)))
  43.       (when (%null-ptr-p defproc_h)
  44.         (setf defproc_h (#_NewHandle (rlength :fake-defproc)))
  45.         (when (%null-ptr-p defproc_h)
  46.           (error "unable to allocate a fake defproc handle."))
  47.         (etypecase fake-defproc-id-or-name
  48.           (string  (with-pstrs ((name_p fake-defproc-id-or-name))
  49.                      (#_AddResource defproc_h defproc-type (#_UniqueID defproc-type) name_p)))
  50.           (fixnum  (with-pstrs ((name_p "fake defproc"))
  51.                      (#_AddResource defproc_h defproc-type fake-defproc-id-or-name name_p)))))
  52.       (with-dereferenced-handles ((defproc_p defproc_h))
  53.         (pset defproc_p :fake-defproc.jmpInst      JMP-instruction)
  54.         (pset defproc_p :fake-defproc.defproc-addr defproc-addr))
  55.       defproc_h)))
  56.  
  57.  
  58. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  59. ;; currently, the MCL menu class doesn't readily lend itself to using
  60. ;; custom MDEFs, so MDEF-menu is provided.
  61.  
  62. (defclass MDEF-menu (menu)
  63.   ((MDEF-defpascal-sym :initarg :MDEF-defpascal-sym
  64.                        :accessor MDEF-defpascal-sym))
  65.   )
  66.  
  67. (defmethod menu-install ((m MDEF-menu))
  68.   (let ((*menubar-frozen* t))
  69.     (call-next-method)
  70.     (MDEF-install-defproc m))
  71.   (draw-menubar-if)
  72.   t)
  73.  
  74. (defmethod MDEF-install-defproc ((m MDEF-menu))
  75.   (with-macptrs ((defproc-addr (symbol-value (MDEF-defpascal-sym m)))
  76.                  (defproc_h (install-defproc "MDEF" (symbol-name (MDEF-defpascal-sym m)) defproc-addr))
  77.                  (menu_h (menu-handle m)))
  78.     (hset menu_h :MenuInfo.menuProc defproc_h)
  79.     (when (menu-installed-p m)
  80.       (#_CalcMenuSize menu_h))))
  81.  
  82. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  83.  
  84. #|
  85.  
  86.  
  87. (defclass card-stack-menu (MDEF-menu)
  88.   ((card-size   :initarg :card-size
  89.                 :accessor card-size)
  90.    (max-vis     :initarg :max-vis
  91.                 :accessor max-vis)
  92.    (dh          :initarg :dh
  93.                 :accessor dh)
  94.    (dv          :initarg :dv
  95.                 :accessor dv)
  96.    (l-region    :accessor l-region)
  97.    (tc-topLeft  :accessor tc-topLeft)
  98.    
  99.    )
  100.   (:default-initargs
  101.     :MDEF-defpascal-sym 'card-stack-MDEF
  102.     :card-size #@(200 100)
  103.     :max-vis nil
  104.     :dh -20
  105.     :dv -20
  106.     )
  107.   )
  108.  
  109.  
  110. (defmethod menu-install :after ((m MDEF-menu))
  111.   (setf (l-region m) (#_NewRgn))
  112.   (card-stack-init m))
  113.  
  114. (defmethod menu-deinstall :after ((m MDEF-menu))
  115.   (#_DisposeRgn (l-region m))
  116.   (slot-makunbound m 'l-region))
  117.  
  118. (defmethod vis-count ((m MDEF-menu))
  119.   (min (or (max-vis m) most-positive-fixnum) (length (menu-items m))))
  120.  
  121. (defmethod card-stack-init ((m MDEF-menu))
  122.   (card-stack-init-l-region m)
  123.   (card-stack-init-tc-topLeft m))
  124.  
  125. (defmethod card-stack-init-tc-topLeft ((m MDEF-menu)) 
  126.   (setf (tc-topLeft m)
  127.         (with-macptrs ((menu_h (menu-handle m)))
  128.           (if (plusp (dv m))
  129.             (if (plusp (dh m))
  130.               #@(0 0)
  131.               (make-point (- (href menu_h :MenuInfo.menuWidth) (point-h (card-size m)))
  132.                           0))
  133.             (if (plusp (dh m))
  134.               (make-point 0
  135.                           (- (href menu_h :MenuInfo.menuHeight) (point-v (card-size m))))
  136.               (make-point (- (href menu_h :MenuInfo.menuWidth)  (point-h (card-size m)))
  137.                           (- (href menu_h :MenuInfo.menuHeight) (point-v (card-size m))))
  138.               )))))
  139.  
  140. (defmethod card-stack-init-l-region ((m MDEF-menu))
  141.   (rlet ((r :Rect
  142.             :topLeft #@(0 0)
  143.             :botRight (card-size m)))
  144.     (with-macptrs ((rgn-a (l-region m))
  145.                    (rgn-b (#_NewRgn)))
  146.       (#_RectRgn rgn-a r)
  147.       (#_OffsetRect r (+ (dh m) (signum (dh m))) (+ (dv m) (signum (dv m))))
  148.       (#_RectRgn rgn-b r)
  149.       (#_DiffRgn rgn-b rgn-a rgn-a)
  150.       (#_DisposeRgn rgn-b))))
  151.  
  152. (defmethod card-stack-card-offset ((m MDEF-menu) item-num)
  153.   (add-points (tc-topLeft m)
  154.               (make-point (* (1- item-num) (dh m)) (* (1- item-num) (dv m)))))
  155.  
  156. (defmethod card-stack-invert-item ((m MDEF-menu) menuRect item-num)
  157.   (let ((first-card-num 1))
  158.     (if (= item-num first-card-num)
  159.       (let ((topLeft (add-points (pref menuRect :Rect.topLeft) (tc-topLeft m))))
  160.         (rlet ((r :Rect
  161.                   :topLeft topLeft
  162.                   :botRight (add-points topLeft (card-size m))))
  163.           (#_InvertRect r)))
  164.       (let ((topLeft (add-points (pref menuRect :Rect.topLeft) (card-stack-card-offset m item-num))))
  165.         (with-macptrs ((l-rgn (l-region m)))
  166.           (move-region-to l-rgn topLeft)
  167.           (#_InvertRgn l-rgn))))))
  168.  
  169. (defmethod card-stack-find-item ((m MDEF-menu) menuRect pt)
  170.     (let ((first-card-num 1))
  171.       (let ((topLeft (add-points (pref menuRect :Rect.topLeft) (tc-topLeft m))))
  172.         (rlet ((r :Rect
  173.                   :topLeft topLeft
  174.                   :botRight (add-points topLeft (card-size m))))
  175.           (dotimes (i (vis-count m) 0)
  176.             (when (#_PtInRect pt r) (return (+ first-card-num i)))
  177.             (#_OffsetRect r (dh m) (dv m)))))))
  178.  
  179. (defmethod card-stack-mSizeMsg ((m card-stack-menu))
  180.   (with-macptrs ((menu_h (menu-handle m)))
  181.     (let ((n (1- (length (menu-items m)))))
  182.       (hset menu_h :MenuInfo.menuWidth  (+ (* (abs (dh m)) n) (point-h (card-size m))))
  183.       (hset menu_h :MenuInfo.menuHeight (+ (* (abs (dv m)) n) (point-v (card-size m)))))))
  184.  
  185. (defmethod card-stack-mChooseMsg ((m card-stack-menu) menuRect hit-point last-item-num)
  186.   (let ((in-item-num (card-stack-find-item m menuRect hit-point)))
  187.     
  188.     (unless (= last-item-num in-item-num)
  189.       (when (plusp last-item-num)
  190.         (card-stack-invert-item m menuRect last-item-num))
  191.       (when (plusp in-item-num)
  192.         (card-stack-invert-item m menuRect in-item-num)))
  193.       in-item-num))
  194.  
  195.  
  196. (defmethod card-stack-mDrawMsg ((m card-stack-menu) menuRect)
  197.  
  198. #|
  199.   ;This restores the area under the menu by calling the MBDF with the Restore message
  200.   ;But, it also crashes the system after you release the mouse.
  201.   ;I think because the restore causes the MBDF to release some memory (the stored bits)
  202.   ;and when the the mouse is released, the restore message is sent a second time, but
  203.   ;the memory it uses has already been released - BOOM.
  204.   (with-macptrs ((MDEF_h (get-resource "MBDF" 0)))
  205.     (with-dereferenced-handles ((MDEF_p MDEF_h))
  206.       (ff-call MDEF_p :word 0 :word 8 :word 0 :long 0 :long)))
  207. |#
  208.  
  209.   (let ((first-card-num 1))
  210.     (let ((topLeft (add-points (pref menuRect :Rect.topLeft) (tc-topLeft m))))
  211.       (rlet ((r :Rect
  212.                 :topLeft topLeft
  213.                 :botRight (add-points topLeft (card-size m))))
  214.         
  215.         ;draw front card
  216.         (with-clip-rect r
  217.           (with-pstrs ((i-title_p (menu-item-title (elt (menu-items m) (1- first-card-num)))))
  218.             (#_TextBox (%inc-ptr i-title_p) (%get-byte i-title_p) r #$teJustCenter))
  219.           (#_FrameRect r))
  220.         
  221.         ;draw rest
  222.         (#_OffsetRect r (dh m) (dv m))
  223.         (with-macptrs ((l-rgn (l-region m)))
  224.           (move-region-to l-rgn (pref r :Rect.topLeft))
  225.           (let ((item-list (rest (menu-items m))))
  226.             (dotimes (i (1- (vis-count m)))
  227.               (with-clip-rgn l-rgn
  228.                 (with-pstrs ((i-title_p (menu-item-title (first item-list))))
  229.                   (#_TextBox (%inc-ptr i-title_p) (%get-byte i-title_p) r #$teJustCenter))
  230.                 (#_FrameRgn l-rgn))
  231.               (#_OffsetRect r     (dh m) (dv m))
  232.               (#_OffsetRgn  l-rgn (dh m) (dv m))
  233.               (pop item-list))))))))
  234.  
  235.  
  236. (def-MDEF card-stack-MDEF (:word message :ptr theMenu :ptr menuRect :long hitPt :ptr whichItem)
  237.   (let ((m (find-menu (pref theMenu :MenuInfo.menuData))))
  238.     (ecase message
  239.       (#.#$mDrawMsg
  240.        (card-stack-mDrawMsg m menuRect))
  241.       (#.#$mChooseMsg
  242.        (%put-word whichItem (card-stack-mChooseMsg m menuRect hitPt (%get-word whichItem))))
  243.       (#.#$mSizeMsg
  244.        (card-stack-mSizeMsg m)))))
  245.  
  246. ;(MDEF-install-defproc *funky-menu*)
  247.  
  248. (defparameter *funky-menu*
  249.   (make-instance 'card-stack-menu
  250.     :menu-title "funky menu"
  251.     :MDEF-defpascal-sym 'card-stack-MDEF
  252.     :menu-items (list
  253.                  (make-instance 'menu-item
  254.                    :menu-item-title "item 1")
  255.                  (make-instance 'menu-item
  256.                    :menu-item-title "item 2")
  257.                  (make-instance 'menu-item
  258.                    :menu-item-title "item 3"))))
  259.  
  260. ;(menu-install   *funky-menu*)
  261. ;(menu-deinstall *funky-menu*)
  262. ;(menu-deinstall (find-menu "funky menu"))
  263.  
  264.  
  265.  
  266. ;MBarHook
  267. ;(%get-ptr (%int-to-ptr #xA2c))
  268.  
  269. ;SavedHandle
  270. ;(%get-ptr (%int-to-ptr #xA28))
  271.  
  272.  
  273.  
  274. |#