[mcclim-cvs] CVS mcclim

[thenriksen]

Update of /project/mcclim/cvsroot/mcclim
In directory clnet:/tmp/cvs-serv8355

Modified Files:
	panes.lisp 
Log Message:
Add some convenience to viewports.


--- /project/mcclim/cvsroot/mcclim/panes.lisp	2006/07/09 06:23:22	1.170
+++ /project/mcclim/cvsroot/mcclim/panes.lisp	2006/10/16 23:53:52	1.171
@@ -27,7 +27,7 @@
 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 ;;; Boston, MA  02111-1307  USA.
 
-;;; $Id: panes.lisp,v 1.170 2006/07/09 06:23:22 ahefner Exp $
+;;; $Id: panes.lisp,v 1.171 2006/10/16 23:53:52 thenriksen Exp $
 
 (in-package :clim-internals)
 
@@ -1849,6 +1849,29 @@
 (defmethod note-input-focus-changed ((pane viewport-pane) state)
   (note-input-focus-changed (sheet-child pane) state))
 
+;; This method ensures that when the child changes size, the viewport
+;; will move its focus so that it will not display a region outside of
+;; `child' (if at all possible, this ideal can be circumvented by
+;; creating a child sheet that is smaller than the viewport). I do not
+;; believe having a viewport look at "empty" space is ever useful.
+(defmethod note-space-requirements-changed ((pane viewport-pane) child)
+  (let ((viewport-width (bounding-rectangle-width pane))
+        (viewport-height (bounding-rectangle-height pane))
+        (child-width (bounding-rectangle-width child))
+        (child-height (bounding-rectangle-height child)))
+    (destructuring-bind (horizontal-scroll vertical-scroll)
+        (mapcar #'- (multiple-value-list
+                     (transform-position (sheet-transformation child) 0 0)))
+      (scroll-extent child
+                     (if (> (+ horizontal-scroll viewport-width)
+                            child-width)
+                         (max 0 (- child-width viewport-width))
+                         horizontal-scroll)
+                     (if (> (+ vertical-scroll viewport-height)
+                            child-width)
+                         (max 0 (- child-height viewport-height))
+                         vertical-scroll)))))
+
 ;;;;
 ;;;; SCROLLER PANE
 ;;;;