1 # cam-client.tcl --
2 #
3 # FIXME: This file needs a description here.
4 #
5 # Copyright (c) 1996-2002 The Regents of the University of California.
6 # All rights reserved.
7 #
8 # Redistribution and use in source and binary forms, with or without
9 # modification, are permitted provided that the following conditions are met:
10 #
11 # A. Redistributions of source code must retain the above copyright notice,
12 # this list of conditions and the following disclaimer.
13 # B. Redistributions in binary form must reproduce the above copyright notice,
14 # this list of conditions and the following disclaimer in the documentation
15 # and/or other materials provided with the distribution.
16 # C. Neither the names of the copyright holders nor the names of its
17 # contributors may be used to endorse or promote products derived from this
18 # software without specific prior written permission.
19 #
20 # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
21 # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23 # ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
24 # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
26 # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
27 # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
28 # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
29 # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30 #
31 #----
32 # Todd Hodes (hodes@cs)
33 # arrows from Gordon Chaffee
34 #
35 # @(#) $Header: /usr/mash/src/repository/mash/mash-1/tcl/applications/camera-client/cam-client.tcl,v 1.13 2002/02/03 04:21:39 lim Exp $
36
37
38 #
39 # A GUI for access to a remote camera
40 #
41 Class CameraUI
42
43 #
44 # init method takes frame/window parent for gui
45 # and unicast address of camera
46 #
47 CameraUI public init {w addrspec} {
48 $self instvar al_ zoomSpeed_ panSpeed_ tiltSpeed_ \
49 presets_ pending_ setPresets_ remain_quiet_
50
51 set remain_quiet_ 1
52 set pending_ -1
53 array set presets_ ""
54 set zoomSpeed_ -1
55 set panSpeed_ -1
56 set tiltSpeed_ -1
57 set setPresets_ 0
58
59 # if addrspec includes a name, turn it into IP addr
60 set firstchar [string index $addrspec 0]
61 if [string match \[a-zA-Z\] $firstchar] {
62 set n [lindex [split $addrspec "/"] 0]
63 set p [lindex [split $addrspec "/"] 1]
64 set s [gethostbyname $n]
65 if { $s == "" } {
66 puts "cannot find address for '$n'"
67 exit
68 }
69 set addrspec $s/$p
70 }
71
72 set al_ [new UDPChannel/CamCl $addrspec $self]
73 $self build_gui $w
74 update
75 set remain_quiet_ 0
76 }
77
78 CameraUI public destroy {} {
79 $self instvar al_
80 delete $al_
81 eval [list $self] next
82 }
83
84
85
86 CameraUI private build_gui {w} {
87 $self instvar al_ scales_ w_
88
89 set w $w.camFrame
90 set w_ $w
91 frame $w
92 pack $w
93
94 # build bottom informational label
95 set il $w.infolabel
96 frame $il -relief groove
97 label $il.l -text "Camera Controller"
98 pack $il -side bottom -fill x -expand 1
99 pack $il.l -in $il -side bottom -fill x -expand 1
100
101 set t $w.camera
102 set cameraParent $w
103
104 frame $t
105 pack $t -in $w
106 set width 120
107 set height 80
108 set winwidth 124
109 set uparrow " -6 -9 -6 -23 -14 -23 0 -35 14 -23 6 -23 6 -9 -6 -9"
110 set dnarrow " -6 9 -6 23 -14 23 0 35 14 23 6 23 6 9 -6 9"
111
112 set ltarrow " -9 -6 -23 -6 -23 -14 -35 0 -23 14 -23 6 -9 6 -9 -6"
113 set rtarrow " 9 -6 23 -6 23 -14 35 0 23 14 23 6 9 6 9 -6"
114
115 set ziarrow " 54 -9 54 -23 46 -23 60 -35 74 -23 66 -23 66 -9 54 -9"
116 set zoarrow " 56 0 56 10 50 10 60 15 70 10 64 10 64 0 56 0"
117
118 set hhalf [expr $height/2]
119 set c $t.c
120 set region [list -40 -$hhalf 80 $hhalf]
121 canvas $c -height $height -width $width -borderwidth 0 \
122 -scrollregion $region
123
124 set p_up [eval $c create polygon $uparrow -tags \{up arrow\}]
125 set p_dn [eval $c create polygon $dnarrow -tags \{dn arrow\}]
126 set p_lt [eval $c create polygon $ltarrow -tags \{lt arrow\}]
127 set p_rt [eval $c create polygon $rtarrow -tags \{rt arrow\}]
128 set p_zi [eval $c create polygon $ziarrow -tags \{zi arrow\}]
129 set p_zo [eval $c create polygon $zoarrow -tags \{zo arrow\}]
130
131 $c scale all 0 0 .8 .8
132
133 set t_pos [$c create text 0 -33 -text "position" -anchor c]
134
135 set t_zoom [$c create text 50 -33 -text "zoom" -anchor c]
136 # -font "-Adobe-Helvetica-Bold-R-Normal--*-80-*"
137
138 $c bind arrow <Any-Enter> "$self itemEnter $c"
139 $c bind arrow <Any-Leave> "$self itemLeave $c"
140
141 set pressCmd "$self itemPress $c"
142 set releaseCmd "$self itemRelease $c"
143 $c bind up <ButtonPress-1> "$pressCmd; $al_ send move_up"
144 $c bind up <ButtonRelease-1> "$releaseCmd; $al_ send move_stop"
145 $c bind dn <ButtonPress-1> "$pressCmd; $al_ send move_down"
146 $c bind dn <ButtonRelease-1> "$releaseCmd; $al_ send move_stop"
147 $c bind lt <ButtonPress-1> "$pressCmd; $al_ send move_left"
148 $c bind lt <ButtonRelease-1> "$releaseCmd; $al_ send move_stop"
149 $c bind rt <ButtonPress-1> "$pressCmd; $al_ send move_right"
150 $c bind rt <ButtonRelease-1> "$releaseCmd; $al_ send move_stop"
151 $c bind zi <ButtonPress-1> "$pressCmd; $al_ send zoom_in"
152 $c bind zi <ButtonRelease-1> "$releaseCmd; $al_ send zoom_stop"
153 $c bind zo <ButtonPress-1> "$pressCmd; $al_ send zoom_out"
154 $c bind zo <ButtonRelease-1> "$releaseCmd; $al_ send zoom_stop"
155 pack $c -side top
156
157 # ---- scales
158 frame $t.right
159 pack $t.right -side right
160 set scales_ $t
161
162 frame $t.pan
163 scale $t.pan.sc -command "$self set_speed p" -showvalue 0 \
164 -from 1 -to 100 -orient horizontal \
165 -font "-*-*-*-*-*-*-8-*-*-*-*-*-*-*" -width 10
166 #$t.pan.sc set 5
167 label $t.pan.lab -text "pan"
168 pack $t.pan.sc $t.pan.lab -in $t.pan -side right
169
170 frame $t.tilt
171 scale $t.tilt.sc -command "$self set_speed t" -showvalue 0 \
172 -from 1 -to 100 -orient horizontal \
173 -font "-*-*-*-*-*-*-8-*-*-*-*-*-*-*" -width 10
174 #$t.tilt.sc set 1
175 label $t.tilt.lab -text "tilt"
176 pack $t.tilt.sc $t.tilt.lab -in $t.tilt -side right
177
178 frame $t.zoom
179 scale $t.zoom.sc -command "$self set_speed z" -showvalue 0 \
180 -from 1 -to 100 -orient horizontal \
181 -font "-*-*-*-*-*-*-8-*-*-*-*-*-*-*" -width 10
182 #$t.zoom.sc set 50
183 label $t.zoom.lab -text "zoom"
184 pack $t.zoom.sc $t.zoom.lab -in $t.zoom -side right
185
186 pack $t.pan $t.tilt $t.zoom -in $t.right -anchor e
187
188 # ---- presets
189 frame $t.presets
190 pack $t.presets -in $t.right
191 set tpre $t.presets
192 checkbutton $tpre.setButton -command "$self toggle_preset_set" -text "set"
193 pack $tpre.setButton -side bottom -anchor e
194 foreach i {1 2 3 4} {
195 button $tpre.b$i -text $i -command "$self presetButtonInvoke $i"
196 pack $tpre.b$i -side left -in $tpre
197 }
198
199 bind . <q> exit
200 }
201
202 CameraUI private hide_gui {} {
203 $self instvar w_
204 pack forget $w_
205 }
206
207 CameraUI private show_gui {} {
208 $self instvar w_
209 pack $w_
210 }
211
212 CameraUI private toggle_preset_set {} {
213 $self instvar setPresets_
214
215 if {$setPresets_} {
216 set setPresets_ 0
217 } else {
218 set setPresets_ 1
219 }
220 }
221
222 #
223 # update UI from server message
224 #
225 # format of received announcement is:
226 # z: <zoomSpeed> t: <tiltSpeed> p: <panSp> pre: <presetList>
227 # [preset list entries are "name" "coords"]
228 #
229 CameraUI private receive_update {data} {
230 $self instvar scales_ zoomSpeed_ panSpeed_ tiltSpeed_ presets_ pending_
231
232 # filter data from other clients
233 if {[scan $data "z: %d t: %d p: %d pre: " z t p] != 3} {return}
234
235 set pres [lrange $data 7 end]
236 array set presets_ $pres
237
238 if {$pending_ != -1} {
239 # a more current update is pending -- throw away these
240 return
241 }
242 scan $data "z: %d t: %d p: %d pre: " z t p
243 if {$zoomSpeed_ != $z} {
244 set zoomSpeed_ $z
245 set s $scales_.zoom.sc
246 catch {$s set $z}
247 }
248 if {$tiltSpeed_ != $t} {
249 set tiltSpeed_ $t
250 set s $scales_.tilt.sc
251 catch {$s set $t}
252 }
253 if {$panSpeed_ != $p} {
254 set panSpeed_ $p
255 set s $scales_.pan.sc
256 catch {$s set $p}
257 }
258
259 }
260
261 # either sets a preset or tells the server to go to the preset
262 # <br>
263 # side effect: asks camera for current settings --
264 # reply is received and interpreted in the recv method.
265 #<br>
266 # reply contains actual preset data (rather than just numeric index)
267 # to preserve presets over client and server crashes
268 #
269 CameraUI private presetButtonInvoke {num} {
270 $self instvar setPresets_ presets_ al_
271
272 if {$setPresets_} {
273 $al_ send "set_preset $num"
274 } elseif {[array names presets_ $num] == ""} {
275 puts "No preset set..."
276 } else {
277 $al_ send "goto_preset $presets_($num)"
278 #puts "goto_preset $presets_($num)"
279 }
280 }
281
282 # holds onto speed updates until slider activity quiets.
283 #
284 CameraUI private set_speed {param perc} {
285 $self instvar pending_ zoomSpeed_ panSpeed_ tiltSpeed_ remain_quiet_
286 switch $param {
287 z {set zoomSpeed_ $perc}
288 p {set panSpeed_ $perc}
289 t {set tiltSpeed_ $perc}
290 }
291
292 if {$remain_quiet_} {
293 return
294 }
295
296 if {$pending_ != -1} {
297 after cancel $pending_
298 }
299 set pending_ [after 300 $self announce_speeds]
300 }
301
302 CameraUI private announce_speeds {} {
303 $self instvar al_ pending_ zoomSpeed_ panSpeed_ tiltSpeed_
304 $al_ send "set_zoom_speed $zoomSpeed_"
305 $al_ send "set_pan_speed $panSpeed_"
306 $al_ send "set_tilt_speed $tiltSpeed_"
307 set pending_ -1
308 }
309
310 CameraUI private itemPress {c} {
311 set fill [lindex [$c itemconfig current -fill] 4]
312 $c itemconfig current -fill blue
313 }
314
315 CameraUI private itemRelease {c} {
316 $c itemconfig current -fill grey
317 }
318
319 CameraUI private itemEnter {c} {
320 $c itemconfig current -fill gray
321 }
322
323 CameraUI private itemLeave {c} {
324 $c itemconfig current -fill black
325 }
326
327
328 #-----------------------------------------------------
329
330
331 import UDPChannel
332
333
334 # Camera RPC-style interface component
335 #
336 Class UDPChannel/CamCl -superclass UDPChannel
337
338 UDPChannel/CamCl public init {addrSpec parent {mtu 1500}} {
339 eval [list $self] next $addrSpec $mtu
340
341 $self instvar parent_
342 set parent_ $parent
343
344 # get the current speed settings and presets
345 $self send "update_state"
346 }
347
348
349 # Receive a msg from the Camera Server.
350 #
351 UDPChannel/CamCl private recv {addr port data size} {
352 #puts "Msg: $addr/$port \[$size\]: $data"
353
354 $self instvar parent_
355 $parent_ receive_update $data
356 }
357
358
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.