[climacs-cvs] CVS update: climacs/gui.lisp

Robert Strandh rstrandh at common-lisp.net
Mon Jan 17 12:26:13 UTC 2005


Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv2459

Modified Files:
	gui.lisp 
Log Message:
preliminary multi-window support. 

Date: Mon Jan 17 13:26:12 2005
Author: rstrandh

Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.76 climacs/gui.lisp:1.77
--- climacs/gui.lisp:1.76	Mon Jan 17 09:04:44 2005
+++ climacs/gui.lisp	Mon Jan 17 13:26:11 2005
@@ -49,15 +49,29 @@
   ((win :reader win)
    (buffers :initform '() :accessor buffers))
   (:panes
-   (win (make-pane 'extended-pane
-		   :width 900 :height 400
-		   :name 'win
-		   :incremental-redisplay t
-		   :display-function 'display-win))
+   (win (vertically ()
+	  (scrolling ()
+	    (make-pane 'extended-pane
+		       :width 900 :height 400
+		       :name 'bla
+		       :incremental-redisplay t
+		       :display-function 'display-win))
+	  (make-pane 'application-pane
+		     :width 900 :height 20 :max-height 20 :min-height 20
+		     ::background +gray85+
+		     :scroll-bars nil
+		     :borders nil
+		     :incremental-redisplay t
+		     :display-function 'display-info)))
+;   (win (make-pane 'extended-pane
+;		   :width 900 :height 400
+;		   :name 'bla
+;		   :incremental-redisplay t
+;		   :display-function 'display-win))
    
    (info :application
-	 :width 900 :height 20 :max-height 20
-	 :name 'info :background +light-gray+
+	 :width 900 :height 20 :max-height 30 :min-height 30
+	 :name 'info :background +gray85+
 	 :scroll-bars nil
 	 :borders nil
 	 :incremental-redisplay t
@@ -68,8 +82,7 @@
   (:layouts
    (default
        (vertically (:scroll-bars nil)
-	 (scrolling (:width 900 :height 400) win)
-	 info
+	 win
 	 int))
    (without-interactor
     (vertically (:scroll-bars nil)
@@ -180,51 +193,61 @@
 	  (t (unread-gesture gesture :stream stream)
 	     (values 1 nil)))))
 
+;;; we know the vbox pane has a scroller pane and an info
+;;; pane in it.  The scroller pane has a viewport in it,
+;;; and the viewport contains the climacs-pane as its only child.
+(defun find-climacs-pane (vbox)
+  (first (sheet-children
+	  (find-if-not (lambda (pane) (typep pane 'scroll-bar-pane))
+		       (sheet-children
+			(find-if (lambda (pane) (typep pane 'scroller-pane))
+				 (sheet-children vbox)))))))
+
 (defun climacs-top-level (frame &key
 			  command-parser command-unparser 
 			  partial-command-parser prompt)
   (declare (ignore command-parser command-unparser partial-command-parser prompt))
   (with-slots (win) frame
-     (setf win (find-pane-named frame 'win))
-     (push (buffer win) (buffers frame)))
-  (let ((*standard-output* (find-pane-named frame 'win))
-	(*standard-input* (find-pane-named frame 'int))
-	(*print-pretty* nil)
-	(*abort-gestures* nil))
-    (redisplay-frame-panes frame :force-p t)
-    (loop (catch 'outer-loop
-	    (loop for gestures = '()
-		  for numarg = (read-numeric-argument :stream *standard-input*)
-		  do (loop (setf *current-gesture* (climacs-read-gesture))
-			   (setf gestures (nconc gestures (list *current-gesture*)))
-			   (let ((item (find-gestures gestures 'global-climacs-table)))
-			     (cond ((not item)
-				    (beep) (return))
-				   ((eq (command-menu-item-type item) :command)
-				    (let ((command (command-menu-item-value item)))
-				      (unless (consp command)
-					(setf command (list command)))
-				      (setf command (substitute-numeric-argument-marker command numarg))
-				      (handler-case 
-					  (execute-frame-command frame command)
-					(error (condition)
-					  (beep)
-					  (format *error-output* "~a~%" condition)))
-				      (setf (previous-command *standard-output*)
-					    (if (consp command)
-						(car command)
-						command))
-				      (return)))
-				   (t nil))))
-		     (let ((buffer (buffer (win frame))))
-		       (when (modified-p buffer)
-			 (setf (needs-saving buffer) t)))
-		     (redisplay-frame-panes frame)))
-	  (beep)
-	  (let ((buffer (buffer (win frame))))
-	    (when (modified-p buffer)
-	      (setf (needs-saving buffer) t)))
-	  (redisplay-frame-panes frame))))
+     (setf win (find-climacs-pane (find-pane-named frame 'win)))
+     (push (buffer win) (buffers frame))
+     (let ((*standard-output* win)
+	   (*standard-input* (find-pane-named frame 'int))
+	   (*print-pretty* nil)
+	   (*abort-gestures* nil))
+       (redisplay-frame-panes frame :force-p t)
+       (loop (catch 'outer-loop
+	       (loop for gestures = '()
+		     for numarg = (read-numeric-argument :stream *standard-input*)
+		     do (loop (setf *current-gesture* (climacs-read-gesture))
+			      (setf gestures (nconc gestures (list *current-gesture*)))
+			      (let ((item (find-gestures gestures 'global-climacs-table)))
+				(cond ((not item)
+				       (beep) (return))
+				      ((eq (command-menu-item-type item) :command)
+				       (let ((command (command-menu-item-value item)))
+					 (unless (consp command)
+					   (setf command (list command)))
+					 (setf command (substitute-numeric-argument-marker command numarg))
+					 (handler-case 
+					     (execute-frame-command frame command)
+					   (error (condition)
+					     (beep)
+					     (format *error-output* "~a~%" condition)))
+					 (setf (previous-command *standard-output*)
+					       (if (consp command)
+						   (car command)
+						   command))
+					 (return)))
+				      (t nil))))
+			(let ((buffer (buffer (win frame))))
+			  (when (modified-p buffer)
+			    (setf (needs-saving buffer) t)))
+			(redisplay-frame-panes frame)))
+	     (beep)
+	     (let ((buffer (buffer (win frame))))
+	       (when (modified-p buffer)
+		 (setf (needs-saving buffer) t)))
+	     (redisplay-frame-panes frame)))))
 
 (defun region-limits (pane)
   (if (mark< (mark pane) (point pane))
@@ -636,6 +659,36 @@
     (setf (offset (low-mark buffer)) 0
 	  (offset (high-mark buffer)) (size buffer))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; 
+;;; Commands for splitting windows
+
+(define-named-command com-split-window-vertically ()
+  (with-look-and-feel-realization
+      ((frame-manager *application-frame*) *application-frame*)
+    (let* ((pane (win *application-frame*))
+	   (new-pane (make-pane 'extended-pane
+				:width 900 :height 400
+				:name 'win
+				:incremental-redisplay t
+				:display-function 'display-win))
+	   (parent (sheet-parent (sheet-parent (sheet-parent pane)))))
+      (setf (buffer new-pane) (buffer pane))
+      (sheet-adopt-child parent
+			 (vertically ()
+			   (scrolling () new-pane)
+			   (make-pane 'application-pane
+				      :width 900 :height 20
+				      :max-height 20 :min-height 20
+				      ::background +gray85+
+				      :scroll-bars nil
+				      :borders nil
+				      :incremental-redisplay t
+				      :display-function 'display-info)))
+      (setf (sheet-enabled-p new-pane) t)
+      (full-redisplay pane)
+      (full-redisplay new-pane))))
+
 ;;;;;;;;;;;;;;;;;;;;
 ;; Kill ring commands
 
@@ -811,6 +864,7 @@
   (add-command-to-command-table command 'c-x-climacs-table
 				:keystroke gesture :errorp nil))
 
+(c-x-set-key '(#\2) 'com-split-window-vertically)
 (c-x-set-key '(#\b) 'com-switch-to-buffer)
 (c-x-set-key '(#\c :control) 'com-quit)
 (c-x-set-key '(#\f :control) 'com-find-file)




More information about the Climacs-cvs mailing list