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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide annotations)
Wed Nov 22 09:06:26 2000 UTC (13 years, 5 months ago) by cvs
Branch: MAIN
Changes since 1.4: +35 -39 lines
Exchanged order of definitions of frame-manager and frame classes to avoid
compile-time message.

Removed unused definition of calculate-standard-panes.

Changed order between adopt-child and compose-space.  Now, the mirrors of
the sheets in the pane hierarchy are realized first.  Their sizes are
arbitrarily assigned, since the space allocation protocol has not been
invoked yet.  Then compose-space and allocate-space are run to adjust all
the sizes.  This order allows us to determine space requirements of certain
panes from their contents, which requires the pane to be grafted so that
font sizes are known.
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     ))
101    
102     (defun application-frame-p (x)
103     (typep x 'application-frame))
104    
105     (defmethod initialize-instance :after ((frame application-frame) &rest args)
106     (declare (ignore args))
107     )
108    
109     (defclass standard-application-frame (application-frame)
110     ())
111    
112     (defmethod (setf frame-manager) (fm (frame application-frame))
113     (let ((old-manager (frame-manager frame)))
114     (setf (slot-value frame 'manager) nil)
115     (when old-manager
116     (disown-frame old-manager frame)
117     (setf (slot-value frame 'panes) nil)
118     (setf (slot-value frame 'layouts) nil))
119     (setf (slot-value frame 'manager) fm)))
120    
121     (defmethod (setf frame-current-layout) (name (frame application-frame))
122     (declare (ignore name))
123     (generate-panes (frame-manager frame) frame))
124    
125     (defmethod generate-panes :before (fm (frame application-frame))
126     (declare (ignore fm))
127     (when (and (slot-boundp frame 'pane)
128     (frame-pane frame))
129     (sheet-disown-child (frame-top-level-sheet frame) (frame-pane frame))))
130    
131     (defmethod generate-panes :after (fm (frame application-frame))
132     (declare (ignore fm))
133     (sheet-adopt-child (frame-top-level-sheet frame) (frame-pane frame))
134 cvs 1.5 (sheet-adopt-child (graft frame) (frame-top-level-sheet frame))
135     (setf (sheet-transformation (frame-top-level-sheet frame))
136     (make-translation-transformation 100 100))
137 mikemac 1.1 (let ((space (compose-space (frame-top-level-sheet frame))))
138 cvs 1.5 ;; automatically generates a window-configuation-event
139     ;; which then calls allocate-space
140 mikemac 1.1 (setf (sheet-region (frame-top-level-sheet frame))
141 cvs 1.5 (make-bounding-rectangle 0 0
142     (space-requirement-width space)
143     (space-requirement-height space)))))
144 mikemac 1.1
145     (defmethod find-pane-named ((frame application-frame) name)
146     (loop for pane in (frame-panes frame)
147     if (eq (pane-name pane) name)
148     return pane))
149    
150     (defmethod layout-frame ((frame application-frame) &optional width height)
151     (let ((pane (frame-pane frame)))
152     (if (and width (not height))
153     (error "LAYOUT-FRAME must be called with both WIDTH and HEIGHT or neither"))
154     (if (and (null width) (null height))
155     (let ((space (compose-space pane)))
156     (setq width (space-requirement-width space))
157     (setq height (space-requirement-height space))))
158     (allocate-space pane width height)))
159    
160     (defmethod frame-standard-output ((frame application-frame))
161     (or (loop for pane in (frame-panes frame)
162     if (typep pane 'application-pane)
163     return pane
164     finally (return nil))
165     (loop for pane in (frame-panes frame)
166     if (typep pane 'interactor-pane)
167     return pane
168     finally (return nil))))
169    
170     (defmethod frame-standard-input ((frame application-frame))
171     (or (loop for pane in (frame-panes frame)
172     if (typep pane 'interactor-pane)
173     return pane
174     finally (return nil))
175     (frame-standard-output frame)))
176    
177     (defmethod frame-query-io ((frame application-frame))
178     (or (frame-standard-input frame)
179     (frame-standard-output frame)))
180    
181     (defmethod frame-error-output ((frame application-frame))
182     (frame-standard-output frame))
183    
184     (defvar *pointer-documentation-output* nil)
185    
186     (defmethod frame-pointer-documentation-output ((frame application-frame))
187     (loop for pane in (frame-panes frame)
188     if (typep pane 'pointer-documentation-pane)
189     return pane
190     finally (return nil)))
191    
192     ;;; Command loop interface
193    
194     (defmethod run-frame-top-level ((frame application-frame))
195     (apply (first (frame-top-level frame)) frame (rest (frame-top-level frame))))
196    
197     (defmethod run-frame-top-level :around ((frame application-frame))
198     (let ((*application-frame* frame)
199     (*input-context* nil)
200     (*input-wait-test* nil)
201     (*input-wait-handler* nil)
202     (*pointer-button-press-handler* nil))
203     (declare (special *input-context* *input-wait-test* *input-wait-handler*
204     *pointer-button-press-handler*))
205     (call-next-method)))
206    
207     (defmethod default-frame-top-level
208     ((frame application-frame)
209     &key (command-parser 'command-line-command-parser)
210     (command-unparser 'command-line-command-unparser)
211     (partial-command-parser
212     'command-line-read-remaining-arguments-for-partial-command)
213     (prompt "Command: "))
214     (let ((*standard-input* (frame-standard-input frame))
215     (*standard-output* (frame-standard-output frame))
216     (*query-io* (frame-query-io frame))
217 cvs 1.2 ;; during development, don't alter *error-output*
218     ;(*error-output* (frame-error-output frame))
219 mikemac 1.1 (*command-parser* command-parser)
220     (*command-unparser* command-unparser)
221     (*partial-command-parser* partial-command-parser)
222     (prompt-style (make-text-style :fixed :italic :normal))
223     results)
224     (setf (cursor-visibility (stream-text-cursor *standard-input*)) t)
225     (loop do
226     (with-text-style (*standard-input* prompt-style)
227     (if (stringp prompt)
228     (stream-write-string *standard-input* prompt)
229     (apply prompt (list *standard-input* frame))))
230     (setq results (multiple-value-list (execute-frame-command frame (read-frame-command frame *standard-input*))))
231     (loop for result in results
232     do (print result *standard-input*))
233     (terpri *standard-input*))
234     ))
235    
236     (defmethod read-frame-command ((frame application-frame) stream)
237     (read-command (frame-command-table frame) :stream stream))
238    
239     (defmethod execute-frame-command ((frame application-frame) command)
240     (apply (command-name command) (command-arguments command)))
241    
242     (defmethod make-pane-1 ((fm frame-manager) (frame application-frame) type &rest args)
243     `(make-pane-1 ,fm ,frame ',type ,@args))
244    
245     (defmethod adopt-frame ((fm frame-manager) (frame application-frame))
246     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
247     (setf (frame-manager frame) fm)
248     (let* ((*application-frame* frame)
249 cvs 1.4 (t-l-s (make-pane-1 fm frame 'top-level-sheet-pane
250 mikemac 1.1 :name 'top-level-sheet)))
251     (setf (slot-value frame 'top-level-sheet) t-l-s)
252     (generate-panes fm frame)))
253    
254     (defmethod disown-frame ((fm frame-manager) (frame application-frame))
255     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
256     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
257     (setf (frame-manager frame) nil))
258    
259     (defmacro with-look-and-feel-realization ((frame-manager frame) &body body)
260     (declare (ignore frame-manager frame))
261     `(progn
262     ,@body))
263    
264     (defun make-single-pane-generate-panes-form (class-name pane)
265     `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
266     (let ((*application-frame* frame))
267     (let ((pane ,pane))
268     (setf (slot-value frame 'pane) pane)))))
269    
270     (defun make-panes-generate-panes-form (class-name panes layouts)
271     `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
272     (let ((*application-frame* frame))
273     (let ,(loop for (name . form) in panes
274     collect `(,name (or (find-pane-named frame ',name)
275     (let ((pane
276     ,(cond
277     ((and (= (length form) 1)
278     (listp (first form)))
279     (first form))
280     ((keywordp (first form))
281     `(make-pane ',(intern (concatenate 'string
282     (symbol-name (first form))
283     "-PANE")
284     :clim)
285     :name ',name ,@(cdr form)))
286     (t `(make-pane ',(first form) :name ',name ,@(cdr form))))))
287     (push pane (slot-value frame 'panes))
288     pane))))
289     (setf (slot-value frame 'pane)
290     (with-look-and-feel-realization (fm frame)
291     (ecase (frame-current-layout frame)
292     ,@layouts)))
293     ))))
294    
295     (defmacro define-application-frame (name superclasses slots &rest options)
296     (if (null superclasses)
297     (setq superclasses '(standard-application-frame)))
298     (let ((pane nil)
299     (panes nil)
300     (layouts nil)
301     (current-layout nil)
302     (command-table nil)
303     (menu-bar t)
304     (disabled-commands nil)
305     (command-definer t)
306     (top-level '(default-frame-top-level))
307     (others nil)
308     (command-name (intern (concatenate 'string "DEFINE-" (symbol-name name) "-COMMAND"))))
309     (loop for (prop . values) in options
310     do (case prop
311     (:pane (setq pane (first values)))
312     (:panes (setq panes values))
313     (:layouts (setq layouts values))
314     (:command-table (setq command-table (first values)))
315     (:menu-bar (setq menu-bar (first values)))
316     (:disabled-commands (setq disabled-commands values))
317     (:command-definer (setq command-definer (first values)))
318     (:top-level (setq top-level (first values)))
319     (t (push (cons prop values) others))))
320     (if (or (and pane panes)
321     (and pane layouts))
322     (error ":pane cannot be specified along with either :panes or :layouts"))
323     (if pane
324     (setq panes (list 'single-pane pane)
325     layouts (list :default (first pane))))
326     (setq current-layout (first (first layouts)))
327     `(progn
328     (defclass ,name ,superclasses
329     ,slots
330     (:default-initargs
331     :name ',name
332     :pretty-name ,(string-capitalize name)
333     :command-table ,command-table
334     :disabled-commands ',disabled-commands
335     :menu-bar ,menu-bar
336     :current-layout ',current-layout
337     :layouts ',layouts
338     :top-level ',top-level
339     )
340     ,@others)
341     ,(if pane
342     (make-single-pane-generate-panes-form name pane)
343     (make-panes-generate-panes-form name panes layouts))
344     ,@(if command-definer
345     `((defmacro ,command-name (name-and-options arguements &rest body)
346     (let ((name (if (listp name-and-options) (first name-and-options) name-and-options))
347     (options (if (listp name-and-options) (cdr name-and-options) nil)))
348     `(define-command ,name ,arguements ,@body))))))))
349    
350     (defun make-application-frame (frame-name
351     &rest options
352     &key pretty-name frame-manager enable state
353     left top right bottom width height save-under
354     frame-class
355     &allow-other-keys)
356     (setq options (loop for (key value) on options by #'cddr
357     if (not (member key '(:pretty-name :frame-manager :enable :state
358     :left :top :right :bottom :width :height :save-under
359     :frame-class)
360     :key #'eq))
361     nconc (list key value)))
362     (if (null frame-class)
363     (setq frame-class frame-name))
364     (if (null pretty-name)
365     (setq pretty-name (string-capitalize frame-name)))
366     (if (null frame-manager)
367     (setq frame-manager (find-frame-manager)))
368     (let ((frame (apply #'make-instance frame-class
369     :port (frame-manager-port frame-manager)
370     :graft (find-graft :port (frame-manager-port frame-manager))
371     :name frame-name :pretty-name pretty-name options)))
372     (adopt-frame frame-manager frame)
373     frame))
374 cvs 1.4

  ViewVC Help
Powered by ViewVC 1.1.5