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

Contents of /mcclim/menu.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Mon Jun 18 12:46:57 2001 UTC (12 years, 10 months ago) by boninfan
Branch: MAIN
Changes since 1.7: +4 -6 lines
Fixed an drawing dimension error for menu-draw-unhighlighted and menu-draw-highlighted
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 (defun menu-draw-highlighted (gadget)
43 (with-double-buffering (gadget)
44 (with-slots (label) gadget
45 (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region gadget)
46 (let ((w (- x2 x1))
47 (h (- y2 y1)))
48 (draw-rectangle* gadget -1 -1 x2 y2
49 :ink (gadget-highlighted-color gadget)
50 :filled t)
51 (draw-edges-lines* gadget 0 0 (1- w) (1- h))
52 (draw-text* gadget label (round w 2) (round h 2)
53 :align-x :center :align-y :center))))))
54
55 (defun menu-draw-unhighlighted (gadget)
56 (with-double-buffering (gadget)
57 (with-slots (label) gadget
58 (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region gadget)
59 (let ((w (- x2 x1))
60 (h (- y2 y1)))
61 (draw-rectangle* gadget -1 -1 w h
62 :ink (gadget-normal-color gadget)
63 :filled t)
64 (draw-text* gadget label (round w 2) (round h 2)
65 :align-x :center :align-y :center))))))
66
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 window-repaint-event))
75 (dispatch-repaint pane (sheet-region 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 (with-slots (armed) button
93 (setf armed nil)))
94
95 (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-button-release-event))
96 (with-slots (armed label client id) pane
97 (when armed
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 (defmethod repaint-sheet ((pane menu-button-leaf-pane) region)
109 (declare (ignore region))
110 (with-slots (armed) pane
111 (if armed
112 (menu-draw-highlighted pane)
113 (menu-draw-unhighlighted pane))))
114
115 ;;; menu-button-submenu-pane
116
117 (defclass menu-button-submenu-pane (menu-button-pane)
118 ((frame-manager :initform nil :initarg :frame-manager)
119 (submenu-frame :initform nil)
120 (bottomp :initform nil :initarg :bottomp)
121 (command-table :initform nil :initarg :command-table)))
122
123 (defmethod menu-children ((submenu menu-button-submenu-pane))
124 (with-slots (submenu-frame) submenu
125 (if submenu-frame
126 (sheet-children (first (sheet-children (frame-pane submenu-frame))))
127 '())))
128
129 (defun create-substructure (sub-menu client)
130 (let* ((frame *application-frame*)
131 (manager (frame-manager frame))
132 (items (mapcar #'(lambda (item)
133 (make-menu-button-from-menu-item item client))
134 (slot-value (find-command-table (slot-value sub-menu 'command-table)) 'menu)))
135 (rack (make-pane-1 manager frame 'vrack-pane
136 :background +grey80+ :contents items))
137 (raised (make-pane-1 manager frame 'raised-pane :contents (list rack))))
138 (with-slots (bottomp) sub-menu
139 (multiple-value-bind (xmin ymin xmax ymax)
140 (bounding-rectangle* (sheet-region sub-menu))
141 (multiple-value-bind (x y)
142 (transform-position (sheet-delta-transformation sub-menu nil)
143 (if bottomp xmin xmax)
144 (if bottomp ymax ymin))
145 (with-slots (frame-manager submenu-frame) sub-menu
146 (setf frame-manager manager
147 submenu-frame (make-menu-frame raised :left x :top y))
148 (adopt-frame manager submenu-frame)))))))
149
150 (defmethod destroy-substructure ((sub-menu menu-button-submenu-pane))
151 (with-slots (frame-manager submenu-frame) sub-menu
152 (when submenu-frame
153 (mapc #'destroy-substructure (menu-children sub-menu))
154 (disown-frame frame-manager submenu-frame)
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 (defmethod repaint-sheet ((pane menu-button-submenu-pane) region)
172 (declare (ignore region))
173 (with-slots (submenu-frame) pane
174 (if submenu-frame
175 (menu-draw-highlighted pane)
176 (menu-draw-unhighlighted pane))))
177
178 ;; Menu creation from command tables
179
180 ;; for now, accept only types :command and :menu, and only
181 ;; command names as values of :command
182 (defun make-menu-button-from-menu-item (item client &key (bottomp nil))
183 (let ((name (command-menu-item-name item))
184 (type (command-menu-item-type item))
185 (value (command-menu-item-value item))
186 (frame *application-frame*)
187 (manager (frame-manager *application-frame*)))
188 (if (eq type :command)
189 (make-pane-1 manager frame 'menu-button-leaf-pane
190 :label name
191 :client client
192 :value-changed-callback
193 #'(lambda (gadget val)
194 (declare (ignore gadget val))
195 (funcall value)))
196 (make-pane-1 manager frame 'menu-button-submenu-pane
197 :label name
198 :client client
199 :frame-manager manager
200 :command-table value
201 :bottomp bottomp))))
202
203 ;;
204 ;; MENU-BAR
205 ;;
206
207 (defclass menu-bar (hrack-pane)
208 ((items :initform nil)
209 (armed :initform nil)))
210
211 (defmethod initialize-instance :after ((pane menu-bar)
212 &rest args
213 &key
214 &allow-other-keys)
215 (declare (ignore args))
216 (setf (slot-value pane 'items) (copy-list (sheet-children pane)))
217 (loop for child in (sheet-children pane)
218 do (setf (gadget-client child) pane)))
219
220 (defmethod menu-children ((menu-bar menu-bar))
221 (slot-value menu-bar 'items))
222
223 (defmethod menu-root ((object menu-bar))
224 object)
225
226 (defmethod destroy-substructure ((object menu-bar))
227 (loop for child in (menu-children object)
228 do (progn (destroy-substructure child)
229 (dispatch-repaint child (sheet-region child))))
230 (setf (slot-value object 'armed) nil))
231
232 (defmethod arm-menu ((object menu-bar))
233 (setf (slot-value object 'armed) t))
234
235 (defmethod disarm-menu ((object menu-bar))
236 (setf (slot-value object 'armed) nil))
237
238 (defun make-menu-bar (command-table
239 &key width height
240 max-width max-height
241 min-width min-height)
242 (with-slots (menu) (find-command-table command-table)
243 (raising ()
244 (make-pane
245 'menu-bar
246 :background +grey80+
247 :width width :height height
248 :max-width max-width :max-height max-height
249 :min-width min-width :min-height min-height
250 :contents
251 (loop for item in menu
252 collect
253 (make-menu-button-from-menu-item item nil :bottomp t))))))

  ViewVC Help
Powered by ViewVC 1.1.5