NetNews Usenet Archive 1992 #31/NN_1992_31.iso/spool/comp/lang/tcl/2259

Text File | 1992-12-29 | 4.8 KB | 207 lines

Newsgroups: comp.lang.tcl
Path: sparky!uunet!timbuk.cray.com!hemlock.cray.com!mgc
From: [e-mail] (M. G. Christenson)
Subject: Re: automatic scrolling (fixed)
Message-ID: <[e-mail]>
Lines: 195
Nntp-Posting-Host: pecan
Reply-To: [e-mail]
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}
}