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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Tue Aug 22 10:38:36 2000 UTC (13 years, 8 months ago) by cvs
Branch: MAIN
Changes since 1.2: +3 -3 lines
Improved the way adopt-frame creates the panes.
1 mikemac 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2    
3     ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4    
5     ;;; This library is free software; you can redistribute it and/or
6     ;;; modify it under the terms of the GNU Library General Public
7     ;;; License as published by the Free Software Foundation; either
8     ;;; version 2 of the License, or (at your option) any later version.
9     ;;;
10     ;;; This library is distributed in the hope that it will be useful,
11     ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12     ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13     ;;; Library General Public License for more details.
14     ;;;
15     ;;; You should have received a copy of the GNU Library General Public
16     ;;; License along with this library; if not, write to the
17     ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18     ;;; Boston, MA 02111-1307 USA.
19    
20     (in-package :CLIM-INTERNALS)
21    
22     (defvar *application-frame* nil)
23     (defvar *default-frame-manager* nil)
24    
25     ;;; Application-Frame class
26    
27     (defclass application-frame ()
28     ((port :initform nil
29     :initarg :port
30     :accessor port)
31     (graft :initform nil
32     :initarg :graft
33     :accessor graft)
34     (name :initarg :name
35     :reader frame-name)
36     (pretty-name :initarg :pretty-name
37     :accessor frame-pretty-name)
38     (command-table :initarg :command-table
39     :initform nil
40     :accessor frame-command-table)
41     (disabled-commands :initarg :disabled-commands
42     :initform nil
43     :accessor frame-disabled-commands)
44     (pane :reader frame-pane)
45     (panes :initform nil
46     :reader frame-panes)
47     (layouts :initform nil
48     :initarg :layouts
49     :reader frame-layouts)
50     (current-layout :initform nil
51     :initarg :current-layout
52     :reader frame-current-layout)
53     (top-level-sheet :initform nil
54     :reader frame-top-level-sheet)
55     (menu-bar :initarg :menu-bar
56     :initform nil)
57     (calling-frame :initarg :calling-frame
58     :initform nil)
59     (state :initarg :state
60     :initform nil
61     :accessor frame-state)
62     (manager :initform nil
63     :reader frame-manager)
64     (properties :initarg :properties
65     :initform nil)
66     (top-level :initform '(default-frame-top-level)
67     :initarg :top-level
68     :reader frame-top-level)
69     ))
70    
71     (defun application-frame-p (x)
72     (typep x 'application-frame))
73    
74     (defmethod initialize-instance :after ((frame application-frame) &rest args)
75     (declare (ignore args))
76     )
77    
78     (defclass standard-application-frame (application-frame)
79     ())
80    
81     (defmethod (setf frame-manager) (fm (frame application-frame))
82     (let ((old-manager (frame-manager frame)))
83     (setf (slot-value frame 'manager) nil)
84     (when old-manager
85     (disown-frame old-manager frame)
86     (setf (slot-value frame 'panes) nil)
87     (setf (slot-value frame 'layouts) nil))
88     (setf (slot-value frame 'manager) fm)))
89    
90     (defmethod calculate-standard-panes ((frame application-frame))
91     ;; Should find the panes for
92     )
93    
94     (defmethod (setf frame-current-layout) (name (frame application-frame))
95     (declare (ignore name))
96     (generate-panes (frame-manager frame) frame))
97    
98     (defmethod generate-panes :before (fm (frame application-frame))
99     (declare (ignore fm))
100     (when (and (slot-boundp frame 'pane)
101     (frame-pane frame))
102     (unrealize-mirror (port frame) (frame-pane frame))
103     (sheet-disown-child (frame-top-level-sheet frame) (frame-pane frame))))
104    
105     (defmethod generate-panes :after (fm (frame application-frame))
106     (declare (ignore fm))
107     (sheet-adopt-child (frame-top-level-sheet frame) (frame-pane frame))
108     (let ((space (compose-space (frame-top-level-sheet frame))))
109     (setf (sheet-region (frame-top-level-sheet frame))
110     (make-bounding-rectangle 100 100
111     (+ 100 (space-requirement-width space))
112     (+ 100 (space-requirement-height space))))
113     (allocate-space (frame-top-level-sheet frame)
114     (space-requirement-width space) (space-requirement-height space)))
115 cvs 1.3 (sheet-adopt-child (graft frame) (frame-top-level-sheet frame)))
116     ; (calculate-standard-panes frame))
117 mikemac 1.1
118     (defmethod find-pane-named ((frame application-frame) name)
119     (loop for pane in (frame-panes frame)
120     if (eq (pane-name pane) name)
121     return pane))
122    
123     (defmethod layout-frame ((frame application-frame) &optional width height)
124     (let ((pane (frame-pane frame)))
125     (if (and width (not height))
126     (error "LAYOUT-FRAME must be called with both WIDTH and HEIGHT or neither"))
127     (if (and (null width) (null height))
128     (let ((space (compose-space pane)))
129     (setq width (space-requirement-width space))
130     (setq height (space-requirement-height space))))
131     (allocate-space pane width height)))
132    
133     (defmethod frame-standard-output ((frame application-frame))
134     (or (loop for pane in (frame-panes frame)
135     if (typep pane 'application-pane)
136     return pane
137     finally (return nil))
138     (loop for pane in (frame-panes frame)
139     if (typep pane 'interactor-pane)
140     return pane
141     finally (return nil))))
142    
143     (defmethod frame-standard-input ((frame application-frame))
144     (or (loop for pane in (frame-panes frame)
145     if (typep pane 'interactor-pane)
146     return pane
147     finally (return nil))
148     (frame-standard-output frame)))
149    
150     (defmethod frame-query-io ((frame application-frame))
151     (or (frame-standard-input frame)
152     (frame-standard-output frame)))
153    
154     (defmethod frame-error-output ((frame application-frame))
155     (frame-standard-output frame))
156    
157     (defvar *pointer-documentation-output* nil)
158    
159     (defmethod frame-pointer-documentation-output ((frame application-frame))
160     (loop for pane in (frame-panes frame)
161     if (typep pane 'pointer-documentation-pane)
162     return pane
163     finally (return nil)))
164    
165     ;;; Command loop interface
166    
167     (defmethod run-frame-top-level ((frame application-frame))
168     (apply (first (frame-top-level frame)) frame (rest (frame-top-level frame))))
169    
170     (defmethod run-frame-top-level :around ((frame application-frame))
171     (let ((*application-frame* frame)
172     (*input-context* nil)
173     (*input-wait-test* nil)
174     (*input-wait-handler* nil)
175     (*pointer-button-press-handler* nil))
176     (declare (special *input-context* *input-wait-test* *input-wait-handler*
177     *pointer-button-press-handler*))
178     (call-next-method)))
179    
180     (defmethod default-frame-top-level
181     ((frame application-frame)
182     &key (command-parser 'command-line-command-parser)
183     (command-unparser 'command-line-command-unparser)
184     (partial-command-parser
185     'command-line-read-remaining-arguments-for-partial-command)
186     (prompt "Command: "))
187     (let ((*standard-input* (frame-standard-input frame))
188     (*standard-output* (frame-standard-output frame))
189     (*query-io* (frame-query-io frame))
190 cvs 1.2 ;; during development, don't alter *error-output*
191     ;(*error-output* (frame-error-output frame))
192 mikemac 1.1 (*command-parser* command-parser)
193     (*command-unparser* command-unparser)
194     (*partial-command-parser* partial-command-parser)
195     (prompt-style (make-text-style :fixed :italic :normal))
196     results)
197     (setf (cursor-visibility (stream-text-cursor *standard-input*)) t)
198     (loop do
199     (with-text-style (*standard-input* prompt-style)
200     (if (stringp prompt)
201     (stream-write-string *standard-input* prompt)
202     (apply prompt (list *standard-input* frame))))
203     (setq results (multiple-value-list (execute-frame-command frame (read-frame-command frame *standard-input*))))
204     (loop for result in results
205     do (print result *standard-input*))
206     (terpri *standard-input*))
207     ))
208    
209     (defmethod read-frame-command ((frame application-frame) stream)
210     (read-command (frame-command-table frame) :stream stream))
211    
212     (defmethod execute-frame-command ((frame application-frame) command)
213     (apply (command-name command) (command-arguments command)))
214    
215     ;;; Frame-Manager class
216    
217     (defclass frame-manager ()
218     ((port :initarg :port
219     :reader frame-manager-port)
220     (frames :initform nil
221     :reader frame-manager-frames)
222     )
223     )
224    
225     (defun frame-manager-p (x)
226     (typep x 'frame-manager))
227    
228     (defun find-frame-manager (&rest options &key port &allow-other-keys)
229     (declare (special *frame-manager*))
230     (if (boundp '*frame-manager*)
231     *frame-manager*
232     (if (and *default-frame-manager*
233     (frame-manager-p *default-frame-manager*))
234     *default-frame-manager*
235     (first (frame-managers (or port (apply #'find-port options)))))))
236    
237     (defmacro with-frame-manager ((frame-manager) &body body)
238     `(let (('*frame-manager* ,frame-manager))
239     (declare (special *frame-manager*))
240     (block ,@body)))
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     (t-l-s (make-pane-1 fm frame 'composite-pane
250     :name 'top-level-sheet)))
251     (setf (slot-value frame 'top-level-sheet) t-l-s)
252 cvs 1.3 ; (sheet-adopt-child (graft frame) t-l-s)
253 mikemac 1.1 (generate-panes fm frame)))
254    
255     (defmethod disown-frame ((fm frame-manager) (frame application-frame))
256     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
257     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
258     (setf (frame-manager frame) nil))
259    
260     (defmacro with-look-and-feel-realization ((frame-manager frame) &body body)
261     (declare (ignore frame-manager frame))
262     `(progn
263     ,@body))
264    
265     (defun make-single-pane-generate-panes-form (class-name pane)
266     `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
267     (let ((*application-frame* frame))
268     (let ((pane ,pane))
269     (setf (slot-value frame 'pane) pane)))))
270    
271     (defun make-panes-generate-panes-form (class-name panes layouts)
272     `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
273     (let ((*application-frame* frame))
274     (let ,(loop for (name . form) in panes
275     collect `(,name (or (find-pane-named frame ',name)
276     (let ((pane
277     ,(cond
278     ((and (= (length form) 1)
279     (listp (first form)))
280     (first form))
281     ((keywordp (first form))
282     `(make-pane ',(intern (concatenate 'string
283     (symbol-name (first form))
284     "-PANE")
285     :clim)
286     :name ',name ,@(cdr form)))
287     (t `(make-pane ',(first form) :name ',name ,@(cdr form))))))
288     (push pane (slot-value frame 'panes))
289     pane))))
290     (setf (slot-value frame 'pane)
291     (with-look-and-feel-realization (fm frame)
292     (ecase (frame-current-layout frame)
293     ,@layouts)))
294     ))))
295    
296     (defmacro define-application-frame (name superclasses slots &rest options)
297     (if (null superclasses)
298     (setq superclasses '(standard-application-frame)))
299     (let ((pane nil)
300     (panes nil)
301     (layouts nil)
302     (current-layout nil)
303     (command-table nil)
304     (menu-bar t)
305     (disabled-commands nil)
306     (command-definer t)
307     (top-level '(default-frame-top-level))
308     (others nil)
309     (command-name (intern (concatenate 'string "DEFINE-" (symbol-name name) "-COMMAND"))))
310     (loop for (prop . values) in options
311     do (case prop
312     (:pane (setq pane (first values)))
313     (:panes (setq panes values))
314     (:layouts (setq layouts values))
315     (:command-table (setq command-table (first values)))
316     (:menu-bar (setq menu-bar (first values)))
317     (:disabled-commands (setq disabled-commands values))
318     (:command-definer (setq command-definer (first values)))
319     (:top-level (setq top-level (first values)))
320     (t (push (cons prop values) others))))
321     (if (or (and pane panes)
322     (and pane layouts))
323     (error ":pane cannot be specified along with either :panes or :layouts"))
324     (if pane
325     (setq panes (list 'single-pane pane)
326     layouts (list :default (first pane))))
327     (setq current-layout (first (first layouts)))
328     `(progn
329     (defclass ,name ,superclasses
330     ,slots
331     (:default-initargs
332     :name ',name
333     :pretty-name ,(string-capitalize name)
334     :command-table ,command-table
335     :disabled-commands ',disabled-commands
336     :menu-bar ,menu-bar
337     :current-layout ',current-layout
338     :layouts ',layouts
339     :top-level ',top-level
340     )
341     ,@others)
342     ,(if pane
343     (make-single-pane-generate-panes-form name pane)
344     (make-panes-generate-panes-form name panes layouts))
345     ,@(if command-definer
346     `((defmacro ,command-name (name-and-options arguements &rest body)
347     (let ((name (if (listp name-and-options) (first name-and-options) name-and-options))
348     (options (if (listp name-and-options) (cdr name-and-options) nil)))
349     `(define-command ,name ,arguements ,@body))))))))
350    
351     (defun make-application-frame (frame-name
352     &rest options
353     &key pretty-name frame-manager enable state
354     left top right bottom width height save-under
355     frame-class
356     &allow-other-keys)
357     (setq options (loop for (key value) on options by #'cddr
358     if (not (member key '(:pretty-name :frame-manager :enable :state
359     :left :top :right :bottom :width :height :save-under
360     :frame-class)
361     :key #'eq))
362     nconc (list key value)))
363     (if (null frame-class)
364     (setq frame-class frame-name))
365     (if (null pretty-name)
366     (setq pretty-name (string-capitalize frame-name)))
367     (if (null frame-manager)
368     (setq frame-manager (find-frame-manager)))
369     (let ((frame (apply #'make-instance frame-class
370     :port (frame-manager-port frame-manager)
371     :graft (find-graft :port (frame-manager-port frame-manager))
372     :name frame-name :pretty-name pretty-name options)))
373     (adopt-frame frame-manager frame)
374     frame))

  ViewVC Help
Powered by ViewVC 1.1.5