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

Contents of /mcclim/menu.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (hide annotations)
Mon Mar 19 19:02:37 2001 UTC (13 years, 1 month ago) by hatchond
Branch: MAIN
Changes since 1.5: +28 -14 lines
Idem for menu, but I add some keyword arguments at make-menu-bar. You can now specify your owne width height etc.
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     (defun menu-draw-highlighted (gadget)
43     (with-slots (label) gadget
44 hatchond 1.6 (multiple-value-bind (x1 y1 x2 y2)
45     (bounding-rectangle* (sheet-region gadget))
46 cvs 1.1 (let ((w (- x2 x1))
47     (h (- y2 y1)))
48 hatchond 1.6 (draw-rectangle* gadget -1 -1 x2 y2
49     :ink (gadget-highlighted-color gadget)
50     :filled t)
51     (draw-edges-lines* gadget 1 1 (- w 2) (- h 2))
52 cvs 1.1 (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-slots (label) gadget
57 hatchond 1.6 (multiple-value-bind (x1 y1 x2 y2)
58     (bounding-rectangle* (sheet-region gadget))
59 cvs 1.1 (let ((w (- x2 x1))
60     (h (- y2 y1)))
61 hatchond 1.6 (draw-rectangle* gadget -1 -1 x2 y2
62     :ink (gadget-normal-color gadget)
63     :filled t)
64 cvs 1.1 (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 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 cvs 1.4 (with-slots (armed) button
93 cvs 1.1 (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 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 (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 cvs 1.5 (sheet-children (first (sheet-children (frame-pane submenu-frame))))
127 cvs 1.1 '())))
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 hatchond 1.6 (rack (make-pane-1 manager frame 'vrack-pane
136     :background +grey80+ :contents items))
137 cvs 1.5 (raised (make-pane-1 manager frame 'raised-pane :contents (list rack))))
138 cvs 1.1 (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 cvs 1.5 submenu-frame (make-menu-frame raised :left x :top y))
148 cvs 1.1 (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 cvs 1.4 (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 cvs 1.1
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 cvs 1.2 &key
214 cvs 1.1 &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 cvs 1.5 (loop for child in (menu-children object)
228 cvs 1.1 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 hatchond 1.6 (defun make-menu-bar (command-table
239     &key width height
240     max-width max-height
241     min-width min-height)
242 cvs 1.1 (with-slots (menu) (find-command-table command-table)
243 hatchond 1.6 (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