From 7e248f4623910beaec820b120a621186121dfb18 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Mon, 18 Mar 2013 17:26:13 -0700 Subject: [PATCH] gtk: Allow for specialization of fix-layout scrollbar behavior. The new generic procedure fix-layout-adjustment-parameters allows Edwin to customize scrolling. --- src/gtk/fix-layout.scm | 70 ++++++++++++++++++++++++------------------ 1 file changed, 40 insertions(+), 30 deletions(-) diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm index f5f8615d6..06d93fc74 100644 --- 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 ) + 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)))) (define-class ( (constructor () no-init)) () -- 2.25.1