home *** CD-ROM | disk | FTP | other *** search
/ Otherware / Otherware_1_SB_Development.iso / mac / developm / source / oodleutl.cpt / oodles-of-utils / brutal-utils / Menus-u.lisp < prev    next >
Encoding:
Text File  |  1992-01-27  |  6.1 KB  |  139 lines
  1. (in-package :oou)
  2. (oou-provide :Menus-u)
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;; Menus-u.Lisp
  5. ;;
  6. ;; Copyright ⌐ 1991 Northwestern University Institute for the Learning Sciences
  7. ;; All Rights Reserved
  8. ;;
  9. ;; author: Michael S. Engber
  10. ;;
  11. ;; utilities for menus
  12. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13.  
  14. (oou-dependencies
  15.  )
  16.  
  17. (export '(select-item-from-pup pup-arrow-draw))
  18.  
  19. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20. ;; pop-up menu functions
  21.  
  22. (defun pup-arrow-draw (rect &key (width 10) (right-indent 4))
  23.   (#_MoveTo (- (pref rect :Rect.right) width right-indent)
  24.    (floor (- (+ (pref rect :Rect.top) (pref rect :Rect.bottom)) (ceiling width 2)) 2))
  25.   (loop
  26.     (#_Line width 0)
  27.     (decf width)
  28.     (#_Move (- width) 1)
  29.     (decf width)
  30.     (when (minusp width) (return))))
  31.  
  32.  
  33. (defun select-item-from-pup (item-list                        
  34.                              &key
  35.                              (where (%stack-block ((p 4))
  36.                                       (#_GetMouse p)
  37.                                       (#_LocalToGlobal p)
  38.                                       (%get-point p)))
  39.                              (default-item 0)
  40.                              (checked-items nil)
  41.                              (other-p nil)
  42.                              (test 'eql)
  43.                              (item-to-string-fn 'princ-to-string)
  44.                              (hier-p-fn nil)
  45.                              (hier-items-fn nil)
  46.                              (hier-parent-fn nil)
  47.                              (hier-select-p t))
  48.   (let ((sub-id-cnt 0)
  49.         (m-alist nil))
  50.     (with-pstrs ((danQuayle " "))
  51.       (labels ((new-id (sub-menu-p)
  52.                        (let ((id (if sub-menu-p
  53.                                    (if (< sub-id-cnt 235)
  54.                                      (incf sub-id-cnt)
  55.                                      (error "no available sub-menu-id's (range 1-235)"))
  56.                                    (#_UniqueID "MENU"))))
  57.                          (if (%null-ptr-p (#_GetMHandle id)) id (new-id sub-menu-p))))
  58.                (make-menu (item-list sub-menu-p)
  59.                           (let ((menu-id (new-id sub-menu-p)))
  60.                             (with-macptrs ((menu_h (#_NewMenu menu-id danQuayle)))
  61.                               (let ((i 1))
  62.                                 (dolist (item item-list)
  63.                                   (let ((hier-p (and hier-p-fn (funcall hier-p-fn item))))
  64.                                     (with-pstrs ((title_p (funcall item-to-string-fn (if hier-p (funcall hier-parent-fn item) item))))
  65.                                       (#_AppendMenu menu_h danQuayle)
  66.                                       (#_SetItem menu_h i title_p)
  67.                                       (when (find item checked-items :test test) (#_CheckItem menu_h i t))
  68.                                       (when hier-p
  69.                                         (#_SetItemCmd  menu_h i (code-char #$hMenuCmd))
  70.                                         (#_SetItemMark menu_h i (code-char (make-menu (funcall hier-items-fn item) t))))))
  71.                                   (#_InsertMenu menu_h #$hierMenu)
  72.                                   (incf i))
  73.                                 (setf m-alist (acons menu-id item-list m-alist))
  74.                                 menu-id)))))
  75.         (declare (dynamic-extent #'new-id #'make-menu))
  76.         
  77.         (unwind-protect
  78.           (with-macptrs ((menu_h (#_GetMHandle (make-menu item-list nil))))
  79.             
  80.             (when other-p (with-pstrs ((dashes "(-")
  81.                                        (title "Other╔"))
  82.                             (#_AppendMenu menu_h dashes)
  83.                             (#_AppendMenu menu_h title)))
  84.             
  85.             ;;FlushEvents is needed in case we're not called from event processing
  86.             ;; (e.g. some one tries us out by typing into the listener)
  87.             (unless (boundp '*current-event*) (#_FlushEvents #$mDownMask 0))
  88.             
  89.             (let ((sel-code (with-cursor *arrow-cursor*
  90.                               (#_PopUpMenuSelect menu_h (point-v where) (point-h where) (1+ default-item)))))
  91.               (when (and (zerop sel-code) hier-select-p) (setf sel-code (#_MenuChoice)))
  92.               (let* ((sel-menu-id   (#_HiWord sel-code))
  93.                      (sel-item-no   (#_LoWord sel-code))
  94.                      (sel-item-list (rest (assoc sel-menu-id m-alist))))
  95.                 (cond ((zerop sel-item-no) (values nil nil))
  96.                       ((<= sel-item-no (length sel-item-list))
  97.                        (let ((sel-item (elt sel-item-list (1- sel-item-no))))
  98.                          (values (if (and hier-p-fn (funcall hier-p-fn sel-item))
  99.                                    (funcall hier-parent-fn sel-item)
  100.                                    sel-item)
  101.                                  (1- sel-item-no))))
  102.                       ((= sel-item-no (+ 2 (length sel-item-list))) (values :other nil))
  103.                       (t (values nil nil))))))
  104.           
  105.           (dolist (i m-alist)
  106.             (#_DeleteMenu (first i))
  107.             (#_DisposeMenu (#_GetMHandle (first i)))))))))
  108.  
  109. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  110.  
  111. #|
  112.  
  113.  
  114. ;simple example
  115. (loop
  116.   (when (mouse-down-p) 
  117.     (without-interrupts 
  118.      (return (select-item-from-pup '(1 2 3 4) :other-p t :default-item 1 :checked-items '(1 3))))))
  119.  
  120. ;illustrates :item-to-string-fn
  121. (loop
  122.   (when (mouse-down-p) 
  123.     (without-interrupts 
  124.      (return (select-item-from-pup '((11111 :item1) (22222 :item2) (55555 :item3))
  125.                                    :item-to-string-fn #'(lambda (i) (princ-to-string (second i))))))))
  126.  
  127.  
  128. ;;example of a hierarchical menu using a simple tree structure
  129. ;; it uses nested lists to represent sub-hierarchy the 1st element being the
  130. ;; parent and the rest being the children.
  131. (loop
  132.   (when (mouse-down-p) 
  133.     (without-interrupts 
  134.      (return (select-item-from-pup '(1 2 (3 31 32 33) 4)
  135.                                    :hier-p-fn 'listp
  136.                                    :hier-items-fn 'rest
  137.                                    :hier-parent-fn 'first)))))
  138.  
  139. |#