;;; -*- Mode:Common-Lisp; Package:XLIB; Fonts:(CPTFONT); Base:10 -*- ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 2909 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1988 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; (unless (find-package 'clx-examples) (make-package 'clx-examples :use '(lisp xlib))) (in-package 'clx-examples :use '(lisp xlib)) ;;;----------------------------------------------------------------------------------+ ;;; | ;;; These functions demonstrate a simple menu implementation described in | ;;; Kimbrough, Kerry, "Windows to the Future", Lisp Pointers, Oct-Nov, 1987. | ;;; See functions JUST-SAY-LISP and POP-UP for demonstrations. | ;;; | ;;;----------------------------------------------------------------------------------+ (defstruct (menu) "A simple menu of text strings." (title "Choose an item:") item-alist ;((item-window item-string)) window gcontext width title-width item-width item-height (geometry-changed-p t)) ;nil iff unchanged since displayed (defun create-menu (parent-window text-color background-color text-font) (make-menu ;; Create menu graphics context :gcontext (CREATE-GCONTEXT :drawable parent-window :foreground text-color :background background-color :font text-font) ;; Create menu window :window (CREATE-WINDOW :parent parent-window :class :input-output :x 0 ;temporary value :y 0 ;temporary value :width 16 ;temporary value :height 16 ;temporary value :border-width 2 :border text-color :background background-color :save-under :on :override-redirect :on ;override window mgr when positioning :event-mask (MAKE-EVENT-MASK :leave-window :exposure)))) (defun menu-set-item-list (menu &rest item-strings) ;; Assume the new items will change the menu's width and height (setf (menu-geometry-changed-p menu) t) ;; Destroy any existing item windows (dolist (item (menu-item-alist menu)) (DESTROY-WINDOW (first item))) ;; Add (item-window item-string) elements to item-alist (setf (menu-item-alist menu) (let (alist) (dolist (item item-strings (nreverse alist)) (push (list (CREATE-WINDOW :parent (menu-window menu) :x 0 ;temporary value :y 0 ;temporary value :width 16 ;temporary value :height 16 ;temporary value :background (GCONTEXT-BACKGROUND (menu-gcontext menu)) :event-mask (MAKE-EVENT-MASK :enter-window :leave-window :button-press :button-release)) item) alist))))) (defparameter *menu-item-margin* 4 "Minimum number of pixels surrounding menu items.") (defun menu-recompute-geometry (menu) (when (menu-geometry-changed-p menu) (let* ((menu-font (GCONTEXT-FONT (menu-gcontext menu))) (title-width (TEXT-EXTENTS menu-font (menu-title menu))) (item-height (+ (FONT-ASCENT menu-font) (FONT-DESCENT menu-font) *menu-item-margin*)) (item-width 0) (items (menu-item-alist menu)) menu-width) ;; Find max item string width (setf item-width (+ *menu-item-margin* (dolist (next-item items item-width) (setf item-width (max item-width (TEXT-EXTENTS menu-font (second next-item))))))) ;; Compute final menu width, taking margins into account (setf menu-width (max title-width (+ item-width *menu-item-margin*))) (let ((window (menu-window menu))) ;; Update width and height of menu window (WITH-STATE (window) (setf (DRAWABLE-WIDTH window) menu-width (DRAWABLE-HEIGHT window) (* (1+ (length items)) item-height))) ;; Update width, height, position of item windows (let ((item-left (round (- menu-width item-width) 2)) (next-item-top (- item-height (round *menu-item-margin* 2)))) (dolist (next-item items) (let ((window (first next-item))) (WITH-STATE (window) (setf (DRAWABLE-HEIGHT window) item-height (DRAWABLE-WIDTH window) item-width (DRAWABLE-X window) item-left (DRAWABLE-Y window) next-item-top))) (incf next-item-top item-height)))) ;; Map all item windows (MAP-SUBWINDOWS (menu-window menu)) ;; Save item geometry (setf (menu-item-width menu) item-width (menu-item-height menu) item-height (menu-width menu) menu-width (menu-title-width menu) title-width (menu-geometry-changed-p menu) nil)))) (defun menu-refresh (menu) (let* ((gcontext (menu-gcontext menu)) (baseline-y (FONT-ASCENT (GCONTEXT-FONT gcontext)))) ;; Show title centered in "reverse-video" (let ((fg (GCONTEXT-BACKGROUND gcontext)) (bg (GCONTEXT-FOREGROUND gcontext))) (WITH-GCONTEXT (gcontext :foreground fg :background bg) (DRAW-IMAGE-GLYPHS (menu-window menu) gcontext (round (- (menu-width menu) (menu-title-width menu)) 2) ;start x baseline-y ;start y (menu-title menu)))) ;; Show each menu item (position is relative to item window) (let ((box-margin (round *menu-item-margin* 2))) (dolist (item (menu-item-alist menu)) (DRAW-IMAGE-GLYPHS (first item) gcontext box-margin ;start x (+ baseline-y box-margin) ;start y (second item)))))) (defun menu-choose (menu x y) ;; Display the menu so that first item is at x,y. (menu-present menu x y) (let ((items (menu-item-alist menu)) (mw (menu-window menu)) selected-item) ;; Event processing loop (do () (selected-item) (EVENT-CASE ((DRAWABLE-DISPLAY mw) :force-output-p t) (:exposure (count) ;; Discard all but final :exposure then display the menu (when (zerop count) (menu-refresh menu)) t) (:button-release (event-window) ;;Select an item (setf selected-item (second (assoc event-window items))) t) (:enter-notify (window) ;;Highlight an item (menu-highlight-item menu (find window items :key #'first)) t) (:leave-notify (window kind) (if (eql mw window) ;; Quit if pointer moved out of main menu window (setf selected-item (when (eq kind :ancestor) :none)) ;; Otherwise, unhighlight the item window left (menu-unhighlight-item menu (find window items :key #'first))) t) (otherwise () ;;Ignore and discard any other event t))) ;; Erase the menu (UNMAP-WINDOW mw) ;; Return selected item string, if any (unless (eq selected-item :none) selected-item))) (defun menu-highlight-item (menu item) ;; Draw a box around the given item window (when item (DRAW-RECTANGLE (first item) (menu-gcontext menu) 0 0 (1- (menu-item-width menu)) (1- (menu-item-height menu))))) (defun menu-unhighlight-item (menu item) ;; Draw a box in the menu background color (let ((gcontext (menu-gcontext menu))) (WITH-GCONTEXT (gcontext :foreground (gcontext-background gcontext)) (menu-highlight-item menu item)))) (defun menu-present (menu x y) ;; Make sure menu geometry is up-to-date (menu-recompute-geometry menu) ;; Try to center first item at the given location, but ;; make sure menu is completely visible in its parent (let ((menu-window (menu-window menu))) (multiple-value-bind (tree parent) (QUERY-TREE menu-window) (declare (ignore tree)) (WITH-STATE (parent) (let* ((parent-width (DRAWABLE-WIDTH parent)) (parent-height (DRAWABLE-HEIGHT parent)) (menu-height (* (1+ (length (menu-item-alist menu))) (menu-item-height menu))) (menu-x (max 0 (min (- parent-width (menu-width menu)) (- x (round (menu-width menu) 2))))) (menu-y (max 0 (min (- parent-height menu-height) (- y (round (- (* 3 (menu-item-height menu)) *menu-item-margin*) 2) ))))) (WITH-STATE (menu-window) (setf (DRAWABLE-X menu-window) menu-x (DRAWABLE-Y menu-window) menu-y))))) ;; Make menu visible (MAP-WINDOW menu-window))) (defun just-say-lisp (host &optional (font-name "fg-16")) (let* ((display (OPEN-DISPLAY host)) (screen (first (DISPLAY-ROOTS display))) (fg-color (SCREEN-BLACK-PIXEL screen)) (bg-color (SCREEN-WHITE-PIXEL screen)) (nice-font (OPEN-FONT display font-name)) (a-menu (create-menu (SCREEN-ROOT screen) ;the menu's parent fg-color bg-color nice-font))) (setf (menu-title a-menu) "Please pick your favorite language:") (menu-set-item-list a-menu "Fortran" "APL" "Forth" "Lisp") ;; Bedevil the user until he picks a nice programming language (unwind-protect (loop (multiple-value-bind (x y) (QUERY-POINTER (SCREEN-ROOT screen)) (let ((choice (menu-choose a-menu x y))) (when (string-equal "Lisp" choice) (return))))) (CLOSE-DISPLAY display)))) (defun pop-up (host strings &key (title "Pick one:") (font "fg-16")) (let* ((display (OPEN-DISPLAY host)) (screen (first (DISPLAY-ROOTS display))) (fg-color (SCREEN-BLACK-PIXEL screen)) (bg-color (SCREEN-WHITE-PIXEL screen)) (font (OPEN-FONT display font)) (parent-width 400) (parent-height 400) (parent (CREATE-WINDOW :parent (SCREEN-ROOT screen) :override-redirect :on :x 100 :y 100 :width parent-width :height parent-height :background bg-color :event-mask (MAKE-EVENT-MASK :button-press :exposure))) (a-menu (create-menu parent fg-color bg-color font)) (prompt "Press a button...") (prompt-gc (CREATE-GCONTEXT :drawable parent :foreground fg-color :background bg-color :font font)) (prompt-y (FONT-ASCENT font)) (ack-y (- parent-height (FONT-DESCENT font)))) (setf (menu-title a-menu) title) (apply #'menu-set-item-list a-menu strings) ;; Present main window (MAP-WINDOW parent) (flet ((display-centered-text (window string gcontext height width) (multiple-value-bind (w a d l r fa fd) (text-extents gcontext string) (declare (ignore a d l r)) (let ((box-height (+ fa fd))) ;; Clear previous text (CLEAR-AREA window :x 0 :y (- height fa) :width width :height box-height) ;; Draw new text (DRAW-IMAGE-GLYPHS window gcontext (round (- width w) 2) height string))))) (unwind-protect (loop (EVENT-CASE (display :force-output-p t) (:exposure (count) ;; Display prompt (when (zerop count) (display-centered-text parent prompt prompt-gc prompt-y parent-width)) t) (:button-press (x y) ;; Pop up the menu (let ((choice (menu-choose a-menu x y))) (if choice (display-centered-text parent (format nil "You have selected ~a." choice) prompt-gc ack-y parent-width) (display-centered-text parent "No selection...try again." prompt-gc ack-y parent-width))) t) (otherwise () ;;Ignore and discard any other event t))) (CLOSE-DISPLAY display)))))