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

Contents of /mcclim/menu-choose.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.24 - (show annotations)
Wed Jan 28 19:27:22 2009 UTC (5 years, 2 months ago) by crhodes
Branch: MAIN
CVS Tags: HEAD
Changes since 1.23: +1 -1 lines
The spec says that PORT is an accessor on frame-manager; remove
CLIMI::FRAME-MANAGER-PORT and implement PORT instead.  Fixup all uses
that I can find.

(Motivated by Climacs's own frame management)
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 2002 by Alexey Dejneka (adejneka@comail.ru)
4
5 ;;; This library is free software; you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Library General Public
7 ;;; License as published by the Free Software Foundation; either
8 ;;; version 2 of the License, or (at your option) any later version.
9 ;;;
10 ;;; This library is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Library General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU Library General Public
16 ;;; License along with this library; if not, write to the
17 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18 ;;; Boston, MA 02111-1307 USA.
19
20 ;;; Long time TODO (if someone wants to implement them - you are welcome):
21 ;;;
22 ;;; - Menu item options: :items, :type.
23 ;;;
24 ;;; - VIEW.
25 ;;;
26 ;;; - Caching.
27 ;;;
28 ;;; - Default item.
29
30 ;;; Mid time TODO:
31 ;;;
32 ;;; - Documentation.
33 ;;;
34 ;;; - Empty menu.
35 ;;;
36 ;;; - :DIVIDER type menu items.
37
38 (in-package :clim-internals)
39
40 ;; Spec function.
41 (defgeneric menu-choose
42 (items
43 &key associated-window printer presentation-type default-item
44 text-style label cache unique-id id-test cache-value cache-test
45 max-width max-height n-rows n-columns x-spacing y-spacing row-wise
46 cell-align-x cell-align-y scroll-bars pointer-documentation))
47
48 ;; Spec function.
49 (defgeneric frame-manager-menu-choose
50 (frame-manager items
51 &key associated-window printer presentation-type default-item
52 text-style label cache unique-id id-test cache-value cache-test
53 max-width max-height n-rows n-columns x-spacing y-spacing row-wise
54 cell-align-x cell-align-y scroll-bars pointer-documentation))
55
56 ;; Spec function.
57 (defgeneric menu-choose-from-drawer
58 (menu presentation-type drawer
59 &key x-position y-position cache unique-id id-test cache-value cache-test
60 default-presentation pointer-documentation))
61
62 (defgeneric adjust-menu-size-and-position (menu &key x-position y-position)
63 (:documentation "Adjust the size of the menu so it fits
64 properly on the screen with regards to the menu entries. `menu'
65 should be the menu pane. This is an internal,
66 non-specification-defined function."))
67
68 (defun menu-item-value (menu-item)
69 (cond ((atom menu-item)
70 menu-item)
71 ((atom (cdr menu-item))
72 (cdr menu-item))
73 (t (getf (cdr menu-item) :value (car menu-item)))))
74
75 (defun menu-item-display (menu-item)
76 (if (atom menu-item)
77 menu-item
78 (car menu-item)))
79
80 (defun menu-item-options (menu-item)
81 (if (and (consp menu-item)
82 (consp (cdr menu-item)))
83 (cdr menu-item) ; XXX Remove :VALUE?
84 nil))
85
86 (defun menu-item-option (menu-item option &optional default)
87 (if (listp menu-item)
88 (getf (menu-item-options menu-item) option default)
89 default))
90
91 (defun print-menu-item (menu-item &optional (stream *standard-output*))
92 (let ((style (getf (menu-item-options menu-item) :style '(nil nil nil))))
93 (with-text-style (stream style)
94 (if (menu-item-option menu-item :active t)
95 (princ (menu-item-display menu-item) stream)
96 (with-drawing-options (stream :ink (compose-over
97 (compose-in
98 ; XXX it should be (MEDIUM-INK),
99 ; but CLX backend is too stupid.
100 ; -- APD, 2002-08-07
101 (medium-foreground stream)
102 (make-opacity 0.5))
103 (medium-background stream)))
104 (princ (menu-item-display menu-item) stream))))))
105
106 ;; Spec function.
107 (defun draw-standard-menu
108 (stream presentation-type items default-item
109 &key item-printer
110 max-width max-height n-rows n-columns x-spacing y-spacing row-wise
111 cell-align-x cell-align-y)
112 (declare (ignore default-item))
113 (orf item-printer #'print-menu-item)
114 (format-items items
115 :stream stream
116 :printer
117 (lambda (item stream)
118 (ecase (menu-item-option item :type :item)
119 (:item
120 ;; This is a normal item, just output.
121 (let ((activep (menu-item-option item :active t)))
122 (with-presentation-type-decoded (name params options)
123 presentation-type
124 (let ((*allow-sensitive-inferiors* activep))
125 (with-text-style
126 (stream (menu-item-option
127 item :style
128 '(:sans-serif nil nil)))
129 (with-output-as-presentation
130 (stream
131 item
132 `((,name ,@params)
133 :description ,(getf (menu-item-options item) :documentation)
134 ,@options))
135 (funcall item-printer item stream)))))))
136 (:label
137 ;; This is a static label, it should not be
138 ;; mouse-sensitive, but not grayed out either.
139 (with-text-style (stream (menu-item-option
140 item :style
141 '(:sans-serif nil nil)))
142 (funcall item-printer item stream)))
143 (:divider
144 ;; FIXME: Should draw a line instead.
145 (with-text-style (stream (menu-item-option
146 item :style
147 '(:sans-serif :italic nil)))
148 (funcall item-printer item stream)))))
149 :presentation-type nil
150 :x-spacing x-spacing
151 :y-spacing y-spacing
152 :n-columns n-columns
153 :n-rows n-rows
154 :max-width max-width
155 :max-height max-height
156 :cell-align-x cell-align-x
157 :cell-align-y (or cell-align-y :top)
158 :row-wise row-wise))
159
160 (defclass menu-pane (clim-stream-pane)
161 ()
162 (:default-initargs :background *3d-normal-color*))
163
164 ;; Spec macro.
165 (defmacro with-menu ((menu &optional associated-window
166 &key (deexpose t) label scroll-bars)
167 &body body)
168 (check-type menu symbol)
169 (with-gensyms (with-menu-cont)
170 `(flet ((,with-menu-cont (,menu)
171 ,@body))
172 (declare (dynamic-extent #',with-menu-cont))
173 (invoke-with-menu #',with-menu-cont
174 ,associated-window ; XXX
175 ',deexpose ; XXX!!!
176 ,label
177 ,scroll-bars))))
178
179 (defun invoke-with-menu (continuation associated-window deexpose
180 label scroll-bars)
181 (let* ((associated-frame (if associated-window
182 (pane-frame associated-window)
183 *application-frame*))
184 (fm (frame-manager associated-frame)))
185 (with-look-and-feel-realization (fm associated-frame) ; hmm... checkme
186 (let* ((menu-stream (make-pane-1 fm associated-frame 'menu-pane))
187 (container (scrolling (:scroll-bar scroll-bars)
188 menu-stream))
189 (frame (make-menu-frame (raising ()
190 (if label
191 (labelling (:label label
192 :name 'label
193 :label-alignment :top)
194 container)
195 container))
196 :left nil
197 :top nil)))
198 (adopt-frame fm frame)
199 (unwind-protect
200 (progn
201 (setf (stream-end-of-line-action menu-stream) :allow
202 (stream-end-of-page-action menu-stream) :allow)
203 (funcall continuation menu-stream))
204 (when deexpose ; Checkme as well.
205 (disown-frame fm frame)))))))
206
207 (define-presentation-type menu-item ())
208
209 (defmethod menu-choose
210 (items &rest args &key associated-window &allow-other-keys)
211 (let* ((associated-frame (if associated-window
212 (pane-frame associated-window)
213 *application-frame*))
214 (frame-manager (frame-manager associated-frame)))
215 (apply #'frame-manager-menu-choose frame-manager items args)))
216
217 (defmethod frame-manager-menu-choose
218 (frame-manager items ; XXX specialize on STANDARD-FRAME-MANAGER
219 &rest options
220 &key associated-window printer presentation-type
221 (default-item nil default-item-p)
222 text-style label cache unique-id id-test cache-value cache-test
223 max-width max-height n-rows (n-columns 1) x-spacing y-spacing row-wise
224 cell-align-x cell-align-y (scroll-bars :vertical)
225 ;; We provide pointer documentation by default.
226 (pointer-documentation *pointer-documentation-output*))
227 (flet ((drawer (stream type)
228 (draw-standard-menu stream type items
229 (if default-item-p
230 default-item
231 (first items))
232 :item-printer (or printer
233 #'print-menu-item)
234 :max-width max-width
235 :max-height max-height
236 :n-rows n-rows
237 :n-columns n-columns
238 :x-spacing x-spacing
239 :y-spacing y-spacing
240 :row-wise row-wise
241 :cell-align-x cell-align-x
242 :cell-align-y cell-align-y)))
243 (multiple-value-bind (object event)
244 (with-menu (menu associated-window
245 :label label
246 :scroll-bars scroll-bars)
247 (when text-style
248 (setf (medium-text-style menu) text-style))
249 (letf (((stream-default-view menu) +textual-menu-view+))
250 (menu-choose-from-drawer menu (or presentation-type 'menu-item)
251 #'drawer
252 :cache cache
253 :unique-id unique-id
254 :id-test id-test
255 :cache-value cache-value
256 :cache-test cache-test
257 :pointer-documentation pointer-documentation)))
258 (unless (null event) ; Event is NIL if user aborted.
259 (let ((subitems (menu-item-option object :items 'menu-item-no-items)))
260 (if (eq subitems 'menu-item-no-items)
261 (values (menu-item-value object) object event)
262 (apply #'frame-manager-menu-choose
263 frame-manager subitems
264 options)))))))
265
266 (defun max-x-y (frame)
267 "Return the maximum X and Y coordinate values for a menu for
268 `frame' (essentially, the screen resolution with a slight
269 padding.)"
270 ;; FIXME? There may be a better way.
271 (let* ((port (port (frame-manager frame)))
272 (graft (find-graft :port port)))
273 (values (- (graft-width graft) 50)
274 (- (graft-height graft) 50))))
275
276 (defun menu-size (menu frame)
277 "Return two values, the height and width of MENU (adjusted for
278 maximum size according to `frame')."
279 (multiple-value-bind (max-width max-height)
280 (max-x-y frame)
281 (with-bounding-rectangle* (x1 y1 x2 y2) menu
282 (declare (ignore x1 y1))
283 (values (min x2 max-width)
284 (min y2 max-height)))))
285
286 (defmethod adjust-menu-size-and-position ((menu menu-pane)
287 &key x-position y-position)
288 ;; Make sure the menu isn't higher or wider than the screen.
289 (multiple-value-bind (menu-width menu-height)
290 (menu-size (stream-output-history menu) *application-frame*)
291 (change-space-requirements menu
292 :width menu-width
293 :height menu-height
294 :resize-frame t)
295
296 ;; If we have scroll-bars, we need to do some calibration of the
297 ;; size of the viewport.
298 (when (pane-viewport menu)
299 (multiple-value-bind (viewport-width viewport-height)
300 (menu-size (pane-viewport menu) *application-frame*)
301 (change-space-requirements (pane-scroller menu)
302 ;; HACK: How are you supposed to
303 ;; change the size of the viewport?
304 ;; I could only find this way, where
305 ;; I calculate the size difference
306 ;; between the viewport and the
307 ;; scroller pane, and set the
308 ;; scroller pane to the desired size
309 ;; of the viewport, plus the
310 ;; difference (to make room for
311 ;; scroll bars).
312 :width (+ menu-width
313 (- (pane-current-width (pane-scroller menu))
314 viewport-width))
315 :height (+ menu-height
316 (- (pane-current-height (pane-scroller menu))
317 viewport-height))
318 :resize-frame t)))
319
320 ;; Modify the size and location of the frame as well.
321 (let* ((top-level-pane (labels ((searching (pane)
322 (if (typep pane 'top-level-sheet-pane)
323 pane
324 (searching (sheet-parent pane)))))
325 (searching menu))))
326 (multiple-value-bind (frame-width frame-height)
327 (menu-size top-level-pane *application-frame*)
328 (multiple-value-bind (res-max-x res-max-y) (max-x-y *application-frame*)
329 ;; Move the menu frame so that no entries are outside the visible
330 ;; part of the screen.
331 (let ((max-left (- res-max-x frame-width))
332 (max-top (- res-max-y frame-height)))
333 ;; XXX: This is an ugly way to find the screen position of
334 ;; the menu frame, possibly even undefined.
335 (multiple-value-bind (left top)
336 (with-slots (dx dy) (sheet-transformation top-level-pane)
337 (values dx dy))
338 (when x-position
339 (setf left x-position))
340 (when y-position
341 (setf top y-position))
342 ;; Adjust for maximum position if the programmer has not
343 ;; explicitly provided coordinates.
344 (if (null x-position)
345 (when (> left max-left)
346 (setf left max-left)))
347 (if (null y-position)
348 (when (> top max-top)
349 (setf top max-top)))
350 (move-sheet top-level-pane
351 (max left 0) (max top 0)))))))))
352
353 (defmethod adjust-menu-size-and-position (menu &key &allow-other-keys)
354 ;; Nothing.
355 nil)
356
357 ;; Spec function.
358 (defmethod menu-choose-from-drawer
359 (menu presentation-type drawer
360 &key x-position y-position cache unique-id id-test cache-value cache-test
361 default-presentation pointer-documentation)
362 (declare (ignore cache unique-id
363 id-test cache-value cache-test default-presentation))
364 (with-room-for-graphics (menu :first-quadrant nil)
365 (funcall drawer menu presentation-type))
366
367 (adjust-menu-size-and-position
368 menu
369 :x-position x-position
370 :y-position y-position)
371
372 (let ((*pointer-documentation-output* pointer-documentation))
373 (let ((*pointer-documentation-output* pointer-documentation))
374 (handler-case
375 (with-input-context (`(or ,presentation-type blank-area) :override t)
376 (object type event)
377 (prog1 nil (loop (read-gesture :stream menu)))
378 (blank-area nil)
379 (t (values object event)))
380 (abort-gesture () nil)))))

  ViewVC Help
Powered by ViewVC 1.1.5