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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.9 - (hide annotations)
Sat Dec 16 14:07:02 2000 UTC (13 years, 4 months ago) by cvs
Branch: MAIN
Changes since 1.8: +3 -3 lines
Replaced calls to compose-space by calls to compute-and-set-space.
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 cvs 1.9 (let ((space (compute-and-set-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 cvs 1.9 (let ((space (compute-and-set-space pane)))
156 mikemac 1.1 (setq width (space-requirement-width space))
157     (setq height (space-requirement-height space))))
158     (allocate-space pane width height)))
159    
160 cvs 1.6 (defun find-pane-of-type (panes type)
161     (setq panes (copy-list panes))
162     (loop for pane in panes
163     if (typep pane type)
164     return pane
165     do (setq panes (nconc panes (copy-list (sheet-children pane))))
166     finally (return nil)))
167    
168 mikemac 1.1 (defmethod frame-standard-output ((frame application-frame))
169 cvs 1.6 (or (find-pane-of-type (frame-panes frame) 'application-pane)
170     (find-pane-of-type (frame-panes frame) 'interactor-pane)))
171 mikemac 1.1
172     (defmethod frame-standard-input ((frame application-frame))
173 cvs 1.6 (or (find-pane-of-type (frame-panes frame) 'interactor-pane)
174 mikemac 1.1 (frame-standard-output frame)))
175    
176     (defmethod frame-query-io ((frame application-frame))
177     (or (frame-standard-input frame)
178     (frame-standard-output frame)))
179    
180     (defmethod frame-error-output ((frame application-frame))
181     (frame-standard-output frame))
182    
183     (defvar *pointer-documentation-output* nil)
184    
185     (defmethod frame-pointer-documentation-output ((frame application-frame))
186     (loop for pane in (frame-panes frame)
187     if (typep pane 'pointer-documentation-pane)
188     return pane
189     finally (return nil)))
190    
191     ;;; Command loop interface
192    
193     (defmethod run-frame-top-level ((frame application-frame))
194     (apply (first (frame-top-level frame)) frame (rest (frame-top-level frame))))
195    
196     (defmethod run-frame-top-level :around ((frame application-frame))
197     (let ((*application-frame* frame)
198     (*input-context* nil)
199     (*input-wait-test* nil)
200     (*input-wait-handler* nil)
201     (*pointer-button-press-handler* nil))
202     (declare (special *input-context* *input-wait-test* *input-wait-handler*
203     *pointer-button-press-handler*))
204     (call-next-method)))
205    
206     (defmethod default-frame-top-level
207     ((frame application-frame)
208     &key (command-parser 'command-line-command-parser)
209     (command-unparser 'command-line-command-unparser)
210     (partial-command-parser
211     'command-line-read-remaining-arguments-for-partial-command)
212     (prompt "Command: "))
213     (let ((*standard-input* (frame-standard-input frame))
214     (*standard-output* (frame-standard-output frame))
215     (*query-io* (frame-query-io frame))
216 cvs 1.2 ;; during development, don't alter *error-output*
217     ;(*error-output* (frame-error-output frame))
218 mikemac 1.1 (*command-parser* command-parser)
219     (*command-unparser* command-unparser)
220     (*partial-command-parser* partial-command-parser)
221     (prompt-style (make-text-style :fixed :italic :normal))
222     results)
223     (setf (cursor-visibility (stream-text-cursor *standard-input*)) t)
224     (loop do
225     (with-text-style (*standard-input* prompt-style)
226     (if (stringp prompt)
227     (stream-write-string *standard-input* prompt)
228     (apply prompt (list *standard-input* frame))))
229     (setq results (multiple-value-list (execute-frame-command frame (read-frame-command frame *standard-input*))))
230     (loop for result in results
231     do (print result *standard-input*))
232     (terpri *standard-input*))
233     ))
234    
235     (defmethod read-frame-command ((frame application-frame) stream)
236     (read-command (frame-command-table frame) :stream stream))
237    
238     (defmethod execute-frame-command ((frame application-frame) command)
239 cvs 1.8 #+ignore (apply (command-name command) (command-arguments command))
240     (eval command))
241 mikemac 1.1
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 cvs 1.8 (defvar *pane-realizer* nil)
260    
261 mikemac 1.1 (defmacro with-look-and-feel-realization ((frame-manager frame) &body body)
262 cvs 1.8 `(let ((*pane-realizer* ,frame-manager)
263     (*application-frame* ,frame))
264     (progn
265     ,@body)))
266 mikemac 1.1
267     (defun make-single-pane-generate-panes-form (class-name pane)
268     `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
269     (let ((*application-frame* frame))
270     (let ((pane ,pane))
271     (setf (slot-value frame 'pane) pane)))))
272    
273     (defun make-panes-generate-panes-form (class-name panes layouts)
274     `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
275     (let ((*application-frame* frame))
276 cvs 1.8 (with-look-and-feel-realization (fm frame)
277     (let ,(loop for (name . form) in panes
278     collect `(,name (or (find-pane-named frame ',name)
279     (let ((pane
280     ,(cond
281     ((and (= (length form) 1)
282     (listp (first form)))
283     (first form))
284     ((keywordp (first form))
285     (let ((maker (intern (concatenate 'string
286     "MAKE-CLIM-"
287     (symbol-name (first form))
288     "-PANE") :clim)))
289     (if (fboundp maker)
290     `(,maker :name ',name ,@(cdr form))
291     `(make-pane ',(first form)
292     :name ',name ,@(cdr form)))))
293     (t `(make-pane ',(first form) :name ',name ,@(cdr form))))))
294     (push pane (slot-value frame 'panes))
295     pane))))
296     (setf (slot-value frame 'pane)
297 mikemac 1.1 (ecase (frame-current-layout frame)
298     ,@layouts)))
299     ))))
300    
301     (defmacro define-application-frame (name superclasses slots &rest options)
302     (if (null superclasses)
303     (setq superclasses '(standard-application-frame)))
304     (let ((pane nil)
305     (panes nil)
306     (layouts nil)
307     (current-layout nil)
308     (command-table nil)
309     (menu-bar t)
310     (disabled-commands nil)
311     (command-definer t)
312     (top-level '(default-frame-top-level))
313     (others nil)
314     (command-name (intern (concatenate 'string "DEFINE-" (symbol-name name) "-COMMAND"))))
315     (loop for (prop . values) in options
316     do (case prop
317     (:pane (setq pane (first values)))
318     (:panes (setq panes values))
319     (:layouts (setq layouts values))
320     (:command-table (setq command-table (first values)))
321     (:menu-bar (setq menu-bar (first values)))
322     (:disabled-commands (setq disabled-commands values))
323     (:command-definer (setq command-definer (first values)))
324     (:top-level (setq top-level (first values)))
325     (t (push (cons prop values) others))))
326     (if (or (and pane panes)
327     (and pane layouts))
328     (error ":pane cannot be specified along with either :panes or :layouts"))
329     (if pane
330     (setq panes (list 'single-pane pane)
331     layouts (list :default (first pane))))
332     (setq current-layout (first (first layouts)))
333     `(progn
334     (defclass ,name ,superclasses
335     ,slots
336     (:default-initargs
337     :name ',name
338     :pretty-name ,(string-capitalize name)
339     :command-table ,command-table
340     :disabled-commands ',disabled-commands
341     :menu-bar ,menu-bar
342     :current-layout ',current-layout
343     :layouts ',layouts
344     :top-level ',top-level
345     )
346     ,@others)
347     ,(if pane
348     (make-single-pane-generate-panes-form name pane)
349     (make-panes-generate-panes-form name panes layouts))
350     ,@(if command-definer
351     `((defmacro ,command-name (name-and-options arguements &rest body)
352     (let ((name (if (listp name-and-options) (first name-and-options) name-and-options))
353     (options (if (listp name-and-options) (cdr name-and-options) nil)))
354     `(define-command ,name ,arguements ,@body))))))))
355    
356     (defun make-application-frame (frame-name
357     &rest options
358     &key pretty-name frame-manager enable state
359     left top right bottom width height save-under
360     frame-class
361     &allow-other-keys)
362     (setq options (loop for (key value) on options by #'cddr
363     if (not (member key '(:pretty-name :frame-manager :enable :state
364     :left :top :right :bottom :width :height :save-under
365     :frame-class)
366     :key #'eq))
367     nconc (list key value)))
368     (if (null frame-class)
369     (setq frame-class frame-name))
370     (if (null pretty-name)
371     (setq pretty-name (string-capitalize frame-name)))
372     (if (null frame-manager)
373     (setq frame-manager (find-frame-manager)))
374     (let ((frame (apply #'make-instance frame-class
375     :port (frame-manager-port frame-manager)
376     :graft (find-graft :port (frame-manager-port frame-manager))
377     :name frame-name :pretty-name pretty-name options)))
378     (adopt-frame frame-manager frame)
379     frame))
380 cvs 1.4
381 cvs 1.7 ;;; Menu frame class
382    
383     (defclass menu-frame ()
384     ((left :initform 0 :initarg :left)
385     (top :initform 0 :initarg :top)
386     (top-level-sheet :initform nil :reader frame-top-level-sheet)
387     (pane :reader frame-pane :initarg :pane)
388     (graft :initform nil :accessor graft)
389     (manager :initform nil :accessor frame-manager)))
390    
391     (defmethod adopt-frame ((fm frame-manager) (frame menu-frame))
392     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
393     (setf (slot-value frame 'manager) fm)
394     (let* ((t-l-s (make-pane-1 fm *application-frame* 'unmanaged-top-level-sheet-pane
395     :name 'top-level-sheet)))
396     (setf (slot-value frame 'top-level-sheet) t-l-s)
397     (sheet-adopt-child t-l-s (frame-pane frame))
398     (let ((graft (find-graft :port (frame-manager-port fm))))
399     (sheet-adopt-child graft t-l-s)
400     (setf (graft frame) graft))
401 cvs 1.9 (let ((space (compute-and-set-space t-l-s)))
402 cvs 1.7 (allocate-space (frame-pane frame)
403     (space-requirement-width space)
404     (space-requirement-height space))
405     (setf (sheet-region t-l-s)
406     (make-bounding-rectangle 0 0
407     (space-requirement-width space)
408     (space-requirement-height space))))
409     (setf (sheet-transformation t-l-s)
410     (make-translation-transformation (slot-value frame 'left)
411     (slot-value frame 'top)))))
412    
413     (defmethod disown-frame ((fm frame-manager) (frame menu-frame))
414     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
415     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
416     (setf (frame-manager frame) nil))
417    
418     (defun make-menu-frame (pane &key (left 0) (top 0))
419     (make-instance 'menu-frame :pane pane :left left :top top))
420    

  ViewVC Help
Powered by ViewVC 1.1.5