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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.28 - (hide annotations)
Sun Apr 21 12:41:14 2002 UTC (12 years ago) by brian
Branch: MAIN
Changes since 1.27: +82 -15 lines
Sundry fixes to run without multiprocessing support.

Added images/ to hold bitmaps for tests.

Added looks/ to hold neutral look-and-feel realizer packages.

Added Examples/gadget-test to test many gadgets with a look and feel.

Added a pixie look and feel, and a pixie/clx to work with the clx backend.

Added drawing support in the CLX backend for ovals and circles.

Fixed pixmaps to work with with-output-to-pixmap with draw-image, etc.

Moved sheet-leaf-mixin to standard-gadget-pane so it doesn't break radio-box-pane, etc.

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

  ViewVC Help
Powered by ViewVC 1.1.5