/[cmucl]/src/contrib/demos/menu.lisp
ViewVC logotype

Contents of /src/contrib/demos/menu.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Thu Apr 9 04:57:40 1998 UTC (16 years ago) by dtc
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, RELENG_18, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
CMUCL MP support by Douglas Crosher.
Enhancements including a CLX menu, rewrite of the greynetic demo, and
other fixes by Fred Gilham.
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 :exposure))))
67
68 (defun menu-set-item-list (menu item-strings)
69 ;; Assume the new items will change the menu's width and height
70 (setf (menu-geometry-changed-p menu) t)
71
72 ;; Destroy any existing item windows
73 (dolist (item (menu-item-alist menu))
74 (DESTROY-WINDOW (first item)))
75
76 ;; Add (item-window item-string) elements to item-alist
77 (setf (menu-item-alist menu)
78 (let (alist)
79 (dolist (item item-strings (nreverse alist))
80 (push (list (CREATE-WINDOW
81 :parent (menu-window menu)
82 :x 0 ;temporary value
83 :y 0 ;temporary value
84 :width 16 ;temporary value
85 :height 16 ;temporary value
86 :background (GCONTEXT-BACKGROUND (menu-gcontext menu))
87 :event-mask (MAKE-EVENT-MASK :enter-window
88 :leave-window
89 :button-press
90 :button-release))
91 item)
92 alist)))))
93
94 (defparameter *menu-item-margin* 4
95 "Minimum number of pixels surrounding menu items.")
96
97
98 (defun menu-recompute-geometry (menu)
99 (when (menu-geometry-changed-p menu)
100 (let* ((menu-font (GCONTEXT-FONT (menu-gcontext menu)))
101 (title-width (TEXT-EXTENTS menu-font (menu-title menu)))
102 (item-height (+ (FONT-ASCENT menu-font) (FONT-DESCENT menu-font)))
103 (item-width 0)
104 (items (menu-item-alist menu))
105 menu-width)
106
107 ;; Find max item string width
108 (dolist (next-item items)
109 (setf item-width (max item-width
110 (TEXT-EXTENTS menu-font (second next-item)))))
111
112 ;; Compute final menu width, taking margins into account
113 (setf menu-width (max title-width
114 (+ item-width *menu-item-margin* *menu-item-margin*)))
115 (let ((window (menu-window menu))
116 (delta-y (+ item-height *menu-item-margin*)))
117
118 ;; Update width and height of menu window
119 (WITH-STATE (window)
120 (setf (DRAWABLE-WIDTH window) menu-width
121 (DRAWABLE-HEIGHT window) (+ *menu-item-margin*
122 (* (1+ (length items))
123 delta-y))))
124
125 ;; Update width, height, position of item windows
126 (let ((item-left (round (- menu-width item-width) 2))
127 (next-item-top delta-y))
128 (dolist (next-item items)
129 (let ((window (first next-item)))
130 (WITH-STATE (window)
131 (setf (DRAWABLE-HEIGHT window) item-height
132 (DRAWABLE-WIDTH window) item-width
133 (DRAWABLE-X window) item-left
134 (DRAWABLE-Y window) next-item-top)))
135 (incf next-item-top delta-y))))
136
137 ;; Map all item windows
138 (MAP-SUBWINDOWS (menu-window menu))
139
140 ;; Save item geometry
141 (setf (menu-item-width menu) item-width
142 (menu-item-height menu) item-height
143 (menu-width menu) menu-width
144 (menu-title-width menu) title-width
145 (menu-geometry-changed-p menu) nil))))
146
147
148 (defun menu-refresh (menu)
149 (xlib:set-wm-properties (menu-window menu)
150 :name (menu-title menu)
151 :icon-name (menu-title menu)
152 :resource-name (menu-title menu))
153 (let* ((gcontext (menu-gcontext menu))
154 (baseline-y (FONT-ASCENT (GCONTEXT-FONT gcontext))))
155
156 ;; Show title centered in "reverse-video"
157 (let ((fg (GCONTEXT-BACKGROUND gcontext))
158 (bg (GCONTEXT-FOREGROUND gcontext)))
159 (WITH-GCONTEXT (gcontext :foreground fg :background bg)
160 (DRAW-IMAGE-GLYPHS
161 (menu-window menu)
162 gcontext
163 (round (- (menu-width menu)
164 (menu-title-width menu)) 2) ;start x
165 baseline-y ;start y
166 (menu-title menu))))
167
168 ;; Show each menu item (position is relative to item window)
169 (dolist (item (menu-item-alist menu))
170 (DRAW-IMAGE-GLYPHS
171 (first item) gcontext
172 0 ;start x
173 baseline-y ;start y
174 (second item)))))
175
176
177 (defun menu-choose (menu x y)
178 ;; Display the menu so that first item is at x,y.
179 (menu-present menu x y)
180
181 (let ((items (menu-item-alist menu))
182 (mw (menu-window menu))
183 selected-item)
184
185 ;; Event processing loop
186 (do () (selected-item)
187 (EVENT-CASE ((DRAWABLE-DISPLAY mw) :force-output-p t)
188 (:exposure (count)
189
190 ;; Discard all but final :exposure then display the menu
191 (when (zerop count) (menu-refresh menu))
192 t)
193
194 (:button-release (event-window)
195 ;;Select an item
196 (setf selected-item (second (assoc event-window items)))
197 t)
198
199 (:enter-notify (window)
200 ;;Highlight an item
201 (let ((position (position window items :key #'first)))
202 (when position
203 (menu-highlight-item menu position)))
204 t)
205
206 (:leave-notify (window kind)
207 (if (eql mw window)
208 ;; Quit if pointer moved out of main menu window
209 (setf selected-item (when (eq kind :ancestor) :none))
210
211 ;; Otherwise, unhighlight the item window left
212 (let ((position (position window items :key #'first)))
213 (when position
214 (menu-unhighlight-item menu position))))
215 t)
216
217 (otherwise ()
218 ;;Ignore and discard any other event
219 t)))
220
221 ;; Erase the menu
222 ;;; (UNMAP-WINDOW mw)
223
224 ;; Return selected item string, if any
225 (unless (eq selected-item :none) selected-item)))
226
227
228 (defun menu-highlight-item (menu position)
229 (let* ((box-margin (round *menu-item-margin* 2))
230 (left (- (round (- (menu-width menu) (menu-item-width menu)) 2)
231 box-margin))
232 (top (- (* (+ *menu-item-margin* (menu-item-height menu))
233 (1+ position))
234 box-margin))
235 (width (+ (menu-item-width menu) box-margin box-margin))
236 (height (+ (menu-item-height menu) box-margin box-margin)))
237
238 ;; Draw a box in menu window around the given item.
239 (DRAW-RECTANGLE (menu-window menu)
240 (menu-gcontext menu)
241 left top
242 width height)))
243
244 (defun menu-unhighlight-item (menu position)
245 ;; Draw a box in the menu background color
246 (let ((gcontext (menu-gcontext menu)))
247 (WITH-GCONTEXT (gcontext :foreground (gcontext-background gcontext))
248 (menu-highlight-item menu position))))
249
250
251 (defun menu-present (menu x y)
252 ;; Make sure menu geometry is up-to-date
253 (menu-recompute-geometry menu)
254
255 ;; Try to center first item at the given location, but
256 ;; make sure menu is completely visible in its parent
257 (let ((menu-window (menu-window menu)))
258 ;; (multiple-value-bind (tree parent) (QUERY-TREE menu-window)
259 ;; (declare (ignore tree))
260 ;; (WITH-STATE (parent)
261 ;; (let* ((parent-width (DRAWABLE-WIDTH parent))
262 ;; (parent-height (DRAWABLE-HEIGHT parent))
263 ;; (menu-height (+ *menu-item-margin*
264 ;; (* (1+ (length (menu-item-alist menu)))
265 ;; (+ (menu-item-height menu) *menu-item-margin*))))
266 ;; (menu-x (max 0 (min (- parent-width (menu-width menu))
267 ;; (- x (round (menu-width menu) 2)))))
268 ;; (menu-y (max 0 (min (- parent-height menu-height)
269 ;; (- y (round (menu-item-height menu) 2/3)
270 ;; *menu-item-margin*)))))
271 ;; (WITH-STATE (menu-window)
272 ;; (setf (DRAWABLE-X menu-window) menu-x
273 ;; (DRAWABLE-Y menu-window) menu-y)))))
274
275 ;; Make menu visible
276 (MAP-WINDOW menu-window)))
277

  ViewVC Help
Powered by ViewVC 1.1.5