aboutsummaryrefslogtreecommitdiff
path: root/sandbox/testicon.tcl
blob: 489478ce4de6df3c977cc753551461e5626bf686 (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
#!/usr/bin/wish -f

load tkradar3.1.so
package require Img

set top 1

image create photo penguin -file /usr/X11R6/include/X11/pixmaps/xpenguin_color.xpm
set mask "/usr/X11R6/include/X11/bitmaps/fvwm.xbm"

set r [radar .r -backcolor gray -relief sunken]
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

#
# 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

source controls.tcl