home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / X / mit / lib / CLX / demo / menu.l < prev    next >
Encoding:
Text File  |  1990-05-01  |  11.9 KB  |  383 lines
  1. ;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10; Lowercase: Yes -*-
  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. (in-package :xlib)
  20.  
  21.  
  22. ;;;----------------------------------------------------------------------------------+
  23. ;;;                                                                                  |
  24. ;;; These functions demonstrate a simple menu implementation described in            |
  25. ;;; Kimbrough, Kerry, "Windows to the Future", Lisp Pointers, Oct-Nov, 1987.         |
  26. ;;; See functions JUST-SAY-LISP and POP-UP for demonstrations.                       |
  27. ;;;                                                                                  |
  28. ;;;----------------------------------------------------------------------------------+
  29.  
  30.  
  31.  
  32. (defstruct (menu)
  33.   "A simple menu of text strings."
  34.   (title "choose an item:")
  35.   item-alist                    ;((item-window item-string))
  36.   window
  37.   gcontext
  38.   width
  39.   title-width
  40.   item-width
  41.   item-height
  42.   (geometry-changed-p t))            ;nil iff unchanged since displayed
  43.  
  44.  
  45.  
  46. (defun create-menu (parent-window text-color background-color text-font)
  47.   (make-menu
  48.     ;; Create menu graphics context
  49.     :gcontext (CREATE-GCONTEXT :drawable   parent-window
  50.                    :foreground text-color
  51.                    :background background-color
  52.                    :font       text-font)
  53.     ;; Create menu window
  54.     :window   (CREATE-WINDOW
  55.         :parent       parent-window
  56.         :class        :input-output
  57.         :x            0            ;temporary value
  58.         :y            0            ;temporary value
  59.         :width        16        ;temporary value
  60.         :height       16        ;temporary value        
  61.         :border-width 2
  62.         :border       text-color
  63.         :background   background-color
  64.         :save-under   :on
  65.         :override-redirect :on        ;override window mgr when positioning
  66.         :event-mask   (MAKE-EVENT-MASK :leave-window                           
  67.                            :exposure))))
  68.  
  69.  
  70. (defun menu-set-item-list (menu &rest item-strings)
  71.   ;; Assume the new items will change the menu's width and height
  72.   (setf (menu-geometry-changed-p menu) t)
  73.  
  74.   ;; Destroy any existing item windows
  75.   (dolist (item (menu-item-alist menu))
  76.     (DESTROY-WINDOW (first item)))
  77.  
  78.   ;; Add (item-window item-string) elements to item-alist
  79.   (setf (menu-item-alist menu)
  80.     (let (alist)
  81.       (dolist (item item-strings (nreverse alist))
  82.         (push (list (CREATE-WINDOW
  83.               :parent     (menu-window menu)
  84.               :x          0         ;temporary value
  85.               :y          0         ;temporary value
  86.               :width      16        ;temporary value
  87.               :height     16        ;temporary value
  88.               :background (GCONTEXT-BACKGROUND (menu-gcontext menu))
  89.               :event-mask (MAKE-EVENT-MASK :enter-window
  90.                                :leave-window
  91.                                :button-press
  92.                                :button-release))
  93.             item)
  94.           alist)))))
  95.  
  96. (defparameter *menu-item-margin* 4
  97.   "Minimum number of pixels surrounding menu items.")
  98.  
  99.  
  100. (defun menu-recompute-geometry (menu)
  101.   (when (menu-geometry-changed-p menu)
  102.     (let* ((menu-font   (GCONTEXT-FONT (menu-gcontext menu)))
  103.        (title-width (TEXT-EXTENTS menu-font (menu-title menu)))
  104.        (item-height (+ (FONT-ASCENT menu-font) (FONT-DESCENT menu-font)))
  105.        (item-width  0)
  106.        (items       (menu-item-alist menu))
  107.        menu-width)
  108.       
  109.       ;; Find max item string width
  110.       (dolist (next-item items)
  111.     (setf item-width (max item-width 
  112.                   (TEXT-EXTENTS menu-font (second next-item)))))
  113.       
  114.       ;; Compute final menu width, taking margins into account
  115.       (setf menu-width (max title-width
  116.                 (+ item-width *menu-item-margin* *menu-item-margin*)))      
  117.       (let ((window  (menu-window menu))
  118.         (delta-y (+ item-height *menu-item-margin*)))
  119.     
  120.     ;; Update width and height of menu window        
  121.     (WITH-STATE (window)
  122.       (setf (DRAWABLE-WIDTH  window) menu-width
  123.         (DRAWABLE-HEIGHT window) (+ *menu-item-margin*
  124.                         (* (1+ (length items))
  125.                            delta-y))))
  126.     
  127.     ;; Update width, height, position of item windows
  128.     (let ((item-left     (round (- menu-width item-width) 2))
  129.           (next-item-top delta-y))
  130.       (dolist (next-item items)
  131.         (let ((window (first next-item)))
  132.           (WITH-STATE (window)
  133.         (setf (DRAWABLE-HEIGHT window) item-height
  134.               (DRAWABLE-WIDTH  window) item-width
  135.               (DRAWABLE-X      window) item-left
  136.               (DRAWABLE-Y      window) next-item-top)))
  137.         (incf next-item-top delta-y))))
  138.       
  139.       ;; Map all item windows
  140.       (MAP-SUBWINDOWS (menu-window menu))
  141.  
  142.       ;; Save item geometry
  143.       (setf (menu-item-width menu)         item-width
  144.         (menu-item-height menu)        item-height
  145.         (menu-width menu)              menu-width
  146.         (menu-title-width menu)        title-width
  147.         (menu-geometry-changed-p menu) nil))))
  148.  
  149.  
  150. (defun menu-refresh (menu)
  151.  (let* ((gcontext   (menu-gcontext menu))
  152.         (baseline-y (FONT-ASCENT (GCONTEXT-FONT gcontext))))
  153.    
  154.    ;; Show title centered in "reverse-video"
  155.    (let ((fg (GCONTEXT-BACKGROUND gcontext))
  156.      (bg (GCONTEXT-FOREGROUND gcontext)))
  157.      (WITH-GCONTEXT (gcontext :foreground fg :background bg)
  158.        (DRAW-IMAGE-GLYPHS
  159.      (menu-window menu)
  160.      gcontext
  161.      (round (- (menu-width menu)
  162.            (menu-title-width menu)) 2)    ;start x
  163.      baseline-y                ;start y
  164.      (menu-title menu))))
  165.    
  166.    ;; Show each menu item (position is relative to item window)
  167.    (dolist (item (menu-item-alist menu))
  168.      (DRAW-IMAGE-GLYPHS
  169.        (first item) gcontext
  170.        0                    ;start x
  171.        baseline-y                ;start y
  172.        (second item)))))
  173.  
  174.  
  175. (defun menu-choose (menu x y)
  176.   ;; Display the menu so that first item is at x,y.
  177.   (menu-present menu x y)
  178.   
  179.   (let ((items (menu-item-alist menu))
  180.     (mw    (menu-window menu))
  181.     selected-item)
  182.  
  183.     ;; Event processing loop
  184.     (do () (selected-item)                
  185.       (EVENT-CASE ((DRAWABLE-DISPLAY mw) :force-output-p t)
  186.     (:exposure     (count)
  187.                
  188.      ;; Discard all but final :exposure then display the menu
  189.      (when (zerop count) (menu-refresh menu))
  190.      t)
  191.     
  192.     (:button-release (event-window)
  193.      ;;Select an item
  194.      (setf selected-item (second (assoc event-window items)))
  195.      t)
  196.     
  197.     (:enter-notify (window)
  198.      ;;Highlight an item
  199.      (let ((position (position window items :key #'first)))
  200.        (when position
  201.          (menu-highlight-item menu position)))
  202.      t)
  203.     
  204.     (:leave-notify (window kind)
  205.      (if (eql mw window)
  206.          ;; Quit if pointer moved out of main menu window
  207.          (setf selected-item (when (eq kind :ancestor) :none))
  208.  
  209.        ;; Otherwise, unhighlight the item window left
  210.        (let ((position (position window items :key #'first)))
  211.          (when position
  212.            (menu-unhighlight-item menu position))))
  213.      t)
  214.     
  215.     (otherwise ()
  216.            ;;Ignore and discard any other event
  217.            t)))
  218.     
  219.     ;; Erase the menu
  220.     (UNMAP-WINDOW mw)
  221.     
  222.     ;; Return selected item string, if any
  223.     (unless (eq selected-item :none) selected-item)))
  224.  
  225.  
  226. (defun menu-highlight-item (menu position)
  227.   (let* ((box-margin  (round *menu-item-margin* 2))
  228.      (left        (- (round (- (menu-width menu) (menu-item-width menu)) 2)
  229.              box-margin))
  230.      (top         (- (* (+ *menu-item-margin* (menu-item-height menu))
  231.                 (1+ position))
  232.              box-margin))
  233.      (width       (+ (menu-item-width menu) box-margin box-margin))
  234.      (height      (+ (menu-item-height menu) box-margin box-margin)))
  235.     
  236.     ;; Draw a box in menu window around the given item.
  237.     (DRAW-RECTANGLE (menu-window menu)
  238.             (menu-gcontext menu)
  239.             left top
  240.             width height)))
  241.  
  242. (defun menu-unhighlight-item (menu position)
  243.   ;; Draw a box in the menu background color
  244.   (let ((gcontext (menu-gcontext menu)))
  245.     (WITH-GCONTEXT (gcontext :foreground (gcontext-background gcontext))
  246.       (menu-highlight-item menu position))))
  247.  
  248.  
  249. (defun menu-present (menu x y)
  250.   ;; Make sure menu geometry is up-to-date
  251.   (menu-recompute-geometry menu)
  252.   
  253.   ;; Try to center first item at the given location, but
  254.   ;; make sure menu is completely visible in its parent
  255.   (let ((menu-window (menu-window menu)))
  256.     (multiple-value-bind (tree parent) (QUERY-TREE menu-window)
  257.       (declare (ignore tree))
  258.       (WITH-STATE (parent)
  259.     (let* ((parent-width  (DRAWABLE-WIDTH parent))
  260.            (parent-height (DRAWABLE-HEIGHT parent))
  261.            (menu-height   (+ *menu-item-margin*
  262.                  (* (1+ (length (menu-item-alist menu)))
  263.                     (+ (menu-item-height menu)  *menu-item-margin*))))
  264.            (menu-x        (max 0 (min (- parent-width (menu-width menu))
  265.                       (- x (round (menu-width menu) 2)))))
  266.            (menu-y        (max 0 (min (- parent-height menu-height)
  267.                       (- y (round (menu-item-height menu) 2/3)
  268.                          *menu-item-margin*)))))
  269.       (WITH-STATE (menu-window)
  270.         (setf (DRAWABLE-X menu-window) menu-x
  271.           (DRAWABLE-Y menu-window) menu-y)))))
  272.  
  273.     ;; Make menu visible
  274.     (MAP-WINDOW menu-window)))
  275.  
  276. (defun just-say-lisp (host &optional (font-name "fixed"))
  277.   (let* ((display   (OPEN-DISPLAY host))
  278.      (screen    (first (DISPLAY-ROOTS display)))
  279.      (fg-color  (SCREEN-BLACK-PIXEL screen))
  280.      (bg-color  (SCREEN-WHITE-PIXEL screen))
  281.      (nice-font (OPEN-FONT display font-name))
  282.      (a-menu    (create-menu (screen-root screen)    ;the menu's parent
  283.                  fg-color bg-color nice-font)))
  284.     
  285.     (setf (menu-title a-menu) "Please pick your favorite language:")
  286.     (menu-set-item-list a-menu "Fortran" "APL" "Forth" "Lisp")
  287.     
  288.     ;; Bedevil the user until he picks a nice programming language
  289.     (unwind-protect
  290.     (do (choice)
  291.         ((and (setf choice (menu-choose a-menu 100 100))
  292.           (string-equal "Lisp" choice))))
  293.  
  294.       (CLOSE-DISPLAY display))))
  295.   
  296.  
  297. (defun pop-up (host strings &key (title "Pick one:") (font "fixed"))
  298.   (let* ((display   (OPEN-DISPLAY host))
  299.      (screen    (first (DISPLAY-ROOTS display)))
  300.      (fg-color  (SCREEN-BLACK-PIXEL screen))
  301.      (bg-color  (SCREEN-WHITE-PIXEL screen))
  302.      (font      (OPEN-FONT display font))
  303.      (parent-width 400)
  304.      (parent-height 400)
  305.      (parent    (CREATE-WINDOW :parent (SCREEN-ROOT screen)
  306.                    :override-redirect :on
  307.                    :x 100 :y 100
  308.                    :width parent-width :height parent-height
  309.                    :background bg-color
  310.                    :event-mask (MAKE-EVENT-MASK :button-press
  311.                                 :exposure)))
  312.      (a-menu    (create-menu parent fg-color bg-color font))
  313.      (prompt    "Press a button...")     
  314.      (prompt-gc (CREATE-GCONTEXT :drawable parent
  315.                      :foreground fg-color
  316.                      :background bg-color
  317.                      :font font))
  318.      (prompt-y  (FONT-ASCENT font))
  319.      (ack-y     (- parent-height  (FONT-DESCENT font))))
  320.     
  321.     (setf (menu-title a-menu) title)
  322.     (apply #'menu-set-item-list a-menu strings)
  323.     
  324.     ;; Present main window
  325.     (MAP-WINDOW parent)
  326.     
  327.     (flet ((display-centered-text
  328.          (window string gcontext height width)         
  329.          (multiple-value-bind (w a d l r fa fd) (text-extents gcontext string)
  330.            (declare (ignore a d l r))
  331.            (let ((box-height (+ fa fd)))
  332.          
  333.          ;; Clear previous text
  334.          (CLEAR-AREA window
  335.                  :x 0 :y (- height fa)
  336.                  :width width :height box-height)
  337.          
  338.          ;; Draw new text
  339.          (DRAW-IMAGE-GLYPHS window gcontext (round (- width w) 2) height string)))))
  340.       
  341.       (unwind-protect
  342.       (loop
  343.         (EVENT-CASE (display :force-output-p t)
  344.           
  345.           (:exposure (count)
  346.              
  347.              ;; Display prompt
  348.              (when (zerop count)
  349.                (display-centered-text
  350.                  parent
  351.                  prompt
  352.                  prompt-gc
  353.                  prompt-y
  354.                  parent-width))
  355.              t)
  356.           
  357.           (:button-press (x y)
  358.                  
  359.                  ;; Pop up the menu
  360.                  (let ((choice (menu-choose a-menu x y)))
  361.                    (if choice
  362.                    (display-centered-text
  363.                      parent
  364.                      (format nil "You have selected ~a." choice)
  365.                      prompt-gc
  366.                      ack-y
  367.                      parent-width)
  368.                    
  369.                    (display-centered-text
  370.                      parent
  371.                      "No selection...try again."
  372.                      prompt-gc
  373.                      ack-y
  374.                      parent-width)))
  375.                  t)                
  376.           
  377.           (otherwise ()
  378.              ;;Ignore and discard any other event
  379.              t)))
  380.     
  381.     (CLOSE-DISPLAY display)))))
  382.  
  383.