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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.52 - (hide annotations)
Tue Sep 24 01:56:29 2002 UTC (11 years, 7 months ago) by moore
Branch: MAIN
Changes since 1.51: +77 -32 lines
Fixed bug reported by Paul Werkowski; coordinate sequences can now be
lists or vectors.  Introduced a do-sequence macro that has similar
semantics to dotimes and dolist as well as features of map-sequence.

Implemented frame-state (except for :shrunk).  Changed timing of when
frames are generated, adopted and enabled to follow the spec.  Fixed
clim-fig to adapt to this new world order.  Disable the frame when the
top level function exits.

Remove erroring methods for copy-to-pixmap (stream ...) and friends.

Wrote a with-keywords-removed macro that attempts to be efficient
about about removing arguments from argument lists.
1 mikemac 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2    
3     ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4 cvs 1.4 ;;; (c) copyright 2000 by
5     ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr)
6     ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr)
7     ;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
8 mikemac 1.1
9     ;;; This library is free software; you can redistribute it and/or
10     ;;; modify it under the terms of the GNU Library General Public
11     ;;; License as published by the Free Software Foundation; either
12     ;;; version 2 of the License, or (at your option) any later version.
13     ;;;
14     ;;; This library is distributed in the hope that it will be useful,
15     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17     ;;; Library General Public License for more details.
18     ;;;
19     ;;; You should have received a copy of the GNU Library General Public
20     ;;; License along with this library; if not, write to the
21     ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22     ;;; Boston, MA 02111-1307 USA.
23    
24     (in-package :CLIM-INTERNALS)
25    
26 gilbert 1.33 ;; *application-frame* is in decls.lisp
27 mikemac 1.1 (defvar *default-frame-manager* nil)
28    
29 cvs 1.5 ;;; Frame-Manager class
30    
31     (defclass frame-manager ()
32     ((port :initarg :port
33     :reader frame-manager-port)
34     (frames :initform nil
35     :reader frame-manager-frames)
36     )
37     )
38    
39     (defun frame-manager-p (x)
40     (typep x 'frame-manager))
41    
42     (defun find-frame-manager (&rest options &key port &allow-other-keys)
43     (declare (special *frame-manager*))
44     (if (boundp '*frame-manager*)
45     *frame-manager*
46     (if (and *default-frame-manager*
47     (frame-manager-p *default-frame-manager*))
48     *default-frame-manager*
49     (first (frame-managers (or port (apply #'find-port options)))))))
50    
51     (defmacro with-frame-manager ((frame-manager) &body body)
52 adejneka 1.43 `(let ((*frame-manager* ,frame-manager))
53 cvs 1.5 (declare (special *frame-manager*))
54 adejneka 1.43 (locally ,@body)))
55    
56 mikemac 1.1 ;;; Application-Frame class
57 moore 1.38 ;;; XXX All these slots should move to a mixin or to standard-application-frame.
58     ;;; -- moore
59 mikemac 1.1
60     (defclass application-frame ()
61     ((port :initform nil
62     :initarg :port
63     :accessor port)
64     (graft :initform nil
65     :initarg :graft
66     :accessor graft)
67     (name :initarg :name
68     :reader frame-name)
69     (pretty-name :initarg :pretty-name
70     :accessor frame-pretty-name)
71     (command-table :initarg :command-table
72     :initform nil
73     :accessor frame-command-table)
74     (disabled-commands :initarg :disabled-commands
75     :initform nil
76     :accessor frame-disabled-commands)
77     (pane :reader frame-pane)
78     (panes :initform nil
79     :reader frame-panes)
80     (layouts :initform nil
81     :initarg :layouts
82     :reader frame-layouts)
83     (current-layout :initform nil
84     :initarg :current-layout
85     :reader frame-current-layout)
86     (top-level-sheet :initform nil
87     :reader frame-top-level-sheet)
88     (menu-bar :initarg :menu-bar
89     :initform nil)
90     (calling-frame :initarg :calling-frame
91     :initform nil)
92     (state :initarg :state
93 moore 1.52 :initform :disowned
94     :reader frame-state)
95 mikemac 1.1 (manager :initform nil
96 adejneka 1.46 :reader frame-manager
97     :accessor %frame-manager)
98 mikemac 1.1 (properties :initarg :properties
99     :initform nil)
100     (top-level :initform '(default-frame-top-level)
101     :initarg :top-level
102     :reader frame-top-level)
103 moore 1.18 (hilited-presentation :initform nil
104     :initarg :hilited-presentation
105 moore 1.38 :accessor frame-hilited-presentation)))
106 mikemac 1.1
107     (defun application-frame-p (x)
108     (typep x 'application-frame))
109    
110     (defmethod initialize-instance :after ((frame application-frame) &rest args)
111 moore 1.24 (declare (ignore args)))
112    
113 adejneka 1.13 ;;; Generic operations
114     ; (defgeneric frame-name (frame))
115     ; (defgeneric frame-pretty-name (frame))
116     ; (defgeneric (setf frame-pretty-name) (name frame))
117     ; (defgeneric frame-command-table (frame))
118     ; (defgeneric (setf frame-command-table) (command-table frame))
119     (defgeneric frame-standard-output (frame)
120     (:documentation
121     "Returns the stream that will be used for *standard-output* for the FRAME."))
122     (defgeneric frame-standard-input (frame)
123     (:documentation
124     "Returns the stream that will be used for *standard-input* for the FRAME."))
125     (defgeneric frame-query-io (frame)
126     (:documentation
127     "Returns the stream that will be used for *query-io* for the FRAME."))
128     (defgeneric frame-error-output (frame)
129     (:documentation
130     "Returns the stream that will be used for *error-output* for the FRAME."))
131     (defgeneric frame-pointer-documentation-output (frame)
132     (:documentation
133     "Returns the stream that will be used for *pointer-documentation-output*
134     for the FRAME."))
135     (defgeneric frame-calling-frame (frame)
136     (:documentation
137     "Returns the application frame that invoked the FRAME."))
138     (defgeneric frame-parent (frame)
139     (:documentation
140     "Returns the object that acts as the parent for the FRAME."))
141     ;(defgeneric frame-pane (frame) ; XXX Is it in Spec?
142     ; (:documentation
143     ; "Returns the pane that is the top-level pane in the current layout
144     ;of the FRAME's named panes."))
145     (defgeneric frame-top-level-sheet (frame)
146     (:documentation
147     "Returns the shhet that is the top-level sheet for the FRAME. This
148     is the sheet that has as its descendants all of the panes of the FRAME."))
149     (defgeneric frame-current-panes (frame)
150     (:documentation
151     "Returns a list of those named panes in the FRAME's current layout.
152     If there are no named panes, only the single, top level pane is returned."))
153     (defgeneric get-frame-pane (frame pane-name)
154     (:documentation
155     "Returns the named CLIM stream pane in the FRAME whose name is PANE-NAME."))
156     (defgeneric find-pane-named (frame pane-name)
157     (:documentation
158     "Returns the pane in the FRAME whose name is PANE-NAME."))
159     ;(defgeneric frame-current-layout (frame))
160     ;(defgeneric frame-all-layouts (frame)) ; XXX Is it in Spec?
161     (defgeneric layout-frame (frame &optional width height))
162 mikemac 1.22 (defgeneric frame-exit-frame (condition)
163     (:documentation
164     "Returns the frame that is being exited from associated with the
165     FRAME-EXIT condition."))
166 adejneka 1.13 (defgeneric frame-exit (frame) ; XXX Is it in Spec?
167     (:documentation
168     "Exits from the FRAME."))
169     (defgeneric pane-needs-redisplay (pane))
170     (defgeneric (setf pane-needs-redisplay) (value pane))
171     (defgeneric redisplay-frame-pane (frame pane &key force-p))
172     (defgeneric redisplay-frame-panes (frame &key force-p))
173     (defgeneric frame-replay (frame stream &optional region))
174     (defgeneric notify-user (frame message &key associated-window title
175     documentation exit-boxes name style text-style))
176     ;(defgeneric frame-properties (frame property))
177     ;(defgeneric (setf frame-properties) (value frame property))
178    
179    
180 mikemac 1.1 (defclass standard-application-frame (application-frame)
181 moore 1.38 ((event-queue :initarg :frame-event-queue
182     :accessor frame-event-queue
183     :documentation "The event queue that, by default, will be
184 moore 1.47 shared by all panes in the stream")
185     (documentation-state :accessor frame-documentation-state
186     :initform nil
187     :documentation "Used to keep of track of what
188     needs to be rendered in the pointer documentation frame.")))
189 moore 1.38
190     ;;; Support the :input-buffer initarg for compatibility with "real CLIM"
191    
192     (defmethod initialize-instance :after ((obj standard-application-frame)
193     &key (input-buffer nil input-buffer-p))
194     (cond (input-buffer-p
195     (setf (frame-event-queue obj) input-buffer))
196     ((not (slot-boundp obj 'event-queue))
197     (setf (frame-event-queue obj) (make-instance 'standard-event-queue)))
198     (t nil)))
199    
200 mikemac 1.1
201     (defmethod (setf frame-manager) (fm (frame application-frame))
202     (let ((old-manager (frame-manager frame)))
203 adejneka 1.46 (setf (%frame-manager frame) nil)
204 mikemac 1.1 (when old-manager
205     (disown-frame old-manager frame)
206     (setf (slot-value frame 'panes) nil)
207     (setf (slot-value frame 'layouts) nil))
208 adejneka 1.46 (setf (%frame-manager frame) fm)))
209 mikemac 1.1
210     (defmethod (setf frame-current-layout) (name (frame application-frame))
211     (declare (ignore name))
212     (generate-panes (frame-manager frame) frame))
213    
214     (defmethod generate-panes :before (fm (frame application-frame))
215     (declare (ignore fm))
216     (when (and (slot-boundp frame 'pane)
217     (frame-pane frame))
218     (sheet-disown-child (frame-top-level-sheet frame) (frame-pane frame))))
219    
220     (defmethod generate-panes :after (fm (frame application-frame))
221     (declare (ignore fm))
222     (sheet-adopt-child (frame-top-level-sheet frame) (frame-pane frame))
223 cvs 1.5 (sheet-adopt-child (graft frame) (frame-top-level-sheet frame))
224 hatchond 1.11 (let ((space (compose-space (frame-top-level-sheet frame))))
225 cvs 1.5 ;; automatically generates a window-configuation-event
226     ;; which then calls allocate-space
227 gilbert 1.39 ;;
228     ;; Not any longer, we turn of CONFIGURE-NOTIFY events until the
229     ;; window is mapped and do the space allocation now, so that all
230     ;; sheets will have their correct geometry at once. --GB
231 mikemac 1.1 (setf (sheet-region (frame-top-level-sheet frame))
232 cvs 1.5 (make-bounding-rectangle 0 0
233     (space-requirement-width space)
234 gilbert 1.39 (space-requirement-height space)))
235     (allocate-space (frame-top-level-sheet frame)
236     (space-requirement-width space)
237     (space-requirement-height space)) ))
238 mikemac 1.1
239     (defmethod layout-frame ((frame application-frame) &optional width height)
240     (let ((pane (frame-pane frame)))
241     (if (and width (not height))
242     (error "LAYOUT-FRAME must be called with both WIDTH and HEIGHT or neither"))
243     (if (and (null width) (null height))
244 hatchond 1.11 (let ((space (compose-space pane)))
245 mikemac 1.1 (setq width (space-requirement-width space))
246     (setq height (space-requirement-height space))))
247     (allocate-space pane width height)))
248    
249 adejneka 1.13 (defun find-pane-if (predicate panes)
250     "Returns a pane satisfying PREDICATE in the forest growing from PANES"
251 moore 1.27 (loop for pane in panes
252     do (map-over-sheets #'(lambda (p)
253     (when (funcall predicate p)
254     (return-from find-pane-if p)))
255     pane)
256     finally (return nil)))
257    
258 adejneka 1.13 (defun find-pane-of-type (panes type)
259     (find-pane-if #'(lambda (pane) (typep pane type)) panes))
260 adejneka 1.40
261 adejneka 1.13 (defmethod frame-current-panes ((frame application-frame))
262     (find-pane-if #'(lambda (pane) (pane-name pane))
263     (frame-current-layout frame)))
264    
265     (defmethod get-frame-pane ((frame application-frame) pane-name)
266     (find-pane-if #'(lambda (pane)
267     (and (typep pane 'clim-stream-pane)
268     (eq pane-name
269     (pane-name pane))))
270     (frame-panes frame)))
271    
272     (defmethod find-pane-named ((frame application-frame) pane-name)
273     (find-pane-if #'(lambda (pane)
274     (eq pane-name
275     (pane-name pane)))
276     (frame-panes frame)))
277    
278 mikemac 1.1 (defmethod frame-standard-output ((frame application-frame))
279 cvs 1.6 (or (find-pane-of-type (frame-panes frame) 'application-pane)
280     (find-pane-of-type (frame-panes frame) 'interactor-pane)))
281 mikemac 1.1
282     (defmethod frame-standard-input ((frame application-frame))
283 cvs 1.6 (or (find-pane-of-type (frame-panes frame) 'interactor-pane)
284 mikemac 1.1 (frame-standard-output frame)))
285    
286     (defmethod frame-query-io ((frame application-frame))
287     (or (frame-standard-input frame)
288     (frame-standard-output frame)))
289    
290     (defmethod frame-error-output ((frame application-frame))
291     (frame-standard-output frame))
292    
293     (defvar *pointer-documentation-output* nil)
294    
295     (defmethod frame-pointer-documentation-output ((frame application-frame))
296 adejneka 1.13 (find-pane-of-type (frame-panes frame) 'pointer-documentation-pane))
297 mikemac 1.1
298     ;;; Command loop interface
299    
300 mikemac 1.22 (define-condition frame-exit (condition)
301 moore 1.26 ((frame :initarg :frame :reader %frame-exit-frame)))
302 mikemac 1.22
303     (defmethod frame-exit ((frame standard-application-frame))
304     (signal 'frame-exit :frame frame))
305 moore 1.26
306     (defmethod frame-exit-frame ((c frame-exit))
307     (%frame-exit-frame c))
308 mikemac 1.22
309 adejneka 1.44 (defmethod run-frame-top-level ((frame application-frame) &key &allow-other-keys)
310 mikemac 1.22 (handler-bind ((frame-exit #'(lambda (condition)
311 gilbert 1.31 (declare (ignore condition))
312 mikemac 1.22 (return-from run-frame-top-level nil))))
313     (apply (first (frame-top-level frame)) frame (rest (frame-top-level frame)))))
314 mikemac 1.1
315 adejneka 1.44 (defmethod run-frame-top-level :around ((frame application-frame) &key)
316 mikemac 1.1 (let ((*application-frame* frame)
317     (*input-context* nil)
318     (*input-wait-test* nil)
319     (*input-wait-handler* nil)
320 moore 1.52 (*pointer-button-press-handler* nil)
321     (original-state (frame-state frame)))
322 mikemac 1.1 (declare (special *input-context* *input-wait-test* *input-wait-handler*
323     *pointer-button-press-handler*))
324 moore 1.52 (when (eq (frame-state frame) :disowned)
325     (adopt-frame (or (frame-manager frame) (find-frame-manager))
326     frame))
327     (unless (or (eq (frame-state frame) :enabled)
328     (eq (frame-state frame) :shrunk))
329     (enable-frame frame))
330 moore 1.24 (let ((query-io (frame-query-io frame)))
331 moore 1.52 (unwind-protect
332     (if query-io
333     (with-input-focus (query-io)
334     (call-next-method))
335     (call-next-method))
336     (case original-state
337     (:disabled
338     (disable-frame frame))
339     (:disowned
340     (disown-frame (frame-manager frame) frame)))))))
341 mikemac 1.1
342     (defmethod default-frame-top-level
343     ((frame application-frame)
344     &key (command-parser 'command-line-command-parser)
345     (command-unparser 'command-line-command-unparser)
346     (partial-command-parser
347     'command-line-read-remaining-arguments-for-partial-command)
348 moore 1.35 (prompt "Command: "))
349 mikemac 1.20 (loop
350     (let ((*standard-input* (frame-standard-input frame))
351     (*standard-output* (frame-standard-output frame))
352     (*query-io* (frame-query-io frame))
353 moore 1.47 (*pointer-documentation-output* (frame-pointer-documentation-output
354     frame))
355 mikemac 1.20 ;; during development, don't alter *error-output*
356 gilbert 1.39 ;; (*error-output* (frame-error-output frame))
357 mikemac 1.20 (*command-parser* command-parser)
358     (*command-unparser* command-unparser)
359     (*partial-command-parser* partial-command-parser)
360 gilbert 1.39 (prompt-style (make-text-style :fix :italic :normal)))
361 mikemac 1.20 (map-over-sheets #'(lambda (pane)
362     (if (and (typep pane 'clim-stream-pane)
363     (eq (pane-display-time pane) :command-loop)
364     (pane-display-function pane))
365     (let ((func (pane-display-function pane)))
366 adejneka 1.42 (window-clear pane)
367 adejneka 1.40 (funcall func frame pane) ; XXX other arguments
368     ; XXX incremental redisplay
369     )))
370 mikemac 1.20 (frame-top-level-sheet frame))
371     (when *standard-input*
372     (setf (cursor-visibility (stream-text-cursor *standard-input*)) t)
373 mikemac 1.21 (when prompt
374     (with-text-style (*standard-input* prompt-style)
375     (if (stringp prompt)
376 moore 1.35 (write-string prompt *standard-input*)
377     (funcall prompt *standard-input* frame))
378 adejneka 1.40 (finish-output *standard-input*)))
379 moore 1.35 (let ((command (read-frame-command frame)))
380     (fresh-line *standard-input*)
381     (when command
382     (execute-frame-command frame command))
383     (fresh-line *standard-input*))))))
384    
385 mikemac 1.1
386 adejneka 1.12 (defmethod read-frame-command ((frame application-frame) &key (stream *standard-input*))
387 mikemac 1.1 (read-command (frame-command-table frame) :stream stream))
388    
389     (defmethod execute-frame-command ((frame application-frame) command)
390 moore 1.35 (apply (command-name command) (command-arguments command)))
391    
392 mikemac 1.1 (defmethod make-pane-1 ((fm frame-manager) (frame application-frame) type &rest args)
393     `(make-pane-1 ,fm ,frame ',type ,@args))
394 moore 1.38
395     (defmethod make-pane-1 :around (fm (frame standard-application-frame) type
396     &rest args
397 moore 1.51 &key (input-buffer nil input-buffer-p)
398     &allow-other-keys)
399 moore 1.38 "Default input-buffer to the frame event queue."
400     (if input-buffer-p
401     (call-next-method)
402     (apply #'call-next-method fm frame type
403     :input-buffer (frame-event-queue frame)
404     args)))
405 mikemac 1.1
406     (defmethod adopt-frame ((fm frame-manager) (frame application-frame))
407     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
408     (setf (frame-manager frame) fm)
409 moore 1.52 (setf (port frame) (frame-manager-port fm))
410     (setf (graft frame) (find-graft :port (port frame)))
411 mikemac 1.1 (let* ((*application-frame* frame)
412 cvs 1.4 (t-l-s (make-pane-1 fm frame 'top-level-sheet-pane
413 moore 1.52 :name 'top-level-sheet
414     ;; enabling should be left to enable-frame
415     :enabled-p nil)))
416 mikemac 1.1 (setf (slot-value frame 'top-level-sheet) t-l-s)
417 moore 1.52 (generate-panes fm frame)
418     (setf (slot-value frame 'state) :disabled)
419     frame))
420 brian 1.28
421 mikemac 1.1 (defmethod disown-frame ((fm frame-manager) (frame application-frame))
422     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
423     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
424 moore 1.52 (setf (%frame-manager frame) nil)
425     (setf (slot-value frame 'state) :disowned)
426     frame)
427    
428     (defgeneric enable-frame (frame))
429     (defgeneric disable-frame (frame))
430    
431     (defgeneric note-frame-enabled (frame-manager frame))
432     (defgeneric note-frame-disbled (frame-manager frame))
433    
434     (defmethod enable-frame ((frame application-frame))
435     (setf (sheet-enabled-p (frame-top-level-sheet frame)) t)
436     (setf (slot-value frame 'state) :enabled)
437     (note-frame-enabled (frame-manager frame) frame))
438    
439     (defmethod disable-frame ((frame application-frame))
440     (setf (sheet-enabled-p (frame-top-level-sheet frame)) nil)
441     (setf (slot-value frame 'state) :disabled)
442     (note-frame-disabled (frame-manager frame) frame))
443    
444     (defmethod note-frame-enabled ((fm frame-manager) frame)
445     (declare (ignore frame))
446     t)
447    
448     (defmethod note-frame-disabled ((fm frame-manager) frame)
449     t)
450 mikemac 1.1
451 cvs 1.8 (defvar *pane-realizer* nil)
452    
453 mikemac 1.1 (defmacro with-look-and-feel-realization ((frame-manager frame) &body body)
454 cvs 1.8 `(let ((*pane-realizer* ,frame-manager)
455     (*application-frame* ,frame))
456 adejneka 1.45 (locally
457     ,@body)))
458 mikemac 1.1
459 brian 1.28 ; The menu-bar code in the following two functions is incorrect.
460     ; it needs to be moved to somewhere after the backend, since
461     ; it depends on the backend chosen.
462     ;
463     ; This hack slaps a menu-bar into the start of the application-frame,
464     ; in such a way that it is hard to find.
465     ;
466     ; FIXME
467     (defun make-single-pane-generate-panes-form (class-name menu-bar pane)
468 mikemac 1.1 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
469 brian 1.28 ; v-- hey, how can this be?
470 moore 1.17 (with-look-and-feel-realization (fm frame)
471 brian 1.28 (let ((pane ,(cond
472     ((eq menu-bar t)
473     `(vertically () (clim-internals::make-menu-bar
474     ',class-name)
475     ,pane))
476 brian 1.32 ((consp menu-bar)
477 brian 1.28 `(vertically () (clim-internals::make-menu-bar
478     (make-command-table nil
479     :menu ',menu-bar))
480     ,pane))
481     (menu-bar
482     `(vertically () (clim-internals::make-menu-bar
483     ',menu-bar)
484     ,pane))
485 gilbert 1.31 ;; The form below is unreachable with (listp
486     ;; menu-bar) instead of (consp menu-bar) above
487     ;; --GB
488 brian 1.28 (t pane))))
489     (setf (slot-value frame 'pane) pane)))))
490 mikemac 1.1
491 brian 1.28 ; could do with some refactoring [BTS] FIXME
492 moore 1.47 (defun make-panes-generate-panes-form (class-name menu-bar panes layouts
493     pointer-documentation)
494     (when pointer-documentation
495     (setf panes (append panes
496     '((%pointer-documentation%
497     pointer-documentation-pane)))))
498 mikemac 1.1 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
499     (let ((*application-frame* frame))
500 cvs 1.8 (with-look-and-feel-realization (fm frame)
501     (let ,(loop for (name . form) in panes
502     collect `(,name (or (find-pane-named frame ',name)
503     (let ((pane
504     ,(cond
505     ((and (= (length form) 1)
506     (listp (first form)))
507     (first form))
508     ((keywordp (first form))
509     (let ((maker (intern (concatenate 'string
510     "MAKE-CLIM-"
511     (symbol-name (first form))
512     "-PANE") :clim)))
513     (if (fboundp maker)
514     `(,maker :name ',name ,@(cdr form))
515     `(make-pane ',(first form)
516     :name ',name ,@(cdr form)))))
517     (t `(make-pane ',(first form) :name ',name ,@(cdr form))))))
518 gilbert 1.19 ;; hmm?! --GB
519     (setf (slot-value pane 'name) ',name)
520     ;;
521 cvs 1.8 (push pane (slot-value frame 'panes))
522     pane))))
523 brian 1.28 ; [BTS] added this, but is not sure that this is correct for adding
524     ; a menu-bar transparently, should also only be done where the
525     ; exterior window system does not support menus
526 moore 1.47 ,(if (or menu-bar pointer-documentation)
527 brian 1.28 `(setf (slot-value frame 'pane)
528     (ecase (frame-current-layout frame)
529     ,@(mapcar (lambda (layout)
530 moore 1.47 `(,(first layout)
531     (vertically ()
532     ,@(cond
533     ((eq menu-bar t)
534     `((clim-internals::make-menu-bar
535     ',class-name)))
536     ((consp menu-bar)
537     `((raising (:border-width 2 :background +Gray83+)
538     (clim-internals::make-menu-bar
539     (make-command-table
540     nil
541     :menu ',menu-bar)))))
542     (menu-bar
543     `((clim-internals::make-menu-bar
544     ',menu-bar)))
545     (t nil))
546     ,@(rest layout)
547     ,@(when pointer-documentation
548     '(%pointer-documentation%)))))
549 brian 1.28 layouts)))
550     `(setf (slot-value frame 'pane)
551     (ecase (frame-current-layout frame)
552     ,@layouts))))))))
553 mikemac 1.1
554     (defmacro define-application-frame (name superclasses slots &rest options)
555     (if (null superclasses)
556     (setq superclasses '(standard-application-frame)))
557     (let ((pane nil)
558     (panes nil)
559     (layouts nil)
560     (current-layout nil)
561 mikemac 1.23 (command-table (list name))
562 mikemac 1.1 (menu-bar t)
563     (disabled-commands nil)
564     (command-definer t)
565     (top-level '(default-frame-top-level))
566     (others nil)
567 moore 1.47 (command-name (intern (concatenate 'string "DEFINE-" (symbol-name name)
568     "-COMMAND")))
569     (pointer-documentation nil))
570 mikemac 1.1 (loop for (prop . values) in options
571     do (case prop
572     (:pane (setq pane (first values)))
573     (:panes (setq panes values))
574     (:layouts (setq layouts values))
575     (:command-table (setq command-table (first values)))
576 brian 1.28 (:menu-bar (setq menu-bar (if (listp values)
577     (first values)
578     values)))
579 mikemac 1.1 (:disabled-commands (setq disabled-commands values))
580     (:command-definer (setq command-definer (first values)))
581     (:top-level (setq top-level (first values)))
582 moore 1.47 (:pointer-documentation (setq pointer-documentation (car values)))
583 mikemac 1.1 (t (push (cons prop values) others))))
584     (if (or (and pane panes)
585     (and pane layouts))
586     (error ":pane cannot be specified along with either :panes or :layouts"))
587     (if pane
588     (setq panes (list 'single-pane pane)
589 moore 1.17 layouts `((:default ,(car pane)))))
590 mikemac 1.1 (setq current-layout (first (first layouts)))
591     `(progn
592     (defclass ,name ,superclasses
593     ,slots
594     (:default-initargs
595     :name ',name
596     :pretty-name ,(string-capitalize name)
597 mikemac 1.23 :command-table (find-command-table ',(first command-table))
598 mikemac 1.1 :disabled-commands ',disabled-commands
599 brian 1.28 :menu-bar ',menu-bar
600 mikemac 1.1 :current-layout ',current-layout
601     :layouts ',layouts
602     :top-level ',top-level
603     )
604     ,@others)
605     ,(if pane
606 brian 1.28 (make-single-pane-generate-panes-form name menu-bar pane)
607 moore 1.47 (make-panes-generate-panes-form name menu-bar panes layouts
608     pointer-documentation))
609 mikemac 1.23 ,@(if command-table
610     `((define-command-table ,@command-table)))
611 mikemac 1.1 ,@(if command-definer
612     `((defmacro ,command-name (name-and-options arguements &rest body)
613     (let ((name (if (listp name-and-options) (first name-and-options) name-and-options))
614 mikemac 1.23 (options (if (listp name-and-options) (cdr name-and-options) nil))
615     (command-table ',(first command-table)))
616     `(define-command (,name :command-table ,command-table ,@options) ,arguements ,@body))))))))
617 mikemac 1.1
618     (defun make-application-frame (frame-name
619     &rest options
620 moore 1.52 &key (pretty-name
621     (string-capitalize frame-name))
622     (frame-manager nil frame-manager-p)
623     enable
624     (state nil state-supplied-p)
625     left top right bottom width height
626     save-under (frame-class frame-name)
627 mikemac 1.1 &allow-other-keys)
628 moore 1.52 (declare (ignore left top right bottom width height save-under))
629     (with-keywords-removed (options (:pretty-name :frame-manager :enable :state
630     :left :top :right :bottom :width :height
631     :save-under:frame-class))
632     (let ((frame (apply #'make-instance frame-class
633     :name frame-name :pretty-name pretty-name options)))
634     (when frame-manager-p
635     (adopt-frame frame-manager frame))
636     (cond ((or enable (eq state :enabled))
637     (enable-frame frame))
638     ((and (eq state :disowned)
639     (not (eq (frame-state frame) :disowned)))
640     (disown-frame (frame-manager frame) frame))
641     (state-supplied-p
642     (warn ":state ~S not supported yet." state)))
643     frame)))
644 cvs 1.4
645 cvs 1.7 ;;; Menu frame class
646    
647     (defclass menu-frame ()
648     ((left :initform 0 :initarg :left)
649     (top :initform 0 :initarg :top)
650     (top-level-sheet :initform nil :reader frame-top-level-sheet)
651     (pane :reader frame-pane :initarg :pane)
652     (graft :initform nil :accessor graft)
653     (manager :initform nil :accessor frame-manager)))
654 adejneka 1.46
655 cvs 1.7 (defmethod adopt-frame ((fm frame-manager) (frame menu-frame))
656     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
657 adejneka 1.46 (setf (frame-manager frame) fm)
658 cvs 1.7 (let* ((t-l-s (make-pane-1 fm *application-frame* 'unmanaged-top-level-sheet-pane
659     :name 'top-level-sheet)))
660     (setf (slot-value frame 'top-level-sheet) t-l-s)
661     (sheet-adopt-child t-l-s (frame-pane frame))
662     (let ((graft (find-graft :port (frame-manager-port fm))))
663     (sheet-adopt-child graft t-l-s)
664     (setf (graft frame) graft))
665 hatchond 1.11 (let ((space (compose-space t-l-s)))
666 cvs 1.7 (allocate-space (frame-pane frame)
667     (space-requirement-width space)
668     (space-requirement-height space))
669     (setf (sheet-region t-l-s)
670     (make-bounding-rectangle 0 0
671     (space-requirement-width space)
672     (space-requirement-height space))))
673     (setf (sheet-transformation t-l-s)
674     (make-translation-transformation (slot-value frame 'left)
675     (slot-value frame 'top)))))
676    
677     (defmethod disown-frame ((fm frame-manager) (frame menu-frame))
678     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
679     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
680     (setf (frame-manager frame) nil))
681    
682     (defun make-menu-frame (pane &key (left 0) (top 0))
683     (make-instance 'menu-frame :pane pane :left left :top top))
684 moore 1.18
685     ;;; Frames and presentations
686    
687     (defmethod frame-find-innermost-applicable-presentation
688     ((frame standard-application-frame) input-context stream x y
689     &key event)
690     (find-innermost-applicable-presentation input-context stream
691     x y
692     :frame frame :event event))
693    
694 adejneka 1.41 (defmethod frame-input-context-button-press-handler
695 moore 1.18 ((frame standard-application-frame)
696     (stream output-recording-stream)
697     button-press-event)
698     (let ((presentation (find-innermost-applicable-presentation
699     *input-context*
700     stream
701     (pointer-event-x button-press-event)
702     (pointer-event-y button-press-event)
703 moore 1.37 :frame frame
704     :event button-press-event)))
705 moore 1.18 (when presentation
706     (throw-highlighted-presentation presentation
707     *input-context*
708     button-press-event))))
709    
710     (defmethod frame-input-context-button-press-handler
711     ((frame standard-application-frame) stream button-press-event)
712 mikemac 1.36 (declare (ignore stream button-press-event))
713 moore 1.27 nil)
714 moore 1.18
715 moore 1.47 (defgeneric frame-update-pointer-documentation
716     (frame input-context stream event))
717    
718     (defconstant +button-documentation+ '((#.+pointer-left-button+ "L")
719     (#.+pointer-middle-button+ "M")
720     (#.+pointer-right-button+ "R")))
721    
722 moore 1.48 (defconstant +modifier-documentation+
723     '((#.+shift-key+ "sh" "Shift")
724     (#.+control-key+ "c" "Control")
725     (#.+meta-key+ "m" "Meta")
726     (#.+super-key+ "s" "Super")
727     (#.+hyper-key+ "h" "Hyper")))
728    
729     ;;; Give a coherent order to sets of modifier combinations. Multi-key combos
730     ;;; come after single keys.
731    
732     (defun cmp-modifiers (a b)
733     (let ((cnt-a (logcount a))
734     (cnt-b (logcount b)))
735     (cond ((eql cnt-a cnt-b)
736     (< a b))
737     (t (< cnt-a cnt-b)))))
738    
739     (defun print-modifiers (stream modifiers style)
740 moore 1.49 (if (zerop modifiers)
741     (when (eq style :long)
742     (write-string "<nothing>" stream))
743     (loop with trailing = nil
744     for (bit short long) in +modifier-documentation+
745     when (logtest bit modifiers)
746     do (progn
747     (format stream "~:[~;-~]~A" trailing (if (eq style :short)
748     short
749     long))
750     (setq trailing t)))))
751 moore 1.48
752    
753     ;;; We don't actually want to print out the translator documentation and redraw
754     ;;; the pointer documentation window on every motion event. So, we compute a
755     ;;; state object (basically modifier state and a list of the applicable
756     ;;; presentation, translator and input context on each mouse button),
757     ;;; compare it to the previous state object, and only write out documentation
758     ;;; if they are different. I suppose it's possible that this state object
759     ;;; doesn't capture all possible documentation changes -- the doc generator is
760     ;;; a function, after all -- but that's just tough.
761     ;;;
762     ;;; It would be nice to evolve this into a protocol so that elements other than
763     ;;; presentations -- menu choices, for example -- could influence pointer
764     ;;; documentation window.
765    
766 moore 1.50 (defgeneric frame-compute-pointer-documentation-state
767     (frame input-context stream event)
768     (:documentation
769     "Compute a state object that will be used to generate pointer documentation."))
770    
771     (defmethod frame-compute-pointer-documentation-state
772     ((frame standard-application-frame) input-context stream event)
773     (let* ((current-modifier (event-modifier-state event))
774     (x (device-event-x event))
775     (y (device-event-y event))
776     (new-translators
777     (loop for (button) in +button-documentation+
778     for context-list = (multiple-value-list
779     (find-innermost-presentation-context
780     input-context
781     stream
782     x y
783     :modifier-state current-modifier
784     :button button))
785     when (car context-list)
786     collect (cons button context-list))))
787     (list current-modifier new-translators)))
788    
789     (defgeneric frame-compare-pointer-documentation-state
790     (frame input-context stream old-state new-state))
791    
792     (defmethod frame-compare-pointer-documentation-state
793     ((frame standard-application-frame) input-context stream
794     old-state new-state)
795     (equal old-state new-state))
796    
797     (defgeneric frame-print-pointer-documentation
798     (frame input-context stream state event))
799    
800     (defmethod frame-print-pointer-documentation
801     ((frame standard-application-frame) input-context stream state event)
802     (unless state
803     (return-from frame-print-pointer-documentation nil))
804     (destructuring-bind (current-modifier new-translators)
805     state
806     (let ((x (device-event-x event))
807     (y (device-event-y event))
808     (pstream *pointer-documentation-output*))
809     (loop for (button presentation translator context)
810     in new-translators
811     for name = (cadr (assoc button +button-documentation+))
812     for first-one = t then nil
813     do (progn
814     (unless first-one
815     (write-string "; " pstream))
816     (unless (zerop current-modifier)
817     (print-modifiers pstream current-modifier :short)
818     (write-string "-" pstream))
819     (format pstream "~A: " name)
820     (document-presentation-translator translator
821     presentation
822     (input-context-type context)
823     *application-frame*
824     event
825     stream
826     x y
827     :stream pstream
828     :documentation-type
829     :pointer))
830     finally (when new-translators
831     (write-char #\. pstream)))
832     ;; Wasteful to do this after doing
833     ;; find-innermost-presentation-context above... look at doing this
834     ;; first and then doing the innermost test.
835     (let ((all-translators (find-applicable-translators
836     (stream-output-history stream)
837     input-context
838     *application-frame*
839     stream
840     x y
841     :for-menu t))
842     (other-modifiers nil))
843     (loop for (translator) in all-translators
844     for gesture = (gesture translator)
845     unless (eq gesture t)
846     do (loop for (name type modifier) in gesture
847     unless (eql modifier current-modifier)
848     do (pushnew modifier other-modifiers)))
849     (when other-modifiers
850     (setf other-modifiers (sort other-modifiers #'cmp-modifiers))
851     (terpri pstream)
852     (write-string "To see other commands, press " pstream)
853     (loop for modifier-tail on other-modifiers
854     for (modifier) = modifier-tail
855     for count from 0
856     do (progn
857     (if (null (cdr modifier-tail))
858     (progn
859     (when (> count 1)
860     (write-char #\, pstream))
861     (when (> count 0)
862     (write-string " or " pstream)))
863     (when (> count 0)
864     (write-string ", " pstream)))
865     (print-modifiers pstream modifier :long)))
866     (write-char #\. pstream))))))
867    
868 moore 1.47 (defmethod frame-update-pointer-documentation
869     ((frame standard-application-frame) input-context stream event)
870     (when *pointer-documentation-output*
871     (with-accessors ((frame-documentation-state frame-documentation-state))
872     frame
873 moore 1.50 (let ((new-state (frame-compute-pointer-documentation-state frame
874     input-context
875     stream
876     event)))
877     (unless (frame-compare-pointer-documentation-state
878     frame
879     input-context
880     stream
881     frame-documentation-state
882     new-state)
883     (window-clear *pointer-documentation-output*)
884     (frame-print-pointer-documentation frame
885     input-context
886     stream
887     new-state
888     event)
889     (setq frame-documentation-state new-state))))))
890 moore 1.47
891 moore 1.18 (defmethod frame-input-context-track-pointer
892     ((frame standard-application-frame)
893     input-context
894     (stream output-recording-stream) event)
895     (declare (ignore input-context event))
896     nil)
897    
898     (defmethod frame-input-context-track-pointer
899     ((frame standard-application-frame) input-context stream event)
900 mikemac 1.36 (declare (ignore input-context stream event))
901 moore 1.27 nil)
902 moore 1.18
903     (defmethod frame-input-context-track-pointer :before
904     ((frame standard-application-frame) input-context stream event)
905 moore 1.47 (flet ((maybe-unhighlight (presentation)
906     (when (and (frame-hilited-presentation frame)
907     (not (eq presentation
908     (car (frame-hilited-presentation frame)))))
909     (highlight-presentation-1 (car (frame-hilited-presentation frame))
910     (cdr (frame-hilited-presentation frame))
911     :unhighlight))))
912 moore 1.18 (if (output-recording-stream-p stream)
913     (let ((presentation (find-innermost-applicable-presentation
914     input-context
915     stream
916 moore 1.50 (device-event-x event)
917     (device-event-y event)
918 moore 1.37 :frame frame
919     :modifier-state (event-modifier-state event))))
920 moore 1.47 (maybe-unhighlight presentation)
921 moore 1.34 (if presentation
922     (when (not (eq presentation
923     (car (frame-hilited-presentation frame))))
924     (setf (frame-hilited-presentation frame)
925     (cons presentation stream))
926     (highlight-presentation-1 presentation stream :highlight))
927 moore 1.47 (setf (frame-hilited-presentation frame) nil)))
928     (progn
929     (maybe-unhighlight nil)
930     (setf (frame-hilited-presentation frame) nil))))
931     (frame-update-pointer-documentation frame input-context stream event))
932 moore 1.34
933 moore 1.27
934     (defun simple-event-loop ()
935     "An simple event loop for applications that want all events to be handled by
936     handle-event methods"
937 adejneka 1.41 (let ((queue (frame-event-queue *application-frame*)))
938     (loop for event = (event-queue-read queue)
939     ;; EVENT-QUEUE-READ in single-process mode calls PROCESS-NEXT-EVENT itself.
940     do (handle-event (event-sheet event) event))))

  ViewVC Help
Powered by ViewVC 1.1.5