blob: 9301d1a7264524ac4dad51cddee62ed2141eeaa4 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
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 atpoint $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 atpoint %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}
|
