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

Contents of /mcclim/menu.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.32 - (show annotations)
Mon Oct 18 06:24:57 2004 UTC (9 years, 6 months ago) by hefner1
Branch: MAIN
Changes since 1.31: +138 -23 lines
Menubar and gadget changes:

In deactivated gadgets, 'engrave' the text rather than simply dimming
the label.

Menu bars now use deactivate-gadget on the menu-buttons to signify
disabled commands.

Implemented divider menu items, with an optional label.

Implemented :function menu items.

For submenu buttons in vertical menus, draw a little arrow to the right
of the name to distinguish them from regular menu items.
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 ;; for now, accept only types :command and :menu, and only
259 ;; command names as values of :command
260
261 (defparameter *enabled-text-style* (make-text-style :sans-serif :roman :normal))
262 (defparameter *disabled-text-style* (make-text-style :sans-serif :roman :normal))
263
264 (defun make-menu-button-from-menu-item (item client
265 &key (bottomp nil)
266 (vertical nil)
267 command-table
268 (presentation-type 'menu-item))
269 (declare (ignore command-table))
270 (let ((name (command-menu-item-name item))
271 (type (command-menu-item-type item))
272 (value (command-menu-item-value item))
273 (frame *application-frame*)
274 (manager (frame-manager *application-frame*)))
275 (case type
276 (:command
277 (let ((command-name (if (consp value) (car value) value)))
278 (if (command-enabled command-name frame)
279 (make-pane-1 manager frame 'menu-button-leaf-pane
280 :label name
281 :text-style *enabled-text-style*
282 :client client
283 :value-changed-callback
284 #'(lambda (gadget val)
285 (declare (ignore gadget val))
286 (throw-object-ptype item presentation-type)))
287 (let ((pane (make-pane-1 manager frame 'menu-button-leaf-pane
288 :label name
289 :text-style *disabled-text-style*
290 :client client
291 :value-changed-callback
292 #'(lambda (gadget val)
293 (declare (ignore gadget val))
294 nil))))
295 (deactivate-gadget pane)
296 pane))))
297 (:function
298 (make-pane-1 manager frame 'menu-button-leaf-pane
299 :label name
300 :text-style *enabled-text-style*
301 :client client
302 :value-changed-callback
303 #'(lambda (gadget val)
304 (declare (ignore gadget val))
305 ;; FIXME: the spec requires us to pass a gesture to the
306 ;; function, but value-changed-callback doesn't provide
307 ;; one, so we pass NIL for now.
308 ;; FIXME: We don't have a numeric argument, either.
309 (let ((command (funcall item nil nil)))
310 (throw-object-ptype command presentation-type)))))
311 (:divider
312 (make-pane-1 manager frame 'menu-divider-leaf-pane
313 :label name
314 :client client))
315 (:menu
316 (make-pane-1 manager frame (if vertical
317 'menu-button-vertical-submenu-pane
318 'menu-button-submenu-pane)
319 :label name
320 :client client
321 :frame-manager manager
322 :command-table value
323 :bottomp bottomp))
324 (otherwise (error "Don't know how to create a menu button for ~W" type)))))
325
326 ;;
327 ;; MENU-BAR
328 ;;
329 (defclass menu-button-hrack-pane (hrack-pane) ())
330
331 (defclass menu-bar (menu-button-hrack-pane
332 permanent-medium-sheet-output-mixin)
333 ((items :initform nil)
334 (armed :initform nil)))
335
336 (defmethod initialize-instance :after ((pane menu-bar)
337 &rest args
338 &key
339 &allow-other-keys)
340 (declare (ignore args))
341 (setf (slot-value pane 'items) (copy-list (sheet-children pane)))
342 (loop for child in (menu-children pane)
343 do (setf (gadget-client child) pane)))
344
345 (defmethod menu-children ((menu-bar menu-bar))
346 (slot-value menu-bar 'items))
347
348 (defmethod menu-root ((object menu-bar))
349 object)
350
351 (defmethod destroy-substructure ((object menu-bar))
352 (loop for child in (menu-children object)
353 do (progn (destroy-substructure child)
354 (dispatch-repaint child (sheet-region child))))
355 (setf (slot-value object 'armed) nil))
356
357 (defmethod arm-menu ((object menu-bar))
358 (setf (slot-value object 'armed) t))
359
360 (defmethod disarm-menu ((object menu-bar))
361 (setf (slot-value object 'armed) nil))
362
363 (defun make-menu-bar (command-table
364 &key width height
365 (max-width +fill+) max-height
366 min-width min-height)
367 (with-slots (menu) (find-command-table command-table)
368 (raising ()
369 (make-pane-1 *pane-realizer* *application-frame*
370 'menu-bar
371 :background *3d-normal-color*
372 :width width :height height
373 :max-width max-width :max-height max-height
374 :min-width min-width :min-height min-height
375 :contents
376 (append
377 (loop for item in menu
378 collect
379 (make-menu-button-from-menu-item
380 item nil
381 :bottomp t
382 :vertical nil
383 :command-table command-table))
384 (list +fill+))))))

  ViewVC Help
Powered by ViewVC 1.1.5