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

Contents of /mcclim/menu.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.31 - (hide annotations)
Thu May 27 08:46:41 2004 UTC (9 years, 10 months ago) by moore
Branch: MAIN
Changes since 1.30: +1 -1 lines
Fix problem with command names in menu items
1 moore 1.29 1;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2 cvs 1.1
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 mikemac 1.25 (in-package :clim-internals)
22 cvs 1.1
23 moore 1.28 (defmethod stream-force-output ((pane menu-button-pane))
24     (with-sheet-medium (medium pane)
25     (medium-force-output medium)))
26    
27 cvs 1.1 (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 gilbert 1.22 (arm-gadget button t))
36 cvs 1.1 (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 gilbert 1.22 (disarm-gadget button)
42 moore 1.28 (dispatch-repaint button (sheet-region button))
43     (stream-force-output button))))
44 cvs 1.1
45 boninfan 1.9 (defun menu-draw-highlighted (gadget)
46 gilbert 1.14 (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 gilbert 1.27 (draw-edges-lines* gadget +white+ 0 0 +black+ (1- w) (1- h))
56 gilbert 1.16 (draw-label* gadget x1 y1 x2 y2)))))))
57 boninfan 1.9
58 cvs 1.1 (defun menu-draw-unhighlighted (gadget)
59 gilbert 1.14 (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 gilbert 1.22 :ink +background-ink+
67 gilbert 1.14 :filled t)
68 gilbert 1.16 (draw-label* gadget x1 y1 x2 y2)))))))
69 cvs 1.1
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 cvs 1.4 (with-slots (client) button
87     (arm-menu client)
88     (mapc #'destroy-substructure (menu-children client))
89     (arm-menu button)))
90 cvs 1.1
91     (defmethod destroy-substructure ((button menu-button-leaf-pane))
92 gilbert 1.22 (disarm-gadget button))
93 cvs 1.1
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 moore 1.28 (unwind-protect
98     (value-changed-callback pane client id label)
99     (disarm-menu pane)
100     (destroy-substructure (menu-root pane))))))
101 cvs 1.1
102     (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-exit-event))
103 cvs 1.4 (disarm-menu pane))
104 cvs 1.1
105 cvs 1.3 (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-ungrab-event))
106     (destroy-substructure (menu-root pane)))
107    
108 cvs 1.1 ;;; menu-button-submenu-pane
109    
110     (defclass menu-button-submenu-pane (menu-button-pane)
111 gilbert 1.22 ((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 cvs 1.1
116     (defmethod menu-children ((submenu menu-button-submenu-pane))
117     (with-slots (submenu-frame) submenu
118     (if submenu-frame
119 moore 1.29 (sheet-children (first (sheet-children (frame-panes submenu-frame))))
120 cvs 1.1 '())))
121    
122     (defun create-substructure (sub-menu client)
123     (let* ((frame *application-frame*)
124 gilbert 1.22 (manager (frame-manager frame))
125 moore 1.26 (command-table-name (slot-value sub-menu 'command-table))
126 gilbert 1.22 (items (mapcar #'(lambda (item)
127 moore 1.26 (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 gilbert 1.22 (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 moore 1.28 (adopt-frame manager submenu-frame)
145     (with-sheet-medium (medium raised)
146     (medium-force-output medium))))))))
147 cvs 1.1
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 gilbert 1.22 (disarm-gadget sub-menu)
154     (dispatch-repaint sub-menu +everywhere+)
155     (setf submenu-frame nil) )))
156 cvs 1.1
157     (defmethod arm-branch ((sub-menu menu-button-submenu-pane))
158 gilbert 1.22 (with-slots (client frame-manager submenu-frame) sub-menu
159 cvs 1.4 (arm-menu client)
160 gilbert 1.22 (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 cvs 1.4 (arm-menu sub-menu)))
167 gilbert 1.22
168 cvs 1.1 (defmethod handle-event ((pane menu-button-submenu-pane) (event pointer-button-release-event))
169 gilbert 1.22 (destroy-substructure (menu-root pane)))
170 cvs 1.1
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 moore 1.30
176     (defparameter *disabled-text-style* (make-text-style :fix :italic :normal))
177    
178 moore 1.26 (defun make-menu-button-from-menu-item (item client
179 moore 1.28 &key (bottomp nil)
180     command-table
181     (presentation-type 'menu-item))
182     (declare (ignore command-table))
183 cvs 1.1 (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 moore 1.31 (if (command-enabled (if (consp value) (car value) value) frame)
190 moore 1.30 (make-pane-1 manager frame 'menu-button-leaf-pane
191     :label name
192     :client client
193     :value-changed-callback
194     #'(lambda (gadget val)
195     (declare (ignore gadget val))
196     (throw-object-ptype item presentation-type)))
197     (make-pane-1 manager frame 'menu-button-leaf-pane
198     :label name
199     :text-style *disabled-text-style*
200     :client client
201     :value-changed-callback
202     #'(lambda (gadget val)
203     (declare (ignore gadget val))
204     nil)))
205 cvs 1.1 (make-pane-1 manager frame 'menu-button-submenu-pane
206     :label name
207     :client client
208     :frame-manager manager
209     :command-table value
210     :bottomp bottomp))))
211    
212     ;;
213     ;; MENU-BAR
214     ;;
215 brian 1.13 (defclass menu-button-hrack-pane (hrack-pane) ())
216 cvs 1.1
217 brian 1.13 (defclass menu-bar (menu-button-hrack-pane
218 gilbert 1.10 permanent-medium-sheet-output-mixin)
219 cvs 1.1 ((items :initform nil)
220     (armed :initform nil)))
221    
222     (defmethod initialize-instance :after ((pane menu-bar)
223     &rest args
224 cvs 1.2 &key
225 cvs 1.1 &allow-other-keys)
226     (declare (ignore args))
227     (setf (slot-value pane 'items) (copy-list (sheet-children pane)))
228 gilbert 1.23 (loop for child in (menu-children pane)
229 cvs 1.1 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 cvs 1.5 (loop for child in (menu-children object)
239 cvs 1.1 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 hatchond 1.6 (defun make-menu-bar (command-table
250     &key width height
251 gilbert 1.15 (max-width +fill+) max-height
252 hatchond 1.6 min-width min-height)
253 cvs 1.1 (with-slots (menu) (find-command-table command-table)
254 gilbert 1.22 (raising ()
255 brian 1.13 (make-pane-1 *pane-realizer* *application-frame*
256 gilbert 1.23 'menu-bar
257     :background *3d-normal-color*
258     :width width :height height
259     :max-width max-width :max-height max-height
260     :min-width min-width :min-height min-height
261     :contents
262     (append
263     (loop for item in menu
264     collect
265 moore 1.26 (make-menu-button-from-menu-item
266     item nil
267     :bottomp t
268     :command-table command-table))
269 gilbert 1.23 (list +fill+))))))

  ViewVC Help
Powered by ViewVC 1.1.5