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

Contents of /mcclim/menu.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.23 - (show annotations)
Sun Nov 10 14:44:04 2002 UTC (11 years, 5 months ago) by gilbert
Branch: MAIN
Changes since 1.22: +12 -10 lines
Menu bars now no longer spread their children out but pack them left
as every other menu bar does.
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 (arm-gadget button t))
32 (dispatch-repaint button (sheet-region button))))
33
34 (defmethod disarm-menu ((button menu-button-pane))
35 (with-slots (client armed id) button
36 (when armed
37 (disarm-gadget button)
38 (dispatch-repaint button (sheet-region button)))))
39
40 (defun menu-draw-highlighted (gadget)
41 (when (sheet-mirror gadget) ;XXX only do this when the gadget is realized.
42 (with-special-choices (gadget)
43 (with-slots (label) gadget
44 (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region gadget)
45 (let ((w (- x2 x1))
46 (h (- y2 y1)))
47 (draw-rectangle* gadget -1 -1 x2 y2
48 :ink (gadget-highlighted-color gadget)
49 :filled t)
50 (draw-edges-lines* gadget 0 0 (1- w) (1- h)) ;(- w 2) (- h 2)
51 (draw-label* gadget x1 y1 x2 y2)))))))
52
53 (defun menu-draw-unhighlighted (gadget)
54 (when (sheet-mirror gadget) ;XXX only do this when the gadget is realized.
55 (with-special-choices (gadget)
56 (with-slots (label) gadget
57 (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region gadget)
58 (let ((w (- x2 x1))
59 (h (- y2 y1)))
60 (draw-rectangle* gadget -1 -1 w h ;-1 -1 x2 y2
61 :ink +background-ink+
62 :filled t)
63 (draw-label* gadget x1 y1 x2 y2)))))))
64
65 (defmethod handle-event ((pane menu-button-pane) (event pointer-enter-event))
66 (when (slot-value (slot-value pane 'client) 'armed)
67 (arm-branch pane)))
68
69 (defmethod handle-event ((pane menu-button-pane) (event pointer-button-press-event))
70 (arm-branch pane))
71
72 (defmethod handle-event ((pane menu-button-pane) (event pointer-ungrab-event))
73 (destroy-substructure (menu-root pane)))
74
75 ;;; menu-button-leaf-pane
76
77 (defclass menu-button-leaf-pane (menu-button-pane)
78 ((command :initform nil :initarg :command)))
79
80 (defmethod arm-branch ((button menu-button-leaf-pane))
81 (with-slots (client) button
82 (arm-menu client)
83 (mapc #'destroy-substructure (menu-children client))
84 (arm-menu button)))
85
86 (defmethod destroy-substructure ((button menu-button-leaf-pane))
87 (disarm-gadget button))
88
89 (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-button-release-event))
90 (with-slots (armed label client id) pane
91 (when armed
92 (value-changed-callback pane client id label)
93 (disarm-menu pane)
94 (destroy-substructure (menu-root pane)))))
95
96 (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-exit-event))
97 (disarm-menu pane))
98
99 (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-ungrab-event))
100 (destroy-substructure (menu-root pane)))
101
102 ;;; menu-button-submenu-pane
103
104 (defclass menu-button-submenu-pane (menu-button-pane)
105 ((frame-manager :initform nil :initarg :frame-manager)
106 (submenu-frame :initform nil)
107 (bottomp :initform nil :initarg :bottomp)
108 (command-table :initform nil :initarg :command-table)))
109
110 (defmethod menu-children ((submenu menu-button-submenu-pane))
111 (with-slots (submenu-frame) submenu
112 (if submenu-frame
113 (sheet-children (first (sheet-children (frame-pane submenu-frame))))
114 '())))
115
116 (defun create-substructure (sub-menu client)
117 (let* ((frame *application-frame*)
118 (manager (frame-manager frame))
119 (items (mapcar #'(lambda (item)
120 (make-menu-button-from-menu-item item client))
121 (slot-value (find-command-table (slot-value sub-menu 'command-table)) 'menu)))
122 (rack (make-pane-1 manager frame 'vrack-pane
123 :background *3d-normal-color* :contents items))
124 (raised (make-pane-1 manager frame 'raised-pane :border-width 2 :background *3d-normal-color* :contents (list rack))))
125 (with-slots (bottomp) sub-menu
126 (multiple-value-bind (xmin ymin xmax ymax)
127 (bounding-rectangle* (sheet-region sub-menu))
128 (multiple-value-bind (x y)
129 (transform-position (sheet-delta-transformation sub-menu nil)
130 (if bottomp xmin xmax)
131 (if bottomp ymax ymin))
132 (with-slots (frame-manager submenu-frame) sub-menu
133 (setf frame-manager manager
134 submenu-frame (make-menu-frame raised :left x :top y))
135 (adopt-frame manager submenu-frame)))))))
136
137 (defmethod destroy-substructure ((sub-menu menu-button-submenu-pane))
138 (with-slots (frame-manager submenu-frame) sub-menu
139 (when submenu-frame
140 (mapc #'destroy-substructure (menu-children sub-menu))
141 (disown-frame frame-manager submenu-frame)
142 (disarm-gadget sub-menu)
143 (dispatch-repaint sub-menu +everywhere+)
144 (setf submenu-frame nil) )))
145
146 (defmethod arm-branch ((sub-menu menu-button-submenu-pane))
147 (with-slots (client frame-manager submenu-frame) sub-menu
148 (arm-menu client)
149 (if submenu-frame
150 (progn (mapc #'destroy-substructure (menu-children sub-menu))
151 (mapc #'disarm-menu (menu-children sub-menu)))
152 (progn
153 (mapc #'destroy-substructure (menu-children client))
154 (create-substructure sub-menu sub-menu)))
155 (arm-menu sub-menu)))
156
157 (defmethod handle-event ((pane menu-button-submenu-pane) (event pointer-button-release-event))
158 (destroy-substructure (menu-root pane)))
159
160 ;; Menu creation from command tables
161
162 ;; for now, accept only types :command and :menu, and only
163 ;; command names as values of :command
164 (defun make-menu-button-from-menu-item (item client &key (bottomp nil))
165 (let ((name (command-menu-item-name item))
166 (type (command-menu-item-type item))
167 (value (command-menu-item-value item))
168 (frame *application-frame*)
169 (manager (frame-manager *application-frame*)))
170 (if (eq type :command)
171 (make-pane-1 manager frame 'menu-button-leaf-pane
172 :label name
173 :client client
174 :value-changed-callback
175 #'(lambda (gadget val)
176 (declare (ignore gadget val))
177 (funcall value)))
178 (make-pane-1 manager frame 'menu-button-submenu-pane
179 :label name
180 :client client
181 :frame-manager manager
182 :command-table value
183 :bottomp bottomp))))
184
185 ;;
186 ;; MENU-BAR
187 ;;
188 (defclass menu-button-hrack-pane (hrack-pane) ())
189
190 (defclass menu-bar (menu-button-hrack-pane
191 permanent-medium-sheet-output-mixin)
192 ((items :initform nil)
193 (armed :initform nil)))
194
195 (defmethod initialize-instance :after ((pane menu-bar)
196 &rest args
197 &key
198 &allow-other-keys)
199 (declare (ignore args))
200 (setf (slot-value pane 'items) (copy-list (sheet-children pane)))
201 (loop for child in (menu-children pane)
202 do (setf (gadget-client child) pane)))
203
204 (defmethod menu-children ((menu-bar menu-bar))
205 (slot-value menu-bar 'items))
206
207 (defmethod menu-root ((object menu-bar))
208 object)
209
210 (defmethod destroy-substructure ((object menu-bar))
211 (loop for child in (menu-children object)
212 do (progn (destroy-substructure child)
213 (dispatch-repaint child (sheet-region child))))
214 (setf (slot-value object 'armed) nil))
215
216 (defmethod arm-menu ((object menu-bar))
217 (setf (slot-value object 'armed) t))
218
219 (defmethod disarm-menu ((object menu-bar))
220 (setf (slot-value object 'armed) nil))
221
222 (defun make-menu-bar (command-table
223 &key width height
224 (max-width +fill+) max-height
225 min-width min-height)
226 (with-slots (menu) (find-command-table command-table)
227 (raising ()
228 (make-pane-1 *pane-realizer* *application-frame*
229 'menu-bar
230 :background *3d-normal-color*
231 :width width :height height
232 :max-width max-width :max-height max-height
233 :min-width min-width :min-height min-height
234 :contents
235 (append
236 (loop for item in menu
237 collect
238 (make-menu-button-from-menu-item item nil :bottomp t))
239 (list +fill+))))))

  ViewVC Help
Powered by ViewVC 1.1.5