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

Contents of /mcclim/menu.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.40 - (show annotations)
Tue Apr 15 21:15:22 2008 UTC (6 years ago) by thenriksen
Branch: MAIN
CVS Tags: McCLIM-0-9-6, HEAD
Changes since 1.39: +3 -3 lines
Made command menu panes less broken.
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 (defclass submenu-border (border-pane) ())
123
124 (defclass submenu-border-pane (raised-pane)
125 ()
126 (:default-initargs :border-width 2 :background *3d-normal-color*))
127
128 (defun make-menu-buttons (command-table-name client)
129 "Map over the available menu items in the command table with
130 name `command-table-name', taking inherited menu items into
131 account, and create a list of menu buttons."
132 (let ((menu-buttons '()))
133 (map-over-command-table-menu-items
134 #'(lambda (name gesture item)
135 (declare (ignore name gesture))
136 (push (make-menu-button-from-menu-item
137 item client :command-table command-table-name :vertical t)
138 menu-buttons))
139 command-table-name)
140 (nreverse menu-buttons)))
141
142 (defun create-substructure (sub-menu client)
143 (let* ((frame *application-frame*)
144 (manager (frame-manager frame))
145 (command-table-name (slot-value sub-menu 'command-table))
146 (items (make-menu-buttons command-table-name client))
147 (rack (make-pane-1 manager frame 'vrack-pane
148 :background *3d-normal-color* :contents items))
149 (raised (make-pane-1 manager frame 'submenu-border :contents (list rack))))
150 (with-slots (bottomp) sub-menu
151 (multiple-value-bind (xmin ymin xmax ymax)
152 (bounding-rectangle* (sheet-region sub-menu))
153 (multiple-value-bind (x y)
154 (transform-position (sheet-delta-transformation sub-menu nil)
155 (if bottomp xmin xmax)
156 (if bottomp ymax ymin))
157 (with-slots (frame-manager submenu-frame) sub-menu
158 (setf frame-manager manager
159 submenu-frame (make-menu-frame raised :left x :top y))
160 (adopt-frame manager submenu-frame)
161 (with-sheet-medium (medium raised)
162 (medium-force-output medium))))))))
163
164 (defmethod destroy-substructure ((sub-menu menu-button-submenu-pane))
165 (with-slots (frame-manager submenu-frame) sub-menu
166 (when submenu-frame
167 (mapc #'destroy-substructure (menu-children sub-menu))
168 (disown-frame frame-manager submenu-frame)
169 (disarm-gadget sub-menu)
170 (dispatch-repaint sub-menu +everywhere+)
171 (setf submenu-frame nil) )))
172
173 (defmethod arm-branch ((sub-menu menu-button-submenu-pane))
174 (with-slots (client frame-manager submenu-frame) sub-menu
175 (arm-menu client)
176 (if submenu-frame
177 (progn (mapc #'destroy-substructure (menu-children sub-menu))
178 (mapc #'disarm-menu (menu-children sub-menu)))
179 (progn
180 (mapc #'destroy-substructure (menu-children client))
181 (create-substructure sub-menu sub-menu)))
182 (arm-menu sub-menu)))
183
184 (defmethod handle-event ((pane menu-button-submenu-pane) (event pointer-button-release-event))
185 (destroy-substructure (menu-root pane)))
186
187 ;;; menu-button-vertical-submenu-pane
188 (defclass menu-button-vertical-submenu-pane (menu-button-submenu-pane) ())
189
190 (let* ((left-padding 10)
191 (widget-size 5)
192 (right-padding 4)
193 (widget-width widget-size)
194 (widget-height (* 2 widget-size))
195 (total-width (+ left-padding widget-width right-padding))
196 (total-height widget-height))
197
198 (defmethod compose-space ((gadget menu-button-vertical-submenu-pane) &key width height)
199 (declare (ignorable width height))
200 (multiple-value-bind (width min-width max-width height min-height max-height)
201 (space-requirement-components (call-next-method))
202 (declare (ignorable max-width))
203 (make-space-requirement :min-width (+ min-width total-width)
204 :width (+ width total-width)
205 :max-width +fill+
206 :min-height (max min-height total-height)
207 :height (max height total-height)
208 :max-height (if (zerop max-height) ; make-space-requirements default maximums are zero..
209 0
210 (max max-height total-height)))))
211
212 (defmethod handle-repaint ((pane menu-button-vertical-submenu-pane) region)
213 (call-next-method)
214 (multiple-value-bind (x1 y1 x2 y2)
215 (bounding-rectangle* (sheet-region pane))
216 (when (and (> (- x2 x1) total-width)
217 (> (- y2 y1) total-height))
218 (let* ((center (/ (+ y1 y2) 2))
219 (vbase (- center (/ widget-height 2)))
220 (hbase (+ (- x2 total-width) left-padding))
221 (shape (list hbase vbase
222 (+ hbase widget-size) (+ vbase widget-size)
223 hbase (+ vbase (* 2 widget-size)))))
224 (draw-polygon* pane shape :ink +black+))))))
225
226 ;;; menu-divider-leaf-pane
227
228 (defclass menu-divider-leaf-pane (standard-gadget)
229 ((label :initform nil :initarg :label)))
230
231 (defparameter *labelled-divider-text-style* (make-text-style :sans-serif :roman :small))
232
233 (defmethod destroy-substructure ((object menu-divider-leaf-pane)))
234 (defmethod arm-menu ((object menu-divider-leaf-pane)))
235 (defmethod disarm-menu ((object menu-divider-leaf-pane)))
236
237 (defmethod compose-space ((gadget menu-divider-leaf-pane) &key width height)
238 (declare (ignorable width height))
239 (flet ((make-sr (w h)
240 (make-space-requirement :min-width w :width w
241 :min-height h :height h :max-height h)))
242 (let ((label (slot-value gadget 'label)))
243 (if label
244 (multiple-value-bind (width height fx fy baseline)
245 (text-size gadget label :text-style *labelled-divider-text-style*)
246 (declare (ignore fx fy height baseline))
247 (make-sr width (+ 0
248 (text-style-ascent *labelled-divider-text-style* gadget)
249 (text-style-descent *labelled-divider-text-style* gadget))))
250 (make-sr 0 4)))))
251
252
253 (defmethod handle-repaint ((pane menu-divider-leaf-pane) region)
254 (let ((label (slot-value pane 'label)))
255 (multiple-value-bind (x1 y1 x2 y2)
256 (bounding-rectangle* (sheet-region pane))
257 (declare (ignore y2))
258 (if label
259 (multiple-value-bind (width height fx fy baseline)
260 (text-size pane label :text-style *labelled-divider-text-style*)
261 (declare (ignore height fx fy))
262 (let ((tx0 (+ x1 (/ (- (- x2 x1) width) 2)))
263 (ty0 (+ 1 y1 baseline)))
264 (draw-line* pane tx0 (1+ ty0) (+ tx0 width) (1+ ty0) :ink *3d-dark-color*)
265 (draw-text* pane label tx0 ty0
266 :text-style *labelled-divider-text-style*)))
267 (progn
268 (draw-line* pane x1 (1+ y1) x2 (1+ y1) :ink *3d-dark-color*)
269 (draw-line* pane x1 (+ 2 y1) x2 (+ 2 y1) :ink *3d-light-color*))))))
270
271
272 ;;; Menu creation from command tables
273
274 (defparameter *enabled-text-style* (make-text-style :sans-serif :roman :normal))
275 (defparameter *disabled-text-style* (make-text-style :sans-serif :roman :normal))
276
277 (defun make-menu-button-from-menu-item (item client
278 &key (bottomp nil)
279 (vertical nil)
280 command-table
281 (presentation-type 'menu-item))
282 (declare (ignore command-table))
283 (let ((name (command-menu-item-name item))
284 (type (command-menu-item-type item))
285 (value (command-menu-item-value item))
286 (frame *application-frame*)
287 (manager (frame-manager *application-frame*)))
288 (case type
289 (:command
290 (let ((command-name (if (consp value) (car value) value)))
291 (if (command-enabled command-name frame)
292 (make-pane-1 manager frame 'menu-button-leaf-pane
293 :label name
294 :text-style *enabled-text-style*
295 :client client
296 :vertical vertical
297 :value-changed-callback
298 #'(lambda (gadget val)
299 (declare (ignore gadget val))
300 (throw-object-ptype item presentation-type)))
301 (let ((pane (make-pane-1 manager frame 'menu-button-leaf-pane
302 :label name
303 :text-style *disabled-text-style*
304 :client client
305 :vertical vertical
306 :value-changed-callback
307 #'(lambda (gadget val)
308 (declare (ignore gadget val))
309 nil))))
310 (deactivate-gadget pane)
311 pane))))
312 (:function
313 (make-pane-1 manager frame 'menu-button-leaf-pane
314 :label name
315 :text-style *enabled-text-style*
316 :client client
317 :vertical vertical
318 :value-changed-callback
319 #'(lambda (gadget val)
320 (declare (ignore gadget val))
321 ;; FIXME: the spec requires us to pass a gesture to the
322 ;; function, but value-changed-callback doesn't provide
323 ;; one, so we pass NIL for now.
324 ;; FIXME: We don't have a numeric argument, either.
325 (let ((command (funcall value nil nil)))
326 (throw-object-ptype command 'command)))))
327 (:divider
328 (make-pane-1 manager frame 'menu-divider-leaf-pane
329 :label name
330 :vertical vertical
331 :client client))
332 (:menu
333 (make-pane-1 manager frame (if vertical
334 'menu-button-vertical-submenu-pane
335 'menu-button-submenu-pane)
336 :label name
337 :client client
338 :vertical vertical
339 :frame-manager manager
340 :command-table value
341 :bottomp bottomp))
342 (otherwise (error "Don't know how to create a menu button for ~W" type)))))
343
344 ;;
345 ;; MENU-BAR
346 ;;
347 (defclass menu-button-hrack-pane (hrack-pane) ())
348
349 (defclass menu-bar (menu-button-hrack-pane
350 permanent-medium-sheet-output-mixin)
351 ((items :initform nil)
352 (armed :initform nil)))
353
354 (defmethod initialize-instance :after ((pane menu-bar)
355 &rest args
356 &key
357 &allow-other-keys)
358 (declare (ignore args))
359 (setf (slot-value pane 'items) (copy-list (sheet-children pane)))
360 (loop for child in (menu-children pane)
361 do (setf (gadget-client child) pane)))
362
363 (defmethod menu-children ((menu-bar menu-bar))
364 (slot-value menu-bar 'items))
365
366 (defmethod menu-root ((object menu-bar))
367 object)
368
369 (defmethod destroy-substructure ((object menu-bar))
370 (loop for child in (menu-children object)
371 do (progn (destroy-substructure child)
372 (dispatch-repaint child (sheet-region child))))
373 (setf (slot-value object 'armed) nil))
374
375 (defmethod arm-menu ((object menu-bar))
376 (setf (slot-value object 'armed) t))
377
378 (defmethod disarm-menu ((object menu-bar))
379 (setf (slot-value object 'armed) nil))
380
381 (defun make-menu-bar (command-table
382 &key width height
383 (max-width +fill+) max-height
384 min-width min-height)
385 (with-slots (menu) (find-command-table command-table)
386 (make-pane-1 *pane-realizer* *application-frame*
387 'menu-bar
388 :background *3d-normal-color*
389 :width width :height height
390 :max-width max-width :max-height max-height
391 :min-width min-width :min-height min-height
392 :contents
393 (append
394 (loop for item in menu
395 collect
396 (make-menu-button-from-menu-item
397 item nil
398 :bottomp t
399 :vertical nil
400 :command-table command-table))
401 (list +fill+)))))
402
403 (defmethod handle-repaint ((pane menu-bar) region)
404 (declare (ignore region))
405 (with-slots (border-width) pane
406 (multiple-value-call #'draw-bordered-rectangle*
407 pane
408 (bounding-rectangle* (sheet-region pane))
409 :style :outset
410 :border-width 2)))
411
412 (defmethod compose-space ((pane menu-bar) &key width height)
413 (declare (ignore width height))
414 (space-requirement+
415 (call-next-method)
416 (make-space-requirement :height 4 :max-height 4 :min-height 4)))
417
418 (defmethod box-layout-mixin/horizontally-allocate-space
419 ((pane menu-bar) real-width real-height)
420 (with-slots (x-spacing) pane
421 (let ((widths
422 (box-layout-mixin/horizontally-allocate-space-aux*
423 pane real-width real-height))
424 (x 2))
425 (loop
426 for child in (box-layout-mixin-clients pane)
427 for width in widths
428 do
429 (when (box-client-pane child)
430 (layout-child (box-client-pane child)
431 :expand
432 :expand
433 x
434 2
435 width
436 (- real-height 4)))
437 (incf x width)
438 (incf x x-spacing)))))
439
440 (defmethod display-command-table-menu ((command-table standard-command-table)
441 (stream fundamental-output-stream)
442 &rest args
443 &key max-width max-height n-rows n-columns
444 x-spacing y-spacing initial-spacing
445 row-wise (cell-align-x :left)
446 (cell-align-y :top) (move-cursor t))
447 (formatting-item-list (stream :max-width max-width :max-height max-height :n-rows n-rows
448 :n-columns n-columns :x-spacing x-spacing :y-spacing y-spacing
449 :initial-spacing initial-spacing :row-wise row-wise
450 :move-cursor move-cursor)
451 (map-over-command-table-menu-items
452 #'(lambda (item-name accelerator item)
453 (declare (ignore accelerator))
454 (formatting-cell (stream :align-x cell-align-x :align-y cell-align-y)
455 (cond ((eq (command-menu-item-type item) :menu)
456 (with-text-style (stream (make-text-style :serif '(:bold :italic) nil))
457 (write-string item-name stream)
458 (terpri stream))
459 (surrounding-output-with-border (stream)
460 (apply #'display-command-table-menu
461 (find-command-table (command-menu-item-value item))
462 stream args)))
463 ((eq (command-menu-item-type item) :command)
464 (let ((name (command-menu-item-name item)))
465 (with-output-as-presentation (stream (command-menu-item-value item) 'command)
466 (write-string name stream)))))))
467 command-table)))
468
469 (defmethod display-command-menu (frame (stream fundamental-output-stream)
470 &rest args &key
471 (command-table (frame-command-table frame))
472 initial-spacing row-wise max-width
473 max-height n-rows n-columns
474 (cell-align-x :left) (cell-align-y :top))
475 (declare (ignore initial-spacing row-wise max-width max-height
476 n-rows n-columns cell-align-x cell-align-y))
477 (with-keywords-removed (args (:command-table))
478 (apply #'display-command-table-menu command-table stream args)))

  ViewVC Help
Powered by ViewVC 1.1.5