$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().
#
# [email protected], 1999/05/07.
# [email protected], 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;
