pkg://tclrobots-1.0.tar.gz:53994/tclrobots.tcl
downloads
#!/usr/local/bin/wish -f
set wishexec wish
# TclRobots
# Copyright 1994 Tom Poindexter
# tpoind@advtech.uswest.com or tpoindex@nyx.cs.du.edu
#
# version 1.0
#
global rob1 rob2 rob3 rob4 c_tab s_tab parms
global running halted ticks maxticks execCmd numList tlimit iconfn
# set general tclrobots environment parameters
set parms(do_wait) 100 ;# number milliseconds robots wait on sys call
set parms(tick) 500 ;# millisecond tick
set parms(errdist) 10 ;# meters of possible error on scan resolution
set parms(sp) 10 ;# distance traveled at 100% per tick
set parms(accel) 10 ;# accel/deaccel speed per tick as % speed
set parms(mismax) 700 ;# maximum range for a missle
set parms(msp) 100 ;# distance missiles travel per tick
set parms(mreload) [expr round(($parms(mismax)/$parms(msp))+0.5)]
;# missle reload time in ticks
set parms(lreload) [expr $parms(mreload)*3]
;# missle long reload time after clip
set parms(clip) 4 ;# number of missles per clip
set parms(turn,0) 100 ;# max turn speed < 25 deg. delta
set parms(turn,1) 50 ;# " " " " 50 " "
set parms(turn,2) 30 ;# " " " " 75 " "
set parms(turn,3) 20 ;# " " " > 75 " "
set parms(rate,0) 90 ;# max rate of turn per tick at speed < 25
set parms(rate,1) 60 ;# " " " " " " " " " 50
set parms(rate,2) 40 ;# " " " " " " " " " 75
set parms(rate,3) 30 ;# " " " " " " " " > 75
set parms(rate,4) 20 ;# " " " " " " " " > 75
set parms(dia1) 10 ;# diameter of maximum missle damage
set parms(dia2) 20 ;# " " medium " "
set parms(dia3) 30 ;# " " minimum " "
set parms(hit1) 10 ;# %damage within range 1
set parms(hit2) 5 ;# " " " 2
set parms(hit3) 2 ;# " " " 3
set parms(coll) 5 ;# " from collision into wall
set parms(heatsp) 35 ;# %speed when heat builds
set parms(heatmax) 200 ;# max heat index, sets speed to heatsp
set parms(hrate) 10 ;# inverse heating rate (greater hrate=slower)
set parms(cooling) -25 ;# cooling rate per tick, after overheat
set parms(quads) {{100 100} {600 100} {100 600} {600 600}}
set parms(shapes) {{3 12 7} {8 12 5} {11 11 3} {12 8 4}}
if {[tk colormodel .]=="color" } {
set parms(cmodel) 1
} else {
set parms(cmodel) 0
}
if {$parms(cmodel)} {
set parms(colors) {SeaGreen3 IndianRed3 orchid3 SlateBlue1}
} else {
set parms(colors) {black black black black}
}
set rob1(status) 0; set rob1(name) ""; set rob1(pid) -1
set rob2(status) 0; set rob2(name) ""; set rob2(pid) -1
set rob3(status) 0; set rob3(name) ""; set rob3(pid) -1
set rob4(status) 0; set rob4(name) ""; set rob4(pid) -1
# init sin & cos tables
set pi [expr 4*atan(1)]
set d2r [expr 180/$pi]
for {set i 0} {$i<360} {incr i} {
set s_tab($i) [expr sin($i/$d2r)]
set c_tab($i) [expr cos($i/$d2r)]
}
###############################################################################
#
# rand routine, scarffed from a comp.lang.tcl posting
# From: eichin@cygnus.com (Mark Eichin)
#
set _lastvalue [expr ([pid]*[file atime /dev/tty])%65536]
proc _rawrand {} {
global _lastvalue
# per Knuth 3.6:
# 65277 mod 8 = 5 (since 65536 is a power of 2)
# c/m = .5-(1/6)\sqrt{3}
# c = 0.21132*m = 13849, and should be odd.
set _lastvalue [expr (65277*$_lastvalue+13849)%65536]
set _lastvalue [expr ($_lastvalue+65536)%65536]
return $_lastvalue
}
proc rand {base} {
set rr [_rawrand]
return [expr abs(($rr*$base)/65536)]
}
###############################################################################
#
# these procs are the tclrobot's interface to the controller and other
# handy things
#
set interface {
set _resume_ 0
set _step_ 0
set _lastvalue [expr ([pid]*[file atime /dev/tty])%65536]
proc _rawrand {} {
global _lastvalue
# per Knuth 3.6:
# 65277 mod 8 = 5 (since 65536 is a power of 2)
# c/m = .5-(1/6)\sqrt{3}
# c = 0.21132*m = 13849, and should be odd.
set _lastvalue [expr (65277*$_lastvalue+13849)%65536]
set _lastvalue [expr ($_lastvalue+65536)%65536]
return $_lastvalue
}
proc rand {base} {
set rr [_rawrand]
return [expr abs(($rr*$base)/65536)]
}
set _ping_proc_ ""
set _alert_on_ 0
proc _ping_check_ {} {
global _ping_proc_ _alert_on_
if {!$_alert_on_} {return}
set val 0
catch {SEND "TCLROBOTS" do_ping HAND} val
if {$val!=0} {
catch {eval $_ping_proc_ $val}
}
}
proc alert {procname} {
global _ping_proc_ _alert_on_
set _ping_proc_ $procname
if {[string length $procname] > 0} {
set _alert_on_ 1
} else {
set _alert_on_ 0
}
}
proc dputs {args} {
global _resume_
set _resume_ 0
catch {.d.l insert end [join $args]; .d.l yview end; UPDATE}
DEBUG
UPDATE
return
}
proc scanner {deg res} {
AFTER DO_WAIT
AFTER DO_WAIT
UPDATE
set val -1
catch {SEND "TCLROBOTS" do_scanner HAND $deg $res} val
DEBUG
_ping_check_
UPDATE
return $val
}
proc dsp {} {
AFTER DO_WAIT
UPDATE
set val -1
catch {SEND "TCLROBOTS" do_dsp HAND} val
DEBUG
_ping_check_
UPDATE
return $val
}
proc cannon {deg range} {
AFTER DO_WAIT
UPDATE
set val -1
catch {SEND "TCLROBOTS" do_cannon HAND $deg $range} val
DEBUG
_ping_check_
UPDATE
return $val
}
proc drive {deg speed} {
AFTER DO_WAIT
UPDATE
set val -1
catch {SEND "TCLROBOTS" do_drive HAND $deg $speed} val
DEBUG
_ping_check_
UPDATE
return $val
}
proc damage {} {
AFTER DO_WAIT
UPDATE
set val -1
catch {SEND "TCLROBOTS" do_damage HAND} val
DEBUG
_ping_check_
UPDATE
return $val
}
proc speed {} {
AFTER DO_WAIT
UPDATE
set val -1
catch {SEND "TCLROBOTS" do_speed HAND} val
DEBUG
_ping_check_
UPDATE
return $val
}
proc loc_x {} {
AFTER DO_WAIT
UPDATE
set val -1
catch {SEND "TCLROBOTS" do_loc_x HAND} val
DEBUG
_ping_check_
UPDATE
return $val
}
proc loc_y {} {
AFTER DO_WAIT
UPDATE
set val -1
catch {SEND "TCLROBOTS" do_loc_y HAND} val
DEBUG
_ping_check_
UPDATE
return $val
}
proc tick {} {
AFTER DO_WAIT
UPDATE
set val -1
catch {SEND "TCLROBOTS" do_tick HAND} val
DEBUG
_ping_check_
UPDATE
return $val
}
proc heat {} {
AFTER DO_WAIT
UPDATE
set val -1
catch {SEND "TCLROBOTS" do_heat HAND} val
DEBUG
_ping_check_
UPDATE
return $val
}
}
# execute these commands on tclrobot startup
set setup {
# setup windows, .l for file name
frame .f
canvas .f.c -width 20 -height 20
label .f.l -relief sunken -width 30 -text "(loading robot code..)"
pack .f.c -side left
pack .f.l -side left -expand 1 -fill both
# .d for debug listbox and scrollbar
frame .d
listbox .d.l -relief sunken -yscrollcommand ".d.s set" \
-xscrollcommand ".d.b set"
scrollbar .d.s -command ".d.l yview"
scrollbar .d.b -command ".d.l xview" -orient horizontal
pack .d.s -side right -fill y
pack .d.b -side bottom -fill x
pack .d.l -side left -expand 1 -fill both
pack .f -side top -fill x -ipady 5
pack .d -side top -expand 1 -fill both
wm minsize . 100 70
update
# disable base tk commands
foreach p {wm frame toplevel label button message listbox scrollbar scale \
entry text menu menubutton canvas selection grab raise lower tk \
pack place focus bind winfo checkbutton radiobutton option} {
catch {rename $p {}}
}
# rename these commands to their random names
rename send SEND
rename tkwait TKWAIT
rename destroy DESTROY
rename exit EXIT
# rename after to a rand generated name, make new proc
rename after AFTER
proc after {args} {
uplevel AFTER $args
}
# rename update to a rand generated name, make new proc
rename update UPDATE
proc update {args} {
uplevel UPDATE $args
}
# disable base tcl commands
foreach p {open close read gets puts eof exec cd flush pwd seek \
glob tell info} {
catch {rename $p {}}
}
# disable base tcl library procs
foreach p {auto_execok auto_load auto_mkindex auto_reset} {
catch {rename $p {}}
}
# our own unknown proc
proc unknown {name args} {
dputs "UNKNOWN: $name"
}
# our own tkerror proc
proc tkerror {args} {
dputs "TKERROR: $args"
}
}
###############################################################################
#
# initialize robot array, start another wish, send init code
#
#
proc robot_init {robx fn x y winx winy color {sim 0}} {
global setup interface parms wishexec
upvar #0 $robx r
set name [file tail $fn]
# generate a new send command
set newsig [rand 65535]
set newdestroy _d_$newsig
set newafter _a_$newsig
set newsend _s_$newsig
set newtkwait _t_$newsig
set newupdate _u_$newsig
set newexit _e_$newsig
set ourname [winfo name .]
if {$sim} {
set newdebug "global _step_; if {\$_step_} \"$newtkwait variable _resume_\""
} else {
set newdebug ""
}
set r(name) ${name}_$newsig ;# window name = source.file_randnumber
set r(num) $newsig ;# the rand number
set r(pid) -1 ;# robot pid
set r(status) 1 ;# robot status: 0=not used or dead, 1=running
set r(color) $color ;# robot color
set r(x) $x ;# robot current x
set r(y) $y ;# robot current y
set r(orgx) $x ;# robot origin x since last heading
set r(orgy) $y ;# robot origin y " " "
set r(range) 0 ;# robot current range on this heading
set r(damage) 0 ;# robot current damage
set r(speed) 0 ;# robot current speed
set r(dspeed) 0 ;# robot desired "
set r(hdg) [rand 360] ;# robot current heading
set r(dhdg) $r(hdg) ;# robot desired "
set r(dir) + ;# robot direction of turn (+/-)
set r(sig) "0 0" ;# robot last scan dsp signature
set r(mstate) 0 ;# missle state: 0=avail, 1=flying
set r(reload) 0 ;# missle reload time: 0=ok, >0 = reloading
set r(mused) 0 ;# number of missles used per clip
set r(mx) 0 ;# missle current x
set r(my) 0 ;# missle current y
set r(morgx) 0 ;# missle origin x
set r(morgy) 0 ;# missle origin y
set r(mhdg) 0 ;# missle heading
set r(mrange) 0 ;# missle current range
set r(mdist) 0 ;# missle target distance
set r(syscall) "" ;# last syscall & return val, for simulator
set r(heat) 0 ;# motor heat index
set r(hflag) 0 ;# overheated flag
set r(ping) 0 ;# signature of last robot to scan us
# startup a new wish with specified name
catch { [exec $wishexec -geom 180x110+$winx+$winy -name $r(name) \
</dev/null >/dev/null 2>/dev/null &] } r(pid)
if {$r(pid) <= 0} {
set r(pid) -1
.l configure -text "Oops...can't find new wish, pid = $r(pid)"
return 0
}
# substitute values in generic setup and interface for this robot
set rset $setup
set rint $interface
regsub -all TCLROBOTS $rint $ourname rint
regsub -all SEND $rint $newsend rint
regsub -all AFTER $rint $newafter rint
regsub -all UPDATE $rint $newupdate rint
regsub -all TKWAIT $rint $newtkwait rint
regsub -all DESTROY $rint $newdestroy rint
regsub -all DEBUG $rint $newdebug rint
regsub -all HAND $rint $robx rint
regsub -all DO_WAIT $rint $parms(do_wait) rint
regsub -all SEND $rset $newsend rset
regsub -all AFTER $rset $newafter rset
regsub -all UPDATE $rset $newupdate rset
regsub -all TKWAIT $rset $newtkwait rset
regsub -all DESTROY $rset $newdestroy rset
regsub -all EXIT $rset $newexit rset
# might need to wait until new wish starts up
set i 0
while {[lsearch [winfo interps] $r(name)] == -1 && \
[incr i] < 10 && \
[catch {send $r(name) "expr 1+1"} result] == 1} {
after 1000
update
}
if {[catch {send $r(name) "expr 1+1"}] == 1} {
.l configure -text "Oops...can't find new wish, pid = $r(pid)"
return 0
}
# send the code
send $r(name) $rset
send $r(name) $rint
if {$sim} {
send $r(name) "set _debug 1"
} else {
send $r(name) "set _debug 0"
}
if {$parms(cmodel)} {
send $r(name) ".f.l configure -bg $color -text $name"
} else {
send $r(name) ".f.l configure -text $name"
}
set i [string index $robx 3]
incr i -1
set arrshape [lindex $parms(shapes) $i]
send $r(name) ".f.c create line 10 12 10 7 -fill $color \
-arrow last -arrowshape \"$arrshape\""
update
send $r(name) \
"$newafter 100 \{set _start_ 0; $newtkwait variable _start_; source $fn\}"
return 1
}
###############################################################################
#
# start the robots!
#
#
proc start_robots {} {
foreach robx {rob1 rob2 rob3 rob4} {
upvar #0 $robx r
if {$r(status)} {
send $r(name) "_a_$r(num) 100 {set _start_ 1}"
}
}
}
###############################################################################
#
# disable robot
#
#
proc disable_robot {robx} {
upvar #0 $robx r
# break the remote tcl interpreter
catch {send $r(name) \
"_a_$r(num) 1 \".d.l insert end disabled;_u_$r(num);_t_$r(num) window .\""}
update
}
###############################################################################
#
# kill robot
#
#
proc kill_robot {robx} {
upvar #0 $robx r
catch {send $r(name) "rename _s_$r(num) send" }
catch {send $r(name) _a_$r(num) 200 "_u_$r(num);_d_$r(num) ." }
update
}
###############################################################################
#
# clean up all left overs
#
#
proc clean_up {} {
global running
.l configure -text "Standby, cleaning up any left overs...."
update
set running 0
foreach rr {rob1 rob2 rob3 rob4} {
upvar #0 $rr r
if {$r(status) || $r(pid) > 0} {
kill_robot $rr
after 500
catch {exec [kill $r(pid)]}
set r(pid) -1
}
}
}
###############################################################################
#
# update position of missiles and robots, assess damage
#
#
proc update_robots {} {
global c_tab s_tab parms ticks running
incr ticks
set num_miss 0
set num_rob 0
foreach robx {rob1 rob2 rob3 rob4} {
upvar #0 $robx r
# check all flying missiles
if {$r(mstate)} {
incr num_miss
# update location of missle
set r(mrange) [expr $r(mrange)+$parms(msp)]
set r(mx) [expr ($c_tab($r(mhdg))*$r(mrange))+$r(morgx)]
set r(my) [expr ($s_tab($r(mhdg))*$r(mrange))+$r(morgy)]
# check if missle reached target
if {$r(mrange) > $r(mdist)} {
set r(mstate) 0
set r(mx) [expr ($c_tab($r(mhdg))*$r(mdist))+$r(morgx)]
set r(my) [expr ($s_tab($r(mhdg))*$r(mdist))+$r(morgy)]
after 1 "show_explode $robx"
# assign damage to all within explosion ranges
foreach robrx {rob1 rob2 rob3 rob4} {
upvar #0 $robrx rr
if {!$rr(status)} {continue}
set d [expr hypot($r(mx)-$rr(x),$r(my)-$rr(y))]
if {$d<$parms(dia3)} {
if {$d<$parms(dia1)} {
incr rr(damage) $parms(hit1)
} elseif {$d<$parms(dia2)} {
incr rr(damage) $parms(hit2)
} else {
incr rr(damage) $parms(hit3)
}
.fd.$robrx configure -text $rr(damage)%
}
}
}
}
# skip rest if robot dead
if {!$r(status)} {continue}
# update missle reloader
if {$r(reload)} {incr r(reload) -1}
# check for excessive speed, increment heat
if {$r(speed) > $parms(heatsp)} {
incr r(heat) [expr round(($r(speed)-$parms(heatsp))/$parms(hrate))+1]
if {$r(heat) >= $parms(heatmax)} {
set r(heat) $parms(heatmax)
set r(hflag) 1
if {$r(dspeed) > $parms(heatsp)} {
set r(dspeed) $parms(heatsp)
}
}
} else {
# if overheating, apply cooling rate
if {$r(hflag) || $r(heat) > 0} {
incr r(heat) $parms(cooling)
if {$r(heat) <= 0} { set r(hflag) 0; set r(heat) 0 }
}
}
# update robot speed, moderated by acceleration
if {$r(speed) != $r(dspeed)} {
if {$r(speed) > $r(dspeed)} {
incr r(speed) -$parms(accel)
if {$r(speed) < $r(dspeed)} {
set r(speed) $r(dspeed)
}
} else {
incr r(speed) $parms(accel)
if {$r(speed) > $r(dspeed)} {
set r(speed) $r(dspeed)
}
}
}
# update robot heading, moderated by turn rates
if {$r(hdg) != $r(dhdg)} {
set mrate $parms(rate,[expr int($r(speed)/25)])
set d1 [expr ($r(dhdg)-$r(hdg)+360)%360]
set d2 [expr ($r(hdg)-$r(dhdg)+360)%360]
set d [expr $d1<$d2?$d1:$d2]
if {$d<=$mrate} {
set r(hdg) $r(dhdg)
} else {
set r(hdg) [expr ($r(hdg)$r(dir)$mrate+360)%360]
}
set r(orgx) $r(x)
set r(orgy) $r(y)
set r(range) 0
}
# update distance traveled on this heading
if {$r(speed) > 0} {
set r(range) [expr $r(range)+($r(speed)*$parms(sp)/100)]
set r(x) [expr round(($c_tab($r(hdg))*$r(range))+$r(orgx))]
set r(y) [expr round(($s_tab($r(hdg))*$r(range))+$r(orgy))]
# check for wall collision
if {$r(x)<0 || $r(x)>999} {
set r(x) [expr $r(x)<0? 0 : 999]
set r(orgx) $r(x)
set r(orgy) $r(y)
set r(range) 0
set r(speed) 0
set r(dspeed) 0
incr r(damage) $parms(coll)
.fd.$robx configure -text $r(damage)%
}
if {$r(y)<0 || $r(y)>999} {
set r(y) [expr $r(y)<0? 0 : 999]
set r(orgx) $r(x)
set r(orgy) $r(y)
set r(range) 0
set r(speed) 0
set r(dspeed) 0
incr r(damage) $parms(coll)
.fd.$robx configure -text $r(damage)%
}
}
}
# check for robot health
foreach robx {rob1 rob2 rob3 rob4} {
upvar #0 $robx r
if {$r(status)} {
if {$r(damage)>=100} {
set r(status) 0
set r(damage) 100
.fd.$robx configure -text \
[lindex {"garbage" "dead" "toast" "scrap" "wasted" "junk"} \
[rand 5]]
disable_robot $robx
} else {
incr num_rob
}
}
}
if {$num_rob<=1 && $num_miss==0} {
set running 0
}
after 1 show_robots
}
###############################################################################
#
# update canvas with position of missiles and robots
#
#
proc show_robots {} {
global c_tab s_tab parms
set i 0
foreach robx {rob1 rob2 rob3 rob4} {
upvar #0 $robx r
# check robots
if {$r(status)} {
.c delete r$r(num)
set x [expr $r(x)/2]
set y [expr (1000-$r(y))/2]
set arrow [lindex $parms(shapes) $i]
.c create line $x $y \
[expr $x+($c_tab($r(hdg))*5)] [expr $y-($s_tab($r(hdg))*5)] \
-fill $r(color) -arrow last -arrowshape $arrow -tags r$r(num)
}
# check missiles
if {$r(mstate)} {
.c delete m$r(num)
set x [expr $r(mx)/2]
set y [expr (1000-$r(my))/2]
.c create oval [expr $x-2] [expr $y-2] [expr $x+2] [expr $y+2] \
-fill black -tags m$r(num)
}
incr i
}
#delete all previous scans
.c delete scan
update
}
###############################################################################
#
# show scanner from a robot
#
#
proc show_scan {hand deg} {
global s_tab c_tab
upvar #0 $hand r
if {[.c find withtag s$r(num)] != ""} {
return
}
set x [expr $r(x)/2]
set y [expr (1000-$r(y))/2]
.c create line $x $y \
[expr $x+($c_tab($deg)*800)] [expr $y-($s_tab($deg)*800)] \
-fill $r(color) -stipple gray50 -width 1 -tags "scan s$r(num) "
update
}
###############################################################################
#
# show explosion of missile
#
#
proc show_explode {hand} {
global parms
upvar #0 $hand r
.c delete m$r(num)
set x [expr $r(mx)/2]
set y [expr (1000-$r(my))/2]
if {$parms(cmodel)} {
.c create oval [expr $x-10] [expr $y-10] [expr $x+10] [expr $y+10] \
-outline yellow -fill yellow -width 1 \
-tags e$r(num)
.c create oval [expr $x-5] [expr $y-5] [expr $x+5] [expr $y+5] \
-outline orange -fill orange -width 1 \
-tags e$r(num)
.c create oval [expr $x-2.5] [expr $y-2.5] [expr $x+2.5] [expr $y+2.5] \
-outline red -fill red -width 1 \
-tags e$r(num)
} else {
.c create oval [expr $x-10] [expr $y-10] [expr $x+10] [expr $y+10] \
-outline "" -fill black -stipple gray25 -width 1 \
-tags e$r(num)
.c create oval [expr $x-5] [expr $y-5] [expr $x+5] [expr $y+5] \
-outline "" -fill black -stipple gray50 -width 1 \
-tags e$r(num)
.c create oval [expr $x-2.5] [expr $y-2.5] [expr $x+2.5] [expr $y+2.5] \
-outline "" -fill black -width 1 \
-tags e$r(num)
}
update
after 750 ".c delete e$r(num)"
}
###############################################################################
#
# robot interface routines - server side
#
#
proc do_scanner {hand deg res} {
update
global parms
upvar #0 $hand r
set r(syscall) "scanner $deg $res"
if [catch {set deg [expr round($deg)]}] {append r(syscall) " (-1)";return -1}
if [catch {set res [expr round($res)]}] {append r(syscall) " (-1)";return -1}
if {($deg<0 || $deg>359)} {append r(syscall) " (-1)"; return -1}
if {($res<0 || $res>10)} {append r(syscall) " (-1)"; return -1}
after 1 "show_scan $hand $deg"
set dsp 0
set dmg 0
set near 9999
foreach robx {rob1 rob2 rob3 rob4} {
upvar #0 $robx rob
if {"$hand" == "$robx" || !$rob(status)} { continue }
set x [expr $rob(x)-$r(x)]
set y [expr $rob(y)-$r(y)]
set d [expr round(57.2958*atan2($y,$x))]
if {$d<0} {incr d 360}
set d1 [expr ($d-$deg+360)%360]
set d2 [expr ($deg-$d+360)%360]
set f [expr $d1<$d2?$d1:$d2]
if {$f<=$res} {
set rob(ping) $r(num)
set dist [expr round(hypot($x,$y))]
if {$dist<$near} {
set derr [expr $parms(errdist)*$res]
set terr [expr ($res>0 ? 10 : 0) + [rand $derr]]
set fud [expr [rand 2]==0 ? \"-\" : \"+\"]
set near [expr $dist $fud $terr]
if {$near<0} {set near 0}
set dsp $rob(num)
set dmg $rob(damage)
}
}
}
set r(sig) "$dsp $dmg"
set val [expr $near==9999?0:$near]
append r(syscall) " ($val)"
return $val
}
proc do_dsp {hand} {
update
upvar #0 $hand r
set r(syscall) "dsp ($r(sig))"
return $r(sig)
}
proc do_ping {hand} {
update
upvar #0 $hand r
set val $r(ping)
set r(ping) 0
return $val
}
proc do_cannon {hand deg rng} {
update
upvar #0 $hand r
global parms
set r(syscall) "cannon $deg $rng"
if {$r(mstate)} {append r(syscall) " (0)";return 0}
if {$r(reload)} {append r(syscall) " (0)";return 0}
if [catch {set deg [expr round($deg)]}] {append r(syscall) " (-1)";return -1}
if [catch {set rng [expr round($rng)]}] {append r(syscall) " (-1)";return -1}
if {($deg<0 || $deg>359)} {append r(syscall) " (-1)"; return -1}
if {($rng<0 || $rng>$parms(mismax))} {append r(syscall) " (-1)"; return -1}
set r(mhdg) $deg
set r(mdist) $rng
set r(mrange) 0
set r(mstate) 1
set r(morgx) $r(x)
set r(morgy) $r(y)
set r(mx) $r(x)
set r(my) $r(y)
incr r(mused)
# set longer reload time if used all missiles in clip
if {$r(mused) == $parms(clip)} {
set r(reload) $parms(lreload)
set r(mused) 0
} else {
set r(reload) $parms(mreload)
}
append r(syscall) " (1)"
return 1
}
proc do_drive {hand deg spd} {
update
global parms
upvar #0 $hand r
set r(syscall) "drive $deg $spd"
if [catch {set deg [expr round($deg)]}] {append r(syscall) " (-1)";return -1}
if [catch {set spd [expr round($spd)]}] {append r(syscall) " (-1)";return -1}
if {($deg<0 || $deg>359)} {append r(syscall) " (-1)";return -1}
if {($spd<0 || $spd>100)} {append r(syscall) " (-1)";return -1}
set d1 [expr ($r(hdg)-$deg+360)%360]
set d2 [expr ($deg-$r(hdg)+360)%360]
set d [expr $d1<$d2?$d1:$d2]
set r(dhdg) $deg
set r(dspeed) [expr $r(hflag) && $spd>$parms(heatsp) ? $parms(heatsp) : $spd]
# shutdown drive if turning too fast at current speed
set idx [expr int($d/25)]
if {$idx>3} {set idx 3}
if {$r(speed)>$parms(turn,$idx)} {
set r(dspeed) 0
set r(dhdg) $r(hdg)
} else {
set r(orgx) $r(x)
set r(orgy) $r(y)
set r(range) 0
}
# find direction of turn
if {($r(hdg)+$d+360)%360==$deg} {
set r(dir) +
} else {
set r(dir) -
}
append r(syscall) " ($r(dspeed))"
return $r(dspeed)
}
proc do_damage {hand} {
update
upvar #0 $hand r
set r(syscall) "damage ($r(damage))"
return $r(damage)
}
proc do_speed {hand} {
update
upvar #0 $hand r
set r(syscall) "speed ($r(speed))"
return $r(speed)
}
proc do_loc_x {hand} {
update
upvar #0 $hand r
set r(syscall) "loc_x ($r(x))"
return $r(x)
}
proc do_loc_y {hand} {
update
upvar #0 $hand r
set r(syscall) "loc_y ($r(y))"
return $r(y)
}
proc do_tick {hand} {
update
upvar #0 $hand r
global ticks
set r(syscall) "tick ($ticks)"
return $ticks
}
proc do_heat {hand} {
update
upvar #0 $hand r
set r(syscall) "heat ($r(hflag) $r(heat))"
return "$r(hflag) $r(heat)"
}
##############################################################################
#
# every scheduler - scarffed from a comp.lang.tcl posing
# From: burdick@ars.rtp.nc.us (Bill Burdick)
#
#######
proc every {period cmd args} {
if {$args == {}} {
set test 1
} {
set test [lindex $args 0]
}
if {[uplevel #0 "expr {$test}"]} {
uplevel #0 $cmd
after [uplevel #0 "expr {$period}"] "every $period {$cmd} {$test}"
}
}
###############################################################################
#
# oops - can't start or send to wish
#
#
proc oops {robx} {
upvar #0 $robx r
global wishexec
if {$r(pid) > 0} {
# bad send text
mkDialog .oops! "-aspect 200 -text \"Couldn't find or send to a new wish,\
bailing out!\n\n\
Is your X server configured for xauth style security?\n\n\
TclRobots uses the Tk 'send' command, which requires that xhost\
security not be used. Use xauth if possible.\n\n\
Alternatively, re-compile the wish\n\
executable '$wishexec' with '-DTK_NO_SECURITY' flag.\n\\n\
\"" {OK {}}
} else {
# bad wish exec
mkDialog .oops! "-aspect 200 -text \"Couldn't start a new wish,\
bailing out!\n\n\
TclRobots is expecting '$wishexec' as the name of the wish executable.\n\
Is it in your PATH?\n\
\"" {OK {}}
}
}
###############################################################################
#
# halt a running match
#
#
proc halt {} {
global execCmd halted running
set running 0
.l configure -text "Stopping battle, standby"
update
foreach robx {rob1 rob2 rob3 rob4} {
upvar #0 $robx r
if {$r(status)} {
disable_robot $robx
}
}
set halted 1
set execCmd reset
.f1.b1 configure -state normal -text "Reset"
.f1.b2 configure -state disabled
.f1.b3 configure -state disabled
.f1.b4 configure -state disabled
.f1.b5 configure -state disabled
}
###############################################################################
#
# reset to file select state
#
#
proc reset {} {
global execCmd
.c delete all
set execCmd start
.f1.b1 configure -text "Run Battle"
pack forget .c
pack .f2 -side top -expand 1 -fill both
.l configure -text "Select robot files for battle" -fg black
foreach robx {rob1 rob2 rob3 rob4} {
.fs.$robx configure -text ""
.fd.$robx configure -text ""
}
.f1.b1 configure -state normal
.f1.b2 configure -state normal
.f1.b3 configure -state normal
.f1.b4 configure -state normal
.f1.b5 configure -state normal
}
###############################################################################
#
# draw arena boundry
#
#
proc draw_arena {} {
.c create line 0 0 0 500
.c create line 0 0 500 0
.c create line 500 0 500 500
.c create line 0 500 500 500
}
###############################################################################
#
# start a match
#
#
proc start {} {
global rob1 rob2 rob3 rob4 parms running halted ticks execCmd numList
set running 0
set halted 0
set ticks 0
set quads $parms(quads)
set colors $parms(colors)
set numbots 4
.l configure -text "Initializing..."
# clean up robots
foreach robx {rob1 rob2 rob3 rob4} {
upvar #0 $robx r
set r(status) 0
set r(mstate) 0
set r(name) ""
set r(pid) -1
.fs.$robx configure -text ""
.fd.$robx configure -text ""
}
# get robot filenames from window
set robots ""
set lst .f2.fr.l1
for {set i 0} {$i < $numList && $i<4} {incr i} {
lappend robots [$lst get $i]
}
if {[llength $robots] < 2} {
.l configure -text "Must have at least two robots to run a battle"
return
}
set dot_geom [winfo geom .]
set dot_geom [split $dot_geom +]
set dot_x [lindex $dot_geom 1]
set dot_y [lindex $dot_geom 2]
# pick random starting quadrant, colors and init robots
set i 1
foreach f $robots {
set n [rand $numbots]
set color [lindex $colors $n]
set colors [lreplace $colors $n $n]
set n [rand $numbots]
set quad [lindex $quads $n]
set quads [lreplace $quads $n $n]
set x [expr [lindex $quad 0]+[rand 300]]
set y [expr [lindex $quad 1]+[rand 300]]
set winx [expr $dot_x+540]
set winy [expr $dot_y+(($i-1)*140)]
set rc [robot_init rob$i $f $x $y $winx $winy $color]
if {$rc == 0} {
oops rob$i
clean_up
return
}
.fs.rob$i configure -text [file tail $f] -fg $color
.fd.rob$i configure -text "0%"
incr i
incr numbots -1
}
pack forget .f2
pack .c -side top -expand 1 -fill both
draw_arena
# start robots
.l configure -text "Running"
set execCmd halt
.f1.b1 configure -state normal -text "Halt"
.f1.b2 configure -state disabled
.f1.b3 configure -state disabled
.f1.b4 configure -state disabled
.f1.b5 configure -state disabled
start_robots
# start physics package
show_robots
set running 1
every $parms(tick) update_robots {$running}
tkwait variable running
# shutdown all spawned wishes
set i 1
foreach f $robots {
upvar #0 rob$i r
if {$r(status)} {
disable_robot rob$i
}
kill_robot rob$i
incr i
}
# find winnner
if {$halted} {
.l configure -text "Battle halted"
} else {
set alive 0
set winner ""
set win_color black
foreach robx {rob1 rob2 rob3 rob4} {
upvar #0 $robx r
if {$r(status)} {
incr alive
lappend winner $r(name)
set win_color $r(color)
}
}
switch $alive {
0 {
.l configure -text "No robots left alive"
}
1 {
.l configure -text "$winner wins!" -fg $win_color
}
default {
.l configure -text "Tie: $winner"
}
}
}
set execCmd reset
.f1.b1 configure -state normal -text "Reset"
}
###############################################################################
#
# about box
#
#
proc about {} {
global iconfn
mkDialog .about_TclRobots {-aspect 1000 -text "\
TclRobots\n\
Copyright 1994 Tom Poindexter\n\n\
tpoind@advtech.uswest.com\n\
tpoindex@nyx.cs.du.edu\n\n\
Version 1.0 August, 1994\n\n\
"} {OK {}}
.about_TclRobots.bot.0.button config -bitmap @$iconfn
}
###############################################################################
#
# set up main window
#
#
proc main_win {} {
global execCmd numList iconfn parms
# make a temp file to hold icon
set tr_icon {
#define tr_width 48
#define tr_height 48
static char tr_bits[] = {
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
0x00, 0x00, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x1e, 0x00, 0x00, 0x00,
0x00, 0x00, 0x38, 0x00, 0x00, 0x00, 0x00, 0x00, 0x70, 0x00, 0x00, 0x00,
0x00, 0x00, 0x60, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe1, 0x00, 0x00, 0x00,
0x00, 0x00, 0xff, 0x07, 0x00, 0x00, 0x00, 0x00, 0xe1, 0x07, 0x00, 0x00,
0x00, 0x00, 0xe0, 0x06, 0x00, 0x00, 0x00, 0x00, 0x70, 0x06, 0x00, 0x00,
0x00, 0x00, 0x38, 0x06, 0x00, 0x00, 0x00, 0x00, 0x1e, 0x06, 0x00, 0x00,
0x00, 0x00, 0x0f, 0x06, 0x00, 0x00, 0x00, 0x00, 0x00, 0x06, 0x00, 0x00,
0x00, 0x00, 0x00, 0x06, 0x00, 0x00, 0x00, 0x00, 0x00, 0x06, 0x00, 0x00,
0x00, 0x00, 0xfe, 0xff, 0x01, 0x00, 0x00, 0x00, 0xff, 0xff, 0x03, 0x00,
0x80, 0x87, 0x03, 0x00, 0x07, 0x00, 0x80, 0xbf, 0x01, 0x50, 0x06, 0x00,
0x00, 0xfc, 0x0f, 0x00, 0x06, 0x00, 0x00, 0xe0, 0x3f, 0x28, 0x06, 0x00,
0x00, 0x80, 0x39, 0x00, 0x06, 0x00, 0x00, 0x80, 0x01, 0x14, 0x06, 0x00,
0x00, 0x80, 0x0f, 0xc0, 0x07, 0x00, 0x00, 0x00, 0xff, 0xff, 0x03, 0x00,
0x00, 0x00, 0xfc, 0xff, 0x00, 0x00, 0x00, 0xfc, 0xff, 0xff, 0x7f, 0x00,
0x00, 0xfe, 0xff, 0xff, 0xff, 0x00, 0x00, 0x07, 0x00, 0x00, 0xc0, 0x01,
0x00, 0x07, 0x00, 0x00, 0xc0, 0x01, 0x80, 0xff, 0xff, 0xff, 0xff, 0x03,
0xc0, 0xff, 0xff, 0xff, 0xff, 0x07, 0xf0, 0x7f, 0x30, 0x0c, 0xfc, 0x1f,
0xf0, 0x7d, 0x30, 0x0c, 0x7c, 0x1f, 0x38, 0xe0, 0x00, 0x00, 0x0e, 0x38,
0x38, 0xe0, 0x00, 0x00, 0x0e, 0x38, 0x3c, 0xe2, 0x01, 0x00, 0x8f, 0x78,
0x1c, 0xc7, 0x01, 0x00, 0xc7, 0x71, 0x3c, 0xe2, 0x01, 0x00, 0x8f, 0x78,
0x38, 0xe0, 0x00, 0x00, 0x0e, 0x38, 0x38, 0xe0, 0x00, 0x00, 0x0e, 0x38,
0xf0, 0x7d, 0x30, 0x0c, 0x7c, 0x1f, 0xf0, 0x7f, 0x30, 0x0c, 0xfc, 0x1f,
0xc0, 0xff, 0xff, 0xff, 0xff, 0x07, 0x00, 0xff, 0xff, 0xff, 0xff, 0x01};
}
set iconfn /tmp/tr.[pid]
exec echo $tr_icon > $iconfn
set numList 0
set execCmd start
set me [winfo name .]
if {$parms(cmodel)} {
option add $me*background gray80
option add $me*activeBackground gray90
option add $me*Scrollbar*Foreground gray80
option add $me*Scrollbar*activeForeground gray90
}
wm title . "TclRobots"
wm iconbitmap . @$iconfn
wm iconname . TclRobots
wm protocol . WM_DELETE_WINDOW "catch {.f1.b5 invoke}"
frame .f1
button .f1.b1 -text "Run Battle" -width 12 -command {eval $execCmd}
button .f1.b2 -text "Simulator.." -command sim
button .f1.b3 -text "Tournament.." -command tournament
button .f1.b4 -text "About.." -command about
button .f1.b5 -text "Quit" -command "clean_up; \
exec rm -f $iconfn; destroy ."
pack .f1.b1 .f1.b2 .f1.b3 .f1.b4 .f1.b5 -side left -expand 1 -fill both
label .l -relief raised -text {Select robot files for battle}
frame .fs
label .fs.rob1 -relief sunken -width 15
label .fs.rob2 -relief sunken -width 15
label .fs.rob3 -relief sunken -width 15
label .fs.rob4 -relief sunken -width 15
pack .fs.rob1 .fs.rob2 .fs.rob3 .fs.rob4 -side left -expand 1 -fill both
frame .fd -relief raised
label .fd.rob1 -relief sunken -width 15
label .fd.rob2 -relief sunken -width 15
label .fd.rob3 -relief sunken -width 15
label .fd.rob4 -relief sunken -width 15
pack .fd.rob1 .fd.rob2 .fd.rob3 .fd.rob4 -side left -expand 1 -fill both
frame .f2 -width 500 -height 500
frame .f2.fl -relief sunken -borderwidth 3
frame .f2.fr -relief sunken -borderwidth 3
fileBox .f2.fl "Select" * "" [pwd] choose_file
label .f2.fr.lab -text "Robot files selected"
listbox .f2.fr.l1 -relief sunken -yscrollcommand ".f2.fr.s set"
scrollbar .f2.fr.s -command ".f2.fr.l1 yview"
frame .f2.fr.fb
button .f2.fr.fb.b1 -text " Remove " -command remove_file
button .f2.fr.fb.b2 -text " Remove All " -command remove_all
pack .f2.fr.fb.b1 .f2.fr.fb.b2 -side left -padx 5
pack .f2.fr.lab -side top -fill x
pack .f2.fr.fb -side bottom -fill x
pack .f2.fr.s -side right -fill y
pack .f2.fr.l1 -side left -expand 1 -fill both
tk_listboxSingleSelect .f2.fr.l1
pack .f2.fl .f2.fr -side left -expand 1 -fill both -padx 10 -pady 10
canvas .c -width 520 -height 520 -scrollregion "-10 -10 510 510"
pack .f1 .l .fs .fd -side top -fill both
pack .f2 -side top -expand 1 -fill both
wm geom . 520x608
update
}
###############################################################################
#
# choose_file
#
proc choose_file {win filename} {
global numList
set listsize $numList
.f2.fr.l1 insert end $filename
incr numList
set dir $filename
for {set i 0} {$i <= $listsize} {incr i} {
set d [.f2.fr.l1 get $i]
if {[string length $d] > [string length $dir]} {
set dir $d
}
}
set idx [expr [string length [file dirname [file dirname $dir]] ]+1]
.f2.fr.l1 xview $idx
}
###############################################################################
#
# choose_all
#
proc choose_all {} {
global numList
set win .f2.fl
set lsize [$win.l.lst size]
for {set i 0} {$i < $lsize} {incr i} {
set f [string trim [$win.l.lst get $i]]
if ![string match */ $f] {
choose_file $win $f
}
}
}
###############################################################################
#
# remove_file
#
proc remove_file {} {
global numList
set idx -1
catch {set idx [.f2.fr.l1 curselection]}
if {$idx >= 0} {
.f2.fr.l1 delete $idx
incr numList -1
}
}
###############################################################################
#
# remove_all
#
proc remove_all {} {
global numList
set idx $numList
if {$idx > 0} {
.f2.fr.l1 delete 0 end
set numList 0
}
}
#######################################################################
# file selection box, from my "wosql" in Oratcl
# modified not to use a toplevel
#######################################################################
# procs to support a file selection dialog box
########################
#
# fillLst
#
# fill the fillBox listbox with selection entries
#
proc fillLst {win filt dir} {
$win.l.lst delete 0 end
cd $dir
set dir [pwd]
if {[string length $filt] == 0} {
set filt *
}
set all_list [lsort [glob -nocomplain $dir/$filt]]
set dlist "$dir/../"
set flist ""
foreach f $all_list {
if [file isfile $f] {
lappend flist $f
}
if [file isdirectory $f] {
lappend dlist ${f}/
}
}
foreach d $dlist {
$win.l.lst insert end $d
}
foreach f $flist {
$win.l.lst insert end $f
}
$win.l.lst yview 0
set idx [expr [string length [file dirname [file dirname $dir]] ]+1]
$win.l.lst xview $idx
}
########################
#
# selInsert
#
# insert into a selection entry, scroll to root name
#
proc selInsert {win pathname} {
$win.sel delete 0 end
$win.sel insert 0 $pathname
set idx [expr [string length [file dirname [file dirname $pathname]] ]+1]
$win.sel view $idx
$win.sel select from 0
}
########################
#
# fileOK
#
# do the OK processing for fileBox
#
proc fileOK {win execproc} {
# might not have a valid selection, so catch the selection
# catch { selInsert $win [lindex [selection get] 0] }
catch { selInsert $win [$win.l.lst get [$win.l.lst curselection]] }
set f [lindex [$win.sel get] 0]
if [file isdirectory $f] {
#set f [file dirname $f]
#set f [file dirname $f]
cd $f
set f [pwd]
fillLst $win [$win.fil get] $f
} else {
# we don't know if a file is really there or not, let the execproc
# figure it out. also, window is passed if execproc wants to kill it.
$execproc $win $f
}
}
########################
#
# fileBox
#
# put up a file selection box
# win - name of toplevel to use
# filt - initial file selection filter
# initfile - initial file selection
# startdir - initial starting dir
# execproc - proc to exec with selected file name
#
proc fileBox {win txt filt initfile startdir execproc} {
if {[string length $startdir] == 0} {
set startdir [pwd]
}
label $win.l1 -text "File Filter" -anchor w
entry $win.fil -relief sunken
$win.fil insert 0 $filt
label $win.l2 -text "Files" -anchor w
frame $win.l
scrollbar $win.l.hor -orient horizontal -command "$win.l.lst xview" \
-relief sunken
scrollbar $win.l.ver -orient vertical -command "$win.l.lst yview" \
-relief sunken
listbox $win.l.lst -yscroll "$win.l.ver set" -xscroll "$win.l.hor set" \
-relief sunken
label $win.l3 -text "Selection" -anchor w
scrollbar $win.scrl -orient horizontal -relief sunken \
-command "$win.sel view"
entry $win.sel -relief sunken -scroll "$win.scrl set"
selInsert $win $initfile
pack $win.l.ver -side right -fill y
pack $win.l.hor -side bottom -fill x
pack $win.l.lst -side left -fill both -expand 1 -ipadx 3
frame $win.o -relief sunken -border 1
button $win.o.ok -text " $txt " -command "fileOK $win $execproc"
button $win.all -text " Select All " -command "choose_all"
button $win.filter -text " Filter " \
-command "fillLst $win \[$win.fil get\] \[pwd\]"
pack $win.l1 -side top -fill x
pack $win.fil -side top -pady 2 -fill x -ipadx 5
pack $win.l2 -side top -fill x
pack $win.l -side top -fill both -expand 1
pack $win.l3 -side top -fill x
pack $win.sel -side top -pady 5 -fill x -ipadx 5
pack $win.scrl -side top -fill x
pack $win.o.ok -side left -padx 5 -pady 5
pack $win.o $win.all $win.filter -side left -padx 5 -pady 10
bind $win.fil <KeyPress-Return> "$win.filter invoke"
bind $win.sel <KeyPress-Return> "$win.o.ok invoke"
tk_listboxSingleSelect $win.l.lst
bind $win.l.lst <ButtonRelease-1> \
"+selInsert $win \[%W get \[ %W nearest %y \] \] "
bind $win.l.lst <Double-1> \
"selInsert $win \[%W get \[%W curselection\]\]; $win.o.ok invoke"
bind $win <1> "$win.o.ok config -relief sunken"
bind $win <ButtonRelease-1> \
"$win.o.ok invoke ; $win.o.ok deactivate"
bind $win <Return> "$win.o.ok invoke "
bind $win.o <Enter> "$win.o.ok activate"
bind $win.o <Leave> "$win.o.ok deactivate"
fillLst $win $filt $startdir
selection own $win
focus $win.sel
}
#
# end of the file selection box stuff
###########################################################################
###########################################################################
#
# stolen from ousterhout's widget demo
#
# mkDialog w msgArgs list list ...
#
# Create a dialog box with a message and any number of buttons at
# the bottom.
#
# Arguments:
# w - Name to use for new top-level window.
# msgArgs - List of arguments to use when creating the message of the
# dialog box (e.g. text, justifcation, etc.)
# list - A two-element list that describes one of the buttons that
# will appear at the bottom of the dialog. The first element
# gives the text to be displayed in the button and the second
# gives the command to be invoked when the button is invoked.
proc mkDialog {w msgArgs args} {
set win_title $w
regsub -all {_} $win_title " " win_title
catch {destroy $w}
toplevel $w -class Dialog
wm transient $w .
set xpos [expr [winfo rootx .]+[winfo width .]/3]
set ypos [expr [winfo rooty .]+[winfo height .]/3]
wm geom $w +${xpos}+$ypos
wm title $w [string range $win_title 1 end]
# Create two frames in the main window. The top frame will hold the
# message and the bottom one will hold the buttons. Arrange them
# one above the other, with any extra vertical space split between
# them.
frame $w.top -relief raised -border 1
frame $w.bot -relief raised -border 1
pack $w.top $w.bot -side top -fill both -expand 1
# Create the message widget and arrange for it to be centered in the
# top frame.
eval message $w.top.msg -justify center \
-font -*-times-medium-r-normal--*-180* $msgArgs
pack $w.top.msg -side top -expand 1 -padx 5 -pady 5
# Create as many buttons as needed and arrange them from left to right
# in the bottom frame. Embed the left button in an additional sunken
# frame to indicate that it is the default button, and arrange for that
# button to be invoked as the default action for clicks and returns in
# the dialog.
if {[llength $args] > 0} {
set arg [lindex $args 0]
frame $w.bot.0 -relief sunken -border 1
pack $w.bot.0 -side left -expand 1 -padx 20 -pady 20
button $w.bot.0.button -text [lindex $arg 0] \
-command "[lindex $arg 1]; destroy $w"
pack $w.bot.0.button -expand 1 -padx 12 -pady 12
bind $w.top <Enter> "$w.bot.0.button activate"
bind $w.top.msg <Enter> "$w.bot.0.button activate"
bind $w.bot <Enter> "$w.bot.0.button activate"
bind $w.top <Leave> "$w.bot.0.button deactivate"
bind $w.top.msg <Leave> "$w.bot.0.button deactivate"
bind $w.bot <Leave> "$w.bot.0.button deactivate"
bind $w <1> "$w.bot.0.button config -relief sunken"
bind $w <ButtonRelease-1> \
"[lindex $arg 1]; $w.bot.0.button deactivate; destroy $w"
bind $w <Return> "[lindex $arg 1]; destroy $w"
focus $w
set i 1
foreach arg [lrange $args 1 end] {
button $w.bot.$i -text [lindex $arg 0] \
-command "[lindex $arg 1]; destroy $w"
pack $w.bot.$i -side left -expand 1 -padx 20
set i [expr $i+1]
}
}
}
###############################################################################
#
# step toggle
#
#
proc do_step {} {
global rob1 parms running step
if {$step} {
send $rob1(name) "set _step_ 1; set _resume_ 1"
.debug.f2.x configure -relief sunken -state normal
.debug.f2.y configure -relief sunken -state normal
.debug.f2.h configure -relief sunken -state normal
.debug.fb.s configure -relief sunken -state normal
.debug.fb.h configure -relief sunken -state normal
.debug.fb.d configure -relief sunken -state normal
} else {
.debug.f2.x configure -relief flat -state disabled
.debug.f2.y configure -relief flat -state disabled
.debug.f2.h configure -relief flat -state disabled
.debug.fb.s configure -relief flat -state disabled
.debug.fb.h configure -relief flat -state disabled
.debug.fb.d configure -relief flat -state disabled
send $rob1(name) "set _step_ 0; set _resume_ 1"
every $parms(tick) update_robots {$running && !$step }
}
}
###############################################################################
#
# single step
#
#
proc do_single {} {
global rob1 parms running step
set step 1
send $rob1(name) "set _step_ 1; set _resume_ 1"
.debug.f2.x configure -relief sunken -state normal
.debug.f2.y configure -relief sunken -state normal
.debug.f2.h configure -relief sunken -state normal
.debug.fb.s configure -relief sunken -state normal
.debug.fb.h configure -relief sunken -state normal
.debug.fb.d configure -relief sunken -state normal
update_robots
}
###############################################################################
#
# examine a variable
#
#
proc examine {} {
global rob1
.debug.f4.val delete 0 end
if {[catch {send $rob1(name) format \$[.debug.f4.var get]} val] == 0} {
.debug.f4.val insert 0 $val
} else {
.debug.f4.val insert 0 "(not found)"
}
}
###############################################################################
#
# set a variable
#
#
proc setval {} {
global rob1
catch {send $rob1(name) set [.debug.f4.var get] [list [.debug.f4.val get]]}
}
###############################################################################
#
# set heat background to indicate over heat
#
#
proc set_h_bg {args} {
global rob1 parms
if {$rob1(hflag)} {
if {$parms(cmodel)} {
.debug.f2.h configure -bg red
} else {
.debug.f2.h configure -bg black -fg white
}
} else {
if {$parms(cmodel)} {
.debug.f2.h configure -bg gray80
} else {
.debug.f2.h configure -bg white -fg black
}
}
}
###############################################################################
#
# bind proc to only allow number entries
#
#
proc num_only {char win} {
if {[regexp {[0123456789]} "$char"]} {
$win insert insert $char
tk_entrySeeCaret $win
}
}
###############################################################################
#
# verify range of an rob1 entry for simulator
#
#
proc ver_range {var low high} {
global rob1
set val [set $var]
if {$val < $low} { set $var $low }
if {$val > $high} { set $var $high }
}
###############################################################################
#
# start the simulator
#
#
proc sim {} {
global rob1 rob2 rob3 rob4 parms running halted ticks execCmd
global step numList iconfn
set running 0
set halted 0
set ticks 0
set color red
.l configure -text "Simulator"
# clean up robots
foreach robx {rob1 rob2 rob3 rob4} {
upvar #0 $robx r
set r(status) 0
set r(mstate) 0
set r(name) ""
set r(pid) -1
.fs.$robx configure -text ""
.fd.$robx configure -text ""
}
# get robot filenames from window
set robots ""
set lst .f2.fr.l1
if {$numList < 1} {
.l configure -text "Must have one robot file selected to run simulator"
return
}
lappend robots [$lst get 0]
set dot_geom [winfo geom .]
set dot_geom [split $dot_geom +]
set dot_x [lindex $dot_geom 1]
set dot_y [lindex $dot_geom 2]
# pick random starting quadrant, colors and init robots
set i 1
set f $robots
set x [expr 100+[rand 800]]
set y [expr 100+[rand 800]]
set winx [expr $dot_x+540]
set winy [expr $dot_y+(($i-1)*140)]
set rc [robot_init rob$i $f $x $y $winx $winy $color 1]
if {$rc == 0} {
oops rob$i
clean_up
return
}
.fs.rob1 configure -text [file tail $f] -fg $color
.fd.rob1 configure -text "0%"
.fs.rob2 configure -text target -fg black
.fd.rob2 configure -text "0%"
pack forget .f2
pack .c -side top -expand 1 -fill both
draw_arena
# start robots
.l configure -text "Running Simulator"
set execCmd reset
.f1.b1 configure -state disabled
.f1.b2 configure -state disabled
.f1.b3 configure -state disabled
.f1.b4 configure -state disabled
.f1.b5 configure -state disabled
start_robots
# setup target
set rob2(name) target_0
set rob2(status) 1
set rob2(num) 1
set rob2(pid) -1
set rob2(color) black
set rob2(x) 500
set rob2(y) 500
set rob2(damage) 0
set rob2(speed) 0
set rob2(dspeed) 0
set rob2(hdg) 0
set rob2(dhdg) 0
set rob2(mstate) 0
set rob2(reload) 0
set rob2(hflag) 0
