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

Contents of /mcclim/frames.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.68 - (hide annotations)
Sat Aug 9 01:34:01 2003 UTC (10 years, 8 months ago) by hefner1
Branch: MAIN
Changes since 1.67: +13 -1 lines
Optimizations for text output...

frames.lisp:
   Leave the stream text cursor invisible by default.

graphics.lisp:
   Make DO-GRAPHICS-WITH-OPTIONS-INTERNAL smarter about not changing the
   medium's ink, clipping region, text style, and line style, unless they've
   really changed.

panes.lisp:
   Removed some dead code (of my own).

recording.lisp:
   Rewrote RECOMPUTE-EXTENT-FOR-CHANGED-CHILD. For the most common case of
   the child growing while fully containing its original bounding rectangle,
   it is possible to compute the parent's new bounding rect without
   recomputing the extent of all the children. This is a significant
   improvement.
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 mikemac 1.60 (in-package :clim-internals)
25 mikemac 1.1
26 gilbert 1.33 ;; *application-frame* is in decls.lisp
27 mikemac 1.1 (defvar *default-frame-manager* nil)
28    
29 cvs 1.5 ;;; Frame-Manager class
30    
31 gilbert 1.56 (define-protocol-class frame-manager ()
32 cvs 1.5 ((port :initarg :port
33     :reader frame-manager-port)
34     (frames :initform nil
35 brian 1.54 :reader frame-manager-frames)))
36 cvs 1.5
37     (defun find-frame-manager (&rest options &key port &allow-other-keys)
38     (declare (special *frame-manager*))
39     (if (boundp '*frame-manager*)
40     *frame-manager*
41     (if (and *default-frame-manager*
42     (frame-manager-p *default-frame-manager*))
43     *default-frame-manager*
44     (first (frame-managers (or port (apply #'find-port options)))))))
45    
46     (defmacro with-frame-manager ((frame-manager) &body body)
47 adejneka 1.43 `(let ((*frame-manager* ,frame-manager))
48 cvs 1.5 (declare (special *frame-manager*))
49 adejneka 1.43 (locally ,@body)))
50    
51 mikemac 1.1 ;;; Application-Frame class
52 moore 1.38 ;;; XXX All these slots should move to a mixin or to standard-application-frame.
53     ;;; -- moore
54 mikemac 1.1
55 gilbert 1.56 (define-protocol-class application-frame ()
56 mikemac 1.1 ((port :initform nil
57     :initarg :port
58     :accessor port)
59     (graft :initform nil
60     :initarg :graft
61     :accessor graft)
62     (name :initarg :name
63     :reader frame-name)
64     (pretty-name :initarg :pretty-name
65     :accessor frame-pretty-name)
66     (command-table :initarg :command-table
67     :initform nil
68     :accessor frame-command-table)
69     (disabled-commands :initarg :disabled-commands
70     :initform nil
71     :accessor frame-disabled-commands)
72     (pane :reader frame-pane)
73     (panes :initform nil
74     :reader frame-panes)
75     (layouts :initform nil
76     :initarg :layouts
77     :reader frame-layouts)
78     (current-layout :initform nil
79     :initarg :current-layout
80     :reader frame-current-layout)
81     (top-level-sheet :initform nil
82     :reader frame-top-level-sheet)
83     (menu-bar :initarg :menu-bar
84     :initform nil)
85     (calling-frame :initarg :calling-frame
86     :initform nil)
87     (state :initarg :state
88 moore 1.52 :initform :disowned
89     :reader frame-state)
90 mikemac 1.1 (manager :initform nil
91 adejneka 1.46 :reader frame-manager
92     :accessor %frame-manager)
93 hefner1 1.65 (keyboard-input-focus :initform nil
94     :accessor keyboard-input-focus)
95 mikemac 1.1 (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 moore 1.38 :accessor frame-hilited-presentation)))
103 mikemac 1.1
104 adejneka 1.13 ;;; Generic operations
105     ; (defgeneric frame-name (frame))
106     ; (defgeneric frame-pretty-name (frame))
107     ; (defgeneric (setf frame-pretty-name) (name frame))
108     ; (defgeneric frame-command-table (frame))
109     ; (defgeneric (setf frame-command-table) (command-table frame))
110     (defgeneric frame-standard-output (frame)
111     (:documentation
112     "Returns the stream that will be used for *standard-output* for the FRAME."))
113     (defgeneric frame-standard-input (frame)
114     (:documentation
115     "Returns the stream that will be used for *standard-input* for the FRAME."))
116     (defgeneric frame-query-io (frame)
117     (:documentation
118     "Returns the stream that will be used for *query-io* for the FRAME."))
119     (defgeneric frame-error-output (frame)
120     (:documentation
121     "Returns the stream that will be used for *error-output* for the FRAME."))
122     (defgeneric frame-pointer-documentation-output (frame)
123     (:documentation
124     "Returns the stream that will be used for *pointer-documentation-output*
125     for the FRAME."))
126     (defgeneric frame-calling-frame (frame)
127     (:documentation
128     "Returns the application frame that invoked the FRAME."))
129     (defgeneric frame-parent (frame)
130     (:documentation
131     "Returns the object that acts as the parent for the FRAME."))
132     ;(defgeneric frame-pane (frame) ; XXX Is it in Spec?
133     ; (:documentation
134     ; "Returns the pane that is the top-level pane in the current layout
135     ;of the FRAME's named panes."))
136     (defgeneric frame-top-level-sheet (frame)
137     (:documentation
138     "Returns the shhet that is the top-level sheet for the FRAME. This
139     is the sheet that has as its descendants all of the panes of the FRAME."))
140     (defgeneric frame-current-panes (frame)
141     (:documentation
142     "Returns a list of those named panes in the FRAME's current layout.
143     If there are no named panes, only the single, top level pane is returned."))
144     (defgeneric get-frame-pane (frame pane-name)
145     (:documentation
146     "Returns the named CLIM stream pane in the FRAME whose name is PANE-NAME."))
147     (defgeneric find-pane-named (frame pane-name)
148     (:documentation
149     "Returns the pane in the FRAME whose name is PANE-NAME."))
150     ;(defgeneric frame-current-layout (frame))
151     ;(defgeneric frame-all-layouts (frame)) ; XXX Is it in Spec?
152     (defgeneric layout-frame (frame &optional width height))
153 mikemac 1.22 (defgeneric frame-exit-frame (condition)
154     (:documentation
155     "Returns the frame that is being exited from associated with the
156     FRAME-EXIT condition."))
157 adejneka 1.13 (defgeneric frame-exit (frame) ; XXX Is it in Spec?
158     (:documentation
159     "Exits from the FRAME."))
160     (defgeneric pane-needs-redisplay (pane))
161     (defgeneric (setf pane-needs-redisplay) (value pane))
162     (defgeneric redisplay-frame-pane (frame pane &key force-p))
163     (defgeneric redisplay-frame-panes (frame &key force-p))
164     (defgeneric frame-replay (frame stream &optional region))
165     (defgeneric notify-user (frame message &key associated-window title
166     documentation exit-boxes name style text-style))
167     ;(defgeneric frame-properties (frame property))
168     ;(defgeneric (setf frame-properties) (value frame property))
169    
170 brian 1.54 ; extension
171     (defgeneric frame-schedule-timer-event (frame sheet delay token))
172 adejneka 1.13
173 hefner1 1.68 (defgeneric note-input-focus-changed (pane state)
174     (:documentation "Called when a pane receives or loses the keyboard
175     input focus. This is a McCLIM extension."))
176    
177 mikemac 1.1 (defclass standard-application-frame (application-frame)
178 moore 1.38 ((event-queue :initarg :frame-event-queue
179 hefner1 1.66 :initarg :input-buffer
180     :initform nil
181 moore 1.38 :accessor frame-event-queue
182     :documentation "The event queue that, by default, will be
183 moore 1.47 shared by all panes in the stream")
184     (documentation-state :accessor frame-documentation-state
185     :initform nil
186     :documentation "Used to keep of track of what
187     needs to be rendered in the pointer documentation frame.")))
188 moore 1.38
189     ;;; Support the :input-buffer initarg for compatibility with "real CLIM"
190    
191     (defmethod initialize-instance :after ((obj standard-application-frame)
192 hefner1 1.66 &key &allow-other-keys)
193     (unless (frame-event-queue obj)
194     (setf (frame-event-queue obj) (make-instance 'standard-event-queue))))
195 moore 1.38
196 mikemac 1.1
197     (defmethod (setf frame-manager) (fm (frame application-frame))
198     (let ((old-manager (frame-manager frame)))
199 adejneka 1.46 (setf (%frame-manager frame) nil)
200 mikemac 1.1 (when old-manager
201     (disown-frame old-manager frame)
202     (setf (slot-value frame 'panes) nil)
203     (setf (slot-value frame 'layouts) nil))
204 adejneka 1.46 (setf (%frame-manager frame) fm)))
205 mikemac 1.1
206     (defmethod (setf frame-current-layout) (name (frame application-frame))
207     (declare (ignore name))
208     (generate-panes (frame-manager frame) frame))
209    
210     (defmethod generate-panes :before (fm (frame application-frame))
211     (declare (ignore fm))
212     (when (and (slot-boundp frame 'pane)
213     (frame-pane frame))
214     (sheet-disown-child (frame-top-level-sheet frame) (frame-pane frame))))
215    
216     (defmethod generate-panes :after (fm (frame application-frame))
217     (declare (ignore fm))
218     (sheet-adopt-child (frame-top-level-sheet frame) (frame-pane frame))
219 cvs 1.5 (sheet-adopt-child (graft frame) (frame-top-level-sheet frame))
220 hatchond 1.11 (let ((space (compose-space (frame-top-level-sheet frame))))
221 cvs 1.5 ;; automatically generates a window-configuation-event
222     ;; which then calls allocate-space
223 gilbert 1.39 ;;
224     ;; Not any longer, we turn of CONFIGURE-NOTIFY events until the
225     ;; window is mapped and do the space allocation now, so that all
226     ;; sheets will have their correct geometry at once. --GB
227 mikemac 1.1 (setf (sheet-region (frame-top-level-sheet frame))
228 cvs 1.5 (make-bounding-rectangle 0 0
229     (space-requirement-width space)
230 gilbert 1.39 (space-requirement-height space)))
231     (allocate-space (frame-top-level-sheet frame)
232     (space-requirement-width space)
233     (space-requirement-height space)) ))
234 mikemac 1.1
235     (defmethod layout-frame ((frame application-frame) &optional width height)
236     (let ((pane (frame-pane frame)))
237     (if (and width (not height))
238     (error "LAYOUT-FRAME must be called with both WIDTH and HEIGHT or neither"))
239     (if (and (null width) (null height))
240 hatchond 1.11 (let ((space (compose-space pane)))
241 mikemac 1.1 (setq width (space-requirement-width space))
242     (setq height (space-requirement-height space))))
243 gilbert 1.63 (let ((tpl-sheet (frame-top-level-sheet frame)))
244     (unless (and (= width (bounding-rectangle-width tpl-sheet))
245     (= height (bounding-rectangle-height tpl-sheet)))
246     (resize-sheet (frame-top-level-sheet frame) width height)))
247 mikemac 1.1 (allocate-space pane width height)))
248    
249 adejneka 1.13 (defun find-pane-if (predicate panes)
250     "Returns a pane satisfying PREDICATE in the forest growing from PANES"
251 moore 1.27 (loop for pane in panes
252     do (map-over-sheets #'(lambda (p)
253     (when (funcall predicate p)
254     (return-from find-pane-if p)))
255     pane)
256     finally (return nil)))
257    
258 adejneka 1.13 (defun find-pane-of-type (panes type)
259     (find-pane-if #'(lambda (pane) (typep pane type)) panes))
260 adejneka 1.40
261 adejneka 1.13 (defmethod frame-current-panes ((frame application-frame))
262     (find-pane-if #'(lambda (pane) (pane-name pane))
263     (frame-current-layout frame)))
264    
265     (defmethod get-frame-pane ((frame application-frame) pane-name)
266     (find-pane-if #'(lambda (pane)
267     (and (typep pane 'clim-stream-pane)
268     (eq pane-name
269     (pane-name pane))))
270     (frame-panes frame)))
271    
272     (defmethod find-pane-named ((frame application-frame) pane-name)
273     (find-pane-if #'(lambda (pane)
274     (eq pane-name
275     (pane-name pane)))
276     (frame-panes frame)))
277    
278 mikemac 1.1 (defmethod frame-standard-output ((frame application-frame))
279 cvs 1.6 (or (find-pane-of-type (frame-panes frame) 'application-pane)
280     (find-pane-of-type (frame-panes frame) 'interactor-pane)))
281 mikemac 1.1
282     (defmethod frame-standard-input ((frame application-frame))
283 cvs 1.6 (or (find-pane-of-type (frame-panes frame) 'interactor-pane)
284 mikemac 1.1 (frame-standard-output frame)))
285    
286     (defmethod frame-query-io ((frame application-frame))
287     (or (frame-standard-input frame)
288     (frame-standard-output frame)))
289    
290     (defmethod frame-error-output ((frame application-frame))
291     (frame-standard-output frame))
292    
293     (defvar *pointer-documentation-output* nil)
294    
295     (defmethod frame-pointer-documentation-output ((frame application-frame))
296 adejneka 1.13 (find-pane-of-type (frame-panes frame) 'pointer-documentation-pane))
297 mikemac 1.1
298     ;;; Command loop interface
299    
300 mikemac 1.22 (define-condition frame-exit (condition)
301 moore 1.26 ((frame :initarg :frame :reader %frame-exit-frame)))
302 mikemac 1.22
303 hefner1 1.66 ;; I make the assumption here that the contents of *application-frame* is
304     ;; the frame the top-level loop is running. With the introduction of
305     ;; window-stream frames that may be sharing the event queue with the main
306     ;; application frame, we need to discriminate between them here to avoid
307     ;; shutting down the application at the wrong time.
308     ;; ...
309     ;; A better way to do this would be to make the handler bound in
310     ;; run-frame-top-level check whether the frame signalled is the one
311     ;; it was invoked on.. -- Hefner
312    
313 mikemac 1.22 (defmethod frame-exit ((frame standard-application-frame))
314 hefner1 1.66 (if (eq *application-frame* frame)
315     (signal 'frame-exit :frame frame)
316     (disown-frame (frame-manager frame) frame)))
317 moore 1.26
318     (defmethod frame-exit-frame ((c frame-exit))
319     (%frame-exit-frame c))
320 mikemac 1.22
321 moore 1.59 (defmethod redisplay-frame-pane ((frame application-frame) pane &key force-p)
322     (declare (ignore pane force-p))
323     nil)
324    
325 adejneka 1.44 (defmethod run-frame-top-level ((frame application-frame) &key &allow-other-keys)
326 mikemac 1.22 (handler-bind ((frame-exit #'(lambda (condition)
327 gilbert 1.31 (declare (ignore condition))
328 mikemac 1.22 (return-from run-frame-top-level nil))))
329     (apply (first (frame-top-level frame)) frame (rest (frame-top-level frame)))))
330 mikemac 1.1
331 adejneka 1.44 (defmethod run-frame-top-level :around ((frame application-frame) &key)
332 mikemac 1.1 (let ((*application-frame* frame)
333     (*input-context* nil)
334     (*input-wait-test* nil)
335     (*input-wait-handler* nil)
336 moore 1.52 (*pointer-button-press-handler* nil)
337     (original-state (frame-state frame)))
338 mikemac 1.1 (declare (special *input-context* *input-wait-test* *input-wait-handler*
339     *pointer-button-press-handler*))
340 moore 1.52 (when (eq (frame-state frame) :disowned)
341     (adopt-frame (or (frame-manager frame) (find-frame-manager))
342     frame))
343     (unless (or (eq (frame-state frame) :enabled)
344     (eq (frame-state frame) :shrunk))
345     (enable-frame frame))
346 moore 1.24 (let ((query-io (frame-query-io frame)))
347 moore 1.52 (unwind-protect
348     (if query-io
349 hefner1 1.66 (with-input-focus (query-io)
350 moore 1.52 (call-next-method))
351     (call-next-method))
352     (case original-state
353     (:disabled
354     (disable-frame frame))
355     (:disowned
356     (disown-frame (frame-manager frame) frame)))))))
357 mikemac 1.1
358     (defmethod default-frame-top-level
359     ((frame application-frame)
360     &key (command-parser 'command-line-command-parser)
361     (command-unparser 'command-line-command-unparser)
362     (partial-command-parser
363     'command-line-read-remaining-arguments-for-partial-command)
364 moore 1.35 (prompt "Command: "))
365 mikemac 1.20 (loop
366     (let ((*standard-input* (frame-standard-input frame))
367     (*standard-output* (frame-standard-output frame))
368     (*query-io* (frame-query-io frame))
369 moore 1.47 (*pointer-documentation-output* (frame-pointer-documentation-output
370     frame))
371 mikemac 1.20 ;; during development, don't alter *error-output*
372 gilbert 1.39 ;; (*error-output* (frame-error-output frame))
373 mikemac 1.20 (*command-parser* command-parser)
374     (*command-unparser* command-unparser)
375     (*partial-command-parser* partial-command-parser)
376 gilbert 1.39 (prompt-style (make-text-style :fix :italic :normal)))
377 mikemac 1.20 (map-over-sheets #'(lambda (pane)
378 moore 1.59 (multiple-value-bind (redisplayp clearp)
379     (pane-needs-redisplay pane)
380     (when redisplayp
381     (when (and clearp
382     (or (not (pane-incremental-redisplay
383     pane))
384     (not *enable-updating-output*)))
385     (window-clear pane))
386     (redisplay-frame-pane frame pane)
387     (unless (eq redisplayp :command-loop)
388     (setf (pane-needs-redisplay pane) nil)))))
389 mikemac 1.20 (frame-top-level-sheet frame))
390     (when *standard-input*
391 hefner1 1.68 ;; We don't need to turn the cursor on here, as Goatee has its own
392     ;; cursor which will appear. In fact, as a sane interface policy,
393     ;; leave it off by default, and hopefully this doesn't violate the spec.
394     (setf (cursor-visibility (stream-text-cursor *standard-input*)) nil)
395 mikemac 1.21 (when prompt
396     (with-text-style (*standard-input* prompt-style)
397     (if (stringp prompt)
398 moore 1.35 (write-string prompt *standard-input*)
399     (funcall prompt *standard-input* frame))
400 adejneka 1.40 (finish-output *standard-input*)))
401 moore 1.35 (let ((command (read-frame-command frame)))
402     (fresh-line *standard-input*)
403     (when command
404     (execute-frame-command frame command))
405     (fresh-line *standard-input*))))))
406    
407 mikemac 1.1
408 moore 1.64 (defmethod read-frame-command ((frame application-frame)
409     &key (stream *standard-input*))
410     (with-input-context ('menu-item)
411     (object)
412     ;; Is this the intended behavior of interactor-panes
413     ;; (vs. application panes)?
414     (if (typep stream 'interactor-pane)
415     (read-command (frame-command-table frame) :stream stream)
416     (loop (read-gesture :stream stream)))
417     (menu-item
418     (let ((command (command-menu-item-value object)))
419     (if (listp command)
420     command
421     (list command))))))
422    
423 mikemac 1.1
424     (defmethod execute-frame-command ((frame application-frame) command)
425 moore 1.35 (apply (command-name command) (command-arguments command)))
426    
427 mikemac 1.1 (defmethod make-pane-1 ((fm frame-manager) (frame application-frame) type &rest args)
428     `(make-pane-1 ,fm ,frame ',type ,@args))
429 moore 1.38
430     (defmethod make-pane-1 :around (fm (frame standard-application-frame) type
431     &rest args
432 moore 1.51 &key (input-buffer nil input-buffer-p)
433     &allow-other-keys)
434 moore 1.38 "Default input-buffer to the frame event queue."
435     (if input-buffer-p
436     (call-next-method)
437     (apply #'call-next-method fm frame type
438     :input-buffer (frame-event-queue frame)
439     args)))
440 mikemac 1.1
441     (defmethod adopt-frame ((fm frame-manager) (frame application-frame))
442     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
443     (setf (frame-manager frame) fm)
444 moore 1.52 (setf (port frame) (frame-manager-port fm))
445     (setf (graft frame) (find-graft :port (port frame)))
446 mikemac 1.1 (let* ((*application-frame* frame)
447 cvs 1.4 (t-l-s (make-pane-1 fm frame 'top-level-sheet-pane
448 moore 1.52 :name 'top-level-sheet
449     ;; enabling should be left to enable-frame
450     :enabled-p nil)))
451 mikemac 1.1 (setf (slot-value frame 'top-level-sheet) t-l-s)
452 moore 1.52 (generate-panes fm frame)
453     (setf (slot-value frame 'state) :disabled)
454     frame))
455 brian 1.28
456 mikemac 1.1 (defmethod disown-frame ((fm frame-manager) (frame application-frame))
457     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
458     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
459 moore 1.52 (setf (%frame-manager frame) nil)
460     (setf (slot-value frame 'state) :disowned)
461     frame)
462    
463     (defgeneric enable-frame (frame))
464     (defgeneric disable-frame (frame))
465    
466     (defgeneric note-frame-enabled (frame-manager frame))
467     (defgeneric note-frame-disbled (frame-manager frame))
468    
469     (defmethod enable-frame ((frame application-frame))
470     (setf (sheet-enabled-p (frame-top-level-sheet frame)) t)
471     (setf (slot-value frame 'state) :enabled)
472     (note-frame-enabled (frame-manager frame) frame))
473    
474     (defmethod disable-frame ((frame application-frame))
475     (setf (sheet-enabled-p (frame-top-level-sheet frame)) nil)
476     (setf (slot-value frame 'state) :disabled)
477     (note-frame-disabled (frame-manager frame) frame))
478    
479     (defmethod note-frame-enabled ((fm frame-manager) frame)
480     (declare (ignore frame))
481     t)
482    
483     (defmethod note-frame-disabled ((fm frame-manager) frame)
484     t)
485 mikemac 1.1
486 cvs 1.8 (defvar *pane-realizer* nil)
487    
488 mikemac 1.1 (defmacro with-look-and-feel-realization ((frame-manager frame) &body body)
489 cvs 1.8 `(let ((*pane-realizer* ,frame-manager)
490     (*application-frame* ,frame))
491 adejneka 1.45 (locally
492     ,@body)))
493 mikemac 1.1
494 brian 1.28 ; The menu-bar code in the following two functions is incorrect.
495     ; it needs to be moved to somewhere after the backend, since
496     ; it depends on the backend chosen.
497     ;
498     ; This hack slaps a menu-bar into the start of the application-frame,
499     ; in such a way that it is hard to find.
500     ;
501     ; FIXME
502     (defun make-single-pane-generate-panes-form (class-name menu-bar pane)
503 mikemac 1.1 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
504 brian 1.28 ; v-- hey, how can this be?
505 moore 1.17 (with-look-and-feel-realization (fm frame)
506 brian 1.28 (let ((pane ,(cond
507     ((eq menu-bar t)
508     `(vertically () (clim-internals::make-menu-bar
509     ',class-name)
510     ,pane))
511 brian 1.32 ((consp menu-bar)
512 brian 1.28 `(vertically () (clim-internals::make-menu-bar
513     (make-command-table nil
514     :menu ',menu-bar))
515     ,pane))
516     (menu-bar
517     `(vertically () (clim-internals::make-menu-bar
518     ',menu-bar)
519     ,pane))
520 gilbert 1.31 ;; The form below is unreachable with (listp
521     ;; menu-bar) instead of (consp menu-bar) above
522     ;; --GB
523 brian 1.28 (t pane))))
524     (setf (slot-value frame 'pane) pane)))))
525 mikemac 1.1
526 brian 1.28 ; could do with some refactoring [BTS] FIXME
527 moore 1.47 (defun make-panes-generate-panes-form (class-name menu-bar panes layouts
528     pointer-documentation)
529     (when pointer-documentation
530     (setf panes (append panes
531     '((%pointer-documentation%
532     pointer-documentation-pane)))))
533 mikemac 1.1 `(defmethod generate-panes ((fm frame-manager) (frame ,class-name))
534     (let ((*application-frame* frame))
535 cvs 1.8 (with-look-and-feel-realization (fm frame)
536     (let ,(loop for (name . form) in panes
537     collect `(,name (or (find-pane-named frame ',name)
538     (let ((pane
539     ,(cond
540     ((and (= (length form) 1)
541     (listp (first form)))
542     (first form))
543     ((keywordp (first form))
544     (let ((maker (intern (concatenate 'string
545 mikemac 1.62 (symbol-name '#:make-clim-)
546 cvs 1.8 (symbol-name (first form))
547 mikemac 1.62 (symbol-name '#:-pane))
548 mikemac 1.61 :clim)))
549 cvs 1.8 (if (fboundp maker)
550     `(,maker :name ',name ,@(cdr form))
551     `(make-pane ',(first form)
552     :name ',name ,@(cdr form)))))
553     (t `(make-pane ',(first form) :name ',name ,@(cdr form))))))
554 gilbert 1.19 ;; hmm?! --GB
555     (setf (slot-value pane 'name) ',name)
556     ;;
557 cvs 1.8 (push pane (slot-value frame 'panes))
558     pane))))
559 brian 1.28 ; [BTS] added this, but is not sure that this is correct for adding
560     ; a menu-bar transparently, should also only be done where the
561     ; exterior window system does not support menus
562 moore 1.47 ,(if (or menu-bar pointer-documentation)
563 brian 1.28 `(setf (slot-value frame 'pane)
564     (ecase (frame-current-layout frame)
565     ,@(mapcar (lambda (layout)
566 moore 1.47 `(,(first layout)
567     (vertically ()
568     ,@(cond
569     ((eq menu-bar t)
570     `((clim-internals::make-menu-bar
571     ',class-name)))
572     ((consp menu-bar)
573 gilbert 1.55 `((clim-internals::make-menu-bar
574 moore 1.47 (make-command-table
575     nil
576 gilbert 1.55 :menu ',menu-bar))))
577 moore 1.47 (menu-bar
578     `((clim-internals::make-menu-bar
579     ',menu-bar)))
580     (t nil))
581     ,@(rest layout)
582     ,@(when pointer-documentation
583     '(%pointer-documentation%)))))
584 brian 1.28 layouts)))
585     `(setf (slot-value frame 'pane)
586     (ecase (frame-current-layout frame)
587     ,@layouts))))))))
588 mikemac 1.1
589     (defmacro define-application-frame (name superclasses slots &rest options)
590     (if (null superclasses)
591     (setq superclasses '(standard-application-frame)))
592     (let ((pane nil)
593     (panes nil)
594     (layouts nil)
595     (current-layout nil)
596 mikemac 1.23 (command-table (list name))
597 mikemac 1.1 (menu-bar t)
598     (disabled-commands nil)
599     (command-definer t)
600     (top-level '(default-frame-top-level))
601     (others nil)
602 mikemac 1.61 (command-name (intern (concatenate 'string
603 mikemac 1.62 (symbol-name '#:define-)
604 mikemac 1.61 (symbol-name name)
605 mikemac 1.62 (symbol-name '#:-command))))
606 moore 1.47 (pointer-documentation nil))
607 mikemac 1.1 (loop for (prop . values) in options
608     do (case prop
609     (:pane (setq pane (first values)))
610     (:panes (setq panes values))
611     (:layouts (setq layouts values))
612     (:command-table (setq command-table (first values)))
613 brian 1.28 (:menu-bar (setq menu-bar (if (listp values)
614     (first values)
615     values)))
616 mikemac 1.1 (:disabled-commands (setq disabled-commands values))
617     (:command-definer (setq command-definer (first values)))
618     (:top-level (setq top-level (first values)))
619 moore 1.47 (:pointer-documentation (setq pointer-documentation (car values)))
620 mikemac 1.1 (t (push (cons prop values) others))))
621     (if (or (and pane panes)
622     (and pane layouts))
623     (error ":pane cannot be specified along with either :panes or :layouts"))
624     (if pane
625     (setq panes (list 'single-pane pane)
626 moore 1.17 layouts `((:default ,(car pane)))))
627 mikemac 1.1 (setq current-layout (first (first layouts)))
628     `(progn
629     (defclass ,name ,superclasses
630     ,slots
631     (:default-initargs
632     :name ',name
633     :pretty-name ,(string-capitalize name)
634 mikemac 1.23 :command-table (find-command-table ',(first command-table))
635 mikemac 1.1 :disabled-commands ',disabled-commands
636 brian 1.28 :menu-bar ',menu-bar
637 mikemac 1.1 :current-layout ',current-layout
638     :layouts ',layouts
639     :top-level ',top-level
640     )
641     ,@others)
642     ,(if pane
643 brian 1.28 (make-single-pane-generate-panes-form name menu-bar pane)
644 moore 1.47 (make-panes-generate-panes-form name menu-bar panes layouts
645     pointer-documentation))
646 mikemac 1.23 ,@(if command-table
647     `((define-command-table ,@command-table)))
648 mikemac 1.1 ,@(if command-definer
649     `((defmacro ,command-name (name-and-options arguements &rest body)
650     (let ((name (if (listp name-and-options) (first name-and-options) name-and-options))
651 mikemac 1.23 (options (if (listp name-and-options) (cdr name-and-options) nil))
652     (command-table ',(first command-table)))
653     `(define-command (,name :command-table ,command-table ,@options) ,arguements ,@body))))))))
654 mikemac 1.1
655     (defun make-application-frame (frame-name
656     &rest options
657 moore 1.52 &key (pretty-name
658     (string-capitalize frame-name))
659     (frame-manager nil frame-manager-p)
660     enable
661     (state nil state-supplied-p)
662     left top right bottom width height
663     save-under (frame-class frame-name)
664 mikemac 1.1 &allow-other-keys)
665 moore 1.52 (declare (ignore left top right bottom width height save-under))
666     (with-keywords-removed (options (:pretty-name :frame-manager :enable :state
667     :left :top :right :bottom :width :height
668 moore 1.53 :save-under :frame-class))
669 moore 1.52 (let ((frame (apply #'make-instance frame-class
670     :name frame-name :pretty-name pretty-name options)))
671     (when frame-manager-p
672     (adopt-frame frame-manager frame))
673     (cond ((or enable (eq state :enabled))
674     (enable-frame frame))
675     ((and (eq state :disowned)
676     (not (eq (frame-state frame) :disowned)))
677     (disown-frame (frame-manager frame) frame))
678     (state-supplied-p
679     (warn ":state ~S not supported yet." state)))
680     frame)))
681 cvs 1.4
682 cvs 1.7 ;;; Menu frame class
683    
684     (defclass menu-frame ()
685     ((left :initform 0 :initarg :left)
686     (top :initform 0 :initarg :top)
687     (top-level-sheet :initform nil :reader frame-top-level-sheet)
688     (pane :reader frame-pane :initarg :pane)
689     (graft :initform nil :accessor graft)
690     (manager :initform nil :accessor frame-manager)))
691 adejneka 1.46
692 cvs 1.7 (defmethod adopt-frame ((fm frame-manager) (frame menu-frame))
693     (setf (slot-value fm 'frames) (cons frame (slot-value fm 'frames)))
694 adejneka 1.46 (setf (frame-manager frame) fm)
695 brian 1.54 (let* ((t-l-s (make-pane-1 fm *application-frame*
696     'unmanaged-top-level-sheet-pane
697 cvs 1.7 :name 'top-level-sheet)))
698     (setf (slot-value frame 'top-level-sheet) t-l-s)
699     (sheet-adopt-child t-l-s (frame-pane frame))
700     (let ((graft (find-graft :port (frame-manager-port fm))))
701     (sheet-adopt-child graft t-l-s)
702     (setf (graft frame) graft))
703 hatchond 1.11 (let ((space (compose-space t-l-s)))
704 cvs 1.7 (allocate-space (frame-pane frame)
705     (space-requirement-width space)
706     (space-requirement-height space))
707     (setf (sheet-region t-l-s)
708     (make-bounding-rectangle 0 0
709     (space-requirement-width space)
710     (space-requirement-height space))))
711     (setf (sheet-transformation t-l-s)
712     (make-translation-transformation (slot-value frame 'left)
713     (slot-value frame 'top)))))
714    
715     (defmethod disown-frame ((fm frame-manager) (frame menu-frame))
716     (setf (slot-value fm 'frames) (remove frame (slot-value fm 'frames)))
717     (sheet-disown-child (graft frame) (frame-top-level-sheet frame))
718     (setf (frame-manager frame) nil))
719    
720     (defun make-menu-frame (pane &key (left 0) (top 0))
721     (make-instance 'menu-frame :pane pane :left left :top top))
722 moore 1.18
723     ;;; Frames and presentations
724    
725     (defmethod frame-find-innermost-applicable-presentation
726     ((frame standard-application-frame) input-context stream x y
727     &key event)
728     (find-innermost-applicable-presentation input-context stream
729     x y
730     :frame frame :event event))
731    
732 adejneka 1.41 (defmethod frame-input-context-button-press-handler
733 moore 1.18 ((frame standard-application-frame)
734     (stream output-recording-stream)
735     button-press-event)
736     (let ((presentation (find-innermost-applicable-presentation
737     *input-context*
738     stream
739     (pointer-event-x button-press-event)
740     (pointer-event-y button-press-event)
741 moore 1.37 :frame frame
742     :event button-press-event)))
743 moore 1.18 (when presentation
744     (throw-highlighted-presentation presentation
745     *input-context*
746     button-press-event))))
747    
748     (defmethod frame-input-context-button-press-handler
749     ((frame standard-application-frame) stream button-press-event)
750 mikemac 1.36 (declare (ignore stream button-press-event))
751 moore 1.27 nil)
752 moore 1.18
753 moore 1.47 (defgeneric frame-update-pointer-documentation
754     (frame input-context stream event))
755    
756     (defconstant +button-documentation+ '((#.+pointer-left-button+ "L")
757     (#.+pointer-middle-button+ "M")
758     (#.+pointer-right-button+ "R")))
759    
760 moore 1.48 (defconstant +modifier-documentation+
761     '((#.+shift-key+ "sh" "Shift")
762     (#.+control-key+ "c" "Control")
763     (#.+meta-key+ "m" "Meta")
764     (#.+super-key+ "s" "Super")
765     (#.+hyper-key+ "h" "Hyper")))
766    
767     ;;; Give a coherent order to sets of modifier combinations. Multi-key combos
768     ;;; come after single keys.
769    
770     (defun cmp-modifiers (a b)
771     (let ((cnt-a (logcount a))
772     (cnt-b (logcount b)))
773     (cond ((eql cnt-a cnt-b)
774     (< a b))
775     (t (< cnt-a cnt-b)))))
776    
777     (defun print-modifiers (stream modifiers style)
778 moore 1.49 (if (zerop modifiers)
779     (when (eq style :long)
780     (write-string "<nothing>" stream))
781     (loop with trailing = nil
782     for (bit short long) in +modifier-documentation+
783     when (logtest bit modifiers)
784     do (progn
785     (format stream "~:[~;-~]~A" trailing (if (eq style :short)
786     short
787     long))
788     (setq trailing t)))))
789 moore 1.48
790    
791     ;;; We don't actually want to print out the translator documentation and redraw
792     ;;; the pointer documentation window on every motion event. So, we compute a
793     ;;; state object (basically modifier state and a list of the applicable
794     ;;; presentation, translator and input context on each mouse button),
795     ;;; compare it to the previous state object, and only write out documentation
796     ;;; if they are different. I suppose it's possible that this state object
797     ;;; doesn't capture all possible documentation changes -- the doc generator is
798     ;;; a function, after all -- but that's just tough.
799     ;;;
800     ;;; It would be nice to evolve this into a protocol so that elements other than
801     ;;; presentations -- menu choices, for example -- could influence pointer
802     ;;; documentation window.
803    
804 moore 1.50 (defgeneric frame-compute-pointer-documentation-state
805     (frame input-context stream event)
806     (:documentation
807     "Compute a state object that will be used to generate pointer documentation."))
808    
809     (defmethod frame-compute-pointer-documentation-state
810     ((frame standard-application-frame) input-context stream event)
811     (let* ((current-modifier (event-modifier-state event))
812     (x (device-event-x event))
813     (y (device-event-y event))
814     (new-translators
815     (loop for (button) in +button-documentation+
816     for context-list = (multiple-value-list
817     (find-innermost-presentation-context
818     input-context
819     stream
820     x y
821     :modifier-state current-modifier
822     :button button))
823     when (car context-list)
824     collect (cons button context-list))))
825     (list current-modifier new-translators)))
826    
827     (defgeneric frame-compare-pointer-documentation-state
828     (frame input-context stream old-state new-state))
829    
830     (defmethod frame-compare-pointer-documentation-state
831     ((frame standard-application-frame) input-context stream
832     old-state new-state)
833     (equal old-state new-state))
834    
835     (defgeneric frame-print-pointer-documentation
836     (frame input-context stream state event))
837    
838     (defmethod frame-print-pointer-documentation
839     ((frame standard-application-frame) input-context stream state event)
840     (unless state
841     (return-from frame-print-pointer-documentation nil))
842     (destructuring-bind (current-modifier new-translators)
843     state
844     (let ((x (device-event-x event))
845     (y (device-event-y event))
846     (pstream *pointer-documentation-output*))
847     (loop for (button presentation translator context)
848     in new-translators
849     for name = (cadr (assoc button +button-documentation+))
850     for first-one = t then nil
851     do (progn
852     (unless first-one
853     (write-string "; " pstream))
854     (unless (zerop current-modifier)
855     (print-modifiers pstream current-modifier :short)
856     (write-string "-" pstream))
857     (format pstream "~A: " name)
858     (document-presentation-translator translator
859     presentation
860     (input-context-type context)
861     *application-frame*
862     event
863     stream
864     x y
865     :stream pstream
866     :documentation-type
867     :pointer))
868     finally (when new-translators
869     (write-char #\. pstream)))
870     ;; Wasteful to do this after doing
871     ;; find-innermost-presentation-context above... look at doing this
872     ;; first and then doing the innermost test.
873     (let ((all-translators (find-applicable-translators
874     (stream-output-history stream)
875     input-context
876     *application-frame*
877     stream
878     x y
879     :for-menu t))
880     (other-modifiers nil))
881     (loop for (translator) in all-translators
882     for gesture = (gesture translator)
883     unless (eq gesture t)
884     do (loop for (name type modifier) in gesture
885     unless (eql modifier current-modifier)
886     do (pushnew modifier other-modifiers)))
887     (when other-modifiers
888     (setf other-modifiers (sort other-modifiers #'cmp-modifiers))
889     (terpri pstream)
890     (write-string "To see other commands, press " pstream)
891     (loop for modifier-tail on other-modifiers
892     for (modifier) = modifier-tail
893     for count from 0
894     do (progn
895     (if (null (cdr modifier-tail))
896     (progn
897     (when (> count 1)
898     (write-char #\, pstream))
899     (when (> count 0)
900     (write-string " or " pstream)))
901     (when (> count 0)
902     (write-string ", " pstream)))
903     (print-modifiers pstream modifier :long)))
904     (write-char #\. pstream))))))
905    
906 moore 1.47 (defmethod frame-update-pointer-documentation
907     ((frame standard-application-frame) input-context stream event)
908     (when *pointer-documentation-output*
909     (with-accessors ((frame-documentation-state frame-documentation-state))
910     frame
911 moore 1.50 (let ((new-state (frame-compute-pointer-documentation-state frame
912     input-context
913     stream
914     event)))
915     (unless (frame-compare-pointer-documentation-state
916     frame
917     input-context
918     stream
919     frame-documentation-state
920     new-state)
921     (window-clear *pointer-documentation-output*)
922     (frame-print-pointer-documentation frame
923     input-context
924     stream
925     new-state
926     event)
927     (setq frame-documentation-state new-state))))))
928 moore 1.47
929 moore 1.18 (defmethod frame-input-context-track-pointer
930     ((frame standard-application-frame)
931     input-context
932     (stream output-recording-stream) event)
933     (declare (ignore input-context event))
934     nil)
935    
936     (defmethod frame-input-context-track-pointer
937     ((frame standard-application-frame) input-context stream event)
938 mikemac 1.36 (declare (ignore input-context stream event))
939 moore 1.27 nil)
940 moore 1.18
941     (defmethod frame-input-context-track-pointer :before
942     ((frame standard-application-frame) input-context stream event)
943 moore 1.47 (flet ((maybe-unhighlight (presentation)
944     (when (and (frame-hilited-presentation frame)
945     (not (eq presentation
946     (car (frame-hilited-presentation frame)))))
947     (highlight-presentation-1 (car (frame-hilited-presentation frame))
948     (cdr (frame-hilited-presentation frame))
949     :unhighlight))))
950 moore 1.18 (if (output-recording-stream-p stream)
951     (let ((presentation (find-innermost-applicable-presentation
952     input-context
953     stream
954 moore 1.50 (device-event-x event)
955     (device-event-y event)
956 moore 1.37 :frame frame
957     :modifier-state (event-modifier-state event))))
958 moore 1.47 (maybe-unhighlight presentation)
959 moore 1.34 (if presentation
960     (when (not (eq presentation
961     (car (frame-hilited-presentation frame))))
962     (setf (frame-hilited-presentation frame)
963     (cons presentation stream))
964     (highlight-presentation-1 presentation stream :highlight))
965 moore 1.47 (setf (frame-hilited-presentation frame) nil)))
966     (progn
967     (maybe-unhighlight nil)
968     (setf (frame-hilited-presentation frame) nil))))
969     (frame-update-pointer-documentation frame input-context stream event))
970 moore 1.27
971     (defun simple-event-loop ()
972     "An simple event loop for applications that want all events to be handled by
973     handle-event methods"
974 adejneka 1.41 (let ((queue (frame-event-queue *application-frame*)))
975     (loop for event = (event-queue-read queue)
976     ;; EVENT-QUEUE-READ in single-process mode calls PROCESS-NEXT-EVENT itself.
977     do (handle-event (event-sheet event) event))))
978 moore 1.57
979     ;;; Am I missing something? Does this need to do more? - moore
980     (defmacro with-application-frame ((frame) &body body)
981     `(let ((,frame *application-frame*))
982     ,@body))
983 hefner1 1.67
984 hefner1 1.68
985     (defmethod note-input-focus-changed (pane state)
986     (declare (ignore pane state)))
987    
988 hefner1 1.67 (defmethod (setf keyboard-input-focus) :after (focus frame)
989     (set-port-keyboard-focus focus (port frame)))
990 hefner1 1.68

  ViewVC Help
Powered by ViewVC 1.1.5