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

Contents of /mcclim/menu.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (hide annotations)
Sun Apr 21 12:41:14 2002 UTC (12 years ago) by brian
Branch: MAIN
Changes since 1.12: +29 -27 lines
Sundry fixes to run without multiprocessing support.

Added images/ to hold bitmaps for tests.

Added looks/ to hold neutral look-and-feel realizer packages.

Added Examples/gadget-test to test many gadgets with a look and feel.

Added a pixie look and feel, and a pixie/clx to work with the clx backend.

Added drawing support in the CLX backend for ovals and circles.

Fixed pixmaps to work with with-output-to-pixmap with draw-image, etc.

Moved sheet-leaf-mixin to standard-gadget-pane so it doesn't break radio-box-pane, etc.

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

  ViewVC Help
Powered by ViewVC 1.1.5