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

Contents of /mcclim/menu.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12 - (show annotations)
Fri Apr 19 22:27:09 2002 UTC (12 years ago) by moore
Branch: MAIN
Changes since 1.11: +0 -3 lines
Make a global choice, based on multiprocessing or not, whether events
should be handled immediately or queued up to be serviced by another
process.  The choice is implemented by the classes
clim-sheet-input-mixin and clim-repainting-mixin, from which all panes
inherit.  These classes' superclasses are conditionalized on whether or
not the implementation is capable of multiprocessing.

When multiprocessing there is a single event queue per frame.  This is
implemented by queue-event on pane classes.

The event loop is implemented in stream-input-wait.  In single
processing mode, stream-input-wait calls process-next-event and
handles events immediately.  When multiprocessing, stream-input-wait
reads events from the frame event queue and handles them.  The
function clim-extensions:simple-event-loop is supplied for
applications which do not loop reading from a stream; various examples
have been changed to use it.

In stream-read-gesture/stream-input-wait the input-wait-test function
is not expected to block anymore; nor is the input-wait-handler
expected to dispatch events.  input-wait-handler is responsible for
consuming events that should not be seen by anyone
else. input-context-wait-test and highlight-applicable-presentation
have been rewritten to reflect this.

The adjustable-array buffer for extended-input-streams has been added
back in.  A typo in %event-matches-gesture has been fixed.

Default methods for map-over-output-records-containing-position and
map-over-output-records-overlapping-region have been added.

