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

Contents of /mcclim/menu.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Fri Dec 8 14:42:43 2000 UTC (13 years, 4 months ago) by cvs
Branch: MAIN
Changes since 1.2: +3 -0 lines
Added method on handle-event for menu-button-leaf-pane and
pointer-ungrab-event.
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 compose-space ((button menu-button-pane))
24 (pane-space-requirement button))
25
26 (defmethod pane-space-requirement ((button menu-button-pane))
27 (or (slot-value button 'space-requirement)
28 (with-sheet-medium (medium button)
29 (multiple-value-bind (width height) (text-size medium (gadget-label button))
30 (setf width (round (* 1.3 width))
31 height (round (* 2.5 height)))
32 (make-space-requirement :width width :height height)))))
33
34 (defmethod menu-root ((button menu-button-pane))
35 (menu-root (gadget-client button)))
36
37 (defmethod arm-menu ((button menu-button-pane))
38 (with-slots (client armed id) button
39 (unless armed
40 (arm-menu client)
41 (mapc #'disarm-menu (menu-children client))
42 (setf armed t)
43 (armed-callback button client id))
44 (dispatch-repaint button (sheet-region button))))
45
46 (defmethod disarm-menu ((button menu-button-pane))
47 (with-slots (client armed id) button
48 (when armed
49 (setf armed nil)
50 (disarmed-callback button client id)
51 (dispatch-repaint button (sheet-region button)))))
52
53 (defun menu-draw-highlighted (gadget)
54 (with-slots (label) gadget
55 (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region gadget))
56 (let ((w (- x2 x1))
57 (h (- y2 y1)))
58 (draw-rectangle* gadget -1 -1 x2 y2 :ink (gadget-highlighted-color gadget) :filled t)
59 (draw-edges-lines* gadget 1 1 (1- w) (1- h))
60 (draw-text* gadget label (round w 2) (round h 2)
61 :align-x :center :align-y :center)))))
62
63 (defun menu-draw-unhighlighted (gadget)
64 (with-slots (label) gadget
65 (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region gadget))
66 (let ((w (- x2 x1))
67 (h (- y2 y1)))
68 (draw-rectangle* gadget -1 -1 x2 y2 :ink (gadget-normal-color gadget) :filled t)
69 (draw-text* gadget label (round w 2) (round h 2)
70 :align-x :center :align-y :center)))))
71
72 (defmethod handle-event ((pane menu-button-pane) (event pointer-enter-event))
73 (when (slot-value (slot-value pane 'client) 'armed)
74 (arm-branch pane)))
75
76 (defmethod handle-event ((pane menu-button-pane) (event pointer-button-press-event))
77 (arm-branch pane))
78
79 (defmethod handle-event ((pane menu-button-pane) (event window-repaint-event))
80 (dispatch-repaint pane (sheet-region pane)))
81
82 (defmethod handle-event ((pane menu-button-pane) (event pointer-ungrab-event))
83 (destroy-substructure (menu-root pane)))
84
85 ;;; menu-button-leaf-pane
86
87 (defclass menu-button-leaf-pane (menu-button-pane)
88 ((command :initform nil :initarg :command)))
89
90 (defmethod arm-branch ((button menu-button-leaf-pane))
91 (unless (slot-value button 'destroyed)
92 (with-slots (client) button
93 (arm-menu client)
94 (mapc #'destroy-substructure (menu-children client))
95 (arm-menu button))))
96
97 (defmethod destroy-substructure ((button menu-button-leaf-pane))
98 (with-slots (armed destroyed) button
99 (setf armed nil)))
100
101 (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-button-release-event))
102 (with-slots (armed label client id) pane
103 (when armed
104 (value-changed-callback pane client id label)
105 (disarm-menu pane)
106 (destroy-substructure (menu-root pane)))))
107
108 (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-exit-event))
109 (unless (slot-value pane 'destroyed)
110 (disarm-menu pane)))
111
112 (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-ungrab-event))
113 (destroy-substructure (menu-root pane)))
114
115 (defmethod repaint-sheet ((pane menu-button-leaf-pane) region)
116 (declare (ignore region))
117 (with-slots (armed) pane
118 (if armed
119 (menu-draw-highlighted pane)
120 (menu-draw-unhighlighted pane))))
121
122 ;;; menu-button-submenu-pane
123
124 (defclass menu-button-submenu-pane (menu-button-pane)
125 ((frame-manager :initform nil :initarg :frame-manager)
126 (submenu-frame :initform nil)
127 (bottomp :initform nil :initarg :bottomp)
128 (command-table :initform nil :initarg :command-table)))
129
130 (defmethod menu-children ((submenu menu-button-submenu-pane))
131 (with-slots (submenu-frame) submenu
132 (if submenu-frame
133 (sheet-children (frame-pane submenu-frame))
134 '())))
135
136 (defun create-substructure (sub-menu client)
137 (let* ((frame *application-frame*)
138 (manager (frame-manager frame))
139 (items (mapcar #'(lambda (item)
140 (make-menu-button-from-menu-item item client))
141 (slot-value (find-command-table (slot-value sub-menu 'command-table)) 'menu)))
142 (rack (make-pane-1 manager frame 'vrack-pane :contents items)))
143 (with-slots (bottomp) sub-menu
144 (multiple-value-bind (xmin ymin xmax ymax)
145 (bounding-rectangle* (sheet-region sub-menu))
146 (multiple-value-bind (x y)
147 (transform-position (sheet-delta-transformation sub-menu nil)
148 (if bottomp xmin xmax)
149 (if bottomp ymax ymin))
150 (with-slots (frame-manager submenu-frame) sub-menu
151 (setf frame-manager manager
152 submenu-frame (make-menu-frame rack :left x :top y))
153 (adopt-frame manager submenu-frame)))))))
154
155 (defmethod destroy-substructure ((sub-menu menu-button-submenu-pane))
156 (with-slots (frame-manager submenu-frame) sub-menu
157 (when submenu-frame
158 (mapc #'destroy-substructure (menu-children sub-menu))
159 (mapc #'(lambda (child)
160 (setf (slot-value child 'destroyed) t))
161 (menu-children sub-menu))
162 (disown-frame frame-manager submenu-frame)
163 (setf submenu-frame nil))))
164
165 (defmethod arm-branch ((sub-menu menu-button-submenu-pane))
166 (unless (slot-value sub-menu 'destroyed)
167 (with-slots (client frame-manager submenu-frame) sub-menu
168 (arm-menu client)
169 (if submenu-frame
170 (progn (mapc #'destroy-substructure (menu-children sub-menu))
171 (mapc #'disarm-menu (menu-children sub-menu)))
172 (progn
173 (mapc #'destroy-substructure (menu-children client))
174 (create-substructure sub-menu sub-menu)))
175 (arm-menu sub-menu))))
176
177 (defmethod handle-event ((pane menu-button-submenu-pane) (event pointer-button-release-event))
178 (destroy-substructure (menu-root pane)))
179
180 (defmethod repaint-sheet ((pane menu-button-submenu-pane) region)
181 (declare (ignore region))
182 (with-slots (submenu-frame) pane
183 (if submenu-frame
184 (menu-draw-highlighted pane)
185 (menu-draw-unhighlighted pane))))
186
187 ;; Menu creation from command tables
188
189 ;; for now, accept only types :command and :menu, and only
190 ;; command names as values of :command
191 (defun make-menu-button-from-menu-item (item client &key (bottomp nil))
192 (let ((name (command-menu-item-name item))
193 (type (command-menu-item-type item))
194 (value (command-menu-item-value item))
195 (frame *application-frame*)
196 (manager (frame-manager *application-frame*)))
197 (if (eq type :command)
198 (make-pane-1 manager frame 'menu-button-leaf-pane
199 :space-requirement nil
200 :label name
201 :client client
202 :value-changed-callback
203 #'(lambda (gadget val)
204 (declare (ignore gadget val))
205 (funcall value)))
206 (make-pane-1 manager frame 'menu-button-submenu-pane
207 :space-requirement nil
208 :label name
209 :client client
210 :frame-manager manager
211 :command-table value
212 :bottomp bottomp))))
213
214 ;;
215 ;; MENU-BAR
216 ;;
217
218 (defclass menu-bar (hrack-pane)
219 ((items :initform nil)
220 (armed :initform nil)))
221
222 (defmethod initialize-instance :after ((pane menu-bar)
223 &rest args
224 &key
225 &allow-other-keys)
226 (declare (ignore args))
227 (setf (slot-value pane 'items) (copy-list (sheet-children pane)))
228 (loop for child in (sheet-children pane)
229 do (setf (gadget-client child) pane)))
230
231 (defmethod menu-children ((menu-bar menu-bar))
232 (slot-value menu-bar 'items))
233
234 (defmethod menu-root ((object menu-bar))
235 object)
236
237 (defmethod destroy-substructure ((object menu-bar))
238 (loop for child in (sheet-children object)
239 do (progn (destroy-substructure child)
240 (dispatch-repaint child (sheet-region child))))
241 (setf (slot-value object 'armed) nil))
242
243 (defmethod arm-menu ((object menu-bar))
244 (setf (slot-value object 'armed) t))
245
246 (defmethod disarm-menu ((object menu-bar))
247 (setf (slot-value object 'armed) nil))
248
249
250 (defun make-menu-bar (command-table)
251 (with-slots (menu) (find-command-table command-table)
252 (make-pane 'menu-bar
253 :contents
254 (mapcar #'(lambda (item)
255 (make-menu-button-from-menu-item item nil :bottomp t))
256 menu))))

  ViewVC Help
Powered by ViewVC 1.1.5