pkg://tclrobots-2.0.tar.gz:73416/
tclrobots-2.0/tclrobots.tcl
downloads
#!/bin/sh
# the next line restarts using wish \
exec /usr/local/bin/wish "$0" ${1+"$@"}
set wishexec /usr/local/bin/wish
# don't fudge with the first 5 lines !! Makefile depends on them!
# TclRobots
# Copyright 1994,1996 Tom Poindexter
# tpoindex@nyx.net
#
# version 1.0 August 1994
# version 2.0 February 1996
#
global rob1 rob2 rob3 rob4 c_tab s_tab parms nowin finish tourn_type
global running halted ticks maxticks execCmd numList tlimit bgColor
# 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(simtick) 500 ;# simulation clock 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)]
;# missile reload time in ticks
set parms(lreload) [expr $parms(mreload)*3]
;# missile long reload time after clip
set parms(clip) 4 ;# number of missiles 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(dia0) 6 ;# diameter of direct missle damage
set parms(dia1) 10 ;# " " maximum " "
set parms(dia2) 20 ;# " " medium " "
set parms(dia3) 40 ;# " " minimum " "
set parms(hit0) 25 ;# %damage within range 0
set parms(hit1) 12 ;# " " " 1
set parms(hit2) 7 ;# " " " 2
set parms(hit3) 3 ;# " " " 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(canheat) 20 ;# cannon heating rate per shell
set parms(cancool) -1 ;# cannon cooling rate per tick
set parms(scanbad) 35 ;# cannon heat index where scanner is inop
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 {[winfo depth .] >= 4 } {
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
set tlimit 10
set outfile ""
# 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
}
proc team_declare {tname} {
# AFTER DO_WAIT
UPDATE
set val -1
catch {SEND "TCLROBOTS" do_team_declare HAND $tname} val
DEBUG
_ping_check_
UPDATE
return $val
}
proc team_send {args} {
# AFTER DO_WAIT
UPDATE
set val -1
catch {SEND "TCLROBOTS" do_team_send HAND "$args"} val
DEBUG
_ping_check_
UPDATE
return $val
}
proc team_get {} {
# AFTER DO_WAIT
UPDATE
set val -1
catch {SEND "TCLROBOTS" do_team_get 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 16
label .f.l -relief sunken -width 30 -text "(loading robot code..)"
label .f.s -relief sunken -width 5 -text "0%"
pack .f.c -side left
pack .f.s -side right
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 \
bind bindtags bell clipboard fileevent image } {
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 {}}
}
# disable base tk library startup procs
proc tkScreenChanged {args} {}
# our own unknown proc
proc unknown {name args} {
dputs "UNKNOWN: $name"
}
# our own tkerror proc
proc tkerror {args} {
global errorInfo
dputs $errorInfo
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 nowin
upvar #0 $robx r
set name [file tail $fn]
# generate a new signature
set newsig [rand 65535]
set ourname [winfo name .]
# set robot parms
set r(name) ${name}_$newsig ;# window name = source.file_randnumber
set r(num) $newsig ;# the rand number as digital signature
set r(cmd) $newsig ;# random command names, also set below
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
set r(team) "" ;# declared team
set r(data) "" ;# last team message sent
set r(btemp) 0 ;# barrel temp, affected by cannon fire
# startup a new wish with specified name
if {$nowin} {
set stdinput "wm withdraw ."
} else {
set stdinput ""
}
catch { exec $wishexec -geom 200x115+$winx+$winy -name $r(name) \
<< $stdinput >/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
}
# generate new command names
global _lastvalue
set oldlast $_lastvalue
if [catch {set fntime [file atime $fn]}] {set fntime [rand 255]}
if [catch {set fnsize [file size $fn]}] {set fnsize [rand 255]}
set _lastvalue [expr ( $r(pid) * (($fntime * $fnsize)%65536) ) % 65536]
set newcmd [rand 65535]
set _lastvalue $oldlast
set r(cmd) $newcmd
set newdestroy _d_$newcmd
set newafter _a_$newcmd
set newsend _s_$newcmd
set newtkwait _t_$newcmd
set newupdate _u_$newcmd
set newexit _e_$newcmd
if {$sim} {
set newdebug "global _step_; if {\$_step_} {$newtkwait variable _resume_}"
} else {
set newdebug ""
}
# 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(cmd) 100 {set _start_ 1}"
}
}
}
###############################################################################
#
# update damage label of robot
#
#
proc up_damage {robx d} {
global parms
upvar #0 $robx r
if {$d >= 100} {
set d dead
set c "-bg red"
} elseif {$d >= 85} {
set d ${d}%
set c "-bg orange"
} elseif {$d >= 50} {
set d ${d}%
set c "-bg yellow"
} else {
set d ${d}%
set c ""
}
if {!$parms(cmodel)} {
set c ""
}
catch {send -async $r(name) ".f.s configure -text $d $c; _u_$r(cmd)"}
}
###############################################################################
#
# disable robot
#
#
proc disable_robot {robx taunt} {
upvar #0 $robx r
# break the remote tcl interpreter by causing it to wait on .
set insults {{junk\\ pile!} {cratered!} {scrap\\ heap!} {toast!} {face\\ plant!} {sleeps\\ with\\ PC\\ Jr.} {roasted!} {flat-liner!} {char-broiled!} {pushing\\ up\\ daisies!} {comatose!} {bits\\ busted!} {core\\ dump!} {GPF} {UAE}}
if {$taunt} {
set insult [lindex $insults [rand [llength $insults]]]
} else {
set insult ""
}
# break after, let the robot spin in an update cycle and wait on .
catch {send -async $r(name) \
"proc after {args} {}; \
proc _ping_check_ \{\} \{while 1 \{_u_$r(cmd);_a_$r(cmd) 100\} \}" }
catch {send -async $r(name) "_a_$r(cmd) 1 \
\".d.l insert end $insult;.d.l yview end;_u_$r(cmd);_t_$r(cmd) window .\""}
}
###############################################################################
#
# kill robot
#
#
proc kill_robot {robx} {
upvar #0 $robx r
catch {send $r(name) "rename _s_$r(cmd) send;proc _s_$r(cmd) {args} {}" }
catch {send $r(name) "_a_$r(cmd) 0 _e_$r(cmd)" }
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 finish
update
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(dia0)} {
incr rr(damage) $parms(hit0)
} elseif {$d<$parms(dia1)} {
incr rr(damage) $parms(hit1)
} elseif {$d<$parms(dia2)} {
incr rr(damage) $parms(hit2)
} else {
incr rr(damage) $parms(hit3)
}
up_damage $robrx $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 }
}
}
# check for barrel overheat, apply cooling
if {$r(btemp)} {
incr r(btemp) $parms(cancool)
if {$r(btemp) < 0} { set r(btemp) 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)
up_damage $robx $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)
up_damage $robx $r(damage)
}
}
}
# check for robot health
set diffteam ""
set num_team 0
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
up_damage $robx $r(damage)
disable_robot $robx 1
append finish "$r(name) team($r(team)) dead at tick: $ticks\n"
} else {
incr num_rob
if {$r(team) != ""} {
if {[lsearch -exact $diffteam $r(team)] == -1} {
lappend diffteam $r(team)
incr num_team
}
} else {
lappend diffteam $r(name)
incr num_team
}
}
}
}
if {($num_rob<=1 || $num_team==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 res} {
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 arc [expr $x-350] [expr $y-350] [expr $x+350] [expr $y+350] \
-start [expr $deg-$res] -extent [expr 2*$res + 1] \
-fill "" -outline $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-3] [expr $y-3] [expr $x+3] [expr $y+3] \
-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-3] [expr $y-3] [expr $x+3] [expr $y+3] \
-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 $res"
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 ? 5 : 0) + [rand $derr]]
set fud1 [expr [rand 2] ? \"-\" : \"+\"]
set fud2 [expr [rand 2] ? \"-\" : \"+\"]
set near [expr $dist $fud1 $terr $fud2 $r(btemp)]
if {$near<1} {set near 1}
set dsp $rob(num)
set dmg $rob(damage)
}
}
}
# if cannon has overheated scanner, report 0
if {$r(btemp) >= $parms(scanbad)} {
set r(sig) "0 0"
set val 0
} else {
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(btemp) $parms(canheat)
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)"
}
proc do_team_declare {hand tname} {
update
upvar #0 $hand r
if {$r(team) == ""} {
set r(team) $tname
}
set r(syscall) "team_declare $tname ($r(team))"
return "$r(team)"
}
proc do_team_send {hand data} {
update
upvar #0 $hand r
if {$r(team) != ""} {
set r(data) $data
}
set r(syscall) "team_send $data ()"
return ""
}
proc do_team_get {hand} {
update
upvar #0 $hand r
set val ""
if {$r(team) == ""} {
set r(syscall) "team_get ($val)"
return ""
}
foreach robx {rob1 rob2 rob3 rob4} {
upvar #0 $robx rob
if {"$hand" == "$robx" || !$rob(status)} { continue }
if {"$r(team)" == "$rob(team)"} {
lappend val [list $rob(num) $rob(data)]
}
}
set r(syscall) "team_get ($val)"
return $val
}
##############################################################################
#
# 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} {
global nowin
upvar #0 $robx r
global wishexec
if {$nowin} {
puts "tclrobots: couldn't start or send to spawned wish interpreter"
puts "'$wishexec'"
puts "exiting tclrobots. possible wish left running...."
exit
}
if {$r(pid) > 0} {
# bad send text
tk_dialog2 .oops "oops!" "Couldn't find or send to a new wish,\
bailing out!\n\nIs your X server configured for xauth style \
security?\n\nTclRobots uses the Tk 'send' command, which \
requires that xhost security not be used. Use xauth \
if possible.\n\nAlternatively, re-compile the wish \
executable\n'$wishexec'\nwith the \
'-DTK_NO_SECURITY' flag." warning 0 dismiss
} else {
# bad wish exec
tk_dialog2 .oops "oops!" "Couldn't start a new wish interpreter,\
bailing out!\n\nTclRobots is expecting \n'$wishexec'\nas the \
name of the wish executable.\nIs it in your PATH?" warning 0 dismiss
}
}
###############################################################################
#
# 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 0
}
}
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
.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
}
###############################################################################
#
# shutdown spawned wishes and reset
#
#
proc kill_wishes {robots} {
# shutdown all spawned wishes
set i 1
foreach f $robots {
upvar #0 rob$i r
if {$r(status)} {
disable_robot rob$i 0
}
kill_robot rob$i
incr i
}
reset
}
###############################################################################
#
# 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
global finish outfile tourn_type nowin
set finish ""
set players "battle: "
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
}
# 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)*145)]
set winy [expr (($i-1)*145)]
set rc [robot_init rob$i $f $x $y $winx $winy $color]
if {$rc == 0} {
oops rob$i
clean_up
return
}
upvar #0 rob$i r
append players "$r(name) "
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
# find winnner
if {$halted} {
.l configure -text "Battle halted"
} else {
set alive 0
set winner ""
set num_team 0
set diffteam ""
set win_color black
foreach robx {rob1 rob2 rob3 rob4} {
upvar #0 $robx r
if {$r(status)} {
disable_robot $robx 0
incr alive
lappend winner $r(name)
set win_color $r(color)
if {$r(team) != ""} {
if {[lsearch -exact $diffteam $r(team)] == -1} {
lappend diffteam $r(team)
incr num_team
}
} else {
incr num_team
}
}
}
switch $alive {
0 {
set msg "No robots left alive"
.l configure -text $msg
}
1 {
if {[string length $diffteam] > 0} {
set diffteam "Team $diffteam"
}
set msg "Winner!\n\n$diffteam\n$winner"
.l configure -text "$winner wins!" -fg $win_color
}
default {
# check for teams
if {$num_team == 1} {
set msg "Winner!\n\nTeam $diffteam\n$winner"
.l configure -text "Team: $diffteam : $winner wins!"
} else {
set msg "Tie:\n\n$winner"
.l configure -text "Tie: $winner"
}
}
}
if {$nowin} {
set msg2 [join [split $msg \n] " "]
set score "score: "
set points 1
foreach l [split $finish \n] {
set n [lindex $l 0]
if {[string length $n] == 0} {continue}
set l [string last _ $n]
if {$l > 0} {incr l -1; set n [string range $n 0 $l]}
append score "$n = $points "
incr points
}
foreach n $winner {
set l [string last _ $n]
if {$l > 0} {incr l -1; set n [string range $n 0 $l]}
append score "$n = $points "
}
catch {write_file $outfile "$players\n$finish\n$msg2\n\n$score\n\n\n"}
} else {
tk_dialog2 .winner "Results" $msg "-image iconfn" 0 dismiss
}
}
set execCmd "kill_wishes \"$robots\""
.f1.b1 configure -state normal -text "Reset"
}
###############################################################################
#
# about box
#
#
proc about {} {
tk_dialog2 .about "About TclRobots" "TclRobots\n\nCopyright 1994,1996\nTom Poindexter\ntpoindex@nyx.net\n\nVersion 2.0\nFebruary, 1996\n" "-image iconfn" 0 dismiss
}
###############################################################################
#
# set up main window
#
#
proc main_win {} {
global execCmd numList parms
# define our 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};
}
image create bitmap iconfn -data $tr_icon -background ""
set numList 0
set execCmd start
set me [winfo name .]
if {$parms(cmodel)} {
#option add *background gray80
#option add *activeBackground gray90
#option add *Scrollbar*background gray80
#option add *Scrollbar*activeBackground gray90
}
option add *highlightThickness 0
# make a toplevel icon window, iconwindow doesn't have transparent bg :-(
catch {destroy .iconm}
toplevel .iconm
pack [label .iconm.i -image iconfn]
wm title . "TclRobots"
wm iconwindow . .iconm
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; 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 .f2 -width 520 -height 520
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" \
-selectmode single
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 -pady 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
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 -side top -fill both
pack .f2 -side top -expand 1 -fill both
wm geom . 524x574
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 xview $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" \
-selectmode single -relief sunken
label $win.l3 -text "Selection" -anchor w
scrollbar $win.scrl -orient horizontal -relief sunken \
-command "$win.sel xview"
entry $win.sel -relief sunken -xscroll "$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"
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"
fillLst $win $filt $startdir
selection own $win
focus $win.sel
}
#
# end of the file selection box stuff
###########################################################################
###############################################################################
#
# 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 bgColor
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 $bgColor
} else {
.debug.f2.h configure -bg white -fg black
}
}
}
#####################################
