[climacs-cvs] CVS climacs

[thenriksen]

Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv2159

Modified Files:
	window-commands.lisp 
Log Message:
Hmm, guess I forgot to commit the meat of typeout pane-scrolling.


--- /project/climacs/cvsroot/climacs/window-commands.lisp	2007/12/27 16:28:08	1.16
+++ /project/climacs/cvsroot/climacs/window-commands.lisp	2008/01/06 11:47:37	1.17
@@ -152,10 +152,26 @@
 	 'window-table
 	 '((#\x :control) (#\1)))
 
+(defun scroll-typeout-window (window y)
+  "Scroll `window' down by `y' device units, but taking care not
+to scroll past the size of `window'. If `window' does not have a
+viewport, do nothing."
+  (let ((viewport (pane-viewport window)))
+    (unless (null viewport)            ; Can't scroll without viewport
+      (multiple-value-bind (x-displacement y-displacement)
+          (transform-position (sheet-transformation window) 0 0)
+        (scroll-extent window
+                       (- x-displacement)
+                       (max 0 (min (+ (- y-displacement) y)
+                                   (- (bounding-rectangle-height window)
+                                      (bounding-rectangle-height viewport)))))))))
+
 (define-command (com-scroll-other-window :name t :command-table window-table) ()
   (let ((other-window (second (windows *application-frame*))))
     (when other-window
-      (page-down (view other-window)))))
+      (if (typeout-pane-p other-window)
+          (scroll-typeout-window other-window (bounding-rectangle-height (pane-viewport other-window)))
+          (page-down (view other-window))))))
 
 (set-key 'com-scroll-other-window
 	 'window-table
@@ -164,7 +180,9 @@
 (define-command (com-scroll-other-window-up :name t :command-table window-table) ()
   (let ((other-window (second (windows *application-frame*))))
     (when other-window
-      (page-up (view other-window)))))
+      (if (typeout-pane-p other-window)
+          (scroll-typeout-window other-window (- (bounding-rectangle-height (pane-viewport other-window))))
+          (page-up (view other-window))))))
 
 (set-key 'com-scroll-other-window-up
 	 'window-table