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

Contents of /mcclim/menu.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (hide annotations)
Mon Feb 11 21:35:57 2002 UTC (12 years, 2 months ago) by gilbert
Branch: MAIN
Changes since 1.9: +2 -1 lines
mixed PERMANENT-MEDIUM-SHEET-OUTPUT-MIXIN into MENU-BAR
1 cvs 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 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 boninfan 1.9 #|
43 cvs 1.1 (defun menu-draw-highlighted (gadget)
44 boninfan 1.9 (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 boninfan 1.7 (with-slots (label) gadget
60 boninfan 1.8 (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region gadget)
61 boninfan 1.7 (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 boninfan 1.9 (draw-edges-lines* gadget 0 0 (1- w) (1- h)) ;(- w 2) (- h 2))
67 boninfan 1.7 (draw-text* gadget label (round w 2) (round h 2)
68     :align-x :center :align-y :center))))))
69 cvs 1.1
70 boninfan 1.9 #|
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 cvs 1.1 (defun menu-draw-unhighlighted (gadget)
85 boninfan 1.9 (with-special-choices (gadget)
86 boninfan 1.7 (with-slots (label) gadget
87 boninfan 1.8 (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region gadget)
88 boninfan 1.7 (let ((w (- x2 x1))
89     (h (- y2 y1)))
90 boninfan 1.9 (draw-rectangle* gadget -1 -1 w h ;-1 -1 x2 y2
91 boninfan 1.7 :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 cvs 1.1
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 window-repaint-event))
104     (dispatch-repaint pane (sheet-region pane)))
105    
106     (defmethod handle-event ((pane menu-button-pane) (event pointer-ungrab-event))
107     (destroy-substructure (menu-root pane)))
108    
109     ;;; menu-button-leaf-pane
110    
111     (defclass menu-button-leaf-pane (menu-button-pane)
112     ((command :initform nil :initarg :command)))
113    
114     (defmethod arm-branch ((button menu-button-leaf-pane))
115 cvs 1.4 (with-slots (client) button
116     (arm-menu client)
117     (mapc #'destroy-substructure (menu-children client))
118     (arm-menu button)))
119 cvs 1.1
120     (defmethod destroy-substructure ((button menu-button-leaf-pane))
121 cvs 1.4 (with-slots (armed) button
122 cvs 1.1 (setf armed nil)))
123    
124     (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-button-release-event))
125     (with-slots (armed label client id) pane
126     (when armed
127     (value-changed-callback pane client id label)
128     (disarm-menu pane)
129     (destroy-substructure (menu-root pane)))))
130    
131     (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-exit-event))
132 cvs 1.4 (disarm-menu pane))
133 cvs 1.1
134 cvs 1.3 (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-ungrab-event))
135     (destroy-substructure (menu-root pane)))
136    
137 cvs 1.1 (defmethod repaint-sheet ((pane menu-button-leaf-pane) region)
138     (declare (ignore region))
139     (with-slots (armed) pane
140     (if armed
141     (menu-draw-highlighted pane)
142     (menu-draw-unhighlighted pane))))
143    
144     ;;; menu-button-submenu-pane
145    
146     (defclass menu-button-submenu-pane (menu-button-pane)
147     ((frame-manager :initform nil :initarg :frame-manager)
148     (submenu-frame :initform nil)
149     (bottomp :initform nil :initarg :bottomp)
150     (command-table :initform nil :initarg :command-table)))
151    
152     (defmethod menu-children ((submenu menu-button-submenu-pane))
153     (with-slots (submenu-frame) submenu
154     (if submenu-frame
155 cvs 1.5 (sheet-children (first (sheet-children (frame-pane submenu-frame))))
156 cvs 1.1 '())))
157    
158     (defun create-substructure (sub-menu client)
159     (let* ((frame *application-frame*)
160     (manager (frame-manager frame))
161     (items (mapcar #'(lambda (item)
162     (make-menu-button-from-menu-item item client))
163     (slot-value (find-command-table (slot-value sub-menu 'command-table)) 'menu)))
164 hatchond 1.6 (rack (make-pane-1 manager frame 'vrack-pane
165     :background +grey80+ :contents items))
166 cvs 1.5 (raised (make-pane-1 manager frame 'raised-pane :contents (list rack))))
167 cvs 1.1 (with-slots (bottomp) sub-menu
168     (multiple-value-bind (xmin ymin xmax ymax)
169     (bounding-rectangle* (sheet-region sub-menu))
170     (multiple-value-bind (x y)
171     (transform-position (sheet-delta-transformation sub-menu nil)
172     (if bottomp xmin xmax)
173     (if bottomp ymax ymin))
174     (with-slots (frame-manager submenu-frame) sub-menu
175     (setf frame-manager manager
176 cvs 1.5 submenu-frame (make-menu-frame raised :left x :top y))
177 cvs 1.1 (adopt-frame manager submenu-frame)))))))
178    
179     (defmethod destroy-substructure ((sub-menu menu-button-submenu-pane))
180     (with-slots (frame-manager submenu-frame) sub-menu
181     (when submenu-frame
182     (mapc #'destroy-substructure (menu-children sub-menu))
183     (disown-frame frame-manager submenu-frame)
184     (setf submenu-frame nil))))
185    
186     (defmethod arm-branch ((sub-menu menu-button-submenu-pane))
187 cvs 1.4 (with-slots (client frame-manager submenu-frame) sub-menu
188     (arm-menu client)
189     (if submenu-frame
190     (progn (mapc #'destroy-substructure (menu-children sub-menu))
191     (mapc #'disarm-menu (menu-children sub-menu)))
192     (progn
193     (mapc #'destroy-substructure (menu-children client))
194     (create-substructure sub-menu sub-menu)))
195     (arm-menu sub-menu)))
196 cvs 1.1
197     (defmethod handle-event ((pane menu-button-submenu-pane) (event pointer-button-release-event))
198     (destroy-substructure (menu-root pane)))
199    
200     (defmethod repaint-sheet ((pane menu-button-submenu-pane) region)
201     (declare (ignore region))
202     (with-slots (submenu-frame) pane
203     (if submenu-frame
204     (menu-draw-highlighted pane)
205     (menu-draw-unhighlighted pane))))
206    
207     ;; Menu creation from command tables
208    
209     ;; for now, accept only types :command and :menu, and only
210     ;; command names as values of :command
211     (defun make-menu-button-from-menu-item (item client &key (bottomp nil))
212     (let ((name (command-menu-item-name item))
213     (type (command-menu-item-type item))
214     (value (command-menu-item-value item))
215     (frame *application-frame*)
216     (manager (frame-manager *application-frame*)))
217     (if (eq type :command)
218     (make-pane-1 manager frame 'menu-button-leaf-pane
219     :label name
220     :client client
221     :value-changed-callback
222     #'(lambda (gadget val)
223     (declare (ignore gadget val))
224     (funcall value)))
225     (make-pane-1 manager frame 'menu-button-submenu-pane
226     :label name
227     :client client
228     :frame-manager manager
229     :command-table value
230     :bottomp bottomp))))
231    
232     ;;
233     ;; MENU-BAR
234     ;;
235    
236 gilbert 1.10 (defclass menu-bar (hrack-pane
237     permanent-medium-sheet-output-mixin)
238 cvs 1.1 ((items :initform nil)
239     (armed :initform nil)))
240    
241     (defmethod initialize-instance :after ((pane menu-bar)
242     &rest args
243 cvs 1.2 &key
244 cvs 1.1 &allow-other-keys)
245     (declare (ignore args))
246     (setf (slot-value pane 'items) (copy-list (sheet-children pane)))
247     (loop for child in (sheet-children pane)
248     do (setf (gadget-client child) pane)))
249    
250     (defmethod menu-children ((menu-bar menu-bar))
251     (slot-value menu-bar 'items))
252    
253     (defmethod menu-root ((object menu-bar))
254     object)
255    
256     (defmethod destroy-substructure ((object menu-bar))
257 cvs 1.5 (loop for child in (menu-children object)
258 cvs 1.1 do (progn (destroy-substructure child)
259     (dispatch-repaint child (sheet-region child))))
260     (setf (slot-value object 'armed) nil))
261    
262     (defmethod arm-menu ((object menu-bar))
263     (setf (slot-value object 'armed) t))
264    
265     (defmethod disarm-menu ((object menu-bar))
266     (setf (slot-value object 'armed) nil))
267    
268 hatchond 1.6 (defun make-menu-bar (command-table
269     &key width height
270     max-width max-height
271     min-width min-height)
272 cvs 1.1 (with-slots (menu) (find-command-table command-table)
273 hatchond 1.6 (raising ()
274     (make-pane
275     'menu-bar
276     :background +grey80+
277     :width width :height height
278     :max-width max-width :max-height max-height
279     :min-width min-width :min-height min-height
280     :contents
281     (loop for item in menu
282     collect
283     (make-menu-button-from-menu-item item nil :bottomp t))))))

  ViewVC Help
Powered by ViewVC 1.1.5