blob: 6c1b8bf9d5be0812e3ee66f068b07ee3ff9b01be (
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
|
#!/usr/local/bin/wish -f
load ../tkzinc3.2.so
package require Img
set top 1
image create photo penguin -file xpenguin.png
image create photo bouton -file bouton.xpm
image create photo boutond -file bouton-down.xpm
set mask "fvwm.xbm"
set r [zinc .r -backcolor gray -relief sunken -render 0]
pack .r -expand t -fill both
.r configure -width 800 -height 500
#.r configure -drawbboxes t
.r scale $top 1 -1
set view [.r add group $top -tags "controls"]
proc maskicon {x y group mask color anchor} {
.r add icon $group -mask "@$mask" -position "$x $y" -anchor $anchor -color $color
.r add rectangle $group [list [expr $x - 3.0] [expr $y - 3.0] \
[expr $x + 3.0] [expr $y + 3.0]] -filled 1 -fillcolor red
}
proc imageicon {x y group image anchor} {
.r add icon $group -image $image -position "$x $y" -anchor $anchor
.r add rectangle $group [list [expr $x - 3.0] [expr $y - 3.0] \
[expr $x + 3.0] [expr $y + 3.0]] -filled 1 -fillcolor red
}
set x 50.0
set y -100.0
maskicon $x $y $view $mask yellow sw
set x [expr $x + 100.0]
maskicon $x $y $view $mask pink s
set x [expr $x + 100.0]
maskicon $x $y $view $mask violet se
set x 50
set y -150
maskicon $x $y $view $mask lightblue w
set x [expr $x + 100.0]
maskicon $x $y $view $mask blue center
set x [expr $x + 100.0]
maskicon $x $y $view $mask darkblue e
set x 50.0
set y -200.0
maskicon $x $y $view $mask violet nw
set x [expr $x + 100.0]
maskicon $x $y $view $mask pink n
set x [expr $x + 100.0]
maskicon $x $y $view $mask yellow ne
set x2 500.0
set y2 -300.0
imageicon $x2 $y2 $view penguin center
.r add icon $view -image bouton -position "$x2 $y2" -anchor center
.r add icon $view -image boutond -position [list [expr $x2 + 50] $y2] -anchor center
#
# Clip
#
puts "crée les clips"
set clip [.r add rectangle $view "50 -300 600 -10" -filled t \
-linewidth 0 -fillcolor darkgray]
#.r rotate $clip [expr 3.14159 / 4]
.r lower $clip
.r itemconfigure $view -clip $clip
.r addtag test withtype icon
.r bind test "<Shift-ButtonPress-1>" "testpress %x %y"
.r bind test "<Shift-ButtonRelease-1>" testrelease
proc testpress {lx ly} {
global testx testy
set testx $lx
set testy $ly
.r bind test "<Motion>" "testmotion %x %y"
}
proc testmotion {lx ly} {
global testx testy
set it [.r find withtag test]
if {$it != ""} {
set it [.r group [lindex $it 0]]
}
set res [.r transform $it "$lx $ly $testx $testy"]
set nx [lindex $res 0]
set ny [lindex $res 1]
set ox [lindex $res 2]
set oy [lindex $res 3]
.r translate current [expr $nx - $ox] [expr $ny - $oy]
set testx $lx
set testy $ly
}
proc testrelease {} {
.r bind test "<Motion>" ""
}
source controls.tcl
|
