← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/ecl/intrepid

« back to all changes in this revision

Viewing changes to src/clx/demo/menu.lisp

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2006-05-17 02:46:26 UTC
  • Revision ID: james.westby@ubuntu.com-20060517024626-lljr08ftv9g9vefl
Tags: upstream-0.9h-20060510
Import upstream version 0.9h-20060510

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/clx/demo/menu.lisp
 
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 (&optional (font-name "fixed"))
 
277
  (let* ((display   (open-default-display))
 
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