#!/usr/bin/perl -w
use strict qw (subs refs vars) ;

# SfExpress - ICFP 2002 Programming Contest Submission
# Copyright 2002 William R. Somsky

# === Early Declarations/Definitions ===

my $turn = 0 ;				# turn counter
my $turn_limit = undef ;		# turn limit

my (@trace, %trace) ;			# trace list
my $verbosity	= 0 ;			# default is silent
my $msg_socket	= "/tmp/SfEx_msg" ;	# message monitoring socket

my $graphical	= 0 ;			# no graphics by default

my $server_port	= undef ;		# eg, 22001
my $server_name	= undef ;		# eg, icfp1.cse.ogi.edu

# === Command Line Parsing ===

use Getopt::Long ;

Getopt::Long::Configure qw (bundling) ;

sub usage
  { "Usage: SfExpress [-qv][-t trace,..][-m msg-socket][-g] server port\n" ; }

GetOptions (
    't|trace=s' => \@trace,
    'v|verbose+' => \$verbosity,
    'g|graphical' => \$graphical,
    'm|msg-socket=s' => \$msg_socket,
    'q|quiet' => sub { $verbosity = 0 } )
  or die usage ;

map { $trace{$_} = 1 } @trace = split ',', join ",", @trace ;

$server_name = shift @ARGV or die "Missing argument: server\n", usage ;
$server_port = shift @ARGV or die "Missing argument: port\n", usage ;
@ARGV == 0                 or die "Too many arguments\n", usage ;

# === Stderr Messaging Routines ===

sub err   { print STDERR @_, "\n" ; }
sub mesg  { print STDERR @_, "\n" if $verbosity >= 1 ; } ;
sub verb  { print STDERR @_, "\n" if $verbosity >= 2 ; } ;
sub blab  { print STDERR @_, "\n" if $verbosity >= 3 ; } ;
sub trace { my $t = shift ; print STDERR @_, "\n" if $trace{$t} }

if ( -S $msg_socket )
  {
  use IO::Socket ;
  verb "Connecting to message monitor, $msg_socket ..." ;
  my $msg = IO::Socket::UNIX->new (Peer => $msg_socket)
    or die "Cannot connect to message monitor, $msg_socket: $!\n" ;
  *STDERR = $msg ; mesg "Connection to message monitor established" ;
  }

# === Server Communications ===

use IO::Socket ;

verb "Connecting to game server, $server_name:$server_port ..." ;

my $server = IO::Socket::INET->new
  (PeerAddr => "$server_name:$server_port", Proto =>"tcp")
    or die "Cannot connect to game server, $server_name:$server_port: $!\n" ;

mesg "Connection to game server established ($server_name:$server_port)" ;

sub xmit
  {
  my $data = join "", @_ ;
  trace "IO", "> ", $data ;
  print $server $data, "\n" or die "Error sending to game server: $!\n" ;
  }

sub rcv
  {
  my $data = <$server> ; chomp $data if $data ;
  if (!defined $data) # eot/error
    {
    trace "IO", "* channel closed by server" ;
    # ??? distinguish EOT/ERR
    return undef ;
    }
  trace "IO", "< ", $data ;
  return $data ;
  }

# === Initialize Game Board ===

my @base ;
my @board ;

sub OPEN  { '.' }
sub WATER { '~' }
sub WALL  { '#' }
sub BASE  { '@' }
sub SELF  { 'o' }
sub BOT   { 'x' }

verb "Initializing game ..." ;

xmit "Player" ;

verb "Waiting for game server ..." ;

my $wh_data = rcv ;
my ($width, $height) =
  $wh_data =~ /^\s*(\d+)\s+(\d+)\s*$/
    or die "Parse Error: expecting width-height data:\n< $wh_data\n" ;

mesg "Game initiated" ;
verb "Receiving playing field ..." ;

trace 'Board', "Board ($width x $height):" ;

for (my $row = 0 ; $row <= $height+1 ; $row++)
  {
  $board[$row][0]        = { TILE => WALL } ;
  $board[$row][$width+1] = { TILE => WALL } ;
  }

