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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (show annotations)
Sat Jan 20 22:34:39 2001 UTC (13 years, 3 months ago) by cvs
Branch: MAIN
Changes since 1.9: +17 -16 lines
bug fixes by Paul Werkowski
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
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
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 ;;; 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 ;;; 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 (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 (let ((space (compute-and-set-space (frame-top-level-sheet frame))))
138 ;; automatically generates a window-configuation-event
139 ;; which then calls allocate-space
140 (setf (sheet-region (frame-top-level-sheet frame))
141 (make-bounding-rectangle 0 0
142 (space-requirement-width space)
143 (space-requirement-height space)))))
144
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 (compute-and-set-space pane)))
156 (setq width (space-requirement-width space))
157 (setq height (space-requirement-height space))))
158 (allocate-space pane width height)))
159
160 (defun find-pane-of-type (panes type)
161 (setq panes (copy-list panes))
162 (do ((pane (pop panes)(pop panes)))
163 ((null pane) nil)
164 (if (typep pane type)
165 (return pane)
166 (setq panes (nconc panes (copy-list (sheet-children pane)))))))
167
168 (defmethod frame-standard-output ((frame application-frame))
169 (or (find-pane-of-type (frame-panes frame) 'application-pane)
170 (find-pane-of-type (frame-panes frame) 'interactor-pane)))
171
172 (defmethod frame-standard-input ((frame application-frame))
173 (or (find-pane-of-type (frame-panes frame) 'interactor-pane)
174 (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 ;; during development, don't alter *error-output*
217 ;(*error-output* (frame-error-output frame))
218 (*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 (when *standard-input*
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 #+ignore (apply (command-name command) (command-arguments command))
241 (eval command))
242
243 (defmethod make-pane-1 ((fm frame-manager) (frame application-frame) type &rest args)
244 `(make-pane-1 ,fm ,frame ',type ,@args))
245
246 (defmethod adopt-frame ((fm frame-manager) (frame application-frame))
247 (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
248 (setf (frame-manager frame) fm)
249 (let* ((*application-frame* frame)
250 (t-l-s (make-pane-1 fm frame 'top-level-sheet-pane
251 :name 'top-level-sheet)))
252 (setf (slot-value frame 'top-level-sheet) t-l-s)
253 (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 (defvar *pane-realizer* nil)
261
262 (defmacro with-look-and-feel-realization ((frame-manager frame) &body body)
263 `(let ((*pane-realizer* ,frame-manager)
264 (*application-frame* ,frame))
265 (progn
266 ,@body)))
267
268 (defun make-single-pane-generate-panes-form (class-name pane)
269 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
270 (let ((*application-frame* frame))
271 (let ((pane ,pane))
272 (setf (slot-value frame 'pane) pane)))))
273
274 (defun make-panes-generate-panes-form (class-name panes layouts)
275 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
276 (let ((*application-frame* frame))
277 (with-look-and-feel-realization (fm frame)
278 (let ,(loop for (name . form) in panes
279 collect `(,name (or (find-pane-named frame ',name)
280 (let ((pane
281 ,(cond
282 ((and (= (length form) 1)
283 (listp (first form)))
284 (first form))
285 ((keywordp (first form))
286 (let ((maker (intern (concatenate 'string
287 "MAKE-CLIM-"
288 (symbol-name (first form))
289 "-PANE") :clim)))
290 (if (fboundp maker)
291 `(,maker :name ',name ,@(cdr form))
292 `(make-pane ',(first form)
293 :name ',name ,@(cdr form)))))
294 (t `(make-pane ',(first form) :name ',name ,@(cdr form))))))
295 (push pane (slot-value frame 'panes))
296 pane))))
297 (setf (slot-value frame 'pane)
298 (ecase (frame-current-layout frame)
299 ,@layouts)))
300 ))))
301
302 (defmacro define-application-frame (name superclasses slots &rest options)
303 (if (null superclasses)
304 (setq superclasses '(standard-application-frame)))
305 (let ((pane nil)
306 (panes nil)
307 (layouts nil)
308 (current-layout nil)
309 (command-table nil)
310 (menu-bar t)
311 (disabled-commands nil)
312 (command-definer t)
313 (top-level '(default-frame-top-level))
314 (others nil)
315 (command-name (intern (concatenate 'string "DEFINE-" (symbol-name name) "-COMMAND"))))
316 (loop for (prop . values) in options
317 do (case prop
318 (:pane (setq pane (first values)))
319 (:panes (setq panes values))
320 (:layouts (setq layouts values))
321 (:command-table (setq command-table (first values)))
322 (:menu-bar (setq menu-bar (first values)))
323 (:disabled-commands (setq disabled-commands values))
324 (:command-definer (setq command-definer (first values)))
325 (:top-level (setq top-level (first values)))
326 (t (push (cons prop values) others))))
327 (if (or (and pane panes)
328 (and pane layouts))
329 (error ":pane cannot be specified along with either :panes or :layouts"))
330 (if pane
331 (setq panes (list 'single-pane pane)
332 layouts (list :default (first pane))))
333 (setq current-layout (first (first layouts)))
334 `(progn
335 (defclass ,name ,superclasses
336 ,slots
337 (:default-initargs
338 :name ',name
339 :pretty-name ,(string-capitalize name)
340 :command-table ,command-table
341 :disabled-commands ',disabled-commands
342 :menu-bar ,menu-bar
343 :current-layout ',current-layout
344 :layouts ',layouts
345 :top-level ',top-level
346 )
347 ,@others)
348 ,(if pane
349 (make-single-pane-generate-panes-form name pane)
350 (make-panes-generate-panes-form name panes layouts))
351 ,@(if command-definer
352 `((defmacro ,command-name (name-and-options arguements &rest body)
353 (let ((name (if (listp name-and-options) (first name-and-options) name-and-options))
354 (options (if (listp name-and-options) (cdr name-and-options) nil)))
355 `(define-command ,name ,arguements ,@body))))))))
356
357 (defun make-application-frame (frame-name
358 &rest options
359 &key pretty-name frame-manager enable state
360 left top right bottom width height save-under
361 frame-class
362 &allow-other-keys)
363 (setq options (loop for (key value) on options by #'cddr
364 if (not (member key '(:pretty-name :frame-manager :enable :state
365 :left :top :right :bottom :width :height :save-under
366 :frame-class)
367 :key #'eq))
368 nconc (list key value)))
369 (if (null frame-class)
370 (setq frame-class frame-name))
371 (if (null pretty-name)
372 (setq pretty-name (string-capitalize frame-name)))
373 (if (null frame-manager)
374 (setq frame-manager (find-frame-manager)))
375 (let ((frame (apply #'make-instance frame-class
376 :port (frame-manager-port frame-manager)
377 :graft (find-graft :port (frame-manager-port frame-manager))
378 :name frame-name :pretty-name pretty-name options)))
379 (adopt-frame frame-manager frame)
380 frame))
381
382 ;;; Menu frame class
383
384 (defclass menu-frame ()
385 ((left :initform 0 :initarg :left)
386 (top :initform 0 :initarg :top)
387 (top-level-sheet :initform nil :reader frame-top-level-sheet)
388 (pane :reader frame-pane :initarg :pane)
389 (graft :initform nil :accessor graft)
390 (manager :initform nil :accessor frame-manager)))
391
392 (defmethod adopt-frame ((fm frame-manager) (frame menu-frame))
393 (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
394 (setf (slot-value frame 'manager) fm)
395 (let* ((t-l-s (make-pane-1 fm *application-frame* 'unmanaged-top-level-sheet-pane
396 :name 'top-level-sheet)))
397 (setf (slot-value frame 'top-level-sheet) t-l-s)
398 (sheet-adopt-child t-l-s (frame-pane frame))
399 (let ((graft (find-graft :port (frame-manager-port fm))))
400 (sheet-adopt-child graft t-l-s)
401 (setf (graft frame) graft))
402 (let ((space (compute-and-set-space t-l-s)))
403 (allocate-space (frame-pane frame)
404 (space-requirement-width space)
405 (space-requirement-height space))
406 (setf (sheet-region t-l-s)
407 (make-bounding-rectangle 0 0
408 (space-requirement-width space)
409 (space-requirement-height space))))
410 (setf (sheet-transformation t-l-s)
411 (make-translation-transformation (slot-value frame 'left)
412 (slot-value frame 'top)))))
413
414 (defmethod disown-frame ((fm frame-manager) (frame menu-frame))
415 (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
416 (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
417 (setf (frame-manager frame) nil))
418
419 (defun make-menu-frame (pane &key (left 0) (top 0))
420 (make-instance 'menu-frame :pane pane :left left :top top))
421

  ViewVC Help
Powered by ViewVC 1.1.5