gtk: Allow for specialization of fix-layout scrollbar behavior.

The new generic procedure fix-layout-adjustment-parameters allows
Edwin to customize scrolling.

diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm
index f5f8615d62e62c51682c15c7d5fa8f79b706c104..06d93fc744ea7f16a3dba6574e850dee353540f0 100644 (file)
--- a/src/gtk/fix-layout.scm
+++ b/src/gtk/fix-layout.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012  Matthew Birkholz
+Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012, 2013  Matthew Birkholz
 
 This file is part of an extension to MIT/GNU Scheme.
 
@@ -634,39 +634,49 @@ USA.
            (extent (fix-layout-scrollable-extent widget)))
        (let ((view-size (fix-rect-size view))
              (extent-size (fix-rect-size extent))
+             (extent-low (fix-rect-low 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))))
-               (%trace2 ";  large-drawing:"extent" view:"view"\n")
+         (fix-layout-adjustment-parameters
+          widget view-size extent-size extent-low
+          (lambda (low page-size)
+
+            (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))))
+
+            (let ((high (fix:+ extent-low extent-size))
+                  (page-incr (fix:max 1 (fix:- page-size step-incr))))
                (let ((value (clamped-value! low (fix:- high page-size))))
                  (%trace2 ";  adjustment: "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 ";  adjustment: "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)))))))
+                                      page-size step-incr page-incr)))))))))
+
+(define-generic fix-layout-adjustment-parameters (widget
+                                                 view-size extent-size
+                                                 extent-low receiver))
+
+(define-method fix-layout-adjustment-parameters ((widget <fix-layout>)
+                                                view-size extent-size
+                                                extent-low receiver)
+  (if (fix:< view-size extent-size)
+      ;; Drawing is larger than viewport: thumb (page) is viewport.
+      (let ((low extent-low)
+           (page-size view-size))
+       (%trace2 ";  large-drawing:"(fix-layout-scrollable-extent widget)
+                " view:"(fix-layout-view widget)"\n")
+       (receiver low page-size))
+      ;; Viewport is larger than drawing: thumb (page) is drawing.
+      (let ((low (fix:- extent-low (fix:- view-size extent-size)))
+           (page-size extent-size))
+       (%trace2 ";  drawing:"(fix-layout-scrollable-extent widget)
+                " large-view:"(fix-layout-view widget)"\n")
+       (receiver low page-size))))
 \f
 (define-class (<fix-drawing> (constructor () no-init))
     ()