/[mcclim]/mcclim/menu.lisp
ViewVC logotype

Contents of /mcclim/menu.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.37 - (show annotations)
Thu Dec 14 19:43:51 2006 UTC (7 years, 4 months ago) by thenriksen
Branch: MAIN
Changes since 1.36: +40 -0 lines
Moved `display-command-table-menu' to menu.lisp and implemented
`display-command-menu'.
1 1;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 2000 by
4 ;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
5
6 ;;; This library is free software; you can redistribute it and/or
7 ;;; modify it under the terms of the GNU Library General Public
8 ;;; License as published by the Free Software Foundation; either
9 ;;; version 2 of the License, or (at your option) any later version.
10 ;;;
11 ;;; This library is distributed in the hope that it will be useful,
12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;; Library General Public License for more details.
15 ;;;
16 ;;; You should have received a copy of the GNU Library General Public
17 ;;; License along with this library; if not, write to the
18 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 ;;; Boston, MA 02111-1307 USA.
20
21 (in-package :clim-internals)
22
23 (defmethod stream-force-output ((pane menu-button-pane))
24 (with-sheet-medium (medium pane)
25 (medium-force-output medium)))
26
27 (defmethod menu-root ((button menu-button-pane))
28 (menu-root (gadget-client button)))
29
30 (defmethod arm-menu ((button menu-button-pane))
31 (with-slots (client armed id) button
32 (unless armed
33 (arm-menu client)
34 (mapc #'disarm-menu (menu-children client))
35 (arm-gadget button t))
36 (dispatch-repaint button (sheet-region button))))
37
38 (defmethod disarm-menu ((button menu-button-pane))
39 (with-slots (client armed id) button
40 (when armed
41 (disarm-gadget button)
42 (dispatch-repaint button (sheet-region button))
43 (stream-force-output button))))
44
45 (defun menu-draw-highlighted (gadget)
46 (when (sheet-mirror gadget) ;XXX only do this when the gadget is realized.
47 (with-special-choices (gadget)
48 (with-slots (label) gadget
49 (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region gadget)
50 (let ((w (- x2 x1))
51 (h (- y2 y1)))
52 (draw-rectangle* gadget -1 -1 x2 y2
53 :ink (gadget-highlighted-color gadget)
54 :filled t)
55 (draw-edges-lines* gadget +white+ 0 0 +black+ (1- w) (1- h))
56 (draw-label* gadget x1 y1 x2 y2)))))))
57
58 (defun menu-draw-unhighlighted (gadget)
59 (when (sheet-mirror gadget) ;XXX only do this when the gadget is realized.
60 (with-special-choices (gadget)
61 (with-slots (label) gadget
62 (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region gadget)
63 (let ((w (- x2 x1))
64 (h (- y2 y1)))
65 (draw-rectangle* gadget -1 -1 w h ;-1 -1 x2 y2
66 :ink +background-ink+
67 :filled t)
68 (draw-label* gadget x1 y1 x2 y2)))))))
69
70 (defmethod handle-event ((pane menu-button-pane) (event pointer-enter-event))
71 (when (slot-value (slot-value pane 'client) 'armed)
72 (arm-branch pane)))
73
74 (defmethod handle-event ((pane menu-button-pane) (event pointer-button-press-event))
75 (arm-branch pane))
76
77 (defmethod handle-event ((pane menu-button-pane) (event pointer-ungrab-event))
78 (destroy-substructure (menu-root pane)))
79
80 ;;; menu-button-leaf-pane
81
82 (defclass menu-button-leaf-pane (menu-button-pane)
83 ((command :initform nil :initarg :command)))
84
85 (defmethod arm-branch ((button menu-button-leaf-pane))
86 (with-slots (client) button
87 (arm-menu client)
88 (mapc #'destroy-substructure (menu-children client))
89 (arm-menu button)))
90
91 (defmethod destroy-substructure ((button menu-button-leaf-pane))
92 (disarm-gadget button))
93
94 (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-button-release-event))
95 (with-slots (armed label client id) pane
96 (when armed
97 (unwind-protect
98 (value-changed-callback pane client id label)
99 (disarm-menu pane)
100 (destroy-substructure (menu-root pane))))))
101
102 (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-exit-event))
103 (disarm-menu pane))
104
105 (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-ungrab-event))
106 (destroy-substructure (menu-root pane)))
107
108 ;;; menu-button-submenu-pane
109
110 (defclass menu-button-submenu-pane (menu-button-pane)
111 ((frame-manager :initform nil :initarg :frame-manager)
112 (submenu-frame :initform nil)
113 (bottomp :initform nil :initarg :bottomp)
114 (command-table :initform nil :initarg :command-table)))
115
116 (defmethod menu-children ((submenu menu-button-submenu-pane))
117 (with-slots (submenu-frame) submenu
118 (if submenu-frame
119 (sheet-children (first (sheet-children (frame-panes submenu-frame))))
120 '())))
121
122 (defun create-substructure (sub-menu client)
123 (let* ((frame *application-frame*)
124 (manager (frame-manager frame))
125 (command-table-name (slot-value sub-menu 'command-table))
126 (items (mapcar #'(lambda (item)
127 (make-menu-button-from-menu-item
128 item client :command-table command-table-name :vertical t))
129 (slot-value (find-command-table command-table-name)
130 'menu)))
131 (rack (make-pane-1 manager frame 'vrack-pane
132 :background *3d-normal-color* :contents items))
133 (raised (make-pane-1 manager frame 'raised-pane :border-width 2 :background *3d-normal-color* :contents (list rack))))
134 (with-slots (bottomp) sub-menu
135 (multiple-value-bind (xmin ymin xmax ymax)
136 (bounding-rectangle* (sheet-region sub-menu))
137 (multiple-value-bind (x y)
138 (transform-position (sheet-delta-transformation sub-menu nil)
139 (if bottomp xmin xmax)
140 (if bottomp ymax ymin))
141 (with-slots (frame-manager submenu-frame) sub-menu
142 (setf frame-manager manager
143 submenu-frame (make-menu-frame raised :left x :top y))
144 (adopt-frame manager submenu-frame)
145 (with-sheet-medium (medium raised)
146 (medium-force-output medium))))))))
147
148 (defmethod destroy-substructure ((sub-menu menu-button-submenu-pane))
149 (with-slots (frame-manager submenu-frame) sub-menu
150 (when submenu-frame
151 (mapc #'destroy-substructure (menu-children sub-menu))
152 (disown-frame frame-manager submenu-frame)
153 (disarm-gadget sub-menu)
154 (dispatch-repaint sub-menu +everywhere+)
155 (setf submenu-frame nil) )))
156
157 (defmethod arm-branch ((sub-menu menu-button-submenu-pane))
158 (with-slots (client frame-manager submenu-frame) sub-menu
159 (arm-menu client)
160 (if submenu-frame
161 (progn (mapc #'destroy-substructure (menu-children sub-menu))
162 (mapc #'disarm-menu (menu-children sub-menu)))
163 (progn
164 (mapc #'destroy-substructure (menu-children client))
165 (create-substructure sub-menu sub-menu)))
166 (arm-menu sub-menu)))
167
168 (defmethod handle-event ((pane menu-button-submenu-pane) (event pointer-button-release-event))
169 (destroy-substructure (menu-root pane)))
170
171 ;;; menu-button-vertical-submenu-pane
172 (defclass menu-button-vertical-submenu-pane (menu-button-submenu-pane) ())
173
174 (let* ((left-padding 10)
175 (widget-size 5)
176 (right-padding 4)
177 (widget-width widget-size)
178 (widget-height (* 2 widget-size))
179 (total-width (+ left-padding widget-width right-padding))
180 (total-height widget-height))
181
182 (defmethod compose-space ((gadget menu-button-vertical-submenu-pane) &key width height)
183 (declare (ignorable width height))
184 (multiple-value-bind (width min-width max-width height min-height max-height)
185 (space-requirement-components (call-next-method))
186 (declare (ignorable max-width))
187 (make-space-requirement :min-width (+ min-width total-width)
188 :width (+ width total-width)
189 :max-width +fill+
190 :min-height (max min-height total-height)
191 :height (max height total-height)
192 :max-height (if (zerop max-height) ; make-space-requirements default maximums are zero..
193 0
194 (max max-height total-height)))))
195
196 (defmethod handle-repaint ((pane menu-button-vertical-submenu-pane) region)
197 (call-next-method)
198 (multiple-value-bind (x1 y1 x2 y2)
199 (bounding-rectangle* (sheet-region pane))
200 (when (and (> (- x2 x1) total-width)
201 (> (- y2 y1) total-height))
202 (let* ((center (/ (+ y1 y2) 2))
203 (vbase (- center (/ widget-height 2)))
204 (hbase (+ (- x2 total-width) left-padding))
205 (shape (list hbase vbase
206 (+ hbase widget-size) (+ vbase widget-size)
207 hbase (+ vbase (* 2 widget-size)))))
208 (draw-polygon* pane shape :ink +black+))))))
209
210 ;;; menu-divider-leaf-pane
211
212 (defclass menu-divider-leaf-pane (standard-gadget)
213 ((label :initform nil :initarg :label)))
214
215 (defparameter *labelled-divider-text-style* (make-text-style :sans-serif :roman :small))
216
217 (defmethod destroy-substructure ((object menu-divider-leaf-pane)))
218 (defmethod arm-menu ((object menu-divider-leaf-pane)))
219 (defmethod disarm-menu ((object menu-divider-leaf-pane)))
220
221 (defmethod compose-space ((gadget menu-divider-leaf-pane) &key width height)
222 (declare (ignorable width height))
223 (flet ((make-sr (w h)
224 (make-space-requirement :min-width w :width w
225 :min-height h :height h :max-height h)))
226 (let ((label (slot-value gadget 'label)))
227 (if label
228 (multiple-value-bind (width height fx fy baseline)
229 (text-size gadget label :text-style *labelled-divider-text-style*)
230 (declare (ignore fx fy height baseline))
231 (make-sr width (+ 0
232 (text-style-ascent *labelled-divider-text-style* gadget)
233 (text-style-descent *labelled-divider-text-style* gadget))))
234 (make-sr 0 4)))))
235
236
237 (defmethod handle-repaint ((pane menu-divider-leaf-pane) region)
238 (let ((label (slot-value pane 'label)))
239 (multiple-value-bind (x1 y1 x2 y2)
240 (bounding-rectangle* (sheet-region pane))
241 (declare (ignore y2))
242 (if label
243 (multiple-value-bind (width height fx fy baseline)
244 (text-size pane label :text-style *labelled-divider-text-style*)
245 (declare (ignore height fx fy))
246 (let ((tx0 (+ x1 (/ (- (- x2 x1) width) 2)))
247 (ty0 (+ 1 y1 baseline)))
248 (draw-line* pane tx0 (1+ ty0) (+ tx0 width) (1+ ty0) :ink *3d-dark-color*)
249 (draw-text* pane label tx0 ty0
250 :text-style *labelled-divider-text-style*)))
251 (progn
252 (draw-line* pane x1 (1+ y1) x2 (1+ y1) :ink *3d-dark-color*)
253 (draw-line* pane x1 (+ 2 y1) x2 (+ 2 y1) :ink *3d-light-color*))))))
254
255
256 ;;; Menu creation from command tables
257
258 (defparameter *enabled-text-style* (make-text-style :sans-serif :roman :normal))
259 (defparameter *disabled-text-style* (make-text-style :sans-serif :roman :normal))
260
261 (defun make-menu-button-from-menu-item (item client
262 &key (bottomp nil)
263 (vertical nil)
264 command-table
265 (presentation-type 'menu-item))
266 (declare (ignore command-table))
267 (let ((name (command-menu-item-name item))
268 (type (command-menu-item-type item))
269 (value (command-menu-item-value item))
270 (frame *application-frame*)
271 (manager (frame-manager *application-frame*)))
272 (case type
273 (:command
274 (let ((command-name (if (consp value) (car value) value)))
275 (if (command-enabled command-name frame)
276 (make-pane-1 manager frame 'menu-button-leaf-pane
277 :label name
278 :text-style *enabled-text-style*
279 :client client
280 :value-changed-callback
281 #'(lambda (gadget val)
282 (declare (ignore gadget val))
283 (throw-object-ptype item presentation-type)))
284 (let ((pane (make-pane-1 manager frame 'menu-button-leaf-pane
285 :label name
286 :text-style *disabled-text-style*
287 :client client
288 :value-changed-callback
289 #'(lambda (gadget val)
290 (declare (ignore gadget val))
291 nil))))
292 (deactivate-gadget pane)
293 pane))))
294 (:function
295 (make-pane-1 manager frame 'menu-button-leaf-pane
296 :label name
297 :text-style *enabled-text-style*
298 :client client
299 :value-changed-callback
300 #'(lambda (gadget val)
301 (declare (ignore gadget val))
302 ;; FIXME: the spec requires us to pass a gesture to the
303 ;; function, but value-changed-callback doesn't provide
304 ;; one, so we pass NIL for now.
305 ;; FIXME: We don't have a numeric argument, either.
306 (let ((command (funcall value nil nil)))
307 (throw-object-ptype command 'command)))))
308 (:divider
309 (make-pane-1 manager frame 'menu-divider-leaf-pane
310 :label name
311 :client client))
312 (:menu
313 (make-pane-1 manager frame (if vertical
314 'menu-button-vertical-submenu-pane
315 'menu-button-submenu-pane)
316 :label name
317 :client client
318 :frame-manager manager
319 :command-table value
320 :bottomp bottomp))
321 (otherwise (error "Don't know how to create a menu button for ~W" type)))))
322
323 ;;
324 ;; MENU-BAR
325 ;;
326 (defclass menu-button-hrack-pane (hrack-pane) ())
327
328 (defclass menu-bar (menu-button-hrack-pane
329 permanent-medium-sheet-output-mixin)
330 ((items :initform nil)
331 (armed :initform nil)))
332
333 (defmethod initialize-instance :after ((pane menu-bar)
334 &rest args
335 &key
336 &allow-other-keys)
337 (declare (ignore args))
338 (setf (slot-value pane 'items) (copy-list (sheet-children pane)))
339 (loop for child in (menu-children pane)
340 do (setf (gadget-client child) pane)))
341
342 (defmethod menu-children ((menu-bar menu-bar))
343 (slot-value menu-bar 'items))
344
345 (defmethod menu-root ((object menu-bar))
346 object)
347
348 (defmethod destroy-substructure ((object menu-bar))
349 (loop for child in (menu-children object)
350 do (progn (destroy-substructure child)
351 (dispatch-repaint child (sheet-region child))))
352 (setf (slot-value object 'armed) nil))
353
354 (defmethod arm-menu ((object menu-bar))
355 (setf (slot-value object 'armed) t))
356
357 (defmethod disarm-menu ((object menu-bar))
358 (setf (slot-value object 'armed) nil))
359
360 (defun make-menu-bar (command-table
361 &key width height
362 (max-width +fill+) max-height
363 min-width min-height)
364 (with-slots (menu) (find-command-table command-table)
365 (make-pane-1 *pane-realizer* *application-frame*
366 'menu-bar
367 :background *3d-normal-color*
368 :width width :height height
369 :max-width max-width :max-height max-height
370 :min-width min-width :min-height min-height
371 :contents
372 (append
373 (loop for item in menu
374 collect
375 (make-menu-button-from-menu-item
376 item nil
377 :bottomp t
378 :vertical nil
379 :command-table command-table))
380 (list +fill+)))))
381
382 (defmethod handle-repaint ((pane menu-bar) region)
383 (declare (ignore region))
384 (with-slots (border-width) pane
385 (multiple-value-call #'draw-bordered-rectangle*
386 pane
387 (bounding-rectangle* (sheet-region pane))
388 :style :outset
389 :border-width 2)))
390
391 (defmethod compose-space ((pane menu-bar) &key width height)
392 (declare (ignore width height))
393 (space-requirement+
394 (call-next-method)
395 (make-space-requirement :height 4 :max-height 4 :min-height 4)))
396
397 (defmethod box-layout-mixin/horizontally-allocate-space
398 ((pane menu-bar) real-width real-height)
399 (with-slots (x-spacing) pane
400 (let ((widths
401 (box-layout-mixin/horizontally-allocate-space-aux*
402 pane real-width real-height))
403 (x 2))
404 (loop
405 for child in (box-layout-mixin-clients pane)
406 for width in widths
407 do
408 (when (box-client-pane child)
409 (layout-child (box-client-pane child)
410 :expand
411 :expand
412 x
413 2
414 width
415 (- real-height 4)))
416 (incf x width)
417 (incf x x-spacing)))))
418
419 (defmethod display-command-table-menu ((command-table standard-command-table)
420 (stream fundamental-output-stream)
421 &rest args
422 &key max-width max-height n-rows n-columns
423 x-spacing y-spacing initial-spacing
424 row-wise (cell-align-x :left)
425 (cell-align-y :top) (move-cursor t))
426 (formatting-item-list (stream :max-width max-width :max-height max-height :n-rows n-rows
427 :n-columns n-columns :x-spacing x-spacing :y-spacing y-spacing
428 :initial-spacing initial-spacing :row-wise row-wise
429 :move-cursor move-cursor)
430 (map-over-command-table-menu-items
431 #'(lambda (item-name accelerator item)
432 (declare (ignore accelerator))
433 (formatting-cell (stream :align-x cell-align-x :align-y cell-align-y)
434 (cond ((eq (command-menu-item-type item) :menu)
435 (with-text-style (stream (make-text-style :serif '(:bold :italic) nil))
436 (write-string item-name stream)
437 (terpri stream))
438 (surrounding-output-with-border (stream)
439 (apply #'display-command-table-menu
440 (find-command-table (command-menu-item-value item))
441 stream args)))
442 ((eq (command-menu-item-type item) :command)
443 (let ((name (command-name (command-menu-item-value item))))
444 (when (command-line-name-for-command name command-table :errorp nil)
445 (present name 'command-name :stream stream)))))))
446 command-table)))
447
448 (defmethod display-command-menu (frame (stream fundamental-output-stream)
449 &rest args &key
450 (command-table (frame-command-table frame))
451 initial-spacing row-wise max-width
452 max-height n-rows n-columns
453 (cell-align-x :left) (cell-align-y :top))
454 (declare (ignore initial-spacing row-wise max-width max-height
455 n-rows n-columns cell-align-x cell-align-y))
456 (with-keywords-removed (args (:command-table))
457 (apply #'display-command-table-menu command-table stream args)))

  ViewVC Help
Powered by ViewVC 1.1.5