TclRobots.pm (Mastering Perl/Tk)

C.9. TclRobots.pm

Chapter 20, "IPC with send" discusses TclRobots in detail. TclRobots.pm allows you to write Robot Control Programs in Perl instead of Tcl.
$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;