/[climacs]/climacs/gui.lisp
ViewVC logotype

Diff of /climacs/gui.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.76 by rstrandh, Mon Jan 17 08:04:44 2005 UTC revision 1.77 by rstrandh, Mon Jan 17 12:26:11 2005 UTC
# Line 49  Line 49 
49    ((win :reader win)    ((win :reader win)
50     (buffers :initform '() :accessor buffers))     (buffers :initform '() :accessor buffers))
51    (:panes    (:panes
52     (win (make-pane 'extended-pane     (win (vertically ()
53                     :width 900 :height 400            (scrolling ()
54                     :name 'win              (make-pane 'extended-pane
55                     :incremental-redisplay t                         :width 900 :height 400
56                     :display-function 'display-win))                         :name 'bla
57                           :incremental-redisplay t
58                           :display-function 'display-win))
59              (make-pane 'application-pane
60                         :width 900 :height 20 :max-height 20 :min-height 20
61                         ::background +gray85+
62                         :scroll-bars nil
63                         :borders nil
64                         :incremental-redisplay t
65                         :display-function 'display-info)))
66    ;   (win (make-pane 'extended-pane
67    ;                  :width 900 :height 400
68    ;                  :name 'bla
69    ;                  :incremental-redisplay t
70    ;                  :display-function 'display-win))
71    
72     (info :application     (info :application
73           :width 900 :height 20 :max-height 20           :width 900 :height 20 :max-height 30 :min-height 30
74           :name 'info :background +light-gray+           :name 'info :background +gray85+
75           :scroll-bars nil           :scroll-bars nil
76           :borders nil           :borders nil
77           :incremental-redisplay t           :incremental-redisplay t
# Line 68  Line 82 
82    (:layouts    (:layouts
83     (default     (default
84         (vertically (:scroll-bars nil)         (vertically (:scroll-bars nil)
85           (scrolling (:width 900 :height 400) win)           win
          info  
86           int))           int))
87     (without-interactor     (without-interactor
88      (vertically (:scroll-bars nil)      (vertically (:scroll-bars nil)
# Line 180  Line 193 
193            (t (unread-gesture gesture :stream stream)            (t (unread-gesture gesture :stream stream)
194               (values 1 nil)))))               (values 1 nil)))))
195    
196    ;;; we know the vbox pane has a scroller pane and an info
197    ;;; pane in it.  The scroller pane has a viewport in it,
198    ;;; and the viewport contains the climacs-pane as its only child.
199    (defun find-climacs-pane (vbox)
200      (first (sheet-children
201              (find-if-not (lambda (pane) (typep pane 'scroll-bar-pane))
202                           (sheet-children
203                            (find-if (lambda (pane) (typep pane 'scroller-pane))
204                                     (sheet-children vbox)))))))
205    
206  (defun climacs-top-level (frame &key  (defun climacs-top-level (frame &key
207                            command-parser command-unparser                            command-parser command-unparser
208                            partial-command-parser prompt)                            partial-command-parser prompt)
209    (declare (ignore command-parser command-unparser partial-command-parser prompt))    (declare (ignore command-parser command-unparser partial-command-parser prompt))
210    (with-slots (win) frame    (with-slots (win) frame
211       (setf win (find-pane-named frame 'win))       (setf win (find-climacs-pane (find-pane-named frame 'win)))
212       (push (buffer win) (buffers frame)))       (push (buffer win) (buffers frame))
213    (let ((*standard-output* (find-pane-named frame 'win))       (let ((*standard-output* win)
214          (*standard-input* (find-pane-named frame 'int))             (*standard-input* (find-pane-named frame 'int))
215          (*print-pretty* nil)             (*print-pretty* nil)
216          (*abort-gestures* nil))             (*abort-gestures* nil))
217      (redisplay-frame-panes frame :force-p t)         (redisplay-frame-panes frame :force-p t)
218      (loop (catch 'outer-loop         (loop (catch 'outer-loop
219              (loop for gestures = '()                 (loop for gestures = '()
220                    for numarg = (read-numeric-argument :stream *standard-input*)                       for numarg = (read-numeric-argument :stream *standard-input*)
221                    do (loop (setf *current-gesture* (climacs-read-gesture))                       do (loop (setf *current-gesture* (climacs-read-gesture))
222                             (setf gestures (nconc gestures (list *current-gesture*)))                                (setf gestures (nconc gestures (list *current-gesture*)))
223                             (let ((item (find-gestures gestures 'global-climacs-table)))                                (let ((item (find-gestures gestures 'global-climacs-table)))
224                               (cond ((not item)                                  (cond ((not item)
225                                      (beep) (return))                                         (beep) (return))
226                                     ((eq (command-menu-item-type item) :command)                                        ((eq (command-menu-item-type item) :command)
227                                      (let ((command (command-menu-item-value item)))                                         (let ((command (command-menu-item-value item)))
228                                        (unless (consp command)                                           (unless (consp command)
229                                          (setf command (list command)))                                             (setf command (list command)))
230                                        (setf command (substitute-numeric-argument-marker command numarg))                                           (setf command (substitute-numeric-argument-marker command numarg))
231                                        (handler-case                                           (handler-case
232                                            (execute-frame-command frame command)                                               (execute-frame-command frame command)
233                                          (error (condition)                                             (error (condition)
234                                            (beep)                                               (beep)
235                                            (format *error-output* "~a~%" condition)))                                               (format *error-output* "~a~%" condition)))
236                                        (setf (previous-command *standard-output*)                                           (setf (previous-command *standard-output*)
237                                              (if (consp command)                                                 (if (consp command)
238                                                  (car command)                                                     (car command)
239                                                  command))                                                     command))
240                                        (return)))                                           (return)))
241                                     (t nil))))                                        (t nil))))
242                       (let ((buffer (buffer (win frame))))                          (let ((buffer (buffer (win frame))))
243                         (when (modified-p buffer)                            (when (modified-p buffer)
244                           (setf (needs-saving buffer) t)))                              (setf (needs-saving buffer) t)))
245                       (redisplay-frame-panes frame)))                          (redisplay-frame-panes frame)))
246            (beep)               (beep)
247            (let ((buffer (buffer (win frame))))               (let ((buffer (buffer (win frame))))
248              (when (modified-p buffer)                 (when (modified-p buffer)
249                (setf (needs-saving buffer) t)))                   (setf (needs-saving buffer) t)))
250            (redisplay-frame-panes frame))))               (redisplay-frame-panes frame)))))
251    
252  (defun region-limits (pane)  (defun region-limits (pane)
253    (if (mark< (mark pane) (point pane))    (if (mark< (mark pane) (point pane))
# Line 636  Line 659 
659      (setf (offset (low-mark buffer)) 0      (setf (offset (low-mark buffer)) 0
660            (offset (high-mark buffer)) (size buffer))))            (offset (high-mark buffer)) (size buffer))))
661    
662    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
663    ;;;
664    ;;; Commands for splitting windows
665    
666    (define-named-command com-split-window-vertically ()
667      (with-look-and-feel-realization
668          ((frame-manager *application-frame*) *application-frame*)
669        (let* ((pane (win *application-frame*))
670               (new-pane (make-pane 'extended-pane
671                                    :width 900 :height 400
672                                    :name 'win
673                                    :incremental-redisplay t
674                                    :display-function 'display-win))
675               (parent (sheet-parent (sheet-parent (sheet-parent pane)))))
676          (setf (buffer new-pane) (buffer pane))
677          (sheet-adopt-child parent
678                             (vertically ()
679                               (scrolling () new-pane)
680                               (make-pane 'application-pane
681                                          :width 900 :height 20
682                                          :max-height 20 :min-height 20
683                                          ::background +gray85+
684                                          :scroll-bars nil
685                                          :borders nil
686                                          :incremental-redisplay t
687                                          :display-function 'display-info)))
688          (setf (sheet-enabled-p new-pane) t)
689          (full-redisplay pane)
690          (full-redisplay new-pane))))
691    
692  ;;;;;;;;;;;;;;;;;;;;  ;;;;;;;;;;;;;;;;;;;;
693  ;; Kill ring commands  ;; Kill ring commands
694    
# Line 811  Line 864 
864    (add-command-to-command-table command 'c-x-climacs-table    (add-command-to-command-table command 'c-x-climacs-table
865                                  :keystroke gesture :errorp nil))                                  :keystroke gesture :errorp nil))
866    
867    (c-x-set-key '(#\2) 'com-split-window-vertically)
868  (c-x-set-key '(#\b) 'com-switch-to-buffer)  (c-x-set-key '(#\b) 'com-switch-to-buffer)
869  (c-x-set-key '(#\c :control) 'com-quit)  (c-x-set-key '(#\c :control) 'com-quit)
870  (c-x-set-key '(#\f :control) 'com-find-file)  (c-x-set-key '(#\f :control) 'com-find-file)

Legend:
Removed from v.1.76  
changed lines
  Added in v.1.77

  ViewVC Help
Powered by ViewVC 1.1.5