blob: 2a16288b252d78020f4da3478eb41df22414d824 (
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
|
#!/usr/local/bin/wish -f
lappend auto_path ..
package require Tkzinc
package require Img
set top 1
set lw 8
set marker AtcSymbol9
set arrow "8 10 6"
#
# Cap Join Filled Border Relief Title
#
set show {\
{round round f 1 flat JoinRound}\
{round bevel f 1 flat JoinBevel}\
{round miter f 1 flat JoinMiter}\
{butt round f 1 flat CapButt}\
{projecting round f 1 flat CapProjecting}\
{round round f 1 sunken Sunken}\
{round round f 1 raised Raised}\
{round round f 1 groove Groove}\
{round round f 1 ridge Ridge}\
{round round t 1 sunken FilledSunken}\
{round round t 1 raised FilledRaised}\
{round round t 1 groove FilledGroove}\
{round round t 1 ridge FilledRidge}\
{round round f 0 flat Marker}\
{round round t 0 flat Fill}\
{round round t 1 flat FillBorder}}
image create photo logo -file logo.gif
#image create photo papier -file /usr/share/toccata/images/dgtexture-dragstrip.xpm
set r [zinc .r -backcolor gray -relief sunken -render 0]
pack .r -expand t -fill both
.r configure -width 1024 -height 800
.r scale $top 1 -1
#.r configure -drawbboxes t
set view [.r add group $top -tags controls]
#
# Create the model
#
set model [.r add group $view]
set mp [.r add curve $model "50 -150 100 -50 270 -130 220 -200 200 -180 180 -300 140 -160 70 -300" \
-linecolor yellow -fillcolor tan -fillpattern AlphaStipple8 \
-markercolor red -tags "poly" -linewidth $lw]
.r add rectangle $model "50 -150 100 -50"
set bbox [.r transform $model [.r bbox $mp]]
set x [expr ([lindex $bbox 2] + [lindex $bbox 0]) / 2]
set y [expr [lindex $bbox 1] + 5]
.r add text $model -text "CapRound" -color blue -alignment center -anchor s -tags "title" \
-position "$x $y"
#
# Now clone for each variation on the polygon
#
proc linecol { relief } {
if {[string compare $relief flat]} {
return yellow
} else {
return tan
}
}
set col 0
set row 0
foreach current $show {
foreach {cap join filled border relief title} $current {
set grp [.r clone $model]
.r translate $grp [expr $col * 240] [expr $row * (-290 - (2 * $lw))]
.r itemconfigure [.r find withtag "$grp*poly"] \
-capstyle $cap -joinstyle $join -filled $filled \
-linewidth [expr $border ? $lw : 0] -relief $relief \
-linecolor [linecol $relief]
.r itemconfigure [.r find withtag "$grp*title"] -text $title
incr col
if {$col >= 4} {
set col 0
incr row
}
}
}
#
# Suppress the model
#
.r remove $model
#
# Some optional graphic features
set closed 0
set marks 0
#set smooth 0
set arrows none
proc toggle_arrows { } {
global arrows arrow
if {$arrows == "none"} {
set arrows first
set f $arrow
set l ""
} elseif {$arrows == "first"} {
set arrows last
set f ""
set l $arrow
} elseif {$arrows == "last"} {
set arrows both
set f $arrow
set l $arrow
} elseif {$arrows == "both"} {
set arrows none
set f ""
set l ""
}
.r itemconfigure poly -firstend $f -lastend $l
}
proc toggle_marks { } {
global marks marker
set marks [expr ! $marks]
if {$marks} {
.r itemconfigure poly -marker $marker
} {
.r itemconfigure poly -marker ""
}
}
#proc toggle_smooth { } {
# global smooth
# set smooth [expr ! $smooth]
# .r itemconfigure poly -smoothed $smooth
#}
proc toggle_closed { } {
global closed
set closed [expr ! $closed]
foreach curve [.r find withtag "poly"] {
.r itemconfigure $curve -closed $closed
}
}
focus .r
bind .r "<a>" toggle_arrows
bind .r "<c>" toggle_closed
bind .r "<m>" toggle_marks
bind .r "<Shift-1>" {set it [.r find closest %x %y]; puts "$it [.r verticeat $it %x %y]"}
bind .r "<Shift-ButtonRelease-1>" {break}
source "controls.tcl"
|
