home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clue.lha / clue / examples / old / demo / demo-all.l < prev    next >
Encoding:
Text File  |  1989-07-12  |  3.7 KB  |  114 lines
  1. ;;; -*- Mode:Lisp; Package:CLUE-EXAMPLES; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2. ;;;
  3. ;;;             TEXAS INSTRUMENTS INCORPORATED
  4. ;;;                  P.O. BOX 2909
  5. ;;;                   AUSTIN, TEXAS 78769
  6. ;;;
  7. ;;; Copyright (C) 1988 Texas Instruments Incorporated.
  8. ;;;
  9. ;;; Permission is granted to any individual or institution to use, copy, modify,
  10. ;;; and distribute this software, provided that this complete copyright and
  11. ;;; permission notice is maintained, intact, in all copies and supporting
  12. ;;; documentation.
  13. ;;;
  14. ;;; Texas Instruments Incorporated provides this software "as is" without
  15. ;;; express or implied warranty.
  16. ;;;
  17.  
  18. ;;;
  19. ;;; Change history:
  20. ;;;
  21. ;;;  Date    Author    Description
  22. ;;; -------------------------------------------------------------------------------------
  23. ;;; 07/27/88    SLM     Defined demo menu driver.
  24. ;;;                     Each "demo" can be run standalone, or from the demo driver.
  25. ;;;                     bind XLIB:*recursive-event-queue* for each demo to avoid problems 
  26. ;;;                     resulting from the opening of a new contact-display to the same host 
  27. ;;;                     as the demo driver.
  28.  
  29. (in-package 'clue-examples :use '(lisp xlib clos cluei))
  30.  
  31.  
  32.  
  33. ;;;----------------------------------------
  34. ;;; Take advantage of TI multiprocess support to run mouse doc demo
  35. #+explorer
  36. (defvar *mouse-doc-process nil)
  37.  
  38. #+explorer
  39. (defun toggle-doc (&optional (host *default-host*))
  40.   (if *mouse-doc-process
  41.       (progn (ticl:send *mouse-doc-process :kill)
  42.          (setf *mouse-doc-process nil))
  43.     (setf *mouse-doc-process
  44.       (ticl:process-run-function "mdoc" 'xlib:mouse-doc host :height 3 :border-width 5))))
  45.  
  46.  
  47. ;;;----------------------------------------
  48. ;;; Driver utility routines
  49.  
  50. (defun execute-the-demo (&rest args)
  51.   (let ((xlib::*recursive-event-queue* nil))
  52. #+explorer
  53.     (catch () ;;keep "abort" in the demos from aborting the driver
  54.     (apply (car args) (cdr args)))
  55. #-explorer
  56.     (apply (car args) (cdr args))))
  57.  
  58.  
  59. (defmethod quit-demo ((contact contact) &optional (tag 'quit) value)
  60.   (throw tag value))
  61.  
  62.  
  63. (defvar *default-image* (merge-pathnames "ti-logo.xbm" user::*clue-demo-directory*))
  64.  
  65.  
  66. (define-resources
  67.   (test * border) 1                             
  68.   (* menu * documentation) "Mouse-Left to select"
  69.   (* demo-menu x) 100
  70.   (* demo-menu y) 100
  71.   )
  72.  
  73.  
  74.  
  75.  
  76. ;;;================================================================================
  77. ;;; Demo Driver 
  78.  
  79.  
  80.  
  81. (defun demo-all (&optional (host *default-host*))
  82.   (let (display demo)
  83.     (unwind-protect
  84.     (catch 'exit
  85.       (setf display (open-contact-display 'test :host host)
  86.         demo (make-contact 'top-level-shell :parent display
  87.                     :shadow-width 8
  88.                     :width 600 :height 600 :x 212 :y 54))
  89.           (x11:x-select-and-enable)
  90.       (menu-choose demo `(("Regular Menu" :select (execute-the-demo menu-demo ,display))
  91.                   ("Popup Cascading Menu" :select (execute-the-demo popup-demo ,display))
  92.                   ("Another Popup Menu" :select (execute-the-demo popup-demo2 ,display))
  93.                   ("Simple Grapher" :select (execute-the-demo user::simple-graph-demo ,display))
  94.                   ("Lisp Listener" :select (execute-the-demo lisp-listener ,display))
  95.                   ("Scrolling Bitmap" :select (execute-the-demo scroll-a-bitmap ,display ,*default-image*))
  96.                   #+explorer ("Toggle Mouse Documentation Window"
  97.                       :select (execute-the-demo toggle-doc ,host))
  98.                   (exit :documentation "Exit the CLUE Demo"
  99.                     :select (do-throw exit 'xxx) :font "vgi-20")
  100.                   )
  101.                :label "CLUE Demo Menu")
  102.                  
  103.       (add-event demo '(:key-press #\q) '(quit-demo exit))
  104.       (setf (contact-state demo) :mapped)
  105.       (loop (process-next-event display))
  106.       )
  107.       (when display (close-display display))
  108.       #+explorer
  109.       (when *mouse-doc-process
  110.     (ticl:send *mouse-doc-process :kill)
  111.     (setf *mouse-doc-process nil))
  112.       )
  113.     ))
  114.