blob: 4013c89033fb4b649985967611eff0ec51fc1c07 (
plain) (
blame)
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
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
|
# REGION.GUI -- Demo the use of region markers.
# This GUI can be run as "cl> hello gui=region.gui".
reset-server
appInitialize regions Regions {
*objects:\
toplevel Paned panel\
panel Box control\
panel Gterm graphics\
panel AsciiText output\
control Command quitButton\
control Command measureButton\
control Toggle skyButton
*background: gray
*foreground: black
*menubar.showGrip: False
*menubar.skipAdjust: True
*menubar.width: 480
*skyButton.label: Annulus
*measureButton.label: Measure
*quitButton.label: Quit
*graphics.resizable: true
*graphics.ginmodeCursor: circle
*graphics.width: 640
*graphics.height: 480
*output.width: 480
*graphics.translations: \
<Btn1Down>: call(makeMarker,$name,$x,$y) m_create() \n\
!Shift <Btn2Down>: crosshair(on) \n\
!Shift <Btn2Motion>: crosshair(on) \n\
<Btn2Up>: crosshair(off) \n\
<EnterWindow>: enter-window() \n\
<LeaveWindow>: leave-window() \n\
<KeyPress>: graphics-input() \n\
<Motion>: track-cursor()
*allowShellResize: true
*shapeStyle: Rectangle
*beNiceToColormap: False
*Label*shadowWidth: 2
}
# Start up the GUI.
createObjects
send graphics setGterm
activate
# Global variables
set marker objMarker ;# only one marker currently
set skyGap 10 ;# gap to sky annulus
set skyWidth 15 ;# width of sky annulus
# Procedures.
# -------------------------
proc quit args { send client gkey q; deactivate unmap }
send quitButton addCallback quit
# Get a description of the region and print it in the output window.
proc measure args {
global marker
# getRegion unmap will reverse any mappings and return raster coords.
set region [send $marker getRegion unmap]
send output set string $region
}; send measureButton addCallback measure
# Draw/erase sky annulus. Once created these are not tied to the object
# region and the user is expected to toggle the skyButton to erase and
# redraw the annulus markers if the object marker is moved. If we wanted
# to be fancier about this we could register a move callback with the object
# marker and redraw the annulus markers at the new location if the object
# marker is moved. Currently there is no way to group markers so that they
# behave as one object.
proc annulus args {
global skyGap skyWidth
global marker
# In this case we use getRegion with no args, which returns window coords.
set region [send $marker getRegion]
if [send skyButton get state] {
set x [lindex $region 2]
set y [lindex $region 3]
set width [lindex $region 4]
set height [lindex $region 5]
set rotangle [lindex $region 6]
# Create a marker outlining the inner boundary of the annulus region.
# See obm/ObmW/Gterm.h for a list of marker attributes.
send graphics createMarker sky1 \
type ellipse \
createMode noninteractive \
lineColor blue \
highlightColor blue \
x $x \
y $y \
width [expr "$width + $skyGap"] \
height [expr "$height + $skyGap"] \
rotangle $rotangle \
activated True \
visible True \
sensitive False
# Create a marker outlining the outer boundary of the annulus region.
send graphics createMarker sky2 \
type ellipse \
createMode noninteractive \
lineColor blue \
highlightColor blue \
x $x \
y $y \
width [expr "$width + $skyGap + $skyWidth"] \
height [expr "$height + $skyGap + $skyWidth"] \
rotangle $rotangle \
activated True \
visible True \
sensitive False
send sky1 "redraw noerase; lower"
send sky2 "redraw noerase; lower"
} else {
send sky1 destroy
send sky2 destroy
}
}; send skyButton addCallback annulus
# Support routines.
# -------------------------
# Create marker action. Makes a new marker.
proc makeMarker { parent x y } \
{
global markerTranslations marker
send $parent createMarker $marker \
type ellipse \
createMode interactive \
translations $markerTranslations \
lineColor green \
x $x \
y $y
send $marker addCallback moveResize moveResize
}
proc moveResize args {
print "moveResize called: $args"
}
# Translations when pointer is inside a marker.
set markerTranslations { \
!Shift <Btn1Motion>: m_rotateResize()
<Btn1Motion>: m_moveResize()
!Shift <Btn1Down>: m_raise() m_markpos()
<Btn1Down>: m_raise() m_markposAdd()
<Btn1Up>: m_redraw() m_destroyNull()
<Btn2Down>: m_lower()
<Btn3Down>: popup(markerMenu)
<Btn3Up>: popdown(markerMenu)
<Key>BackSpace: m_deleteDestroy()
<Key>Delete: m_deleteDestroy()
<KeyPress>: m_input()
<Motion>: track-cursor()
}
# Popup menu in effect when inside marker.
createMenu markerMenu graphics {
{ Object f.title }
{ f.dblline }
{ Measure f.exec {
measure
} }
{ Dummy1 f.exec {
print dummy1 ;# (replace by real code)
} }
{ Dummy2 f.exec {
print dummy2 ;# (replace by real code)
} }
{ f.line }
{ Destroy f.exec {
send $marker destroy
} }
}
|