for (my $col = 0 ; $col <= $width+1 ; $col++)
  {
  $board[0][$col]         = { TILE => WALL } ;
  $board[$height+1][$col] = { TILE => WALL } ;
  }

for (my $row = 1 ; $row <= $height ; $row++)
  {
  my $board_row = rcv ;
  $board_row =~ /^[.~#@]{$width}$/
    or die "Parse Error: malformed board-row:\n< $board_row\n" ;

  for (my $col = 1 ; $col <= $width ; $col++)
    {
    my $tile = substr $board_row, $col-1, 1 ;
    $board[$row][$col] = { TILE => $tile } ;
    if ($tile eq BASE) { push @base, { X => $col, Y => $row } ; }
    }
  }

for (my $row = $height+1 ; $row >= 0 ; $row--)
  {
  trace 'Board', join "", map $_->{TILE}, @{$board[$row]} ;
  }

foreach my $base (@base)
  {
  trace 'Board', sprintf "Base:  (%4d, %4d)", $base->{X}, $base->{Y} ;
  }

verb "Receiving player configuration ..." ;

my $icm_data = rcv ;
my ($id, $capacity, $funds) =
  $icm_data =~ /^\s*(\d+)\s+(\d+)\s+(\d+)\s*$/
    or die "Parse Error: expecting id-capacity-funds line:\n< $icm_data\n" ;

trace 'Config', "Robot id: $id" ;
trace 'Config', "Initial funds: $funds" ;
trace 'Config', "Carrying capacity: $capacity" ;

# === Bot Maintainance ===

my %bot ;

sub get_bot_update
  {
  my $update = rcv ;
  trace 'BotUpd', "Bot Update: $update" ;

  if ($update =~ /^Robot/) # end of game message
    {
    # ??? unify end-game cases
    mesg $update if $update ne "" ;
    while ($update = rcv) { mesg $update ; }
    exit 0 ;
    }

  if ($update =~ /^#/)
    {
    my $bot = undef ;
    my @update = split /\s+/, $update ;

    while (@update)
      {
      my $tkn = shift @update ;
      if ($tkn =~ /#(\d+)/) { $bot = $1 }
      elsif   ($tkn eq "N") { $bot{$bot}->{Y}++ ; }
      elsif   ($tkn eq "S") { $bot{$bot}->{Y}-- ; }
      elsif   ($tkn eq "E") { $bot{$bot}->{X}++ ; }
      elsif   ($tkn eq "W") { $bot{$bot}->{X}-- ; }
      elsif   ($tkn eq "P") { $bot{$bot}->{LOAD}{shift @update} = 1 ; }
      elsif   ($tkn eq "D") { delete $bot{$bot}->{LOAD}{shift @update} ; }
      elsif   ($tkn eq "X") { $bot{$bot}->{X} = shift @update ; }
      elsif   ($tkn eq "Y") { $bot{$bot}->{Y} = shift @update ; }
      else { die "Parse Error: bad update token: \"$tkn\"\n< $update\n" ; }
      }

    if ($trace{'Bots'})
      {
      foreach my $bot (keys %bot)
	{
	trace 'Bots',
	  (sprintf "Bot %4d%s ", $bot, $bot == $id ? "*" : " "),
	  (sprintf "(%4d, %4d) ", $bot{$bot}->{X}, $bot{$bot}->{Y}),
	  join " ", keys %{$bot{$bot}->{LOAD}} ;
	}
      }
    }

  else 
    {
    die "Parse Error: expecting bot-update:\n< $update\n" ;
    }
  }

# ??? Do bots ever disappear?  How is this shown?  
# ??? evidentally by not mentioning them anymore...

# === Package Maintainance ===

my %pkg ;
my @pkgs_here = () ;

sub get_pkg_list
  {
  @pkgs_here = () ;
  my $pkg_list = rcv ; # [id x y wt] ...
  trace 'PkgList', "Pkg list: $pkg_list" ;

  if ($pkg_list =~ /^Robot/) # end of game message
    {
    # ??? unify end-game cases
    mesg $pkg_list if $pkg_list ne "" ;
    while ($pkg_list = rcv) { mesg $pkg_list ; }
    exit 0 ;
    }

  my @pkg_list = split /\s+/, $pkg_list ;

  while (@pkg_list)
    {
    my $pid = shift @pkg_list ;
    my $dx  = shift @pkg_list ;
    my $dy  = shift @pkg_list ;
    my $wt  = shift @pkg_list ;
    $pkg{$pid} = { PID => $pid, DX => $dx, DY => $dy, WT => $wt } ;
    trace 'Pkgs', "Pkg $pid ($dx,$dy) $wt" ;
    push @pkgs_here, $pid ;
    }
  }

# ??? Do packages ever disappear?  How is this shown?
# ??? Can you tell the difference whether another bot
# ??? had delivered or just dropped a package?
# ??? Are any packages ever undeliverable?

# === Graphics ===

my $map    = undef ;
my $metric = undef ;
my $status = undef ;

if ($graphical)
  {
  verb "Initializing graphics ..." ;
  }

BEGIN { eval { require Curses ; import Curses ; } ; }

if ($graphical && !$INC{'Curses.pm'})
  {
  print "Curses unavailable: skipping graphics\n" ; STDOUT->flush ;
  $graphical = 0 ;
  }

if ($graphical)
  {
  initscr () ;

  $status = new Curses (0, 0, 0, 0) ;
  $map    = new Curses ($height+2, $width+2, 1, 0) ;
  $metric = new Curses ($height+2, $width+2, 1, $width+3) ;

  if (!$status || !$map)
    {
    endwin () ;
    $graphical = 0 ;
    $status = undef ;
    $map    = undef ;
    print "Cannot allocate map area: skipping graphics\n" ; STDOUT->flush ;
    }
  }

if ($graphical)
  {
  curs_set (0) ;
  start_color () ;
  END { endwin () if $graphical ; }
  use subs qw (COLOR_BLACK COLOR_WHITE COLOR_GREEN COLOR_BLUE COLOR_RED) ;

  init_pair (1, COLOR_BLACK, COLOR_WHITE) ; sub BLACK_WHITE { COLOR_PAIR(1) } ;
  init_pair (2, COLOR_GREEN, COLOR_WHITE) ; sub GREEN_WHITE { COLOR_PAIR(2) } ;
  init_pair (3, COLOR_RED  , COLOR_WHITE) ; sub   RED_WHITE { COLOR_PAIR(3) } ;
  init_pair (4, COLOR_BLACK, COLOR_BLUE ) ; sub BLACK_BLUE  { COLOR_PAIR(4) } ;
  init_pair (5, COLOR_BLACK, COLOR_BLACK) ; sub BLACK_BLACK { COLOR_PAIR(5) } ;
  init_pair (6, COLOR_WHITE, COLOR_BLACK) ; sub WHITE_BLACK { COLOR_PAIR(5) } ;

  $status->bkgd (BLACK_WHITE) ;
  $status->resize (1, 0) ;
  $status->refresh ;
  }

if ($graphical) { mesg "Graphics initialized" ; }

my %tile ;

if ($graphical)
  {
  $tile{OPEN ()} = { SYM => ' ', ATTR => BLACK_WHITE } ;
  $tile{BASE ()} = { SYM => '@', ATTR => GREEN_WHITE } ;
  $tile{WALL ()} = { SYM => '#', ATTR => BLACK_BLACK } ;
  $tile{WATER()} = { SYM => '~', ATTR => BLACK_BLUE  } ;
  $tile{SELF ()} = { SYM => 'o', ATTR =>   RED_WHITE } ;
  $tile{BOT  ()} = { SYM => 'x', ATTR => BLACK_WHITE } ;
  }

sub show_map
  {
  return unless $map ;
  for (my $row = 0 ; $row <= $height+1 ; $row++)
    {
    for (my $col = 0 ; $col <= $width+1 ; $col++)
      {
      my $tile = $board[$row][$col]->{TILE} ;
      $map->attrset ($tile{$tile}->{ATTR}) ;
      $map->addch ($height+1-$row, $col, $tile{$tile}->{SYM}) ;
      }
    }

  foreach my $bot (keys %bot)
    {
    my $x = $bot{$bot}->{X} ;
    my $y = $bot{$bot}->{Y} ;
    my $tile = $bot == $id ? SELF() : BOT() ;
    $map->attrset ($tile{$tile}->{ATTR}) ;
    $map->addch ($height+1-$y, $x, $tile{$tile}->{SYM}) ;
    }

  $map->refresh ;
  }

# === Play Sequence === -------------------------------------------------------

verb "Receiving inital bot configuration ..." ;

get_bot_update () ;	# initial configuration
show_map () ;

verb "Entering main play loop ..." ;

for ($turn = 1 ; !$turn_limit || $turn < $turn_limit ; $turn++)
  {
  trace 'Turns', "Turn: $turn" ;
  get_pkg_list () ;
  issue_command () ;
  get_bot_update () ;
  show_map () ;
  }

# Bailout Hack...
trace 'Turns', "Turn: bailout" ;
xmit "0 Move N" ;
get_bot_update () ;
exit 0 ;

# === Gameplay Logic === ------------------------------------------------------

my $x ;
my $y ;
my @pkgs ;
my $pkgs_wt ;
## @pkgs_here ;
## $capacity ;

sub issue_command
  {
  my $stat ;

  $x = $bot{$id}->{X} ;
  $y = $bot{$id}->{Y} ;
  @pkgs = keys %{$bot{$id}->{LOAD}} ;
  $pkgs_wt = 0 ; foreach (@pkgs) { $pkgs_wt += $pkg{$_}->{WT} ; }

  if ($map)
    {
    $stat = sprintf "%d: %d (%d/%d)\n",
      $turn, 0+@pkgs, $pkgs_wt, $capacity  ;
    $status->addstr (0, 0, $stat) ;
    $status->refresh ;
    }

  my $cmd = undef ;
  $cmd ||= deliver_here() ;
  $cmd ||= pickup_here() ;
  $cmd ||= gofor_delivery() ;
  $cmd ||= goto_base() ;  
  $cmd ||= sit() ;

  mesg $cmd->{mesg} if $cmd->{mesg} ;
  verb $cmd->{verb} if $cmd->{verb} ;
  blab $cmd->{blab} if $cmd->{blab} ;

  if ($map)
    {
    chomp $stat ;
    $stat .= "  " . ($cmd->{mesg} || $cmd->{verb} || $cmd->{blab}) ."\n" ;
    $status->addstr (0, 0, $stat) ;
    $status->refresh ;
    }

  xmit "1 ", $cmd->{cmd} ;
  }

sub deliver_here
  {
  return undef unless @pkgs ;

  my @deliverable =
    grep { $pkg{$_}->{DX} == $x
       and $pkg{$_}->{DY} == $y } @pkgs ;

  return undef unless @deliverable ;

  return
    {
    cmd  => (join " ", "Drop",    @deliverable),
    verb => (join " ", "Deliver", @deliverable)
    }
  }

sub pickup_here
  {
  return undef unless @pkgs_here ;

  my @pick ;
  my $wt = $pkgs_wt ;

  foreach my $pkg (@pkgs_here)
    {
    if ($wt + $pkg{$pkg}->{WT} <= $capacity)
      {
      push @pick, $pkg ;
      $wt += $pkg{$pkg}->{WT} ;
      }
    }

  return undef unless @pick ;

  return
    {
    cmd  => (join " ", "Pick",   @pick),
    verb => (join " ", "Pickup", @pick)
    }
  }

sub gofor_delivery
  {
  return undef unless @pkgs ;

  my $p = $pkg{$pkgs[0]} ;

  my $cmd = bot_goto ($p->{DX}, $p->{DY}) ;
  $cmd->{blab}
    = (join "", "Goto Delivery: ", $p->{DX}, " ", $p->{DY})
      if $cmd ;

  return $cmd ;
  }

sub goto_base
  {
  # if we're already at the base,
  # then there was nothing we could pick up here
  if ($x == $base[0]->{X} and $y == $base[0]->{Y})
    {
    # rotate base list...
    push @base, shift @base ;
    }

  my $cmd = bot_goto ($base[0]->{X}, $base[0]->{Y}) ;

  $cmd->{blab}
    = (join "", "Goto Base: ", $base[0]->{X}, " ", $base[0]->{Y})
     if $cmd ;

  return $cmd ;
  }

sub sit
  {
  return
    {
    cmd => "Pick 1234567",
    blab => "Just sit..."
    }
  }

my @metric ;
my $metric_x ;
my $metric_y ;

sub HUGE { 10000000 } ;

sub distance_matrix
  {
  my $x = shift ;
  my $y = shift ;

  $metric_x = HUGE unless defined $metric_x ;
  $metric_y = HUGE unless defined $metric_x ;

  return if $x == $metric_x and $y == $metric_y ; # stored...

  $metric_x = $x ;
  $metric_y = $y ;

  trace 'DMX', "compute DMX" ;

  for (my $dx = 0 ; $dx <= $width+1  ; $dx++) {
  for (my $dy = 0 ; $dy <= $height+1 ; $dy++) {
    my $tile = $board[$dy][$dx]->{TILE} ;
    $metric[$dy][$dx] = ($tile eq WALL or $tile eq WATER) ? HUGE : undef ;
    }}

  $metric[$y][$x] = 0 ;

  my @site ;
  push @site, [$y,$x] ;

  while (@site)
    {
    my $p  = shift @site ;
    my $py = $p->[0] ;
    my $px = $p->[1] ;
    my $d  = $metric[$py][$px] ;

    if (!defined $metric[$py+1][$px])
               { $metric[$py+1][$px] = $d+1 ; push @site, [$py+1, $px] ; }
    if (!defined $metric[$py-1][$px])
               { $metric[$py-1][$px] = $d+1 ; push @site, [$py-1, $px] ; }
    if (!defined $metric[$py][$px+1])
               { $metric[$py][$px+1] = $d+1 ; push @site, [$py, $px+1] ; }
    if (!defined $metric[$py][$px-1])
               { $metric[$py][$px-1] = $d+1 ; push @site, [$py, $px-1] ; }
    }

  display_metric () ;
  }

sub display_metric
  {
  return unless $metric ;

  for (my $row = 0 ; $row <= $height+1 ; $row++)
    {
    for (my $col = 0 ; $col <= $width+1 ; $col++)
      {
      my $d = $metric[$row][$col] ;
      if (!defined $d)
	{
	$metric->attrset (BLACK_BLUE) ;
	$metric->addch ($height+1-$row, $col, '-') ;
	}
      elsif ($d == HUGE)
	{
	$metric->attrset (BLACK_BLACK) ;
	$metric->addch ($height+1-$row, $col, '#') ;
	}
      elsif ($d == 0)
	{
	$metric->attrset (RED_WHITE) ;
	$metric->addch ($height+1-$row, $col, '*') ;
	}
      else
	{
	$metric->attrset (GREEN_WHITE) ;
	$metric->addch ($height+1-$row, $col, sprintf ("%d", $d%10) ) ;
	}
      }
    }

  $metric->refresh ;
  }

sub bot_goto
  {
  my $dest_x = shift ;
  my $dest_y = shift ;

  distance_matrix ($dest_x, $dest_y) ;

  my $dist = $metric[$y][$x] ; # current...

  # ??? what about unreachable destinations such as islands?

  if (0) {} 
  elsif ($metric[$y+1][$x] < $dist) { return { cmd => "Move N" } }
  elsif ($metric[$y-1][$x] < $dist) { return { cmd => "Move S" } }
  elsif ($metric[$y][$x+1] < $dist) { return { cmd => "Move E" } }
  elsif ($metric[$y][$x-1] < $dist) { return { cmd => "Move W" } }
  else                              { return undef ; }
  }

__END__ =======================================================================

=head1 NAME

B<SfExpress> - ICFP 2002 Programming Contest Submission

=head1 AUTHOR

W R Somsky E<lt>I<wrsomsky@speakeasy.org>E<gt>

=head1 SYNOPSIS

B<SfExpress> [B<-qv>] [B<-t> I<trace>,I<...>] [B<-m> I<msg-socket>] [B<-g>]
          I<server> I<port>

=head1 OPTIONS

=over

=item B<-q>

Run silently.

=item B<-v>

Print informational output.  Multiple invocations of
this option will give increasing amounts of output.

=item B<-t> F<trace>,F<...>

Turn on tracing/debugging information for the
specified subsystems.  The subsystems currently
traceable are: C<IO>, C<Board>, C<Config>, C<BotUpd>,
C<Bots>, C<PkgList>, C<Pkgs>, C<Turns>.

=item B<-m> F<msg-socket>

Change the unix-domain socket used for stderr redirection.
By default, the socket C</tmp/SfEx_msg> is used.
See the DESCRIPTION section for details.

=item B<-g>

Invoke the curses-based graphical display.

=item I<server>

The game server hostname/IP address

=item I<port>

The port number of the game server socket

=back

=head1 DESCRIPTION

B<SfExpress> is my submission for the ICFP 2002 Programming Contest.
The challenge task which this program attempts to accomplish
might best be described as a "package delivery service" game,
where one controls a robot which moves over a playing field of
rectangular cells, picking up and dropping packages.  The task
description should be consulted for further details.

The program is written entirely in I<perl>.  It should require only
core modules for it's basic functionality, although if the
C<Curses> module is available, a graphical is available.

B<SfExpress> has a number of interesting features:

=over

=item Graphical Display

If run from a terminal and invoked w/ the B<-g> option,
B<SfExpress> will display a graphical real-time representation
of the playing field as the game progresses.  This display will
be in color if the the displaying terminal supports this.  (Note
that on some machines a C<term> setting of C<xterm-color> is required
to obtain access to color effects.)  Selecting a font with nearly
square aspect ration improves the appearance of the display --
try C<lucidasans-8>, C<lucidasans-10> or C<lucidasans-12>.

This graphical display is based on the perl C<Curses> module,
but the program is coded such a way that it should run successfully
even if the C<Curses> module is not present, although without
graphical display abilities.

=item Socket Redirection of Standard Error

If a unix-domain socket C</tmp/SfEx_msg> exits,
B<SfExpress> will divert its standard error output
to this socket.  This is useful when used in conjunction
with B<SfExpress>'s curses-based graphical output to keep
the two output streams from interfering with each other.

A simple script
(included as B<monitor> in the tar package)
which may be used to create and
display this messaging-socket is :

    #!/usr/bin/perl -w
    use strict qw (subs refs vars) ;

    use IO::Socket ;

    $SIG{INT} = sub { die ; } ;

    my $socket = $ARGV[0] || "/tmp/SfEx_msg" ;

    my $server = IO::Socket::UNIX->new
      (Local => $socket, Type=>SOCK_STREAM, Listen=>1)
	or die "Cannot establish socket $socket: $!\n" ;

    END { unlink $socket if $server ; }

    print "Monitoring established on $socket\n" ;

    while (my $client = $server->accept())
      {
      $client->autoflush (1) ;
      STDOUT->autoflush (1) ;
      print '+ ', '='x50, "\n" ;
      while (<$client>) { print ; }
      print '- ', '='x50, "\n" ;
      close $client ;
      }

=item Gameplay Logic

The gameplay logic of B<SfExpress> is totally simplistic.
If you can deliver a package here, do so.  Else, if you can
pick up a package here, do that.  Otherwise if you have any
packages to deliver move towards the delivery point of one
of them.  If you have none, head for a base to pick up more.

There are many things one could try to do to optimize delivery
paths and strategies, but I first concentrated on trying to get
the underlying mechanisms working.  The framework of the program
would support more elaborate AI, however, "clever" schemes should
B<always> be examined quite closely to make sure they actually
perform as desired.  The graphical display feature of B<SfExpress>
is particularly useful for this.  Even with the simplistic logic
implemented thus far, observation of the robot's behavior during its
operation shows interesting and unexpected effects that one would
need to take into account for any more intelligent control logic.

=item Coding Style

I<It's not a bug, it's a feature.>  While not completely excreable, 
the coding style used in B<SfExpress> is hardly what one would
consider I<high style>.  In particular, the lack of useful
comments makes the code particularly ill-suited for ongoing
maintainance.  However, the terse style does posess a certain
"hack factor" suited for the quick code modification and changeout
typical of programming contests and off-the-cuff prototyping.

=back

=head1 BUGS

Probably too many to shake a stick at.
Not to mention more than a few rough edges
one might bark one's shin upon.

