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

Contents of /mcclim/menu.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.40 - (hide 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 moore 1.29 1;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2 cvs 1.1
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 mikemac 1.25 (in-package :clim-internals)
22 cvs 1.1
23 moore 1.28 (defmethod stream-force-output ((pane menu-button-pane))
24     (with-sheet-medium (medium pane)
25     (medium-force-output medium)))
26    
27 cvs 1.1 (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 gilbert 1.22 (arm-gadget button t))
36 cvs 1.1 (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 gilbert 1.22 (disarm-gadget button)
42 moore 1.28 (dispatch-repaint button (sheet-region button))
43     (stream-force-output button))))
44 cvs 1.1
45 boninfan 1.9 (defun menu-draw-highlighted (gadget)
46 gilbert 1.14 (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 gilbert 1.27 (draw-edges-lines* gadget +white+ 0 0 +black+ (1- w) (1- h))
56 gilbert 1.16 (draw-label* gadget x1 y1 x2 y2)))))))
57 boninfan 1.9
58 cvs 1.1 (defun menu-draw-unhighlighted (gadget)
59 gilbert 1.14 (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 gilbert 1.22 :ink +background-ink+
67 gilbert 1.14 :filled t)
68 gilbert 1.16 (draw-label* gadget x1 y1 x2 y2)))))))
69 cvs 1.1
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 cvs 1.4 (with-slots (client) button
87     (arm-menu client)
88     (mapc #'destroy-substructure (menu-children client))
89     (arm-menu button)))
90 cvs 1.1
91     (defmethod destroy-substructure ((button menu-button-leaf-pane))
92 gilbert 1.22 (disarm-gadget button))
93 cvs 1.1
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 moore 1.28 (unwind-protect
98     (value-changed-callback pane client id label)
99     (disarm-menu pane)
100     (destroy-substructure (menu-root pane))))))
101 cvs 1.1
102     (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-exit-event))
103 cvs 1.4 (disarm-menu pane))
104 cvs 1.1
105 cvs 1.3 (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-ungrab-event))
106     (destroy-substructure (menu-root pane)))
107    
108 cvs 1.1 ;;; menu-button-submenu-pane
109    
110     (defclass menu-button-submenu-pane (menu-button-pane)
111 gilbert 1.22 ((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 cvs 1.1
116     (defmethod menu-children ((submenu menu-button-submenu-pane))
117     (with-slots (submenu-frame) submenu
118     (if submenu-frame
119 moore 1.29 (sheet-children (first (sheet-children (frame-panes submenu-frame))))
120 cvs 1.1 '())))
121    
122 ahefner 1.38 (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 thenriksen 1.39 (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 cvs 1.1 (defun create-substructure (sub-menu client)
143     (let* ((frame *application-frame*)
144 gilbert 1.22 (manager (frame-manager frame))
145 moore 1.26 (command-table-name (slot-value sub-menu 'command-table))
146 thenriksen 1.39 (items (make-menu-buttons command-table-name client))
147 gilbert 1.22 (rack (make-pane-1 manager frame 'vrack-pane
148     :background *3d-normal-color* :contents items))
149 ahefner 1.38 (raised (make-pane-1 manager frame 'submenu-border :contents (list rack))))
150 gilbert 1.22 (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 moore 1.28 (adopt-frame manager submenu-frame)
161     (with-sheet-medium (medium raised)
162     (medium-force-output medium))))))))
163 cvs 1.1
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 gilbert 1.22 (disarm-gadget sub-menu)
170     (dispatch-repaint sub-menu +everywhere+)
171     (setf submenu-frame nil) )))
172 cvs 1.1
173     (defmethod arm-branch ((sub-menu menu-button-submenu-pane))
174 gilbert 1.22 (with-slots (client frame-manager submenu-frame) sub-menu
175 cvs 1.4 (arm-menu client)
176 gilbert 1.22 (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 cvs 1.4 (arm-menu sub-menu)))
183 hefner1 1.32
184 cvs 1.1 (defmethod handle-event ((pane menu-button-submenu-pane) (event pointer-button-release-event))
185 gilbert 1.22 (destroy-substructure (menu-root pane)))
186 cvs 1.1
187 hefner1 1.32 ;;; 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 cvs 1.1
274 hefner1 1.32 (defparameter *enabled-text-style* (make-text-style :sans-serif :roman :normal))
275     (defparameter *disabled-text-style* (make-text-style :sans-serif :roman :normal))
276 moore 1.30
277 moore 1.26 (defun make-menu-button-from-menu-item (item client
278 moore 1.28 &key (bottomp nil)
279 hefner1 1.32 (vertical nil)
280 moore 1.28 command-table
281     (presentation-type 'menu-item))
282     (declare (ignore command-table))
283 cvs 1.1 (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 hefner1 1.32 (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 ahefner 1.38 :vertical vertical
297 hefner1 1.32 :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 ahefner 1.38 :vertical vertical
306 hefner1 1.32 :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 ahefner 1.38 :vertical vertical
318 hefner1 1.32 :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 hefner1 1.33 (let ((command (funcall value nil nil)))
326     (throw-object-ptype command 'command)))))
327 hefner1 1.32 (:divider
328     (make-pane-1 manager frame 'menu-divider-leaf-pane
329     :label name
330 ahefner 1.38 :vertical vertical
331 hefner1 1.32 :client client))
332     (:menu
333     (make-pane-1 manager frame (if vertical
334     'menu-button-vertical-submenu-pane
335     'menu-button-submenu-pane)
336 cvs 1.1 :label name
337     :client client
338 ahefner 1.38 :vertical vertical
339 cvs 1.1 :frame-manager manager
340     :command-table value
341 hefner1 1.32 :bottomp bottomp))
342     (otherwise (error "Don't know how to create a menu button for ~W" type)))))
343 cvs 1.1
344     ;;
345     ;; MENU-BAR
346     ;;
347 brian 1.13 (defclass menu-button-hrack-pane (hrack-pane) ())
348 cvs 1.1
349 brian 1.13 (defclass menu-bar (menu-button-hrack-pane
350 gilbert 1.10 permanent-medium-sheet-output-mixin)
351 cvs 1.1 ((items :initform nil)
352     (armed :initform nil)))
353    
354     (defmethod initialize-instance :after ((pane menu-bar)
355     &rest args
356 cvs 1.2 &key
357 cvs 1.1 &allow-other-keys)
358     (declare (ignore args))
359     (setf (slot-value pane 'items) (copy-list (sheet-children pane)))
360 gilbert 1.23 (loop for child in (menu-children pane)
361 cvs 1.1 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 cvs 1.5 (loop for child in (menu-children object)
371 cvs 1.1 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 hatchond 1.6 (defun make-menu-bar (command-table
382     &key width height
383 gilbert 1.15 (max-width +fill+) max-height
384 hatchond 1.6 min-width min-height)
385 cvs 1.1 (with-slots (menu) (find-command-table command-table)
386 dlichteblau 1.35 (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 ahefner 1.38 (make-menu-button-from-menu-item
397 dlichteblau 1.35 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 dlichteblau 1.36 (space-requirement+
415     (call-next-method)
416     (make-space-requirement :height 4 :max-height 4 :min-height 4)))
417 dlichteblau 1.35
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 thenriksen 1.37
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 thenriksen 1.40 (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 thenriksen 1.37 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