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

Contents of /mcclim/menu.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.29 - (show annotations)
Sat Feb 7 14:05:50 2004 UTC (10 years, 2 months ago) by moore
Branch: MAIN
Changes since 1.28: +2 -2 lines
Cleaned up the frame layout code. It's now possible to change layouts
on the fly. Got rid of frame-pane and replaced it with a proper
definition of frame-panes that conforms to the Spec. All the frame
pane and layout functions in the spec should be implemented now.

In presentation-replace-input, checked in a fix that I thought was
already in.
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 (defun create-substructure (sub-menu client)
123 (let* ((frame *application-frame*)
124 (manager (frame-manager frame))
125 (command-table-name (slot-value sub-menu 'command-table))
126 (items (mapcar #'(lambda (item)
127 (make-menu-button-from-menu-item
128 item client :command-table command-table-name))
129 (slot-value (find-command-table command-table-name)
130 'menu)))
131 (rack (make-pane-1 manager frame 'vrack-pane
132 :background *3d-normal-color* :contents items))
133 (raised (make-pane-1 manager frame 'raised-pane :border-width 2 :background *3d-normal-color* :contents (list rack))))
134 (with-slots (bottomp) sub-menu
135 (multiple-value-bind (xmin ymin xmax ymax)
136 (bounding-rectangle* (sheet-region sub-menu))
137 (multiple-value-bind (x y)
138 (transform-position (sheet-delta-transformation sub-menu nil)
139 (if bottomp xmin xmax)
140 (if bottomp ymax ymin))
141 (with-slots (frame-manager submenu-frame) sub-menu
142 (setf frame-manager manager
143 submenu-frame (make-menu-frame raised :left x :top y))
144 (adopt-frame manager submenu-frame)
145 (with-sheet-medium (medium raised)
146 (medium-force-output medium))))))))
147
148 (defmethod destroy-substructure ((sub-menu menu-button-submenu-pane))
149 (with-slots (frame-manager submenu-frame) sub-menu
150 (when submenu-frame
151 (mapc #'destroy-substructure (menu-children sub-menu))
152 (disown-frame frame-manager submenu-frame)
153 (disarm-gadget sub-menu)
154 (dispatch-repaint sub-menu +everywhere+)
155 (setf submenu-frame nil) )))
156
157 (defmethod arm-branch ((sub-menu menu-button-submenu-pane))
158 (with-slots (client frame-manager submenu-frame) sub-menu
159 (arm-menu client)
160 (if submenu-frame
161 (progn (mapc #'destroy-substructure (menu-children sub-menu))
162 (mapc #'disarm-menu (menu-children sub-menu)))
163 (progn
164 (mapc #'destroy-substructure (menu-children client))
165 (create-substructure sub-menu sub-menu)))
166 (arm-menu sub-menu)))
167
168 (defmethod handle-event ((pane menu-button-submenu-pane) (event pointer-button-release-event))
169 (destroy-substructure (menu-root pane)))
170
171 ;; Menu creation from command tables
172
173 ;; for now, accept only types :command and :menu, and only
174 ;; command names as values of :command
175 (defun make-menu-button-from-menu-item (item client
176 &key (bottomp nil)
177 command-table
178 (presentation-type 'menu-item))
179 (declare (ignore command-table))
180 (let ((name (command-menu-item-name item))
181 (type (command-menu-item-type item))
182 (value (command-menu-item-value item))
183 (frame *application-frame*)
184 (manager (frame-manager *application-frame*)))
185 (if (eq type :command)
186 (make-pane-1 manager frame 'menu-button-leaf-pane
187 :label name
188 :client client
189 :value-changed-callback
190 #'(lambda (gadget val)
191 (declare (ignore gadget val))
192 (throw-object-ptype item presentation-type)))
193 (make-pane-1 manager frame 'menu-button-submenu-pane
194 :label name
195 :client client
196 :frame-manager manager
197 :command-table value
198 :bottomp bottomp))))
199
200 ;;
201 ;; MENU-BAR
202 ;;
203 (defclass menu-button-hrack-pane (hrack-pane) ())
204
205 (defclass menu-bar (menu-button-hrack-pane
206 permanent-medium-sheet-output-mixin)
207 ((items :initform nil)
208 (armed :initform nil)))
209
210 (defmethod initialize-instance :after ((pane menu-bar)
211 &rest args
212 &key
213 &allow-other-keys)
214 (declare (ignore args))
215 (setf (slot-value pane 'items) (copy-list (sheet-children pane)))
216 (loop for child in (menu-children pane)
217 do (setf (gadget-client child) pane)))
218
219 (defmethod menu-children ((menu-bar menu-bar))
220 (slot-value menu-bar 'items))
221
222 (defmethod menu-root ((object menu-bar))
223 object)
224
225 (defmethod destroy-substructure ((object menu-bar))
226 (loop for child in (menu-children object)
227 do (progn (destroy-substructure child)
228 (dispatch-repaint child (sheet-region child))))
229 (setf (slot-value object 'armed) nil))
230
231 (defmethod arm-menu ((object menu-bar))
232 (setf (slot-value object 'armed) t))
233
234 (defmethod disarm-menu ((object menu-bar))
235 (setf (slot-value object 'armed) nil))
236
237 (defun make-menu-bar (command-table
238 &key width height
239 (max-width +fill+) max-height
240 min-width min-height)
241 (with-slots (menu) (find-command-table command-table)
242 (raising ()
243 (make-pane-1 *pane-realizer* *application-frame*
244 'menu-bar
245 :background *3d-normal-color*
246 :width width :height height
247 :max-width max-width :max-height max-height
248 :min-width min-width :min-height min-height
249 :contents
250 (append
251 (loop for item in menu
252 collect
253 (make-menu-button-from-menu-item
254 item nil
255 :bottomp t
256 :command-table command-table))
257 (list +fill+))))))

  ViewVC Help
Powered by ViewVC 1.1.5