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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.47 - (hide annotations)
Fri Aug 2 08:05:16 2002 UTC (11 years, 8 months ago) by moore
Branch: MAIN
Changes since 1.46: +103 -33 lines
First try at pointer documentation.
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     :initform nil
94     :accessor frame-state)
95     (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     (*pointer-button-press-handler* nil))
321     (declare (special *input-context* *input-wait-test* *input-wait-handler*
322     *pointer-button-press-handler*))
323 moore 1.24 (let ((query-io (frame-query-io frame)))
324     (if query-io
325     (with-input-focus (query-io)
326     (call-next-method))
327     (call-next-method)))))
328 mikemac 1.1
329     (defmethod default-frame-top-level
330     ((frame application-frame)
331     &key (command-parser 'command-line-command-parser)
332     (command-unparser 'command-line-command-unparser)
333     (partial-command-parser
334     'command-line-read-remaining-arguments-for-partial-command)
335 moore 1.35 (prompt "Command: "))
336 mikemac 1.20 (loop
337     (let ((*standard-input* (frame-standard-input frame))
338     (*standard-output* (frame-standard-output frame))
339     (*query-io* (frame-query-io frame))
340 moore 1.47 (*pointer-documentation-output* (frame-pointer-documentation-output
341     frame))
342 mikemac 1.20 ;; during development, don't alter *error-output*
343 gilbert 1.39 ;; (*error-output* (frame-error-output frame))
344 mikemac 1.20 (*command-parser* command-parser)
345     (*command-unparser* command-unparser)
346     (*partial-command-parser* partial-command-parser)
347 gilbert 1.39 (prompt-style (make-text-style :fix :italic :normal)))
348 mikemac 1.20 (map-over-sheets #'(lambda (pane)
349     (if (and (typep pane 'clim-stream-pane)
350     (eq (pane-display-time pane) :command-loop)
351     (pane-display-function pane))
352     (let ((func (pane-display-function pane)))
353 adejneka 1.42 (window-clear pane)
354 adejneka 1.40 (funcall func frame pane) ; XXX other arguments
355     ; XXX incremental redisplay
356     )))
357 mikemac 1.20 (frame-top-level-sheet frame))
358     (when *standard-input*
359     (setf (cursor-visibility (stream-text-cursor *standard-input*)) t)
360 mikemac 1.21 (when prompt
361     (with-text-style (*standard-input* prompt-style)
362     (if (stringp prompt)
363 moore 1.35 (write-string prompt *standard-input*)
364     (funcall prompt *standard-input* frame))
365 adejneka 1.40 (finish-output *standard-input*)))
366 moore 1.35 (let ((command (read-frame-command frame)))
367     (fresh-line *standard-input*)
368     (when command
369     (execute-frame-command frame command))
370     (fresh-line *standard-input*))))))
371    
372 mikemac 1.1
373 adejneka 1.12 (defmethod read-frame-command ((frame application-frame) &key (stream *standard-input*))
374 mikemac 1.1 (read-command (frame-command-table frame) :stream stream))
375    
376     (defmethod execute-frame-command ((frame application-frame) command)
377 moore 1.35 (apply (command-name command) (command-arguments command)))
378    
379 mikemac 1.1 (defmethod make-pane-1 ((fm frame-manager) (frame application-frame) type &rest args)
380     `(make-pane-1 ,fm ,frame ',type ,@args))
381 moore 1.38
382     (defmethod make-pane-1 :around (fm (frame standard-application-frame) type
383     &rest args
384     &key (input-buffer nil input-buffer-p))
385     "Default input-buffer to the frame event queue."
386     (if input-buffer-p
387     (call-next-method)
388     (apply #'call-next-method fm frame type
389     :input-buffer (frame-event-queue frame)
390     args)))
391 mikemac 1.1
392     (defmethod adopt-frame ((fm frame-manager) (frame application-frame))
393     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
394     (setf (frame-manager frame) fm)
395     (let* ((*application-frame* frame)
396 cvs 1.4 (t-l-s (make-pane-1 fm frame 'top-level-sheet-pane
397 mikemac 1.1 :name 'top-level-sheet)))
398     (setf (slot-value frame 'top-level-sheet) t-l-s)
399     (generate-panes fm frame)))
400 brian 1.28
401 mikemac 1.1 (defmethod disown-frame ((fm frame-manager) (frame application-frame))
402     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
403     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
404 adejneka 1.46 (setf (%frame-manager frame) nil))
405 mikemac 1.1
406 cvs 1.8 (defvar *pane-realizer* nil)
407    
408 mikemac 1.1 (defmacro with-look-and-feel-realization ((frame-manager frame) &body body)
409 cvs 1.8 `(let ((*pane-realizer* ,frame-manager)
410     (*application-frame* ,frame))
411 adejneka 1.45 (locally
412     ,@body)))
413 mikemac 1.1
414 brian 1.28 ; The menu-bar code in the following two functions is incorrect.
415     ; it needs to be moved to somewhere after the backend, since
416     ; it depends on the backend chosen.
417     ;
418     ; This hack slaps a menu-bar into the start of the application-frame,
419     ; in such a way that it is hard to find.
420     ;
421     ; FIXME
422     (defun make-single-pane-generate-panes-form (class-name menu-bar pane)
423 mikemac 1.1 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
424 brian 1.28 ; v-- hey, how can this be?
425 moore 1.17 (with-look-and-feel-realization (fm frame)
426 brian 1.28 (let ((pane ,(cond
427     ((eq menu-bar t)
428     `(vertically () (clim-internals::make-menu-bar
429     ',class-name)
430     ,pane))
431 brian 1.32 ((consp menu-bar)
432 brian 1.28 `(vertically () (clim-internals::make-menu-bar
433     (make-command-table nil
434     :menu ',menu-bar))
435     ,pane))
436     (menu-bar
437     `(vertically () (clim-internals::make-menu-bar
438     ',menu-bar)
439     ,pane))
440 gilbert 1.31 ;; The form below is unreachable with (listp
441     ;; menu-bar) instead of (consp menu-bar) above
442     ;; --GB
443 brian 1.28 (t pane))))
444     (setf (slot-value frame 'pane) pane)))))
445 mikemac 1.1
446 brian 1.28 ; could do with some refactoring [BTS] FIXME
447 moore 1.47 (defun make-panes-generate-panes-form (class-name menu-bar panes layouts
448     pointer-documentation)
449     (when pointer-documentation
450     (setf panes (append panes
451     '((%pointer-documentation%
452     pointer-documentation-pane)))))
453 mikemac 1.1 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
454     (let ((*application-frame* frame))
455 cvs 1.8 (with-look-and-feel-realization (fm frame)
456     (let ,(loop for (name . form) in panes
457     collect `(,name (or (find-pane-named frame ',name)
458     (let ((pane
459     ,(cond
460     ((and (= (length form) 1)
461     (listp (first form)))
462     (first form))
463     ((keywordp (first form))
464     (let ((maker (intern (concatenate 'string
465     "MAKE-CLIM-"
466     (symbol-name (first form))
467     "-PANE") :clim)))
468     (if (fboundp maker)
469     `(,maker :name ',name ,@(cdr form))
470     `(make-pane ',(first form)
471     :name ',name ,@(cdr form)))))
472     (t `(make-pane ',(first form) :name ',name ,@(cdr form))))))
473 gilbert 1.19 ;; hmm?! --GB
474     (setf (slot-value pane 'name) ',name)
475     ;;
476 cvs 1.8 (push pane (slot-value frame 'panes))
477     pane))))
478 brian 1.28 ; [BTS] added this, but is not sure that this is correct for adding
479     ; a menu-bar transparently, should also only be done where the
480     ; exterior window system does not support menus
481 moore 1.47 ,(if (or menu-bar pointer-documentation)
482 brian 1.28 `(setf (slot-value frame 'pane)
483     (ecase (frame-current-layout frame)
484     ,@(mapcar (lambda (layout)
485 moore 1.47 `(,(first layout)
486     (vertically ()
487     ,@(cond
488     ((eq menu-bar t)
489     `((clim-internals::make-menu-bar
490     ',class-name)))
491     ((consp menu-bar)
492     `((raising (:border-width 2 :background +Gray83+)
493     (clim-internals::make-menu-bar
494     (make-command-table
495     nil
496     :menu ',menu-bar)))))
497     (menu-bar
498     `((clim-internals::make-menu-bar
499     ',menu-bar)))
500     (t nil))
501     ,@(rest layout)
502     ,@(when pointer-documentation
503     '(%pointer-documentation%)))))
504 brian 1.28 layouts)))
505     `(setf (slot-value frame 'pane)
506     (ecase (frame-current-layout frame)
507     ,@layouts))))))))
508 mikemac 1.1
509     (defmacro define-application-frame (name superclasses slots &rest options)
510     (if (null superclasses)
511     (setq superclasses '(standard-application-frame)))
512     (let ((pane nil)
513     (panes nil)
514     (layouts nil)
515     (current-layout nil)
516 mikemac 1.23 (command-table (list name))
517 mikemac 1.1 (menu-bar t)
518     (disabled-commands nil)
519     (command-definer t)
520     (top-level '(default-frame-top-level))
521     (others nil)
522 moore 1.47 (command-name (intern (concatenate 'string "DEFINE-" (symbol-name name)
523     "-COMMAND")))
524     (pointer-documentation nil))
525 mikemac 1.1 (loop for (prop . values) in options
526     do (case prop
527     (:pane (setq pane (first values)))
528     (:panes (setq panes values))
529     (:layouts (setq layouts values))
530     (:command-table (setq command-table (first values)))
531 brian 1.28 (:menu-bar (setq menu-bar (if (listp values)
532     (first values)
533     values)))
534 mikemac 1.1 (:disabled-commands (setq disabled-commands values))
535     (:command-definer (setq command-definer (first values)))
536     (:top-level (setq top-level (first values)))
537 moore 1.47 (:pointer-documentation (setq pointer-documentation (car values)))
538 mikemac 1.1 (t (push (cons prop values) others))))
539     (if (or (and pane panes)
540     (and pane layouts))
541     (error ":pane cannot be specified along with either :panes or :layouts"))
542     (if pane
543     (setq panes (list 'single-pane pane)
544 moore 1.17 layouts `((:default ,(car pane)))))
545 mikemac 1.1 (setq current-layout (first (first layouts)))
546     `(progn
547     (defclass ,name ,superclasses
548     ,slots
549     (:default-initargs
550     :name ',name
551     :pretty-name ,(string-capitalize name)
552 mikemac 1.23 :command-table (find-command-table ',(first command-table))
553 mikemac 1.1 :disabled-commands ',disabled-commands
554 brian 1.28 :menu-bar ',menu-bar
555 mikemac 1.1 :current-layout ',current-layout
556     :layouts ',layouts
557     :top-level ',top-level
558     )
559     ,@others)
560     ,(if pane
561 brian 1.28 (make-single-pane-generate-panes-form name menu-bar pane)
562 moore 1.47 (make-panes-generate-panes-form name menu-bar panes layouts
563     pointer-documentation))
564 mikemac 1.23 ,@(if command-table
565     `((define-command-table ,@command-table)))
566 mikemac 1.1 ,@(if command-definer
567     `((defmacro ,command-name (name-and-options arguements &rest body)
568     (let ((name (if (listp name-and-options) (first name-and-options) name-and-options))
569 mikemac 1.23 (options (if (listp name-and-options) (cdr name-and-options) nil))
570     (command-table ',(first command-table)))
571     `(define-command (,name :command-table ,command-table ,@options) ,arguements ,@body))))))))
572 mikemac 1.1
573     (defun make-application-frame (frame-name
574     &rest options
575     &key pretty-name frame-manager enable state
576     left top right bottom width height save-under
577     frame-class
578     &allow-other-keys)
579 mikemac 1.16 (declare (ignore enable state left top right bottom width height save-under))
580 mikemac 1.1 (setq options (loop for (key value) on options by #'cddr
581     if (not (member key '(:pretty-name :frame-manager :enable :state
582     :left :top :right :bottom :width :height :save-under
583     :frame-class)
584 mikemac 1.15 :test #'eq))
585 mikemac 1.1 nconc (list key value)))
586     (if (null frame-class)
587     (setq frame-class frame-name))
588     (if (null pretty-name)
589     (setq pretty-name (string-capitalize frame-name)))
590     (if (null frame-manager)
591     (setq frame-manager (find-frame-manager)))
592     (let ((frame (apply #'make-instance frame-class
593     :port (frame-manager-port frame-manager)
594     :graft (find-graft :port (frame-manager-port frame-manager))
595     :name frame-name :pretty-name pretty-name options)))
596     (adopt-frame frame-manager frame)
597     frame))
598 cvs 1.4
599 cvs 1.7 ;;; Menu frame class
600    
601     (defclass menu-frame ()
602     ((left :initform 0 :initarg :left)
603     (top :initform 0 :initarg :top)
604     (top-level-sheet :initform nil :reader frame-top-level-sheet)
605     (pane :reader frame-pane :initarg :pane)
606     (graft :initform nil :accessor graft)
607     (manager :initform nil :accessor frame-manager)))
608 adejneka 1.46
609 cvs 1.7 (defmethod adopt-frame ((fm frame-manager) (frame menu-frame))
610     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
611 adejneka 1.46 (setf (frame-manager frame) fm)
612 cvs 1.7 (let* ((t-l-s (make-pane-1 fm *application-frame* 'unmanaged-top-level-sheet-pane
613     :name 'top-level-sheet)))
614     (setf (slot-value frame 'top-level-sheet) t-l-s)
615     (sheet-adopt-child t-l-s (frame-pane frame))
616     (let ((graft (find-graft :port (frame-manager-port fm))))
617     (sheet-adopt-child graft t-l-s)
618     (setf (graft frame) graft))
619 hatchond 1.11 (let ((space (compose-space t-l-s)))
620 cvs 1.7 (allocate-space (frame-pane frame)
621     (space-requirement-width space)
622     (space-requirement-height space))
623     (setf (sheet-region t-l-s)
624     (make-bounding-rectangle 0 0
625     (space-requirement-width space)
626     (space-requirement-height space))))
627     (setf (sheet-transformation t-l-s)
628     (make-translation-transformation (slot-value frame 'left)
629     (slot-value frame 'top)))))
630    
631     (defmethod disown-frame ((fm frame-manager) (frame menu-frame))
632     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
633     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
634     (setf (frame-manager frame) nil))
635    
636     (defun make-menu-frame (pane &key (left 0) (top 0))
637     (make-instance 'menu-frame :pane pane :left left :top top))
638 moore 1.18
639     ;;; Frames and presentations
640    
641     (defmethod frame-find-innermost-applicable-presentation
642     ((frame standard-application-frame) input-context stream x y
643     &key event)
644     (find-innermost-applicable-presentation input-context stream
645     x y
646     :frame frame :event event))
647    
648 adejneka 1.41 (defmethod frame-input-context-button-press-handler
649 moore 1.18 ((frame standard-application-frame)
650     (stream output-recording-stream)
651     button-press-event)
652     (let ((presentation (find-innermost-applicable-presentation
653     *input-context*
654     stream
655     (pointer-event-x button-press-event)
656     (pointer-event-y button-press-event)
657 moore 1.37 :frame frame
658     :event button-press-event)))
659 moore 1.18 (when presentation
660     (throw-highlighted-presentation presentation
661     *input-context*
662     button-press-event))))
663    
664     (defmethod frame-input-context-button-press-handler
665     ((frame standard-application-frame) stream button-press-event)
666 mikemac 1.36 (declare (ignore stream button-press-event))
667 moore 1.27 nil)
668 moore 1.18
669 moore 1.47 (defgeneric frame-update-pointer-documentation
670     (frame input-context stream event))
671    
672     (defconstant +button-documentation+ '((#.+pointer-left-button+ "L")
673     (#.+pointer-middle-button+ "M")
674     (#.+pointer-right-button+ "R")))
675    
676     (defmethod frame-update-pointer-documentation
677     ((frame standard-application-frame) input-context stream event)
678     (when *pointer-documentation-output*
679     (with-accessors ((frame-documentation-state frame-documentation-state))
680     frame
681     (destructuring-bind (&optional modifier-bits translators)
682     frame-documentation-state
683     (let* ((current-modifier (event-modifier-state event))
684     (x (pointer-event-x event))
685     (y (pointer-event-y event))
686     (new-translators
687     (loop for (button) in +button-documentation+
688     for context-list = (multiple-value-list
689     (find-innnermost-presentation-context
690     input-context
691     stream
692     x y
693     :modifier-state current-modifier
694     :button button))
695     when (car context-list)
696     collect (cons button context-list))))
697     (unless (and (eql modifier-bits current-modifier)
698     (equal translators new-translators))
699     ;; State is different, so print out new documentation
700     (window-clear *pointer-documentation-output*)
701     (loop for (button presentation translator context)
702     in new-translators
703     for name = (cadr (assoc button +button-documentation+))
704     do (progn
705     (format *pointer-documentation-output* "~A: " name)
706     (document-presentation-translator
707     translator
708     presentation
709     (input-context-type context)
710     *application-frame*
711     event
712     stream
713     x y
714     :stream *pointer-documentation-output*
715     :documentation-type :pointer)
716     (write-string " " *pointer-documentation-output*)))
717     (setq frame-documentation-state (list current-modifier
718     new-translators))))))))
719    
720 moore 1.18 (defmethod frame-input-context-track-pointer
721     ((frame standard-application-frame)
722     input-context
723     (stream output-recording-stream) event)
724     (declare (ignore input-context event))
725     nil)
726    
727     (defmethod frame-input-context-track-pointer
728     ((frame standard-application-frame) input-context stream event)
729 mikemac 1.36 (declare (ignore input-context stream event))
730 moore 1.27 nil)
731 moore 1.18
732     (defmethod frame-input-context-track-pointer :before
733     ((frame standard-application-frame) input-context stream event)
734 moore 1.47 (flet ((maybe-unhighlight (presentation)
735     (when (and (frame-hilited-presentation frame)
736     (not (eq presentation
737     (car (frame-hilited-presentation frame)))))
738     (highlight-presentation-1 (car (frame-hilited-presentation frame))
739     (cdr (frame-hilited-presentation frame))
740     :unhighlight))))
741 moore 1.18 (if (output-recording-stream-p stream)
742     (let ((presentation (find-innermost-applicable-presentation
743     input-context
744     stream
745     (pointer-event-x event)
746     (pointer-event-y event)
747 moore 1.37 :frame frame
748     :modifier-state (event-modifier-state event))))
749 moore 1.47 (maybe-unhighlight presentation)
750 moore 1.34 (if presentation
751     (when (not (eq presentation
752     (car (frame-hilited-presentation frame))))
753     (setf (frame-hilited-presentation frame)
754     (cons presentation stream))
755     (highlight-presentation-1 presentation stream :highlight))
756 moore 1.47 (setf (frame-hilited-presentation frame) nil)))
757     (progn
758     (maybe-unhighlight nil)
759     (setf (frame-hilited-presentation frame) nil))))
760     (frame-update-pointer-documentation frame input-context stream event))
761 moore 1.34
762 moore 1.27
763     (defun simple-event-loop ()
764     "An simple event loop for applications that want all events to be handled by
765     handle-event methods"
766 adejneka 1.41 (let ((queue (frame-event-queue *application-frame*)))
767     (loop for event = (event-queue-read queue)
768     ;; EVENT-QUEUE-READ in single-process mode calls PROCESS-NEXT-EVENT itself.
769     do (handle-event (event-sheet event) event))))

  ViewVC Help
Powered by ViewVC 1.1.5