home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clue.lha / clue / examples / old / demo / menu-demo.l < prev    next >
Encoding:
Text File  |  1989-07-12  |  4.7 KB  |  160 lines
  1. ;;; -*- Mode:Lisp; Package:CLUE-EXAMPLES; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1988 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17.  
  18.  
  19. ;;; Change history:
  20. ;;;
  21. ;;;  Date    Author    Description
  22. ;;; -------------------------------------------------------------------------------------
  23. ;;; 09/14/87    LGO    Created
  24. ;;; 07/26/88    LGO     Updated to use new implementation of menus.
  25.  
  26. (in-package 'clue-examples :use '(lisp xlib clos cluei))
  27.  
  28.  
  29.  
  30.  
  31. (defun menu-demo (display)
  32.   ;;      (add-before-action display 'basic-contact 'trace :motion-notify) ;; debug
  33.   
  34.   
  35.   (let* ((p (make-contact 'top-level-shell :parent display
  36.                           :name 'demo-menu
  37.                           :shadow-width 8)))
  38.     (add-callback p :map #'position-over-mouse p)
  39.     (unwind-protect
  40.     (progn
  41.       (catch 'exit
  42.         
  43.         (menu-choose p '((one :documentation "Item one documentation")
  44.                  (two :documentation (("item two normal documentation")
  45.                           ("item two shift documentation" :state (:shift))))
  46.                  (three :documentation (("Item three documentation")
  47.                             ("Double-click any key to beep"))
  48.                     :select (print hi-there)
  49.                     :event (:any :double-click) :select (eval (print "Greetings")))
  50.                  (four :documentation (("item Four normal documentation" :select (:shift))
  51.                            ("Item Four shifty documentation" :state (:shift))))
  52.                  (five :documentation "Item Five documentation")
  53.                  (six :documentation (("item Six normal documentation" :select (:shift :control))
  54.                           ("Item Six Shift documentation" :state (:shift))
  55.                           ("Item Six Control documentation" :state (:control))))
  56.                  (seven :documentation "Item Seven documentation")
  57.                  (eight :documentation (("Item Eight documentation, line 1")
  58.                             ("Item Eight documentation, line 2")))
  59.                  (exit :documentation "Exit the Menu-Demo"
  60.                    :select  (do-throw exit 'xxx)
  61.                    :font "vgi-20"))
  62.              :label "Regular Menu"
  63.              :width 20
  64.              :handler 'print)
  65.             (setf (contact-state p) :mapped)
  66.         (loop (process-next-event display))))
  67.       (destroy p))))
  68.  
  69.  
  70.  
  71.  
  72.  
  73. (defun popup-demo (display)
  74.   (let* ((p (make-contact 'top-level-shell :parent display
  75.                           :name 'demo-menu
  76.                           :shadow-width 8)))
  77.     (add-callback p :map #'position-over-mouse p)
  78.     (unwind-protect
  79.     (progn
  80.       (catch 'abort
  81. ;;      (add-before-action display 'basic-contact 'trace :motion-notify) ;; debug
  82.         
  83.         
  84.         (menu-choose p
  85.              `(one
  86.                 two
  87.                 three
  88.                 four
  89.                 (cascade :cascade
  90.                      (popup-choose ,display
  91.                            (aaaaaaaa
  92.                              bbbbbbbbb
  93.                              (ccccccccc :cascade
  94.                                 (popup-choose ,display
  95.                                           (xxxxx    
  96.                                         yyyyy
  97.                                         zzzzz
  98.                                         )
  99.                                           :spring-loaded t
  100.                                           :name cascade-2))
  101.                              ddddddddd
  102.                              eeeeeeeee
  103.                              )
  104.                            :spring-loaded t
  105.                            :name cascade-1))
  106.                 six
  107.                 seven
  108.                 eight
  109.                 (exit :select (do-throw abort 'xxx) :font "vgi-20"))
  110.         
  111.         :label "Pop-up Cascading menu"
  112.         :handler #'print
  113.         :name 'first-entry-to-cascade)
  114.           (setf (contact-state p) :mapped)
  115.       (loop (process-next-event display))))
  116.       (destroy p))))
  117.  
  118.  
  119.  
  120. (defun popup-demo2 (display)
  121.   (let* ((shell (make-contact 'top-level-shell :parent display)))
  122.  
  123.     (add-callback shell :map #'position-over-mouse shell)
  124.     (unwind-protect
  125.         (catch 'shell
  126.           (menu-choose shell
  127.                        `((one :select (menu-exit 1))
  128.                          (two :select (menu-exit 2.0))
  129.                          (three :select (menu-exit 3))
  130.                          (four :select (menu-exit 4))
  131.              (cascade :cascade (popup-choose ,display
  132.                              (aaaaaaaa
  133.                                 bbbbbbbbb
  134.                                 (ccccccccc :cascade
  135.                                        (popup-choose ,display
  136.                                              (xxxxx yyyyy zzzzzz)
  137.                                              :name cascade2
  138.                                              :spring-loaded t
  139.                                              :handler menu-exit))
  140.                                 ddddddddd
  141.                                 eeeeeeeee)
  142.                              :name cascade1
  143.                              :spring-loaded t
  144.                              :handler menu-exit))
  145.              (six :select (menu-exit 6))
  146.              (seven :select (menu-exit 7))
  147.              (eight :select (menu-exit 8)))
  148.                :name 'popup-demo-2)
  149.           (setf (contact-state shell) :mapped)
  150.       (loop (process-next-event display)))
  151.       (destroy shell))))
  152.  
  153.  
  154.  
  155.  
  156.  
  157.  
  158.  
  159.  
  160.