home *** CD-ROM | disk | FTP | other *** search
/ Education Sampler 1992 [NeXTSTEP] / Education_1992_Sampler.iso / Programming / Source / winterp-1.13 / examples / popup-menu.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1991-10-06  |  6.9 KB  |  218 lines
  1. ; -*-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;
  4. ; File:         popup-menu.lsp
  5. ; RCS:          $Header: popup-menu.lsp,v 1.3 91/10/05 18:38:00 mayer Exp $
  6. ; Description:  POPUP menu example. This is a 1-to-1 translation of the popup
  7. ;               menu example in the Motif Programmer's Guide. Just 'load' this
  8. ;               file to see the example.                    
  9. ;        Note that for Motif 1.1, closing the popup-menu shell created
  10. ;        here will give the following message (due to Motif bug):
  11. ;        "Warning: Attempt to remove non-existant passive grab"
  12. ;        However, if you have WINTERP resource "enableXtWarningBreak" set
  13. ;        to TRUE, you will corrupt the internal state of Motif, resulting
  14. ;        in subsequent inability to close windows, coredumps, etc.
  15. ;        The resource is set to FALSE by default so as to prevent such
  16. ;        problems. See ./../doc/BUGS for details. 
  17. ; Author:       Niels Mayer, HPLabs
  18. ; Created:      Thu Nov 23 12:43:54 1989
  19. ; Modified:     Sat Oct  5 18:37:40 1991 (Niels Mayer) mayer@hplnpm
  20. ; Language:     Lisp
  21. ; Package:      N/A
  22. ; Status:       X11r5 contrib tape release
  23. ;
  24. ; WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  25. ; XLISP version 2.1, Copyright (c) 1989, by David Betz.
  26. ;
  27. ; Permission to use, copy, modify, distribute, and sell this software and its
  28. ; documentation for any purpose is hereby granted without fee, provided that
  29. ; the above copyright notice appear in all copies and that both that
  30. ; copyright notice and this permission notice appear in supporting
  31. ; documentation, and that the name of Hewlett-Packard and Niels Mayer not be
  32. ; used in advertising or publicity pertaining to distribution of the software
  33. ; without specific, written prior permission.  Hewlett-Packard and Niels Mayer
  34. ; makes no representations about the suitability of this software for any
  35. ; purpose.  It is provided "as is" without express or implied warranty.
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37.  
  38. (setq toplevel
  39.       (send TOP_LEVEL_SHELL_WIDGET_CLASS :new "PopUp-Menu"
  40.         :XMN_TITLE "Popup Menu Example"
  41.         :XMN_ICON_NAME "Popup"
  42.         ))
  43.  
  44.  
  45. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  46. ;; Create RowColumn in toplevel with two pushbuttons
  47. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  48.  
  49. (setq rc
  50.       (send XM_ROW_COLUMN_WIDGET_CLASS :new :managed "rc" toplevel
  51.         :XMN_WIDTH 400
  52.         :XMN_HEIGHT 125
  53.         :XMN_RESIZE_WIDTH nil
  54.         :XMN_RESIZE_HEIGHT nil
  55.         :XMN_ADJUST_LAST nil
  56.         ))
  57.  
  58. (let ((buttons (MAKE-ARRAY 2)))
  59.  
  60.   (setf (aref buttons 0)
  61.     (send XM_PUSH_BUTTON_GADGET_CLASS :new "button0" rc
  62.           ))
  63.   (send (aref buttons 0) :set_callback :XMN_ACTIVATE_CALLBACK ()
  64.     '(
  65.       (format T "Button 0 selected.\n")
  66.       ))
  67.  
  68.   (setf (aref buttons 1) 
  69.     (send XM_PUSH_BUTTON_GADGET_CLASS :new "button1" rc
  70.           ))
  71.   (send (aref buttons 1) :set_callback :XMN_ACTIVATE_CALLBACK ()
  72.     '(
  73.       (format T "Button 1 selected.\n")
  74.       ))
  75.  
  76.   (xt_manage_children buttons)
  77.   )
  78.  
  79.  
  80. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  81. ;; Create Popup Menu
  82. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  83.  
  84. (setq popup
  85.       (send XM_ROW_COLUMN_WIDGET_CLASS :new :POPUP_MENU "popup" rc
  86.         ))
  87.  
  88. (send rc :set_event_handler BUTTON_PRESS_MASK
  89.       '(EVHANDLER_BUTTON        ;gets bound to button of event
  90.     EVHANDLER_XEVENT)        ;gets bound to Xevent struct.
  91.       `(
  92.     (if (= EVHANDLER_BUTTON 3)
  93.         (progn
  94.           (send ,popup :menu_position EVHANDLER_XEVENT)
  95.           (send ,popup :manage)
  96.           )))
  97.       )
  98.  
  99.  
  100. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  101. ;; Create two submenus and cascadebuttons in the popup menu
  102. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  103.  
  104. (setq submenu1
  105.       (send XM_ROW_COLUMN_WIDGET_CLASS :new :PULLDOWN_MENU "submenu1" popup
  106.         ))
  107.  
  108. (let ((popupBtn (MAKE-ARRAY 2)))
  109.  
  110.   (setf (aref popupBtn 0)
  111.     (send XM_CASCADE_BUTTON_GADGET_CLASS :new "cbutton1" popup
  112.           :XMN_SUB_MENU_ID submenu1
  113.           :XMN_LABEL_STRING "First Submenu"
  114.           ))
  115.  
  116.   (setq submenu2
  117.     (send XM_ROW_COLUMN_WIDGET_CLASS :new :PULLDOWN_MENU "submenu2" popup
  118.           ))
  119.  
  120.   (setf (aref popupBtn 1)
  121.     (send XM_CASCADE_BUTTON_GADGET_CLASS :new "cbutton2" popup
  122.           :XMN_SUB_MENU_ID submenu2
  123.           :XMN_LABEL_STRING "Second Submenu"
  124.           ))
  125.  
  126.   (xt_manage_children popupBtn)
  127.   )
  128.  
  129.  
  130. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  131. ;; Create pushbuttons in submenu1 and submenu2
  132. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  133.  
  134. (setq sub1Btn  (MAKE-ARRAY 3))
  135.  
  136. (setf (aref sub1Btn 0)
  137.       (send XM_PUSH_BUTTON_GADGET_CLASS :new "button1a" submenu1
  138.         ))
  139. (send (aref sub1Btn 0) :set_callback :XMN_ACTIVATE_CALLBACK '()
  140.       '(
  141.     (format T "Button 1a selected.\n")
  142.     ))
  143.  
  144. (setf (aref sub1Btn 1)
  145.       (send XM_PUSH_BUTTON_GADGET_CLASS :new "button1b" submenu1
  146.         ))
  147. (send (aref sub1Btn 1) :set_callback :XMN_ACTIVATE_CALLBACK '()
  148.       '(
  149.     (format T "Button 1b selected.\n")
  150.     ))
  151.  
  152.  
  153. (let ((sub2Btn (MAKE-ARRAY 2)))
  154.  
  155.   (setf (aref sub2Btn 0)
  156.     (send XM_PUSH_BUTTON_GADGET_CLASS :new "button2a" submenu2
  157.           ))
  158.   (send (aref sub2Btn 0) :set_callback :XMN_ACTIVATE_CALLBACK '()
  159.     '(
  160.       (format T "Button 2a selected.\n")
  161.       ))
  162.  
  163.   (setf (aref sub2Btn 1)
  164.     (send XM_PUSH_BUTTON_GADGET_CLASS :new "button2b" submenu2
  165.           ))
  166.   (send (aref sub2Btn 1) :set_callback :XMN_ACTIVATE_CALLBACK '()
  167.     '(
  168.       (format T "Button 2b selected.\n")
  169.       ))
  170.  
  171.   (xt_manage_children sub2Btn)
  172.   )
  173.  
  174. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  175. ;; Create a submenu of submenu 1
  176. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  177. (setq submenu3
  178.       (send XM_ROW_COLUMN_WIDGET_CLASS :new :PULLDOWN_MENU "submenu3" submenu1
  179.         ))
  180.  
  181. (setf (aref sub1Btn 2)
  182.       (send XM_CASCADE_BUTTON_GADGET_CLASS :new "cbutton3" submenu1
  183.         :XMN_SUB_MENU_ID submenu3
  184.         :XMN_LABEL_STRING "To Third Submenu"
  185.         ))
  186.  
  187. (xt_manage_children sub1Btn)
  188.  
  189. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  190. ;; Create Pushbuttons in submenu 3
  191. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  192.  
  193. (let ((sub3Btn (MAKE-ARRAY 2)))
  194.  
  195.   (setf (aref sub3Btn 0)
  196.     (send XM_PUSH_BUTTON_GADGET_CLASS :new "button3a" submenu3
  197.           ))
  198.   (send (aref sub3Btn 0) :set_callback :XMN_ACTIVATE_CALLBACK '()
  199.     '(
  200.       (format T "Button 3a selected.\n")
  201.       ))
  202.  
  203.   (setf (aref sub3Btn 1)
  204.     (send XM_PUSH_BUTTON_GADGET_CLASS :new "button3b" submenu3
  205.           ))
  206.   (send (aref sub3Btn 1) :set_callback :XMN_ACTIVATE_CALLBACK '()
  207.     '(
  208.       (format T "Button 3b selected.\n")
  209.       ))
  210.  
  211.   (xt_manage_children sub3Btn)
  212.   )
  213.  
  214. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  215. ;; Create the windows and Make them visible.
  216. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  217. (send toplevel :realize)
  218.