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

Contents of /mcclim/menu.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.38 - (hide annotations)
Sat Dec 23 11:52:27 2006 UTC (7 years, 3 months ago) by ahefner
Branch: MAIN
CVS Tags: mcclim-0-9-4, McCLIM-0-9-5, McCLIM-0-9-4
Changes since 1.37: +13 -2 lines
Further hacking to polish the "pixie" look. Enabled pixie-style menus,
revamped various compose-space and handle-repaint methods. Minor changes
to menu.lisp allowing pixie to customize the decoration of submenu
windows, and to detect when menu buttons are in a vertical menu (versus
the menu bar). Changed drawing of the arrow widget on scroll bars and
submenu buttons to use a small bitmap rather than polygon drawing, as the
polygon drawing was awkward and (due to rounding?) did not look right.

On CLX, Pixie can be invoked as follows:
(setf *default-frame-manager*
      (make-instance 'climi::pixie/clx-look :port (find-port)))
1 moore 1.29 1;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2 cvs 1.1
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 mikemac 1.25 (in-package :clim-internals)
22 cvs 1.1
23 moore 1.28 (defmethod stream-force-output ((pane menu-button-pane))
24     (with-sheet-medium (medium pane)
25     (medium-force-output medium)))
26    
27 cvs 1.1 (defmethod menu-root ((button menu-button-pane))
28     (menu-root (gadget-client button)))
29    
30     (defmethod arm-menu ((button menu-button-pane))
31     (with-slots (client armed id) button
32     (unless armed
33     (arm-menu client)
34     (mapc #'disarm-menu (menu-children client))
35 gilbert 1.22 (arm-gadget button t))
36 cvs 1.1 (dispatch-repaint button (sheet-region button))))
37    
38     (defmethod disarm-menu ((button menu-button-pane))
39     (with-slots (client armed id) button
40     (when armed
41 gilbert 1.22 (disarm-gadget button)
42 moore 1.28 (dispatch-repaint button (sheet-region button))
43     (stream-force-output button))))
44 cvs 1.1
45 boninfan 1.9 (defun menu-draw-highlighted (gadget)
46 gilbert 1.14 (when (sheet-mirror gadget) ;XXX only do this when the gadget is realized.
47     (with-special-choices (gadget)
48     (with-slots (label) gadget
49     (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region gadget)
50     (let ((w (- x2 x1))
51     (h (- y2 y1)))
52     (draw-rectangle* gadget -1 -1 x2 y2
53     :ink (gadget-highlighted-color gadget)
54     :filled t)
55 gilbert 1.27 (draw-edges-lines* gadget +white+ 0 0 +black+ (1- w) (1- h))
56 gilbert 1.16 (draw-label* gadget x1 y1 x2 y2)))))))
57 boninfan 1.9
58 cvs 1.1 (defun menu-draw-unhighlighted (gadget)
59 gilbert 1.14 (when (sheet-mirror gadget) ;XXX only do this when the gadget is realized.
60     (with-special-choices (gadget)
61     (with-slots (label) gadget
62     (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region gadget)
63     (let ((w (- x2 x1))
64     (h (- y2 y1)))
65     (draw-rectangle* gadget -1 -1 w h ;-1 -1 x2 y2
66 gilbert 1.22 :ink +background-ink+
67 gilbert 1.14 :filled t)
68 gilbert 1.16 (draw-label* gadget x1 y1 x2 y2)))))))
69 cvs 1.1
70     (defmethod handle-event ((pane menu-button-pane) (event pointer-enter-event))
71     (when (slot-value (slot-value pane 'client) 'armed)
72     (arm-branch pane)))
73    
74     (defmethod handle-event ((pane menu-button-pane) (event pointer-button-press-event))
75     (arm-branch 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 gilbert 1.22 (disarm-gadget button))
93 cvs 1.1
94     (defmethod handle-event ((pane menu-button-leaf-pane) (event pointer-button-release-event))
95     (with-slots (armed label client id) pane
96     (when armed
97 moore 1.28 (unwind-protect
98     (value-changed-callback pane client id label)
99     (disarm-menu pane)
100     (destroy-substructure (menu-root pane))))))
101 cvs 1.1
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 ;;; menu-button-submenu-pane
109    
110     (defclass menu-button-submenu-pane (menu-button-pane)
111 gilbert 1.22 ((frame-manager :initform nil :initarg :frame-manager)
112     (submenu-frame :initform nil)
113     (bottomp :initform nil :initarg :bottomp)
114     (command-table :initform nil :initarg :command-table)))
115 cvs 1.1
116     (defmethod menu-children ((submenu menu-button-submenu-pane))
117     (with-slots (submenu-frame) submenu
118     (if submenu-frame
119 moore 1.29 (sheet-children (first (sheet-children (frame-panes submenu-frame))))
120 cvs 1.1 '())))
121    
122 ahefner 1.38 (defclass submenu-border (border-pane) ())
123    
124     (defclass submenu-border-pane (raised-pane)
125     ()
126     (:default-initargs :border-width 2 :background *3d-normal-color*))
127    
128 cvs 1.1 (defun create-substructure (sub-menu client)
129     (let* ((frame *application-frame*)
130 gilbert 1.22 (manager (frame-manager frame))
131 moore 1.26 (command-table-name (slot-value sub-menu 'command-table))
132 gilbert 1.22 (items (mapcar #'(lambda (item)
133 moore 1.26 (make-menu-button-from-menu-item
134 hefner1 1.32 item client :command-table command-table-name :vertical t))
135 moore 1.26 (slot-value (find-command-table command-table-name)
136     'menu)))
137 gilbert 1.22 (rack (make-pane-1 manager frame 'vrack-pane
138     :background *3d-normal-color* :contents items))
139 ahefner 1.38 (raised (make-pane-1 manager frame 'submenu-border :contents (list rack))))
140 gilbert 1.22 (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 raised :left x :top y))
150 moore 1.28 (adopt-frame manager submenu-frame)
151     (with-sheet-medium (medium raised)
152     (medium-force-output medium))))))))
153 cvs 1.1
154     (defmethod destroy-substructure ((sub-menu menu-button-submenu-pane))
155     (with-slots (frame-manager submenu-frame) sub-menu
156     (when submenu-frame
157     (mapc #'destroy-substructure (menu-children sub-menu))
158     (disown-frame frame-manager submenu-frame)
159 gilbert 1.22 (disarm-gadget sub-menu)
160     (dispatch-repaint sub-menu +everywhere+)
161     (setf submenu-frame nil) )))
162 cvs 1.1
163     (defmethod arm-branch ((sub-menu menu-button-submenu-pane))
164 gilbert 1.22 (with-slots (client frame-manager submenu-frame) sub-menu
165 cvs 1.4 (arm-menu client)
166 gilbert 1.22 (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 cvs 1.4 (arm-menu sub-menu)))
173 hefner1 1.32
174 cvs 1.1 (defmethod handle-event ((pane menu-button-submenu-pane) (event pointer-button-release-event))
175 gilbert 1.22 (destroy-substructure (menu-root pane)))
176 cvs 1.1
177 hefner1 1.32 ;;; menu-button-vertical-submenu-pane
178     (defclass menu-button-vertical-submenu-pane (menu-button-submenu-pane) ())
179    
180     (let* ((left-padding 10)
181     (widget-size 5)
182     (right-padding 4)
183     (widget-width widget-size)
184     (widget-height (* 2 widget-size))
185     (total-width (+ left-padding widget-width right-padding))
186     (total-height widget-height))
187    
188     (defmethod compose-space ((gadget menu-button-vertical-submenu-pane) &key width height)
189     (declare (ignorable width height))
190     (multiple-value-bind (width min-width max-width height min-height max-height)
191     (space-requirement-components (call-next-method))
192     (declare (ignorable max-width))
193     (make-space-requirement :min-width (+ min-width total-width)
194     :width (+ width total-width)
195     :max-width +fill+
196     :min-height (max min-height total-height)
197     :height (max height total-height)
198     :max-height (if (zerop max-height) ; make-space-requirements default maximums are zero..
199     0
200     (max max-height total-height)))))
201    
202     (defmethod handle-repaint ((pane menu-button-vertical-submenu-pane) region)
203     (call-next-method)
204     (multiple-value-bind (x1 y1 x2 y2)
205     (bounding-rectangle* (sheet-region pane))
206     (when (and (> (- x2 x1) total-width)
207     (> (- y2 y1) total-height))
208     (let* ((center (/ (+ y1 y2) 2))
209     (vbase (- center (/ widget-height 2)))
210     (hbase (+ (- x2 total-width) left-padding))
211     (shape (list hbase vbase
212     (+ hbase widget-size) (+ vbase widget-size)
213     hbase (+ vbase (* 2 widget-size)))))
214     (draw-polygon* pane shape :ink +black+))))))
215    
216     ;;; menu-divider-leaf-pane
217    
218     (defclass menu-divider-leaf-pane (standard-gadget)
219     ((label :initform nil :initarg :label)))
220    
221     (defparameter *labelled-divider-text-style* (make-text-style :sans-serif :roman :small))
222    
223     (defmethod destroy-substructure ((object menu-divider-leaf-pane)))
224     (defmethod arm-menu ((object menu-divider-leaf-pane)))
225     (defmethod disarm-menu ((object menu-divider-leaf-pane)))
226    
227     (defmethod compose-space ((gadget menu-divider-leaf-pane) &key width height)
228     (declare (ignorable width height))
229     (flet ((make-sr (w h)
230     (make-space-requirement :min-width w :width w
231     :min-height h :height h :max-height h)))
232     (let ((label (slot-value gadget 'label)))
233     (if label
234     (multiple-value-bind (width height fx fy baseline)
235     (text-size gadget label :text-style *labelled-divider-text-style*)
236     (declare (ignore fx fy height baseline))
237     (make-sr width (+ 0
238     (text-style-ascent *labelled-divider-text-style* gadget)
239     (text-style-descent *labelled-divider-text-style* gadget))))
240     (make-sr 0 4)))))
241    
242    
243     (defmethod handle-repaint ((pane menu-divider-leaf-pane) region)
244     (let ((label (slot-value pane 'label)))
245     (multiple-value-bind (x1 y1 x2 y2)
246     (bounding-rectangle* (sheet-region pane))
247     (declare (ignore y2))
248     (if label
249     (multiple-value-bind (width height fx fy baseline)
250     (text-size pane label :text-style *labelled-divider-text-style*)
251     (declare (ignore height fx fy))
252     (let ((tx0 (+ x1 (/ (- (- x2 x1) width) 2)))
253     (ty0 (+ 1 y1 baseline)))
254     (draw-line* pane tx0 (1+ ty0) (+ tx0 width) (1+ ty0) :ink *3d-dark-color*)
255     (draw-text* pane label tx0 ty0
256     :text-style *labelled-divider-text-style*)))
257     (progn
258     (draw-line* pane x1 (1+ y1) x2 (1+ y1) :ink *3d-dark-color*)
259     (draw-line* pane x1 (+ 2 y1) x2 (+ 2 y1) :ink *3d-light-color*))))))
260    
261    
262     ;;; Menu creation from command tables
263 cvs 1.1
264 hefner1 1.32 (defparameter *enabled-text-style* (make-text-style :sans-serif :roman :normal))
265     (defparameter *disabled-text-style* (make-text-style :sans-serif :roman :normal))
266 moore 1.30
267 moore 1.26 (defun make-menu-button-from-menu-item (item client
268 moore 1.28 &key (bottomp nil)
269 hefner1 1.32 (vertical nil)
270 moore 1.28 command-table
271     (presentation-type 'menu-item))
272     (declare (ignore command-table))
273 cvs 1.1 (let ((name (command-menu-item-name item))
274     (type (command-menu-item-type item))
275     (value (command-menu-item-value item))
276     (frame *application-frame*)
277     (manager (frame-manager *application-frame*)))
278 hefner1 1.32 (case type
279     (:command
280     (let ((command-name (if (consp value) (car value) value)))
281     (if (command-enabled command-name frame)
282     (make-pane-1 manager frame 'menu-button-leaf-pane
283     :label name
284     :text-style *enabled-text-style*
285     :client client
286 ahefner 1.38 :vertical vertical
287 hefner1 1.32 :value-changed-callback
288     #'(lambda (gadget val)
289     (declare (ignore gadget val))
290     (throw-object-ptype item presentation-type)))
291     (let ((pane (make-pane-1 manager frame 'menu-button-leaf-pane
292     :label name
293     :text-style *disabled-text-style*
294     :client client
295 ahefner 1.38 :vertical vertical
296 hefner1 1.32 :value-changed-callback
297     #'(lambda (gadget val)
298     (declare (ignore gadget val))
299     nil))))
300     (deactivate-gadget pane)
301     pane))))
302     (:function
303     (make-pane-1 manager frame 'menu-button-leaf-pane
304     :label name
305     :text-style *enabled-text-style*
306     :client client
307 ahefner 1.38 :vertical vertical
308 hefner1 1.32 :value-changed-callback
309     #'(lambda (gadget val)
310     (declare (ignore gadget val))
311     ;; FIXME: the spec requires us to pass a gesture to the
312     ;; function, but value-changed-callback doesn't provide
313     ;; one, so we pass NIL for now.
314     ;; FIXME: We don't have a numeric argument, either.
315 hefner1 1.33 (let ((command (funcall value nil nil)))
316     (throw-object-ptype command 'command)))))
317 hefner1 1.32 (:divider
318     (make-pane-1 manager frame 'menu-divider-leaf-pane
319     :label name
320 ahefner 1.38 :vertical vertical
321 hefner1 1.32 :client client))
322     (:menu
323     (make-pane-1 manager frame (if vertical
324     'menu-button-vertical-submenu-pane
325     'menu-button-submenu-pane)
326 cvs 1.1 :label name
327     :client client
328 ahefner 1.38 :vertical vertical
329 cvs 1.1 :frame-manager manager
330     :command-table value
331 hefner1 1.32 :bottomp bottomp))
332     (otherwise (error "Don't know how to create a menu button for ~W" type)))))
333 cvs 1.1
334     ;;
335     ;; MENU-BAR
336     ;;
337 brian 1.13 (defclass menu-button-hrack-pane (hrack-pane) ())
338 cvs 1.1
339 brian 1.13 (defclass menu-bar (menu-button-hrack-pane
340 gilbert 1.10 permanent-medium-sheet-output-mixin)
341 cvs 1.1 ((items :initform nil)
342     (armed :initform nil)))
343    
344     (defmethod initialize-instance :after ((pane menu-bar)
345     &rest args
346 cvs 1.2 &key
347 cvs 1.1 &allow-other-keys)
348     (declare (ignore args))
349     (setf (slot-value pane 'items) (copy-list (sheet-children pane)))
350 gilbert 1.23 (loop for child in (menu-children pane)
351 cvs 1.1 do (setf (gadget-client child) pane)))
352    
353     (defmethod menu-children ((menu-bar menu-bar))
354     (slot-value menu-bar 'items))
355    
356     (defmethod menu-root ((object menu-bar))
357     object)
358    
359     (defmethod destroy-substructure ((object menu-bar))
360 cvs 1.5 (loop for child in (menu-children object)
361 cvs 1.1 do (progn (destroy-substructure child)
362     (dispatch-repaint child (sheet-region child))))
363     (setf (slot-value object 'armed) nil))
364    
365     (defmethod arm-menu ((object menu-bar))
366     (setf (slot-value object 'armed) t))
367    
368     (defmethod disarm-menu ((object menu-bar))
369     (setf (slot-value object 'armed) nil))
370    
371 hatchond 1.6 (defun make-menu-bar (command-table
372     &key width height
373 gilbert 1.15 (max-width +fill+) max-height
374 hatchond 1.6 min-width min-height)
375 cvs 1.1 (with-slots (menu) (find-command-table command-table)
376 dlichteblau 1.35 (make-pane-1 *pane-realizer* *application-frame*
377     'menu-bar
378     :background *3d-normal-color*
379     :width width :height height
380     :max-width max-width :max-height max-height
381     :min-width min-width :min-height min-height
382     :contents
383     (append
384     (loop for item in menu
385     collect
386 ahefner 1.38 (make-menu-button-from-menu-item
387 dlichteblau 1.35 item nil
388     :bottomp t
389     :vertical nil
390     :command-table command-table))
391     (list +fill+)))))
392    
393     (defmethod handle-repaint ((pane menu-bar) region)
394     (declare (ignore region))
395     (with-slots (border-width) pane
396     (multiple-value-call #'draw-bordered-rectangle*
397     pane
398     (bounding-rectangle* (sheet-region pane))
399     :style :outset
400     :border-width 2)))
401    
402     (defmethod compose-space ((pane menu-bar) &key width height)
403     (declare (ignore width height))
404 dlichteblau 1.36 (space-requirement+
405     (call-next-method)
406     (make-space-requirement :height 4 :max-height 4 :min-height 4)))
407 dlichteblau 1.35
408     (defmethod box-layout-mixin/horizontally-allocate-space
409     ((pane menu-bar) real-width real-height)
410     (with-slots (x-spacing) pane
411     (let ((widths
412     (box-layout-mixin/horizontally-allocate-space-aux*
413     pane real-width real-height))
414     (x 2))
415     (loop
416     for child in (box-layout-mixin-clients pane)
417     for width in widths
418     do
419     (when (box-client-pane child)
420     (layout-child (box-client-pane child)
421     :expand
422     :expand
423     x
424     2
425     width
426     (- real-height 4)))
427     (incf x width)
428     (incf x x-spacing)))))
429 thenriksen 1.37
430     (defmethod display-command-table-menu ((command-table standard-command-table)
431     (stream fundamental-output-stream)
432     &rest args
433     &key max-width max-height n-rows n-columns
434     x-spacing y-spacing initial-spacing
435     row-wise (cell-align-x :left)
436     (cell-align-y :top) (move-cursor t))
437     (formatting-item-list (stream :max-width max-width :max-height max-height :n-rows n-rows
438     :n-columns n-columns :x-spacing x-spacing :y-spacing y-spacing
439     :initial-spacing initial-spacing :row-wise row-wise
440     :move-cursor move-cursor)
441     (map-over-command-table-menu-items
442     #'(lambda (item-name accelerator item)
443     (declare (ignore accelerator))
444     (formatting-cell (stream :align-x cell-align-x :align-y cell-align-y)
445     (cond ((eq (command-menu-item-type item) :menu)
446     (with-text-style (stream (make-text-style :serif '(:bold :italic) nil))
447     (write-string item-name stream)
448     (terpri stream))
449     (surrounding-output-with-border (stream)
450     (apply #'display-command-table-menu
451     (find-command-table (command-menu-item-value item))
452     stream args)))
453     ((eq (command-menu-item-type item) :command)
454     (let ((name (command-name (command-menu-item-value item))))
455     (when (command-line-name-for-command name command-table :errorp nil)
456     (present name 'command-name :stream stream)))))))
457     command-table)))
458    
459     (defmethod display-command-menu (frame (stream fundamental-output-stream)
460     &rest args &key
461     (command-table (frame-command-table frame))
462     initial-spacing row-wise max-width
463     max-height n-rows n-columns
464     (cell-align-x :left) (cell-align-y :top))
465     (declare (ignore initial-spacing row-wise max-width max-height
466     n-rows n-columns cell-align-x cell-align-y))
467     (with-keywords-removed (args (:command-table))
468     (apply #'display-command-table-menu command-table stream args)))

  ViewVC Help
Powered by ViewVC 1.1.5