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

Contents of /mcclim/menu.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations)
Mon Dec 4 15:00:52 2000 UTC (13 years, 4 months ago) by cvs
Branch: MAIN
Support for menu bars.
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 compose-space ((button menu-button-pane))
24     (pane-space-requirement button))
25    
26     (defmethod pane-space-requirement ((button menu-button-pane))
27     (or (slot-value button 'space-requirement)
28     (with-sheet-medium (medium button)
29     (multiple-value-bind (width height) (text-size medium (gadget-label button))
30     (setf width (round (* 1.3 width))
31     height (round (* 2.5 height)))
32     (make-space-requirement :width width :height height)))))
33    
34     (defmethod menu-root ((button menu-button-pane))
35     (menu-root (gadget-client button)))
36    
37     (defmethod arm-menu ((button menu-button-pane))
38     (with-slots (client armed id) button
39     (unless armed
40     (arm-menu client)
41     (mapc #'disarm-menu (menu-children client))
42     (setf armed t)
43     (armed-callback button client id))
44     (dispatch-repaint button (sheet-region button))))
45    
46     (defmethod disarm-menu ((button menu-button-pane))
47     (with-slots (client armed id) button
48     (when armed
49     (setf armed nil)
50     (disarmed-callback button client id)
51     (dispatch-repaint button (sheet-region button)))))
52    
53     (defun menu-draw-highlighted (gadget)
54     (with-slots (label) gadget
55     (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region gadget))
56     (let ((w (- x2 x1))
57     (h (- y2 y1)))
58     (draw-rectangle* gadget -1 -1 x2 y2 :ink (gadget-highlighted-color gadget) :filled t)
59     (draw-edges-lines* gadget 1 1 (1- w) (1- h))
60     (draw-text* gadget label (round w 2) (round h 2)
61     :align-x :center :align-y :center)))))
62    
63     (defun menu-draw-unhighlighted (gadget)
64     (with-slots (label) gadget
65     (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* (sheet-region gadget))
66     (let ((w (- x2 x1))
67     (h (- y2 y1)))
68     (draw-rectangle* gadget -1 -1 x2 y2 :ink (gadget-normal-color gadget) :filled t)
69     (draw-text* gadget label (round w 2) (round h 2)
70     :align-x :center :align-y :center)))))
71    
72     (defmethod handle-event ((pane menu-button-pane) (event pointer-enter-event))
73     (when (slot-value (slot-value pane 'client) 'armed)
74     (arm-branch pane)))
75    
76     (defmethod handle-event ((pane menu-button-pane) (event pointer-button-press-event))
77     (arm-branch pane))
78    
79     (defmethod handle-event ((pane menu-button-pane) (event window-repaint-event))
80     (dispatch-repaint pane (sheet-region pane)))
81    
82     (defmethod handle-event ((pane menu-button-pane) (event pointer-ungrab-event))
83     (destroy-substructure (menu-root pane)))
84    
85     ;;; menu-button-leaf-pane
86    
87     (defclass menu-button-leaf-pane (menu-button-pane)
88     ((command :initform nil :initarg :command)))
89    
90     (defmethod arm-branch ((button menu-button-leaf-pane))
91     (unless (slot-value button 'destroyed)
92     (with-slots (client) button
93     (arm-menu client)
94     (mapc #'destroy-substructure (menu-children client))
95     (arm-menu button))))
96    
97     (defmethod destroy-substructure ((button menu-button-leaf-pane))
98     (with-slots (armed destroyed) button
99     (setf armed nil)))
100    
101     (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-button-release-event))
102     (with-slots (armed label client id) pane
103     (when armed
104     (value-changed-callback pane client id label)
105     (disarm-menu pane)
106     (destroy-substructure (menu-root pane)))))
107    
108     (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-exit-event))
109     (unless (slot-value pane 'destroyed)
110     (disarm-menu pane)))
111    
112     (defmethod repaint-sheet ((pane menu-button-leaf-pane) region)
113     (declare (ignore region))
114     (with-slots (armed) pane
115     (if armed
116     (menu-draw-highlighted pane)
117     (menu-draw-unhighlighted pane))))
118    
119     ;;; menu-button-submenu-pane
120    
121     (defclass menu-button-submenu-pane (menu-button-pane)
122     ((frame-manager :initform nil :initarg :frame-manager)
123     (submenu-frame :initform nil)
124     (bottomp :initform nil :initarg :bottomp)
125     (command-table :initform nil :initarg :command-table)))
126    
127     (defmethod menu-children ((submenu menu-button-submenu-pane))
128     (with-slots (submenu-frame) submenu
129     (if submenu-frame
130     (sheet-children (frame-pane submenu-frame))
131     '())))
132    
133     (defun create-substructure (sub-menu client)
134     (let* ((frame *application-frame*)
135     (manager (frame-manager frame))
136     (items (mapcar #'(lambda (item)
137     (make-menu-button-from-menu-item item client))
138     (slot-value (find-command-table (slot-value sub-menu 'command-table)) 'menu)))
139     (rack (make-pane-1 manager frame 'vrack-pane :contents items)))
140     (with-slots (bottomp) sub-menu
141     (multiple-value-bind (xmin ymin xmax ymax)
142     (bounding-rectangle* (sheet-region sub-menu))
143     (multiple-value-bind (x y)
144     (transform-position (sheet-delta-transformation sub-menu nil)
145     (if bottomp xmin xmax)
146     (if bottomp ymax ymin))
147     (with-slots (frame-manager submenu-frame) sub-menu
148     (setf frame-manager manager
149     submenu-frame (make-menu-frame rack :left x :top y))
150     (adopt-frame manager submenu-frame)))))))
151    
152     (defmethod destroy-substructure ((sub-menu menu-button-submenu-pane))
153     (with-slots (frame-manager submenu-frame) sub-menu
154     (when submenu-frame
155     (mapc #'destroy-substructure (menu-children sub-menu))
156     (mapc #'(lambda (child)
157     (setf (slot-value child 'destroyed) t))
158     (menu-children sub-menu))
159     (disown-frame frame-manager submenu-frame)
160     (setf submenu-frame nil))))
161    
162     (defmethod arm-branch ((sub-menu menu-button-submenu-pane))
163     (unless (slot-value sub-menu 'destroyed)
164     (with-slots (client frame-manager submenu-frame) sub-menu
165     (arm-menu client)
166     (if submenu-frame
167     (progn (mapc #'destroy-substructure (menu-children sub-menu))
168     (mapc #'disarm-menu (menu-children sub-menu)))
169     (progn
170     (mapc #'destroy-substructure (menu-children client))
171     (create-substructure sub-menu sub-menu)))
172     (arm-menu sub-menu))))
173    
174     (defmethod handle-event ((pane menu-button-submenu-pane) (event pointer-button-release-event))
175     (destroy-substructure (menu-root pane)))
176    
177     (defmethod repaint-sheet ((pane menu-button-submenu-pane) region)
178     (declare (ignore region))
179     (with-slots (submenu-frame) pane
180     (if submenu-frame
181     (menu-draw-highlighted pane)
182     (menu-draw-unhighlighted pane))))
183    
184     ;; Menu creation from command tables
185    
186     ;; for now, accept only types :command and :menu, and only
187     ;; command names as values of :command
188     (defun make-menu-button-from-menu-item (item client &key (bottomp nil))
189     (let ((name (command-menu-item-name item))
190     (type (command-menu-item-type item))
191     (value (command-menu-item-value item))
192     (frame *application-frame*)
193     (manager (frame-manager *application-frame*)))
194     (if (eq type :command)
195     (make-pane-1 manager frame 'menu-button-leaf-pane
196     :space-requirement nil
197     :label name
198     :client client
199     :value-changed-callback
200     #'(lambda (gadget val)
201     (declare (ignore gadget val))
202     (funcall value)))
203     (make-pane-1 manager frame 'menu-button-submenu-pane
204     :space-requirement nil
205     :label name
206     :client client
207     :frame-manager manager
208     :command-table value
209     :bottomp bottomp))))
210    
211     ;;
212     ;; MENU-BAR
213     ;;
214    
215     (defclass menu-bar (hrack-pane)
216     ((items :initform nil)
217     (armed :initform nil)))
218    
219     (defmethod initialize-instance :after ((pane menu-bar)
220     &rest args
221     &allow-other-keys)
222     (declare (ignore args))
223     (setf (slot-value pane 'items) (copy-list (sheet-children pane)))
224     (loop for child in (sheet-children pane)
225     do (setf (gadget-client child) pane)))
226    
227     (defmethod menu-children ((menu-bar menu-bar))
228     (slot-value menu-bar 'items))
229    
230     (defmethod menu-root ((object menu-bar))
231     object)
232    
233     (defmethod destroy-substructure ((object menu-bar))
234     (loop for child in (sheet-children object)
235     do (progn (destroy-substructure child)
236     (dispatch-repaint child (sheet-region child))))
237     (setf (slot-value object 'armed) nil))
238    
239     (defmethod arm-menu ((object menu-bar))
240     (setf (slot-value object 'armed) t))
241    
242     (defmethod disarm-menu ((object menu-bar))
243     (setf (slot-value object 'armed) nil))
244    
245    
246     (defun make-menu-bar (command-table)
247     (with-slots (menu) (find-command-table command-table)
248     (make-pane 'menu-bar
249     :contents
250     (mapcar #'(lambda (item)
251     (make-menu-button-from-menu-item item nil :bottomp t))
252     menu))))

  ViewVC Help
Powered by ViewVC 1.1.5