Panner

GPS: Feb 12, 2004 - In reponse to a question asked on this Wiki about panning widgets I wrote a demonstration. This could fairly easily be turned into a reusable megawidget by someone with some time. :)
proc update.panner.view {win panner type args} {
    foreach {x1 y1 x2 y2} [$panner coords panner] {}
    if {"x" == $type} {
        set x1 [expr {[winfo width $panner] * [lindex $args 0]}]
        set x2 [expr {[winfo width $panner] * [lindex $args 1]}]
    } else {
        set y1 [expr {[winfo height $panner] * [lindex $args 0]}]
        set y2 [expr {[winfo height $panner] * [lindex $args 1]}]
    }
    $panner coords panner [list $x1 $y1 $x2 $y2]
}

proc start.drag {x y} {
    variable start_x
    variable start_y
    set start_x $x
    set start_y $y
}

proc drag {win panner x y} {
    variable start_x
    variable start_y

    set x_diff [expr {$x - $start_x}]
    set y_diff [expr {$y - $start_y}]
    foreach {sx1 sy1 sx2 sy2} [$win cget -scrollregion] {}

    foreach {xv1 xv2} [$win xview] {}
    set xview_limit [expr {1.0 - ($xv2 - $xv1)}]
    foreach {yv1 yv2} [$win yview] {}
    set yview_limit [expr {1.0 - ($yv2 - $yv1)}]

    set pxview [expr {((1.0 / [winfo width $panner]) * $x_diff) + $xv1}]
    if {$pxview < 0.0} {
        $win xview moveto 0.0
    } elseif {$pxview > $xview_limit} {
        $win xview moveto $xview_limit
    } else {
        $win xview moveto $pxview
        set start_x $x
    }

    set pyview [expr {((1.0 / [winfo height $panner]) * $y_diff) + $yv1}]
    if {$pyview < 0.0} {
        $win yview moveto 0.0
    } elseif {$pyview > $yview_limit} {
        $win yview moveto $yview_limit
    } else {
        $win yview moveto $pyview
        set start_y $y
    }
}

proc main {} {
    canvas .m -width 400 -height 400 -bg blue
    canvas .p -width 100 -height 100 -bg orange

    grid .p -row 0 -column 0
    grid .m -row 0 -rowspan 2 -column 1 -sticky news
    grid rowconfigure . 1 -weight 100
    grid columnconfigure . 1 -weight 100

    .p create rectangle 0 0 100 100 -tags panner -fill purple

    .m create rectangle -300 20 -200 50 -fill green 
    .m create rectangle -50 500 50 600 -fill red

    text .m.t -width 60 -height 20
    .m create window 200 200 -window .m.t

    .m.t insert end "Hello, I'm a text widget embedded in a canvas with a\
        panner.\n\nThe orange window represents the total area of the canvas.\
        The purple area represents the current view area.  You may\
        shrink/enlarge the window and the panner will compensate.\n\
        \nYou may use/copy/modify the code under the same terms as Tcl.\n\
        \nBy George Peter Staplin."

    .m config -xscrollcommand {update.panner.view .m .p x}
    .m config -yscrollcommand {update.panner.view .m .p y}
    .m config -scrollregion {-500 0 500 1000}
 
    entry .e -textvariable ::eval_me
    grid .e
    bind .e <KeyPress-Return> {puts [uplevel #0 $::eval_me]}

    bind .p <ButtonPress-1> {start.drag %X %Y}
    bind .p <B1-Motion> {drag .m .p %X %Y}
}
main
EB: Such widget exists in BWidget, named ScrollView [1].
Category Widget
Category Graphics