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

Contents of /mcclim/menu.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.20 - (hide annotations)
Fri Sep 20 17:55:41 2002 UTC (11 years, 6 months ago) by brian
Branch: MAIN
Changes since 1.19: +51 -31 lines
added look and feel support to menus, fixed floating menu leakage, etc
1 cvs 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 menu-root ((button menu-button-pane))
24     (menu-root (gadget-client button)))
25    
26     (defmethod arm-menu ((button menu-button-pane))
27     (with-slots (client armed id) button
28     (unless armed
29     (arm-menu client)
30     (mapc #'disarm-menu (menu-children client))
31     (setf armed t)
32     (armed-callback button client id))
33     (dispatch-repaint button (sheet-region button))))
34    
35     (defmethod disarm-menu ((button menu-button-pane))
36     (with-slots (client armed id) button
37     (when armed
38     (setf armed nil)
39     (disarmed-callback button client id)
40     (dispatch-repaint button (sheet-region button)))))
41    
42 boninfan 1.9 (defun menu-draw-highlighted (gadget)
43 gilbert 1.14 (when (sheet-mirror gadget) ;XXX only do this when the gadget is realized.
44     (with-special-choices (gadget)
45     (with-slots (label) gadget
46     (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region gadget)
47     (let ((w (- x2 x1))
48     (h (- y2 y1)))
49     (draw-rectangle* gadget -1 -1 x2 y2
50     :ink (gadget-highlighted-color gadget)
51     :filled t)
52 brian 1.19 (draw-edges-lines* gadget +white+ 0 0 +black+ (1- w) (1- h)) ;(- w 2) (- h 2)
53 gilbert 1.16 (draw-label* gadget x1 y1 x2 y2)))))))
54 boninfan 1.9
55 cvs 1.1 (defun menu-draw-unhighlighted (gadget)
56 gilbert 1.14 (when (sheet-mirror gadget) ;XXX only do this when the gadget is realized.
57     (with-special-choices (gadget)
58     (with-slots (label) gadget
59     (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region gadget)
60     (let ((w (- x2 x1))
61     (h (- y2 y1)))
62     (draw-rectangle* gadget -1 -1 w h ;-1 -1 x2 y2
63     :ink (gadget-normal-color gadget)
64     :filled t)
65 gilbert 1.16 (draw-label* gadget x1 y1 x2 y2)))))))
66 cvs 1.1
67     (defmethod handle-event ((pane menu-button-pane) (event pointer-enter-event))
68     (when (slot-value (slot-value pane 'client) 'armed)
69     (arm-branch pane)))
70    
71     (defmethod handle-event ((pane menu-button-pane) (event pointer-button-press-event))
72     (arm-branch pane))
73    
74     (defmethod handle-event ((pane menu-button-pane) (event pointer-ungrab-event))
75     (destroy-substructure (menu-root pane)))
76    
77     ;;; menu-button-leaf-pane
78    
79     (defclass menu-button-leaf-pane (menu-button-pane)
80     ((command :initform nil :initarg :command)))
81    
82     (defmethod arm-branch ((button menu-button-leaf-pane))
83 cvs 1.4 (with-slots (client) button
84     (arm-menu client)
85     (mapc #'destroy-substructure (menu-children client))
86     (arm-menu button)))
87 cvs 1.1
88     (defmethod destroy-substructure ((button menu-button-leaf-pane))
89 cvs 1.4 (with-slots (armed) button
90 cvs 1.1 (setf armed nil)))
91    
92     (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-button-release-event))
93     (with-slots (armed label client id) pane
94     (when armed
95     (value-changed-callback pane client id label)
96     (disarm-menu pane)
97     (destroy-substructure (menu-root pane)))))
98    
99     (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-exit-event))
100 cvs 1.4 (disarm-menu pane))
101 cvs 1.1
102 cvs 1.3 (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-ungrab-event))
103     (destroy-substructure (menu-root pane)))
104    
105 gilbert 1.14 (defmethod handle-repaint ((pane menu-button-leaf-pane) region)
106 cvs 1.1 (declare (ignore region))
107     (with-slots (armed) pane
108     (if armed
109     (menu-draw-highlighted pane)
110     (menu-draw-unhighlighted pane))))
111    
112     ;;; menu-button-submenu-pane
113    
114     (defclass menu-button-submenu-pane (menu-button-pane)
115 brian 1.20 ((frame-manager
116     :initform nil
117     :initarg :frame-manager)
118     (submenu-frame
119     :initform nil)
120     (bottomp
121     :initform nil
122     :initarg :bottomp)
123     (command-table
124     :initform nil
125     :initarg :command-table)
126     (dissolving ; nasty hack to prevent menus from leaking
127     :initform nil)))
128 cvs 1.1
129     (defmethod menu-children ((submenu menu-button-submenu-pane))
130     (with-slots (submenu-frame) submenu
131     (if submenu-frame
132 cvs 1.5 (sheet-children (first (sheet-children (frame-pane submenu-frame))))
133 cvs 1.1 '())))
134    
135     (defun create-substructure (sub-menu client)
136     (let* ((frame *application-frame*)
137 brian 1.20 (manager (frame-manager frame)))
138     (with-look-and-feel-realization (manager frame)
139     (let* ((frame *application-frame*)
140     (items (mapcar #'(lambda (item)
141     (make-menu-button-from-menu-item item client))
142     (slot-value (find-command-table (slot-value sub-menu 'command-table)) 'menu)))
143     (rack (make-pane-1 manager frame 'vrack-pane
144     :background +grey80+ :contents items))
145     ;(raised (make-pane-1 manager frame 'raised-pane :contents (list rack)))
146     (raised (make-pane-1 manager frame 'raised-pane :border-width 2 :background +gray80+ :contents (list rack))))
147     (with-slots (bottomp) sub-menu
148     (multiple-value-bind (xmin ymin xmax ymax)
149     (bounding-rectangle* (sheet-region sub-menu))
150     (multiple-value-bind (x y)
151     (transform-position (sheet-delta-transformation sub-menu nil)
152     (if bottomp xmin xmax)
153     (if bottomp ymax ymin))
154     (with-slots (frame-manager submenu-frame) sub-menu
155     (setf frame-manager manager
156     submenu-frame (make-menu-frame raised :left x :top y))
157     (adopt-frame manager submenu-frame)))))))))
158 cvs 1.1
159     (defmethod destroy-substructure ((sub-menu menu-button-submenu-pane))
160     (with-slots (frame-manager submenu-frame) sub-menu
161     (when submenu-frame
162     (mapc #'destroy-substructure (menu-children sub-menu))
163     (disown-frame frame-manager submenu-frame)
164     (setf submenu-frame nil))))
165    
166     (defmethod arm-branch ((sub-menu menu-button-submenu-pane))
167 brian 1.20 (with-slots (client frame-manager submenu-frame dissolving) sub-menu
168 cvs 1.4 (arm-menu client)
169 brian 1.20 (cond
170     (submenu-frame
171     (mapc #'destroy-substructure (menu-children sub-menu))
172     (mapc #'disarm-menu (menu-children sub-menu)))
173     (t
174     (mapc #'destroy-substructure (menu-children client))
175     (if dissolving
176     (progn
177     (setf dissolving nil)
178     (disarm-menu client))
179     (create-substructure sub-menu sub-menu))))
180 cvs 1.4 (arm-menu sub-menu)))
181 adejneka 1.17
182 cvs 1.1 (defmethod handle-event ((pane menu-button-submenu-pane) (event pointer-button-release-event))
183 brian 1.20 (destroy-substructure (menu-root pane))
184     (with-slots (dissolving client) pane
185     (setf dissolving t)))
186 cvs 1.1
187 gilbert 1.14 (defmethod handle-repaint ((pane menu-button-submenu-pane) region)
188 cvs 1.1 (declare (ignore region))
189     (with-slots (submenu-frame) pane
190     (if submenu-frame
191     (menu-draw-highlighted pane)
192     (menu-draw-unhighlighted pane))))
193    
194     ;; Menu creation from command tables
195    
196     ;; for now, accept only types :command and :menu, and only
197     ;; command names as values of :command
198     (defun make-menu-button-from-menu-item (item client &key (bottomp nil))
199     (let ((name (command-menu-item-name item))
200     (type (command-menu-item-type item))
201     (value (command-menu-item-value item))
202     (frame *application-frame*)
203     (manager (frame-manager *application-frame*)))
204     (if (eq type :command)
205     (make-pane-1 manager frame 'menu-button-leaf-pane
206 brian 1.20 :name name
207 cvs 1.1 :label name
208     :client client
209     :value-changed-callback
210     #'(lambda (gadget val)
211 adejneka 1.17 (declare (ignore val))
212     (throw-highlighted-presentation
213     (make-instance 'standard-presentation
214 adejneka 1.18 :object (if (listp value)
215     value
216     (list value))
217 adejneka 1.17 :type 'command)
218     *input-context*
219     (make-instance 'pointer-button-press-event
220     :sheet gadget
221     :x 0 :y 0
222     :modifier-state 0
223     :button +pointer-left-button+))))
224 cvs 1.1 (make-pane-1 manager frame 'menu-button-submenu-pane
225 brian 1.20 :name name
226 cvs 1.1 :label name
227     :client client
228     :frame-manager manager
229     :command-table value
230     :bottomp bottomp))))
231    
232     ;;
233     ;; MENU-BAR
234     ;;
235 brian 1.13 (defclass menu-button-hrack-pane (hrack-pane) ())
236 cvs 1.1
237 brian 1.13 (defclass menu-bar (menu-button-hrack-pane
238 gilbert 1.10 permanent-medium-sheet-output-mixin)
239 cvs 1.1 ((items :initform nil)
240     (armed :initform nil)))
241    
242     (defmethod initialize-instance :after ((pane menu-bar)
243     &rest args
244 cvs 1.2 &key
245 cvs 1.1 &allow-other-keys)
246     (declare (ignore args))
247     (setf (slot-value pane 'items) (copy-list (sheet-children pane)))
248     (loop for child in (sheet-children pane)
249     do (setf (gadget-client child) pane)))
250    
251     (defmethod menu-children ((menu-bar menu-bar))
252     (slot-value menu-bar 'items))
253    
254     (defmethod menu-root ((object menu-bar))
255     object)
256    
257     (defmethod destroy-substructure ((object menu-bar))
258 cvs 1.5 (loop for child in (menu-children object)
259 cvs 1.1 do (progn (destroy-substructure child)
260     (dispatch-repaint child (sheet-region child))))
261     (setf (slot-value object 'armed) nil))
262    
263     (defmethod arm-menu ((object menu-bar))
264     (setf (slot-value object 'armed) t))
265    
266     (defmethod disarm-menu ((object menu-bar))
267     (setf (slot-value object 'armed) nil))
268    
269 hatchond 1.6 (defun make-menu-bar (command-table
270     &key width height
271 gilbert 1.15 (max-width +fill+) max-height
272 hatchond 1.6 min-width min-height)
273 cvs 1.1 (with-slots (menu) (find-command-table command-table)
274 gilbert 1.11 (progn ;;raising () ;; XXX temporary medicine as RAISED is borken --GB
275 brian 1.13 (make-pane-1 *pane-realizer* *application-frame*
276 hatchond 1.6 'menu-bar
277     :background +grey80+
278     :width width :height height
279     :max-width max-width :max-height max-height
280     :min-width min-width :min-height min-height
281     :contents
282     (loop for item in menu
283     collect
284     (make-menu-button-from-menu-item item nil :bottomp t))))))

  ViewVC Help
Powered by ViewVC 1.1.5