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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.31 - (hide annotations)
Sun Apr 28 07:54:33 2002 UTC (11 years, 11 months ago) by gilbert
Branch: MAIN
Changes since 1.30: +5 -1 lines
RUN-FRAME-TOP-LEVEL
    added ignore declaration

MAKE-SINGLE-PANE-GENERATE-PANES-FORM
    Switched LISTP into CONSP.
    Is that the right thing to do?
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     (defvar *application-frame* nil)
27     (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     `(let (('*frame-manager* ,frame-manager))
53     (declare (special *frame-manager*))
54     (block ,@body)))
55    
56 mikemac 1.1 ;;; Application-Frame class
57    
58     (defclass application-frame ()
59     ((port :initform nil
60     :initarg :port
61     :accessor port)
62     (graft :initform nil
63     :initarg :graft
64     :accessor graft)
65     (name :initarg :name
66     :reader frame-name)
67     (pretty-name :initarg :pretty-name
68     :accessor frame-pretty-name)
69     (command-table :initarg :command-table
70     :initform nil
71     :accessor frame-command-table)
72     (disabled-commands :initarg :disabled-commands
73     :initform nil
74     :accessor frame-disabled-commands)
75     (pane :reader frame-pane)
76     (panes :initform nil
77     :reader frame-panes)
78     (layouts :initform nil
79     :initarg :layouts
80     :reader frame-layouts)
81     (current-layout :initform nil
82     :initarg :current-layout
83     :reader frame-current-layout)
84     (top-level-sheet :initform nil
85     :reader frame-top-level-sheet)
86     (menu-bar :initarg :menu-bar
87     :initform nil)
88     (calling-frame :initarg :calling-frame
89     :initform nil)
90     (state :initarg :state
91     :initform nil
92     :accessor frame-state)
93     (manager :initform nil
94     :reader frame-manager)
95     (properties :initarg :properties
96     :initform nil)
97     (top-level :initform '(default-frame-top-level)
98     :initarg :top-level
99     :reader frame-top-level)
100 moore 1.18 (hilited-presentation :initform nil
101     :initarg :hilited-presentation
102     :accessor frame-hilited-presentation)
103 moore 1.27 (event-queue :initform (make-instance 'standard-event-queue)
104 moore 1.24 :initarg :intercept-event-queue
105 moore 1.27 :accessor frame-event-queue)))
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     ())
182    
183     (defmethod (setf frame-manager) (fm (frame application-frame))
184     (let ((old-manager (frame-manager frame)))
185     (setf (slot-value frame 'manager) nil)
186     (when old-manager
187     (disown-frame old-manager frame)
188     (setf (slot-value frame 'panes) nil)
189     (setf (slot-value frame 'layouts) nil))
190     (setf (slot-value frame 'manager) fm)))
191    
192     (defmethod (setf frame-current-layout) (name (frame application-frame))
193     (declare (ignore name))
194     (generate-panes (frame-manager frame) frame))
195    
196     (defmethod generate-panes :before (fm (frame application-frame))
197     (declare (ignore fm))
198     (when (and (slot-boundp frame 'pane)
199     (frame-pane frame))
200     (sheet-disown-child (frame-top-level-sheet frame) (frame-pane frame))))
201    
202     (defmethod generate-panes :after (fm (frame application-frame))
203     (declare (ignore fm))
204     (sheet-adopt-child (frame-top-level-sheet frame) (frame-pane frame))
205 cvs 1.5 (sheet-adopt-child (graft frame) (frame-top-level-sheet frame))
206     (setf (sheet-transformation (frame-top-level-sheet frame))
207     (make-translation-transformation 100 100))
208 hatchond 1.11 (let ((space (compose-space (frame-top-level-sheet frame))))
209 cvs 1.5 ;; automatically generates a window-configuation-event
210     ;; which then calls allocate-space
211 mikemac 1.1 (setf (sheet-region (frame-top-level-sheet frame))
212 cvs 1.5 (make-bounding-rectangle 0 0
213     (space-requirement-width space)
214     (space-requirement-height space)))))
215 mikemac 1.1
216     (defmethod layout-frame ((frame application-frame) &optional width height)
217     (let ((pane (frame-pane frame)))
218     (if (and width (not height))
219     (error "LAYOUT-FRAME must be called with both WIDTH and HEIGHT or neither"))
220     (if (and (null width) (null height))
221 hatchond 1.11 (let ((space (compose-space pane)))
222 mikemac 1.1 (setq width (space-requirement-width space))
223     (setq height (space-requirement-height space))))
224     (allocate-space pane width height)))
225    
226 adejneka 1.13 (defun find-pane-if (predicate panes)
227     "Returns a pane satisfying PREDICATE in the forest growing from PANES"
228 cvs 1.6 (setq panes (copy-list panes))
229 cvs 1.10 (do ((pane (pop panes)(pop panes)))
230     ((null pane) nil)
231 adejneka 1.13 (if (funcall predicate pane)
232 cvs 1.10 (return pane)
233     (setq panes (nconc panes (copy-list (sheet-children pane)))))))
234 adejneka 1.13
235 moore 1.27 (defun find-pane-if (predicate panes)
236     "Returns a pane satisfying PREDICATE in the forest growing from PANES"
237     (loop for pane in panes
238     do (map-over-sheets #'(lambda (p)
239     (when (funcall predicate p)
240     (return-from find-pane-if p)))
241     pane)
242     finally (return nil)))
243    
244 adejneka 1.13 (defun find-pane-of-type (panes type)
245     (find-pane-if #'(lambda (pane) (typep pane type)) panes))
246 cvs 1.6
247 adejneka 1.13 (defmethod frame-current-panes ((frame application-frame))
248     (find-pane-if #'(lambda (pane) (pane-name pane))
249     (frame-current-layout frame)))
250    
251     (defmethod get-frame-pane ((frame application-frame) pane-name)
252     (find-pane-if #'(lambda (pane)
253     (and (typep pane 'clim-stream-pane)
254     (eq pane-name
255     (pane-name pane))))
256     (frame-panes frame)))
257    
258     (defmethod find-pane-named ((frame application-frame) pane-name)
259     (find-pane-if #'(lambda (pane)
260     (eq pane-name
261     (pane-name pane)))
262     (frame-panes frame)))
263    
264 mikemac 1.1 (defmethod frame-standard-output ((frame application-frame))
265 cvs 1.6 (or (find-pane-of-type (frame-panes frame) 'application-pane)
266     (find-pane-of-type (frame-panes frame) 'interactor-pane)))
267 mikemac 1.1
268     (defmethod frame-standard-input ((frame application-frame))
269 cvs 1.6 (or (find-pane-of-type (frame-panes frame) 'interactor-pane)
270 mikemac 1.1 (frame-standard-output frame)))
271    
272     (defmethod frame-query-io ((frame application-frame))
273     (or (frame-standard-input frame)
274     (frame-standard-output frame)))
275    
276     (defmethod frame-error-output ((frame application-frame))
277     (frame-standard-output frame))
278    
279     (defvar *pointer-documentation-output* nil)
280    
281     (defmethod frame-pointer-documentation-output ((frame application-frame))
282 adejneka 1.13 (find-pane-of-type (frame-panes frame) 'pointer-documentation-pane))
283 mikemac 1.1
284     ;;; Command loop interface
285    
286 mikemac 1.22 (define-condition frame-exit (condition)
287 moore 1.26 ((frame :initarg :frame :reader %frame-exit-frame)))
288 mikemac 1.22
289     (defmethod frame-exit ((frame standard-application-frame))
290     (signal 'frame-exit :frame frame))
291 moore 1.26
292     (defmethod frame-exit-frame ((c frame-exit))
293     (%frame-exit-frame c))
294 mikemac 1.22
295 mikemac 1.1 (defmethod run-frame-top-level ((frame application-frame))
296 mikemac 1.22 (handler-bind ((frame-exit #'(lambda (condition)
297 gilbert 1.31 (declare (ignore condition))
298 mikemac 1.22 (return-from run-frame-top-level nil))))
299     (apply (first (frame-top-level frame)) frame (rest (frame-top-level frame)))))
300 mikemac 1.1
301     (defmethod run-frame-top-level :around ((frame application-frame))
302     (let ((*application-frame* frame)
303     (*input-context* nil)
304     (*input-wait-test* nil)
305     (*input-wait-handler* nil)
306     (*pointer-button-press-handler* nil))
307     (declare (special *input-context* *input-wait-test* *input-wait-handler*
308     *pointer-button-press-handler*))
309 moore 1.24 (let ((query-io (frame-query-io frame)))
310     (if query-io
311     (with-input-focus (query-io)
312     (call-next-method))
313     (call-next-method)))))
314 mikemac 1.1
315     (defmethod default-frame-top-level
316     ((frame application-frame)
317     &key (command-parser 'command-line-command-parser)
318     (command-unparser 'command-line-command-unparser)
319     (partial-command-parser
320     'command-line-read-remaining-arguments-for-partial-command)
321 mikemac 1.21 (prompt nil))
322 pixel 1.30 (when *multiprocessing-p*
323 brian 1.28 (sleep 4)) ; wait for the panes to be finalized - KLUDGE!!! - mikemac
324 mikemac 1.20 (loop
325     (let ((*standard-input* (frame-standard-input frame))
326     (*standard-output* (frame-standard-output frame))
327     (*query-io* (frame-query-io frame))
328     ;; during development, don't alter *error-output*
329     ;(*error-output* (frame-error-output frame))
330     (*command-parser* command-parser)
331     (*command-unparser* command-unparser)
332     (*partial-command-parser* partial-command-parser)
333     (prompt-style (make-text-style :fixed :italic :normal))
334     results)
335     (map-over-sheets #'(lambda (pane)
336     (if (and (typep pane 'clim-stream-pane)
337     (eq (pane-display-time pane) :command-loop)
338     (pane-display-function pane))
339     (let ((func (pane-display-function pane)))
340     (window-clear pane)
341     (funcall func frame pane))))
342     (frame-top-level-sheet frame))
343     (when *standard-input*
344     (setf (cursor-visibility (stream-text-cursor *standard-input*)) t)
345 mikemac 1.21 (when prompt
346     (with-text-style (*standard-input* prompt-style)
347     (if (stringp prompt)
348     (stream-write-string *standard-input* prompt)
349     (apply prompt (list *standard-input* frame)))
350     (stream-finish-output *standard-input*)))
351 mikemac 1.20 (setq results (multiple-value-list (execute-frame-command frame (read-frame-command frame))))
352     (loop for result in results
353     do (print result *standard-input*))
354     (terpri *standard-input*))
355 cvs 1.10 )))
356 mikemac 1.1
357 adejneka 1.12 (defmethod read-frame-command ((frame application-frame) &key (stream *standard-input*))
358 mikemac 1.1 (read-command (frame-command-table frame) :stream stream))
359    
360     (defmethod execute-frame-command ((frame application-frame) command)
361 cvs 1.8 #+ignore (apply (command-name command) (command-arguments command))
362     (eval command))
363 mikemac 1.1
364     (defmethod make-pane-1 ((fm frame-manager) (frame application-frame) type &rest args)
365     `(make-pane-1 ,fm ,frame ',type ,@args))
366    
367     (defmethod adopt-frame ((fm frame-manager) (frame application-frame))
368     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
369     (setf (frame-manager frame) fm)
370     (let* ((*application-frame* frame)
371 cvs 1.4 (t-l-s (make-pane-1 fm frame 'top-level-sheet-pane
372 mikemac 1.1 :name 'top-level-sheet)))
373     (setf (slot-value frame 'top-level-sheet) t-l-s)
374     (generate-panes fm frame)))
375 brian 1.28
376 mikemac 1.1 (defmethod disown-frame ((fm frame-manager) (frame application-frame))
377     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
378     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
379     (setf (frame-manager frame) nil))
380    
381 cvs 1.8 (defvar *pane-realizer* nil)
382    
383 mikemac 1.1 (defmacro with-look-and-feel-realization ((frame-manager frame) &body body)
384 cvs 1.8 `(let ((*pane-realizer* ,frame-manager)
385     (*application-frame* ,frame))
386     (progn
387     ,@body)))
388 mikemac 1.1
389 brian 1.28 ; The menu-bar code in the following two functions is incorrect.
390     ; it needs to be moved to somewhere after the backend, since
391     ; it depends on the backend chosen.
392     ;
393     ; This hack slaps a menu-bar into the start of the application-frame,
394     ; in such a way that it is hard to find.
395     ;
396     ; FIXME
397     (defun make-single-pane-generate-panes-form (class-name menu-bar pane)
398 mikemac 1.1 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
399 brian 1.28 ; v-- hey, how can this be?
400 moore 1.17 (with-look-and-feel-realization (fm frame)
401 brian 1.28 (let ((pane ,(cond
402     ((eq menu-bar t)
403     `(vertically () (clim-internals::make-menu-bar
404     ',class-name)
405     ,pane))
406 gilbert 1.31 ((consp menu-bar) ;; was: (listp menu-bar) --GB
407 brian 1.28 `(vertically () (clim-internals::make-menu-bar
408     (make-command-table nil
409     :menu ',menu-bar))
410     ,pane))
411     (menu-bar
412     `(vertically () (clim-internals::make-menu-bar
413     ',menu-bar)
414     ,pane))
415 gilbert 1.31 ;; The form below is unreachable with (listp
416     ;; menu-bar) instead of (consp menu-bar) above
417     ;; --GB
418 brian 1.28 (t pane))))
419     (setf (slot-value frame 'pane) pane)))))
420 mikemac 1.1
421 brian 1.28 ; could do with some refactoring [BTS] FIXME
422     (defun make-panes-generate-panes-form (class-name menu-bar panes layouts)
423 mikemac 1.1 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
424     (let ((*application-frame* frame))
425 cvs 1.8 (with-look-and-feel-realization (fm frame)
426     (let ,(loop for (name . form) in panes
427     collect `(,name (or (find-pane-named frame ',name)
428     (let ((pane
429     ,(cond
430     ((and (= (length form) 1)
431     (listp (first form)))
432     (first form))
433     ((keywordp (first form))
434     (let ((maker (intern (concatenate 'string
435     "MAKE-CLIM-"
436     (symbol-name (first form))
437     "-PANE") :clim)))
438     (if (fboundp maker)
439     `(,maker :name ',name ,@(cdr form))
440     `(make-pane ',(first form)
441     :name ',name ,@(cdr form)))))
442     (t `(make-pane ',(first form) :name ',name ,@(cdr form))))))
443 gilbert 1.19 ;; hmm?! --GB
444     (setf (slot-value pane 'name) ',name)
445     ;;
446 cvs 1.8 (push pane (slot-value frame 'panes))
447     pane))))
448 brian 1.28 ; [BTS] added this, but is not sure that this is correct for adding
449     ; a menu-bar transparently, should also only be done where the
450     ; exterior window system does not support menus
451     ,(if menu-bar
452     `(setf (slot-value frame 'pane)
453     (ecase (frame-current-layout frame)
454     ,@(mapcar (lambda (layout)
455     `(,(first layout) (vertically ()
456     ,(cond
457     ((eq menu-bar t)
458     `(clim-internals::make-menu-bar
459     ',class-name))
460     ((listp menu-bar)
461     `(raising (:border-width 2 :background +Gray83+)
462     (clim-internals::make-menu-bar
463     (make-command-table nil
464     :menu ',menu-bar))))
465     (menu-bar
466     `(clim-internals::make-menu-bar
467     ',menu-bar)))
468     ,@(rest layout))))
469     layouts)))
470     `(setf (slot-value frame 'pane)
471     (ecase (frame-current-layout frame)
472     ,@layouts))))))))
473 mikemac 1.1
474     (defmacro define-application-frame (name superclasses slots &rest options)
475     (if (null superclasses)
476     (setq superclasses '(standard-application-frame)))
477     (let ((pane nil)
478     (panes nil)
479     (layouts nil)
480     (current-layout nil)
481 mikemac 1.23 (command-table (list name))
482 mikemac 1.1 (menu-bar t)
483     (disabled-commands nil)
484     (command-definer t)
485     (top-level '(default-frame-top-level))
486     (others nil)
487     (command-name (intern (concatenate 'string "DEFINE-" (symbol-name name) "-COMMAND"))))
488     (loop for (prop . values) in options
489     do (case prop
490     (:pane (setq pane (first values)))
491     (:panes (setq panes values))
492     (:layouts (setq layouts values))
493     (:command-table (setq command-table (first values)))
494 brian 1.28 (:menu-bar (setq menu-bar (if (listp values)
495     (first values)
496     values)))
497 mikemac 1.1 (:disabled-commands (setq disabled-commands values))
498     (:command-definer (setq command-definer (first values)))
499     (:top-level (setq top-level (first values)))
500     (t (push (cons prop values) others))))
501     (if (or (and pane panes)
502     (and pane layouts))
503     (error ":pane cannot be specified along with either :panes or :layouts"))
504     (if pane
505     (setq panes (list 'single-pane pane)
506 moore 1.17 layouts `((:default ,(car pane)))))
507 mikemac 1.1 (setq current-layout (first (first layouts)))
508     `(progn
509     (defclass ,name ,superclasses
510     ,slots
511     (:default-initargs
512     :name ',name
513     :pretty-name ,(string-capitalize name)
514 mikemac 1.23 :command-table (find-command-table ',(first command-table))
515 mikemac 1.1 :disabled-commands ',disabled-commands
516 brian 1.28 :menu-bar ',menu-bar
517 mikemac 1.1 :current-layout ',current-layout
518     :layouts ',layouts
519     :top-level ',top-level
520     )
521     ,@others)
522     ,(if pane
523 brian 1.28 (make-single-pane-generate-panes-form name menu-bar pane)
524     (make-panes-generate-panes-form name menu-bar panes layouts))
525 mikemac 1.23 ,@(if command-table
526     `((define-command-table ,@command-table)))
527 mikemac 1.1 ,@(if command-definer
528     `((defmacro ,command-name (name-and-options arguements &rest body)
529     (let ((name (if (listp name-and-options) (first name-and-options) name-and-options))
530 mikemac 1.23 (options (if (listp name-and-options) (cdr name-and-options) nil))
531     (command-table ',(first command-table)))
532     `(define-command (,name :command-table ,command-table ,@options) ,arguements ,@body))))))))
533 mikemac 1.1
534     (defun make-application-frame (frame-name
535     &rest options
536     &key pretty-name frame-manager enable state
537     left top right bottom width height save-under
538     frame-class
539     &allow-other-keys)
540 mikemac 1.16 (declare (ignore enable state left top right bottom width height save-under))
541 mikemac 1.1 (setq options (loop for (key value) on options by #'cddr
542     if (not (member key '(:pretty-name :frame-manager :enable :state
543     :left :top :right :bottom :width :height :save-under
544     :frame-class)
545 mikemac 1.15 :test #'eq))
546 mikemac 1.1 nconc (list key value)))
547     (if (null frame-class)
548     (setq frame-class frame-name))
549     (if (null pretty-name)
550     (setq pretty-name (string-capitalize frame-name)))
551     (if (null frame-manager)
552     (setq frame-manager (find-frame-manager)))
553     (let ((frame (apply #'make-instance frame-class
554     :port (frame-manager-port frame-manager)
555     :graft (find-graft :port (frame-manager-port frame-manager))
556     :name frame-name :pretty-name pretty-name options)))
557     (adopt-frame frame-manager frame)
558     frame))
559 cvs 1.4
560 cvs 1.7 ;;; Menu frame class
561    
562     (defclass menu-frame ()
563     ((left :initform 0 :initarg :left)
564     (top :initform 0 :initarg :top)
565     (top-level-sheet :initform nil :reader frame-top-level-sheet)
566     (pane :reader frame-pane :initarg :pane)
567     (graft :initform nil :accessor graft)
568     (manager :initform nil :accessor frame-manager)))
569    
570     (defmethod adopt-frame ((fm frame-manager) (frame menu-frame))
571     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
572     (setf (slot-value frame 'manager) fm)
573     (let* ((t-l-s (make-pane-1 fm *application-frame* 'unmanaged-top-level-sheet-pane
574     :name 'top-level-sheet)))
575     (setf (slot-value frame 'top-level-sheet) t-l-s)
576     (sheet-adopt-child t-l-s (frame-pane frame))
577     (let ((graft (find-graft :port (frame-manager-port fm))))
578     (sheet-adopt-child graft t-l-s)
579     (setf (graft frame) graft))
580 hatchond 1.11 (let ((space (compose-space t-l-s)))
581 cvs 1.7 (allocate-space (frame-pane frame)
582     (space-requirement-width space)
583     (space-requirement-height space))
584     (setf (sheet-region t-l-s)
585     (make-bounding-rectangle 0 0
586     (space-requirement-width space)
587     (space-requirement-height space))))
588     (setf (sheet-transformation t-l-s)
589     (make-translation-transformation (slot-value frame 'left)
590     (slot-value frame 'top)))))
591    
592     (defmethod disown-frame ((fm frame-manager) (frame menu-frame))
593     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
594     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
595     (setf (frame-manager frame) nil))
596    
597     (defun make-menu-frame (pane &key (left 0) (top 0))
598     (make-instance 'menu-frame :pane pane :left left :top top))
599 moore 1.18
600     ;;; Frames and presentations
601    
602     (defmethod frame-find-innermost-applicable-presentation
603     ((frame standard-application-frame) input-context stream x y
604     &key event)
605     (find-innermost-applicable-presentation input-context stream
606     x y
607     :frame frame :event event))
608    
609     (defmethod frame-input-context-button-press-handler
610     ((frame standard-application-frame)
611     (stream output-recording-stream)
612     button-press-event)
613     (format *debug-io* "frame button press event: ~D ~D in ~S~%"
614     (pointer-event-x button-press-event)
615     (pointer-event-y button-press-event)
616     stream)
617     (let ((presentation (find-innermost-applicable-presentation
618     *input-context*
619     stream
620     (pointer-event-x button-press-event)
621     (pointer-event-y button-press-event)
622     :frame frame)))
623     (when presentation
624     (format *debug-io* "presentation: ~S of type ~S~%"
625     (presentation-object presentation)
626     (presentation-type presentation))
627     (throw-highlighted-presentation presentation
628     *input-context*
629     button-press-event))))
630    
631     (defmethod frame-input-context-button-press-handler
632     ((frame standard-application-frame) stream button-press-event)
633 moore 1.27 nil)
634 moore 1.18
635     (defmethod frame-input-context-track-pointer
636     ((frame standard-application-frame)
637     input-context
638     (stream output-recording-stream) event)
639     (declare (ignore input-context event))
640     nil)
641    
642     (defmethod frame-input-context-track-pointer
643     ((frame standard-application-frame) input-context stream event)
644     (declare (ignore input-context))
645 moore 1.27 nil)
646 moore 1.18
647     (defmethod frame-input-context-track-pointer :before
648     ((frame standard-application-frame) input-context stream event)
649     (if (output-recording-stream-p stream)
650     (let ((presentation (find-innermost-applicable-presentation
651     input-context
652     stream
653     (pointer-event-x event)
654     (pointer-event-y event)
655     :frame frame)))
656     (when (and (frame-hilited-presentation frame)
657     (not (eq presentation
658     (car (frame-hilited-presentation frame)))))
659     (highlight-presentation-1 (car (frame-hilited-presentation frame))
660     (cdr (frame-hilited-presentation frame))
661     :unhighlight))
662     (when presentation
663     (setf (frame-hilited-presentation frame)
664     (cons presentation stream))
665     (highlight-presentation-1 presentation
666     stream
667     :highlight)))))
668 moore 1.27
669     (defun simple-event-loop ()
670     "An simple event loop for applications that want all events to be handled by
671     handle-event methods"
672     (if *multiprocessing-p*
673     (let ((queue (frame-event-queue *application-frame*)))
674     (loop for event = (event-queue-read queue)
675     do (handle-event (event-sheet event) event)))
676     (let ((port (port *application-frame*)))
677     (loop
678     (process-next-event port)))))

  ViewVC Help
Powered by ViewVC 1.1.5