The cursor implementation has been broken out into a cursor-mixin so I
can snarf it for Goatee :)
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 #|
43 (defun menu-draw-highlighted (gadget)
44 (with-slots (label) gadget
45 (multiple-value-bind (x1 y1 x2 y2)
46 (bounding-rectangle* (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 (draw-edges-lines* gadget 1 1 (- w 2) (- h 2))
53 (draw-text* gadget label (round w 2) (round h 2)
54 :align-x :center :align-y :center)))))
55 |#
56
57 (defun menu-draw-highlighted (gadget)
58 (with-special-choices (gadget)
59 (with-slots (label) gadget
60 (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region gadget)
61 (let ((w (- x2 x1))
62 (h (- y2 y1)))
63 (draw-rectangle* gadget -1 -1 x2 y2
64 :ink (gadget-highlighted-color gadget)
65 :filled t)
66 (draw-edges-lines* gadget 0 0 (1- w) (1- h)) ;(- w 2) (- h 2))
67 (draw-text* gadget label (round w 2) (round h 2)
68 :align-x :center :align-y :center))))))
69
70 #|
71 (defun menu-draw-unhighlighted (gadget)
72 (with-slots (label) gadget
73 (multiple-value-bind (x1 y1 x2 y2)
74 (bounding-rectangle* (sheet-region gadget))
75 (let ((w (- x2 x1))
76 (h (- y2 y1)))
77 (draw-rectangle* gadget -1 -1 x2 y2
78 :ink (gadget-normal-color gadget)
79 :filled t)
80 (draw-text* gadget label (round w 2) (round h 2)
81 :align-x :center :align-y :center)))))
82 |#
83
84 (defun menu-draw-unhighlighted (gadget)
85 (with-special-choices (gadget)
86 (with-slots (label) gadget
87 (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region gadget)
88 (let ((w (- x2 x1))
89 (h (- y2 y1)))
90 (draw-rectangle* gadget -1 -1 w h ;-1 -1 x2 y2
91 :ink (gadget-normal-color gadget)
92 :filled t)
93 (draw-text* gadget label (round w 2) (round h 2)
94 :align-x :center :align-y :center))))))
95
96 (defmethod handle-event ((pane menu-button-pane) (event pointer-enter-event))
97 (when (slot-value (slot-value pane 'client) 'armed)
98 (arm-branch pane)))
99
100 (defmethod handle-event ((pane menu-button-pane) (event pointer-button-press-event))
101 (arm-branch pane))
102
103 (defmethod handle-event ((pane menu-button-pane) (event pointer-ungrab-event))
104 (destroy-substructure (menu-root pane)))
105
106 ;;; menu-button-leaf-pane
107
108 (defclass menu-button-leaf-pane (menu-button-pane)
109 ((command :initform nil :initarg :command)))
110
111 (defmethod arm-branch ((button menu-button-leaf-pane))
112 (with-slots (client) button
113 (arm-menu client)
114 (mapc #'destroy-substructure (menu-children client))
115 (arm-menu button)))
116
117 (defmethod destroy-substructure ((button menu-button-leaf-pane))
118 (with-slots (armed) button
119 (setf armed nil)))
120
121 (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-button-release-event))
122 (with-slots (armed label client id) pane
123 (when armed
124 (value-changed-callback pane client id label)
125 (disarm-menu pane)
126 (destroy-substructure (menu-root pane)))))
127
128 (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-exit-event))
129 (disarm-menu pane))
130
131 (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-ungrab-event))
132 (destroy-substructure (menu-root pane)))
133
134 (defmethod repaint-sheet ((pane menu-button-leaf-pane) region)
135 (declare (ignore region))
136 (with-slots (armed) pane
137 (if armed
138 (menu-draw-highlighted pane)
139 (menu-draw-unhighlighted pane))))
140
141 ;;; menu-button-submenu-pane
142
143 (defclass menu-button-submenu-pane (menu-button-pane)
144 ((frame-manager :initform nil :initarg :frame-manager)
145 (submenu-frame :initform nil)
146 (bottomp :initform nil :initarg :bottomp)
147 (command-table :initform nil :initarg :command-table)))
148
149 (defmethod menu-children ((submenu menu-button-submenu-pane))
150 (with-slots (submenu-frame) submenu
151 (if submenu-frame
152 (sheet-children (first (sheet-children (frame-pane submenu-frame))))
153 '())))
154
155 (defun create-substructure (sub-menu client)
156 (let* ((frame *application-frame*)
157 (manager (frame-manager frame))
158 (items (mapcar #'(lambda (item)
159 (make-menu-button-from-menu-item item client))
160 (slot-value (find-command-table (slot-value sub-menu 'command-table)) 'menu)))
161 (rack (make-pane-1 manager frame 'vrack-pane
162 :background +grey80+ :contents items))
163 (raised (make-pane-1 manager frame 'raised-pane :contents (list rack))))
164 (with-slots (bottomp) sub-menu
165 (multiple-value-bind (xmin ymin xmax ymax)
166 (bounding-rectangle* (sheet-region sub-menu))
167 (multiple-value-bind (x y)
168 (transform-position (sheet-delta-transformation sub-menu nil)
169 (if bottomp xmin xmax)
170 (if bottomp ymax ymin))
171 (with-slots (frame-manager submenu-frame) sub-menu
172 (setf frame-manager manager
173 submenu-frame (make-menu-frame raised :left x :top y))
174 (adopt-frame manager submenu-frame)))))))
175
176 (defmethod destroy-substructure ((sub-menu menu-button-submenu-pane))
177 (with-slots (frame-manager submenu-frame) sub-menu
178 (when submenu-frame
179 (mapc #'destroy-substructure (menu-children sub-menu))
180 (disown-frame frame-manager submenu-frame)
181 (setf submenu-frame nil))))
182
183 (defmethod arm-branch ((sub-menu menu-button-submenu-pane))
184 (with-slots (client frame-manager submenu-frame) sub-menu
185 (arm-menu client)
186 (if submenu-frame
187 (progn (mapc #'destroy-substructure (menu-children sub-menu))
188 (mapc #'disarm-menu (menu-children sub-menu)))
189 (progn
190 (mapc #'destroy-substructure (menu-children client))
191 (create-substructure sub-menu sub-menu)))
192 (arm-menu sub-menu)))
193
194 (defmethod handle-event ((pane menu-button-submenu-pane) (event pointer-button-release-event))
195 (destroy-substructure (menu-root pane)))
196
197 (defmethod repaint-sheet ((pane menu-button-submenu-pane) region)
198 (declare (ignore region))
199 (with-slots (submenu-frame) pane
200 (if submenu-frame
201 (menu-draw-highlighted pane)
202 (menu-draw-unhighlighted pane))))
203
204 ;; Menu creation from command tables
205
206 ;; for now, accept only types :command and :menu, and only
207 ;; command names as values of :command
208 (defun make-menu-button-from-menu-item (item client &key (bottomp nil))
209 (let ((name (command-menu-item-name item))
210 (type (command-menu-item-type item))
211 (value (command-menu-item-value item))
212 (frame *application-frame*)
213 (manager (frame-manager *application-frame*)))
214 (if (eq type :command)
215 (make-pane-1 manager frame 'menu-button-leaf-pane
216 :label name
217 :client client
218 :value-changed-callback
219 #'(lambda (gadget val)
220 (declare (ignore gadget val))
221 (funcall value)))
222 (make-pane-1 manager frame 'menu-button-submenu-pane
223 :label name
224 :client client
225 :frame-manager manager
226 :command-table value
227 :bottomp bottomp))))
228
229 ;;
230 ;; MENU-BAR
231 ;;
232
233 (defclass menu-bar (hrack-pane
234 permanent-medium-sheet-output-mixin)
235 ((items :initform nil)
236 (armed :initform nil)))
237
238 (defmethod initialize-instance :after ((pane menu-bar)
239 &rest args
240 &key
241 &allow-other-keys)
242 (declare (ignore args))
243 (setf (slot-value pane 'items) (copy-list (sheet-children pane)))
244 (loop for child in (sheet-children pane)
245 do (setf (gadget-client child) pane)))
246
247 (defmethod menu-children ((menu-bar menu-bar))
248 (slot-value menu-bar 'items))
249
250 (defmethod menu-root ((object menu-bar))
251 object)
252
253 (defmethod destroy-substructure ((object menu-bar))
254 (loop for child in (menu-children object)
255 do (progn (destroy-substructure child)
256 (dispatch-repaint child (sheet-region child))))
257 (setf (slot-value object 'armed) nil))
258
259 (defmethod arm-menu ((object menu-bar))
260 (setf (slot-value object 'armed) t))
261
262 (defmethod disarm-menu ((object menu-bar))
263 (setf (slot-value object 'armed) nil))
264
265 (defun make-menu-bar (command-table
266 &key width height
267 max-width max-height
268 min-width min-height)
269 (with-slots (menu) (find-command-table command-table)
270 (progn ;;raising () ;; XXX temporary medicine as RAISED is borken --GB
271 (make-pane
272 'menu-bar
273 :background +grey80+
274 :width width :height height
275 :max-width max-width :max-height max-height
276 :min-width min-width :min-height min-height
277 :contents
278 (loop for item in menu
279 collect
280 (make-menu-button-from-menu-item item nil :bottomp t))))))

  ViewVC Help
Powered by ViewVC 1.1.5