From: mgc@cray.com (M. G. Christenson)
Subject: Re: automatic scrolling (fixed)
Reply-To: mgc@cray.com
Organization: Cray Research, Inc.
Date: 28 Dec 92 15:33:57 CST

My newsreader mangled my previous post of my autoscrolling code.
This is what it should have looked like:

proc autoscroll_var w {
    global autoscroll_index

    if [info exists autoscroll_index($w)] {
	return autoscroll.$autoscroll_index($w)
    } else {
	if [info exists autoscroll_index(next)] {
	    set next [expr {$autoscroll_index(next) + 1}]
	} else {
	    set next 0
	}
	set autoscroll_index(next) $next
	return autoscroll.[set autoscroll_index($w) $next]
    }
}

proc autoscroll_init \
    {w delta_t {yscrollbar {}} {delta_y 1} {xscrollbar {}} {delta_x 1}} {
    upvar #0 [autoscroll_var $w] v

    if {$delta_t == 0} {
	catch {unset v}
	return {}
    }

    set v(autoscroll_delta_t) $delta_t
    set v(autoscroll_delta_x) $delta_x
    set v(autoscroll_delta_y) $delta_y

    set v(autoscroll_xscrollbar) $xscrollbar
    if {$xscrollbar == {}} {
	set v(autoscroll_dx) 0
    }
    set v(autoscroll_yscrollbar) $yscrollbar
    if {$yscrollbar == {}} {
	set v(autoscroll_dy) 0
    }

    if {[trace vinfo v(autoscroll_dx)] == {}} {
	set v(autoscrolling) 0
	set v(autoscroll_dx) 0
	set v(autoscroll_dy) 0

	trace variable v(autoscroll_dx) w "autoscroll $w"
	trace variable v(autoscroll_dy) w "autoscroll $w"
    }

    return {}
}

proc autoscroll_event {w x y event} {
    set cmd [bind $w $event]
    if {$cmd == {}} {
	set cmd [bind [winfo class $w] $event]
    }
    if {$cmd != {}} {
	regsub -all %W $cmd $w cmd
	regsub -all %x $cmd $x cmd
	regsub -all %y $cmd $y cmd
	uplevel #0 $cmd
    }
}

proc autoscroll {w args} {
    upvar #0 [autoscroll_var $w] v

    if {$args == {}} {
	if $v(autoscroll_dx) {
	    set current [lindex [$v(autoscroll_xscrollbar) get] 2]
	    set cmd [lindex [$v(autoscroll_xscrollbar) config -command] 4]
	    eval $cmd [expr "$current + $v(autoscroll_dx)"]
	    if {$v(autoscroll_event) != {}} {
		autoscroll_event $w $v(autoscroll_x) $v(autoscroll_y) \
		    $v(autoscroll_event)
	    }
	}
	if $v(autoscroll_dy) {
	    set current [lindex [$v(autoscroll_yscrollbar) get] 2]
	    set cmd [lindex [$v(autoscroll_yscrollbar) config -command] 4]
	    eval $cmd [expr "$current + $v(autoscroll_dy)"]
	    if {$v(autoscroll_event) != {}} {
		autoscroll_event $w $v(autoscroll_x) $v(autoscroll_y) \
		    $v(autoscroll_event)
	    }
	}
	set v(autoscrolling) 0
    }

    if {$v(autoscroll_dx) || $v(autoscroll_dy)} {
	if !$v(autoscrolling) {
	    set v(autoscrolling) 1
	    after $v(autoscroll_delta_t) autoscroll $w
	}
    } else {
	set v(autoscrolling) 0
    }
}

proc clear_autoscroll {w} {
    upvar #0 [autoscroll_var $w] v

    if [info exists v] {
	set v(autoscroll_dx) 0
	set v(autoscroll_dy) 0
    }
    return {}
}

proc check_autoscroll {w x y {event {}}} {
    upvar #0 [autoscroll_var $w] v

    if ![info exists v] {
	return {}
    }

    set dx 0
    if {$v(autoscroll_xscrollbar) != {}} {
	if {$x < 0} {
	    set dx -$v(autoscroll_delta_x)
	} else {
	    if {$x >= [winfo width $w]} {
		set dx $v(autoscroll_delta_x)
	    }
	}
    }

    set dy 0
    if {$v(autoscroll_yscrollbar) != {}} {
	if {$y < 0} {
	    set dy -$v(autoscroll_delta_y)
	} else {
	    if {$y >= [winfo height $w]} {
		set dy $v(autoscroll_delta_y)
	    }
	}
    }

    set v(autoscroll_x) $x
    set v(autoscroll_y) $y
    set v(autoscroll_event) $event

    if {$v(autoscroll_dx) != $dx} {
	set v(autoscroll_dx) $dx
    }

    if {$v(autoscroll_dy) != $dy} {
	set v(autoscroll_dy) $dy
    }

    return {}
}

proc bind_for_autoscroll {{classes {Text Listbox Canvas Entry}}} {
    foreach class $classes {
	bind $class <B1-Motion> {+check_autoscroll %W %x %y <B1-Motion>}
	bind $class <Shift-B1-Motion> \
	    {+check_autoscroll %W %x %y <Shift-B1-Motion>}
	bind $class <Any-ButtonRelease-1> {+clear_autoscroll %W}
    }
}

proc autoscroll_example {} {
    catch {destroy .example}

    frame .example
    scrollbar .example.h -orient horizontal -command ".example.c xview"
    scrollbar .example.v -command ".example.c yview"
    canvas .example.c -confine 0 -xscrollcommand ".example.h set" \
	-yscrollcommand ".example.v set"

    bind .example.c <1> {set x [%W canvasx %x]; set y [%W canvasy %y]}
    bind .example.c <B1-Motion> {
	%W delete oval
	set xx  [%W canvasx %x]
	set yy  [%W canvasy %y]
	%W create oval \
	    $x $y $xx $yy -tag oval -fill red
	%W config -scrollregion [%W bbox withtag oval]
    }

    autoscroll_init .example.c 100 .example.v 1 .example.h 1

    bind_for_autoscroll .example.c

    pack append .example \
	.example.h {bottom fillx} \
	.example.c {left expand fill} \
	.example.v {left filly}

    pack append . .example {top expand fill}
}

Newsgroups: comp.lang.tcl