diff options
Diffstat (limited to 'sandbox/controls.tcl')
| -rw-r--r-- | sandbox/controls.tcl | 158 |
1 files changed, 0 insertions, 158 deletions
diff --git a/sandbox/controls.tcl b/sandbox/controls.tcl deleted file mode 100644 index d865020..0000000 --- a/sandbox/controls.tcl +++ /dev/null @@ -1,158 +0,0 @@ -set tlbbox [.r add group $top -sensitive f -visible f -tags currentbbox] -.r add rectangle $tlbbox "-3 -3 +3 +3" -set trbbox [.r add group $top -sensitive f -visible f -tags currentbbox] -.r add rectangle $trbbox "-3 -3 +3 +3" -set blbbox [.r add group $top -sensitive f -visible f -tags currentbbox] -.r add rectangle $blbbox "-3 -3 +3 +3" -set brbbox [.r add group $top -sensitive f -visible f -tags currentbbox] -.r add rectangle $brbbox "-3 -3 +3 +3" -.r add rectangle $top "0 0 1 1" -linecolor red -tags "lasso" -visible f -sensitive f - -# -# Controls for the window transform. -# -proc press {lx ly action} { - global x y angle - set x $lx - set y $ly - set angle [expr atan2($y, $x)] - bind .r "<Motion>" "$action %x %y" -} - -proc motion {lx ly} { - global x y - set it [.r find withtag controls] - if {$it != ""} { - set it [.r group [lindex $it 0]] - } - set res [.r transform $it "$lx $ly $x $y"] - set nx [lindex $res 0] - set ny [lindex $res 1] - set ox [lindex $res 2] - set oy [lindex $res 3] - .r translate controls [expr $nx - $ox] [expr $ny - $oy] - set x $lx - set y $ly -} - -proc zoom {lx ly} { - global x y - - if {$lx > $x} { - set maxx $lx - } else { - set maxx $x - } - if {$ly > $y} { - set maxy $ly - } else { - set maxy $y - } - set sx [expr 1.0 + double($lx - $x)/$maxx] - set sy [expr 1.0 + double($ly - $y)/$maxy] - set x $lx - set y $ly - .r scale controls $sx $sy -} - -proc rotate {lx ly} { - global angle - - set langle [expr atan2($ly, $lx)] - .r rotate controls [expr -($langle-$angle)] - set angle $langle -} - -proc release {} { - bind .r "<Motion>" "" -} - -proc start_lasso {lx ly} { - global top x y cx cy - set x $lx - set y $ly - set cx $lx - set cy $ly - set coords [.r transform $top "$x $y"] - set fx [lindex $coords 0] - set fy [lindex $coords 1] - .r coords lasso "$fx $fy $fx $fy" - .r itemconfigure lasso -visible t - .r raise lasso - bind .r "<Motion>" "lasso %x %y" -} - -proc lasso {lx ly} { - global top x y cx cy - set cx $lx - set cy $ly - set coords [.r transform $top "$x $y $lx $ly"] - set fx [lindex $coords 0] - set fy [lindex $coords 1] - set fcx [lindex $coords 2] - set fcy [lindex $coords 3] - .r coords lasso "$fx $fy $fcx $fcy" -} - -proc fin_lasso {} { - global x y cx cy - - bind .r "<Motion>" "" - .r itemconfigure lasso -visible f -# puts "x=$x, y=$y, cx=$cx, cy=$cy" - puts "enclosed='[.r find enclosed $x $y $cx $cy]', overlapping='[.r find overlapping $x $y $cx $cy]'" -} - -proc getrect {x y} { - list [expr $x-3] [expr $y-3] [expr $x+3] [expr $y+3] -} - -proc showbox {} { - global top tlbbox trbbox blbbox brbbox - - if { ! [.r hastag current currentbbox]} { - if {[catch {.r find withtag current} item] } { - return - } - set coords [.r transform $top [.r bbox current]] - set xo [lindex $coords 0] - set yo [lindex $coords 1] - set xc [lindex $coords 2] - set yc [lindex $coords 3] - - .r coords $tlbbox "$xo $yo" - .r coords $trbbox "$xc $yo" - .r coords $brbbox "$xc $yc" - .r coords $blbbox "$xo $yc" - .r itemconfigure currentbbox -visible t - } -} - -proc hidebox {lx ly} { - set next [.r find closest $lx $ly] - if {[llength $next] > 1} { - set next [lindex $next 0] - } - if { $next == "" || ! [.r hastag $next currentbbox] ||\ - [.r hastag current currentbbox]} { - .r itemconfigure currentbbox -visible f - } -} - - -bind .r "<ButtonPress-1>" "start_lasso %x %y" -bind .r "<ButtonRelease-1>" fin_lasso - -bind .r "<ButtonPress-2>" {puts "at point='[.r find closest %x %y]'"} - -bind .r "<ButtonPress-3>" "press %x %y motion" -bind .r "<ButtonRelease-3>" release - -bind .r "<Shift-ButtonPress-3>" "press %x %y zoom" -bind .r "<Shift-ButtonRelease-3>" release - -bind .r "<Control-ButtonPress-3>" "press %x %y rotate" -bind .r "<Control-ButtonRelease-3>" release - -.r bind current "<Enter>" showbox -.r bind current "<Leave>" {hidebox %x %y} |