aboutsummaryrefslogtreecommitdiff
path: root/sandbox/controls.tcl
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}