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

Contents of /mcclim/menu.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.22 - (hide annotations)
Tue Nov 5 10:46:35 2002 UTC (11 years, 5 months ago) by gilbert
Branch: MAIN
Changes since 1.21: +44 -94 lines
An attempt to fix menus.
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 gilbert 1.22 (arm-gadget button t))
32 cvs 1.1 (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 gilbert 1.22 (disarm-gadget button)
38 cvs 1.1 (dispatch-repaint button (sheet-region button)))))
39    
40 boninfan 1.9 (defun menu-draw-highlighted (gadget)
41 gilbert 1.14 (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 gilbert 1.22 (draw-edges-lines* gadget 0 0 (1- w) (1- h)) ;(- w 2) (- h 2)
51 gilbert 1.16 (draw-label* gadget x1 y1 x2 y2)))))))
52 boninfan 1.9
53 cvs 1.1 (defun menu-draw-unhighlighted (gadget)
54 gilbert 1.14 (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 gilbert 1.22 :ink +background-ink+
62 gilbert 1.14 :filled t)
63 gilbert 1.16 (draw-label* gadget x1 y1 x2 y2)))))))
64 cvs 1.1
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 cvs 1.4 (with-slots (client) button
82     (arm-menu client)
83     (mapc #'destroy-substructure (menu-children client))
84     (arm-menu button)))
85 cvs 1.1
86     (defmethod destroy-substructure ((button menu-button-leaf-pane))
87 gilbert 1.22 (disarm-gadget button))
88 cvs 1.1
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 cvs 1.4 (disarm-menu pane))
98 cvs 1.1
99 cvs 1.3 (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-ungrab-event))
100     (destroy-substructure (menu-root pane)))
101    
102 cvs 1.1 ;;; menu-button-submenu-pane
103    
104     (defclass menu-button-submenu-pane (menu-button-pane)
105 gilbert 1.22 ((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 cvs 1.1
110     (defmethod menu-children ((submenu menu-button-submenu-pane))
111     (with-slots (submenu-frame) submenu
112     (if submenu-frame
113 cvs 1.5 (sheet-children (first (sheet-children (frame-pane submenu-frame))))
114 cvs 1.1 '())))
115    
116     (defun create-substructure (sub-menu client)
117     (let* ((frame *application-frame*)
118 gilbert 1.22 (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 cvs 1.1
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 gilbert 1.22 (disarm-gadget sub-menu)
143     (dispatch-repaint sub-menu +everywhere+)
144     (setf submenu-frame nil) )))
145 cvs 1.1
146     (defmethod arm-branch ((sub-menu menu-button-submenu-pane))
147 gilbert 1.22 (with-slots (client frame-manager submenu-frame) sub-menu
148 cvs 1.4 (arm-menu client)
149 gilbert 1.22 (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 cvs 1.4 (arm-menu sub-menu)))
156 gilbert 1.22
157 cvs 1.1 (defmethod handle-event ((pane menu-button-submenu-pane) (event pointer-button-release-event))
158 gilbert 1.22 (destroy-substructure (menu-root pane)))
159 cvs 1.1
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 gilbert 1.22 (declare (ignore gadget val))
177     (funcall value)))
178 cvs 1.1 (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 brian 1.13 (defclass menu-button-hrack-pane (hrack-pane) ())
189 cvs 1.1
190 brian 1.13 (defclass menu-bar (menu-button-hrack-pane
191 gilbert 1.10 permanent-medium-sheet-output-mixin)
192 cvs 1.1 ((items :initform nil)
193     (armed :initform nil)))
194    
195     (defmethod initialize-instance :after ((pane menu-bar)
196     &rest args
197 cvs 1.2 &key
198 cvs 1.1 &allow-other-keys)
199     (declare (ignore args))
200     (setf (slot-value pane 'items) (copy-list (sheet-children pane)))
201     (loop for child in (sheet-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 cvs 1.5 (loop for child in (menu-children object)
212 cvs 1.1 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 hatchond 1.6 (defun make-menu-bar (command-table
223     &key width height
224 gilbert 1.15 (max-width +fill+) max-height
225 hatchond 1.6 min-width min-height)
226 cvs 1.1 (with-slots (menu) (find-command-table command-table)
227 gilbert 1.22 (raising ()
228 brian 1.13 (make-pane-1 *pane-realizer* *application-frame*
229 hatchond 1.6 'menu-bar
230 gilbert 1.22 :background *3d-normal-color*
231 hatchond 1.6 :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     (loop for item in menu
236     collect
237 gilbert 1.22 (make-menu-button-from-menu-item item nil :bottomp t))))))

  ViewVC Help
Powered by ViewVC 1.1.5