From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Thu, 30 Aug 2012 20:13:40 +0000 (-0700)
Subject: gtk: Fixed adjust-adjustments for drawings smaller than the viewport.
X-Git-Tag: mit-scheme-pucked-9.2.12~557
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=09584b41d49434557207a9c8e549934980453ff9;p=mit-scheme.git

gtk: Fixed adjust-adjustments for drawings smaller than the viewport.

Now maximizing the demo works.
---

diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm
index 9b59d2376..b265f2c76 100644
--- a/src/gtk/fix-layout.scm
+++ b/src/gtk/fix-layout.scm
@@ -374,6 +374,12 @@ USA.
   (let ((drawing (fix-layout-drawing layout)))
     (if drawing (fix-drawing-remove-widget! drawing layout))))
 
+(define-integrable (fix-layout-hstep-incr widget)
+  (car (fix-layout-scroll-step widget)))
+
+(define-integrable (fix-layout-vstep-incr widget)
+  (cdr (fix-layout-scroll-step widget)))
+
 (define (fix-layout-clip-area layout cairo)
   ;; The cairo context is clipped to the exposed area in widget
   ;; coords (window coordinates).
@@ -609,33 +615,62 @@ USA.
   ;; Called after the widget gets new adjustment(s) or its size or
   ;; scrollable extent changes.
 
-  (let ((vadj (fix-layout-vadjustment widget)))
-    (if (and vadj (gobject-live? vadj))
-	(let* ((view (fix-layout-view widget))
-	       (view-height (fix-rect-height view))
-	       (extent (fix-layout-scrollable-extent widget))
-	       (top (fix-rect-y extent))
-	       (bottom (fix:+ top (fix:max (fix-rect-height extent) view-height)))
-	       (value (fix-rect-y view))
-	       (page-size view-height)
-	       (step-incr (cdr (fix-layout-scroll-step widget)))
-	       (page-incr (min page-size (- page-size step-incr))))
-	  (set-gtk-adjustment! vadj value top bottom
-			       page-size step-incr page-incr))))
-
-  (let ((hadj (fix-layout-hadjustment widget)))
-    (if (and hadj (gobject-live? hadj))
-	(let* ((view (fix-layout-view widget))
-	       (view-width (fix-rect-width view))
-	       (extent (fix-layout-scrollable-extent widget))
-	       (left (fix-rect-x extent))
-	       (right (fix:+ left (fix:max (fix-rect-width extent) view-width)))
-	       (value (fix-rect-x view))
-	       (page-size view-width)
-	       (step-incr (car (fix-layout-scroll-step widget)))
-	       (page-incr (min page-size (- page-size step-incr))))
-	  (set-gtk-adjustment! hadj value left right
-			       page-size step-incr page-incr)))))
+  (%trace2 ";adjust horizontal adjustment "widget"\n")
+  (adjust-adjustment widget (fix-layout-hadjustment widget)
+		     fix-rect-width fix-rect-x
+		     (lambda (rect x)
+		       (set-fix-rect-x! rect x)
+		       (gtk-widget-queue-draw widget))
+		     fix-layout-hstep-incr)
+  (%trace2 ";adjust vertical adjustment "widget"\n")
+  (adjust-adjustment widget (fix-layout-vadjustment widget)
+		     fix-rect-height fix-rect-y
+		     (lambda (rect y)
+		       (set-fix-rect-y! rect y)
+		       (gtk-widget-queue-draw widget))
+		     fix-layout-vstep-incr))
+
+(define (adjust-adjustment widget adj
+			   fix-rect-size fix-rect-low set-fix-rect-low!
+			   widget-step-incr)
+  (if (and adj (gobject-live? adj))
+      (let ((view (fix-layout-view widget))
+	    (extent (fix-layout-scrollable-extent widget)))
+	(let ((view-size (fix-rect-size view))
+	      (extent-size (fix-rect-size extent))
+	      (step-incr (widget-step-incr widget)))
+	  (if (fix:< view-size extent-size)
+	      ;; Drawing is larger than viewport: thumb (page) is viewport.
+	      (let ((low (fix-rect-low extent))
+		    (high (fix:+ (fix-rect-low extent) extent-size))
+		    (page-size view-size)
+		    (page-incr (fix:max 1 (fix:- view-size step-incr))))
+		(%trace ";  large-drawing:"extent" view:"view"\n")
+		(let ((value (clamped-value! low (fix:- high page-size))))
+		  (%trace ";    "low" "value" "high" "page-size"\n")
+		  (set-gtk-adjustment! adj value low high
+				       page-size step-incr page-incr)))
+	      ;; Viewport is larger than drawing: thumb (page) is drawing.
+	      (let* ((low (fix:- (fix-rect-low extent)
+				 (fix:- view-size extent-size)))
+		     (high (fix:+ (fix-rect-low extent) extent-size))
+		     (page-size extent-size)
+		     (page-incr (fix:max 1 (fix:- extent-size step-incr))))
+		(%trace ";  drawing:"extent" large-view:"view"\n")
+		(let ((value (clamped-value! low (fix:- high page-size))))
+		  (%trace ";    "low" "value" "high" "page-size"\n")
+		  (set-gtk-adjustment! adj value low high
+				       page-size step-incr page-incr)))))
+
+	(define-integrable (clamped-value! low high)
+	  (let ((value (fix-rect-low view)))
+	    (cond ((fix:< value low)
+		   (set-fix-rect-low! view low)
+		   low)
+		  ((fix:< high value)
+		   (set-fix-rect-low! view high)
+		   high)
+		  (else value)))))))
 
 ;;; This is a simple <fix-widget> that handles the draw signal by
 ;;; calling gtk_render_handle().