$TclRobots::VERSION = '2.1'; package TclRobots; # This module implements a thin API that interfaces Perl with tclrobots # version 2, written by Tom Poindexter. This means that you can write # RCPs (Robot Control Programs) in your favorite language - Perl - and # do battle with all the existing Tcl RCPs. # # This module is rather wierd - you're never supposed to use it! # Instead, it's used when tclrobots runs an instance of perl, at which # time this module is loaded and begins execution on behalf of your # RCP. It creates the main window of the required dimensions and at # the proper location on the display, and adds all the widgets, text, # and images # # When instructed by tclrobots, this module then loads your Perl RCP # (via require, so be sure your code returns a TRUE value!), and the # contest begins. From that point on, incoming tclrobot messages are # dispatched to Perl emulation handlers, and Perl RCP commands are # converted to Tcl syntax and sent to tclrobots - the communication is # via Tk::send() and Tk::Receive(). # # Stephen.O.Lidie@Lehigh.EDU, 1999/05/07. # Stephen.O.Lidie@Lehigh.EDU, 2000/04/13, for Perl 5.6.0. use Exporter; @ISA = qw/Exporter/; @EXPORT = qw/after alert cannon damage dputs drive dsp heat loc_x loc_y scanner speed team_declare team_get team_send tick update/; use File::Basename; use Tk; use Tk qw/after catch/; use Tk::widgets qw/Dialog/; use subs qw/_arrowshape__configure_widgets__customize_window_ _disable_rcp__insult_rcp__destroy_rcp__load_rcp_ _see_variable__set_variables__setup_window__start_rcp_/; use vars qw/$_after_ $_alert_on_ $_debug $_dl_ $_fc_ $_fl_ $_fs_ $_mw_ $_ping_proc_ $_rcp_filename_ $_resume_ $_robot_ $_start_ $_step_ $_tclrobots_/; use strict; ############################################################################## # # Note, we run tainted so that send() and receive() work. Grab command line # arguments: # # perl5 -Tw -I. -MTclRobots /dev/null RCP.ptr_2462 \ # WidthxHeigh+X+Y rob2 tclrobots ./RCP.ptr # ############################################################################## return 1 if $ENV{TCLROBOTS_RCP_CHECK};
# if checking RCP syntax $ENV{'HOME'} = '/tmp'; $_mw_ = MainWindow->new; $_mw_->withdraw; $ARGV[0] =~ /(.*)/; # robot's Tcl name $_mw_->appname($1); $_mw_->title($1); $ARGV[1] =~ /(.*)/; # window geometry $_mw_->geometry($1); $ARGV[2] =~ /(.*)/; # robot's handle $_robot_ = $1; $ARGV[3] =~ /(.*)/; # tclrobot's name $_tclrobots_ = $1; $ARGV[4] =~ /(.*)/; # RCP filename $_rcp_filename_ = $1; $_mw_->deiconify; MainLoop; ############################################################################## # # Robot Control Program commands available to your Perl controlware. For # the most part, they simply invoke Tcl subroutines in tclrobots. We also # handle single stepping in Debug mode. # ############################################################################## {
local $^W = 0; eval 'sub after {$_mw_->after(@_)}';
}
sub alert {
my($code_ref) = @_; $_ping_proc_ = $code_ref; if (defined $code_ref) {
$_alert_on_ = 1;
}
else {
$_alert_on_ = 0;
}
} sub cannon {
my($deg, $range) = @_; $_mw_->after(100); $_mw_->update; my $val = Tk::catch {
$_mw_->send($_tclrobots_, "do_cannon $_robot_ $deg $range");
};
$_mw_->waitVariable(\$_resume_) if $_debug and $_step_; &_ping_check_; $_mw_->update;
return $val;
}
sub damage {
$_mw_->after(100); $_mw_->update; my $val = Tk::catch {
$_mw_->send($_tclrobots_, "do_damage $_robot_");
};
$_mw_->waitVariable(\$_resume_) if $_debug and $_step_; &_ping_check_; $_mw_->update;
return $val;
}
sub dputs {
my(@args) = @_; $_resume_ = 0; Tk::catch {
$_dl_->insert('end', join(' ', @args)); $_dl_->yview('end'); $_mw_->update;
};
$_mw_->waitVariable(\$_resume_) if $_debug and $_step_; $_mw_->update;
}
sub drive {
my($deg, $speed) = @_; $_mw_->after(100); $_mw_->update; my $val = Tk::catch {
$_mw_->send($_tclrobots_, "do_drive $_robot_ $deg $speed");
};
$_mw_->waitVariable(\$_resume_) if $_debug and $_step_; &_ping_check_; $_mw_->update;
return $val;
}
sub dsp {
$_mw_->after(100); $_mw_->update; my $val = Tk::catch {
$_mw_->send($_tclrobots_, "do_dsp $_robot_");
};
$_mw_->waitVariable(\$_resume_) if $_debug and $_step_; &_ping_check_; $_mw_->update; my(@dsp) = split(' ', $val);
return @dsp;
}
sub heat {
$_mw_->after(100); $_mw_->update; my $val = Tk::catch {
$_mw_->send($_tclrobots_, "do_heat $_robot_");
};
$_mw_->waitVariable(\$_resume_) if $_debug and $_step_; &_ping_check_; $_mw_->update; my(@heat) = split(' ', $val);
return @heat;
}
sub loc_x {
$_mw_->after(100); $_mw_->update; my $val = Tk::catch {
$_mw_->send($_tclrobots_, "do_loc_x $_robot_");
};
$_mw_->waitVariable(\$_resume_) if $_debug and $_step_; &_ping_check_; $_mw_->update;
return $val;
}
sub loc_y {
$_mw_->after(100); $_mw_->update; my $val = Tk::catch {
$_mw_->send($_tclrobots_, "do_loc_y $_robot_");
};
$_mw_->waitVariable(\$_resume_) if $_debug and $_step_; &_ping_check_; $_mw_->update;
return $val;
}
sub scanner {
my($deg, $res) = @_; $_mw_->after(100); $_mw_->after(100); $_mw_->update; my $val = Tk::catch {
$_mw_->send($_tclrobots_, "do_scanner $_robot_ $deg $res");
};
$_mw_->waitVariable(\$_resume_) if $_debug and $_step_; &_ping_check_; $_mw_->update;
return $val;
}
sub speed {
$_mw_->after(100); $_mw_->update; my $val = Tk::catch {
$_mw_->send($_tclrobots_, "do_speed $_robot_");
};
$_mw_->waitVariable(\$_resume_) if $_debug and $_step_; &_ping_check_; $_mw_->update;
return $val;
}
sub team_declare {
my($tname) = @_; $_mw_->update; my $val = Tk::catch {
$_mw_->send($_tclrobots_, "do_team_declare $_robot_ $tname");
};
$_mw_->waitVariable(\$_resume_) if $_debug and $_step_; &_ping_check_; $_mw_->update;
return $val;
}
sub team_get {
$_mw_->update; my $val = Tk::catch {
$_mw_->send($_tclrobots_, "do_team_get $_robot_");
};
$_mw_->waitVariable(\$_resume_) if $_debug and $_step_; &_ping_check_; $_mw_->update; my @teams; foreach my $team (&SplitString($val)) {
my($dsp, $data) = split ' ', $team; push @teams, [$dsp, $data];
}
return @teams;
}
sub team_send {
my($args) = @_; $_mw_->update; my $val = Tk::catch {
$_mw_->send($_tclrobots_, "do_team_send $_robot_ \"$args\"");
};
$_mw_->waitVariable(\$_resume_) if $_debug and $_step_; &_ping_check_; $_mw_->update;
return $val;
}
sub tick {
$_mw_->after(100); $_mw_->update; my $val = Tk::catch {
$_mw_->send($_tclrobots_, "do_tick $_robot_");
};
$_mw_->waitVariable(\$_resume_) if $_debug and $_step_; &_ping_check_; $_mw_->update;
return $val;
}
sub update {
$_mw_->update;
}
############################################################################## # # Tcl -> Perl handlers. # ############################################################################## sub Tk::Receive {
# Accept Tcl strings from tclrobots and invoke # Perl/Tk emulation code. my($mw) = shift; # main window $_ = shift; # Tcl command return 2 if /expr 1\+1/;
return if /(Knuth|^rename)/m; CASE: {
/setup window/m and do {_setup_window_; last CASE};
/create|configure/ and do {_customize_window_ $_; last CASE};
/set _start_ 0/ and do {_load_rcp_; last CASE};
/set _start_ 1/ and do {_start_rcp_; last CASE};
/^proc after/ and do {_disable_rcp_; last CASE};
/\.d\.l insert/ and do {_insult_rcp_ $_; last CASE};
/^_a_\d+ 0 _e_\d+/ and do {_destroy_rcp_; last CASE};
/^set/ and do {_set_variables_ $_; last CASE};
/^format/ and do {return _see_variable_ $_;};
print STDERR "UNHANDLED cmd=$_!\n";
}
# casend
}
# end Tk::Receive sub _arrowshape_ {
my($cmd) = @_; my($cs, $ar) = $cmd =~ /\.f\.. create (.*) (-arrowshape.*)/; my(@cs) = split(' ', $cs); $ar =~ /"(\d+) (\d+) (\d+)/; my $as = [$1, $2, $3]; $_fc_->create(@cs, -arrowshape => $as);
}
sub _configure_widgets_ {
my($cmd) = @_; my($w) = $cmd =~ /\.f\.l/ ? $_fl_ : $_fs_; my($cs) = $cmd =~ /configure (.*)/; $cs =~ s/(;.*)//; my(@cs) = split(' ', $cs); $w->configure(@cs); $w->update;
}
sub _customize_window_ {
$_ = $_[0]; /configure/ and do {_configure_widgets_ $_;
return};
/create/ and do {_arrowshape_ $_;
return};
}
sub _destroy_rcp_ {
$_mw_->after(1 => $_mw_->destroy);
}
sub _disable_rcp_ {
{ local $^W = 0; eval 'sub after {}'; eval 'sub _ping_check_ {
while (1) {
$_mw_->update; $_mw_->after(100);
}
}';
}
} sub _insult_rcp_ {
my($cmd) = @_; my($text) = $cmd =~ /insert end(.*)?;\.d\.l/; $_mw_->after(1 => sub {
$text =~ s/\\//g; $_dl_->insert('end', $text); $_dl_->yview('end'); $_mw_->update; $_mw_->waitWindow;
}
);
}
sub _load_rcp_ {
$_start_ = 0; $_mw_->after(100 => sub {
$_mw_->waitVariable(\$_start_); eval "require \"$_rcp_filename_\""; if ($@) {
my $bn = basename $_rcp_filename_; my $d = $_mw_->Dialog( -title => $_mw_->appname, -text => "$@\nYour RCP failed to compile. To perform a syntax " . "check, do:\n\nTCLROBOTS_RCP_CHECK=1 perl -MTclRobots $bn", -font => 'fixed'); $d->Subwidget('message')->configure(-wraplength => '8i'); $d->Show; $d->destroy;
}
});
}
sub _see_variable_ {
my($expression) = @_; # including leading $ $expression = substr $expression, 8; {
no strict; # Perl bug: I want eval "$expression"; # So for now, assume a scalar var name. $$expression;
}
} sub _setup_window_ {
# Setup the RCP's debug and damage window. my $f = $_mw_->Frame; $f->pack(qw/-side top -fill x -ipady 5/); $_fc_ = $f->Canvas(qw/-width 20 -height 16/); $_fl_ = $f->Label(qw/-relief sunken -width 30 -text/ => "(loading robot code..)"); $_fs_ = $f->Label(qw/-relief sunken -width 5 -text/ => "0%"); $_fc_->pack(qw/-side left/); $_fs_->pack(qw/-side right/); $_fl_->pack(qw/-side left -expand 1 -fill both/); $_dl_ = $_mw_->Scrolled('Listbox', qw/-relief sunken -scrollbars se/); $_dl_->pack(qw/-side left -expand 1 -fill both/); $_mw_->minsize(100, 70); $_mw_->update; $_resume_ = 0; $_step_ = 0;
}
sub _set_variables_ {
my($cmd) = @_; foreach (split /;/, $cmd) {
my($set, $var, $val) = /(set)\s+(\S+)\s+(.*)/; {no strict; eval {$$var = $val}}
}
} sub _start_rcp_ {
$_mw_->after(100 => sub {$_start_ = 1});
}
############################################################################## # # Auxiliary routines. # ############################################################################## $_ping_proc_ = ''; $_alert_on_ = 0; sub _ping_check_ {
return unless $_alert_on_; my $val = Tk::catch {
$_mw_->send($_tclrobots_, "do_ping $_robot_");
};
Tk::catch {&$_ping_proc_($val)} if $val != 0;
}
sub SplitString {
# Swiped from Tk800.015 distribution - a weak attempt to # turn a Tcl LOL into a Perl LOL. local $_ = shift; my (@arr, $tmp); while (/\{([^{}]*)\}|((?:[^\s\\]|\\.)+)/gs) {
if (defined $1) {
push @arr, $1;
}
else {
$tmp = $2 ; $tmp =~ s/\\([\s\\])/$1/g; push @arr, $tmp;
}
} return @arr;
}
# end SplitString 1;