[ViewVC] Annotation of: cvs/kgsueme/bin/gtp-controller

#!/opt/bin/perl

# lots of things have been hardcoded. search for #d# to find the places

require 5.008;

use KGS::Protocol;
use KGS::Listener::Debug;

use IO::Socket::INET;
use Event;

use Getopt::Long;
use Carp;

our $VERSION = '0.0'; # be more confident....

$SIG{QUIT} = sub { Carp::confess "SIGQUIT" };

my $conn = new KGS::Protocol;
my $kgs;
my $gtp;

my $verbose = 1;
my $user = "gtpguest";
my $pass = undef;

$Event::DIED = sub {
   Event::verbose_exception_handler (@_);
   Event::unloop_all;
};

sub format_user($) {
   my $format =
      sprintf "%s|%s|%s",
         $_[0]{name},
         $_[0]->flags_string,
         $_[0]->rank_string;

   $format =~ y/ //d;
   $format;
}

sub coord($$) {
   qw(A B C D E F G H J K L M N O P Q R S T U V W X Y Z)[$_[0]] . $_[1];
}

#############################################################################

package kgs;

use base KGS::Listener;

sub new {
   my $class = shift;
   my $self = bless { @_ }, $class;

   print STDERR "$0 version $VERSION connecting...\n" if $verbose;

   my $sock = new IO::Socket::INET PeerHost => KGS::Protocol::KGSHOST, PeerPort => KGS::Protocol::KGSPORT
      or die "connect: $!";

   $sock->blocking (1);
   $conn->handshake ($sock);

   $self->listen ($conn, "any");

   # Listener for kgs data
   $self->{w} = Event->io (fd => $sock, poll => 'r', cb => sub {
      my $len = sysread $sock, my $buf, 16384;
      if ($len) {
         $conn->feed_data ($buf);
      } elsif (defined $len || (!$!{EINTR} and !$!{EAGAIN})) {
         print STDERR "disconnected\n" if $verbose;
         Event::unloop;
      }
   });

   $conn->login ("gtp-controller $VERSION", $self->{user}, delete $self->{password});

   $self;
}

sub inject_login {
   my ($self, $msg) = @_;

   print STDERR "login: $msg->{message}\n" if $verbose >= 2;

   $gtp->send ("kgs-login $msg->{message}");

#   use KGS::Listener::User;
#   $user = new KGS::Listener::User name => "tetra";
#   $user->listen ($self->{conn});
#   $user->game_record;
}

sub inject_msg_room {
   my ($self, $msg) = @_;

   $gtp->send ("kgs-room-chat $msg->{channel} $msg->{message}");
}

sub inject_any {
   my ($self, $msg) = @_;
   if ($verbose >= 2) {
      print STDERR "DEBUG: $msg->{type}#$msg->{channel}";
      for (sort keys %$msg) {
         print  STDERR"   $_<$msg->{$_}>";
      }
      print STDERR "\n";
   }
}

sub inject_upd_rooms {
   my ($self, $msg) = @_;

   for (@{$msg->{rooms}}) {
      $gtp->send ("kgs-room-update $_->{channel} $_->{name}");
   }
}

sub inject_msg_chat {
   my ($self, $msg) = @_;

   return unless (lc $self->{conn}{name}) eq (lc $msg->{name2});

   $gtp->send ("kgs-user-chat $msg->{name} $msg->{message}");
}

sub inject_new_game {
   my ($self, $msg) = @_;

   $::lastnew = $msg->{channel};#d#
   $gtp->send ("kgs-game-new $msg->{cid} $msg->{channel}");
}

sub inject_idle_warn {
   my ($self, $msg) = @_;

   $self->send ("idle_reset");
}

#############################################################################

package room;

use base KGS::Listener::Room;

sub new {
   my $class = shift;
   my $self = $class->SUPER::new (@_);

   $self->listen ($self->{conn});
   $self->join;

   $self;
}

sub event_join {
   my $self = shift;

   $self->SUPER::join (@_);

   $self->{timer} = Event->timer (after => 0, interval => 60, cb => sub {
      $self->req_games;
   });
}

sub event_update_games {
   my ($self, $add, $upd, $del) = @_;

   for (@$add, @$upd) {
      $gtp->send (sprintf "kgs-game-update %d %d %s %s %s %s %d %d %f %d %d %d %d %s",
                  $self->{channel}, $_->{channel},
                  $_->type_char,
                  ::format_user $_->{black},
                  ::format_user $_->{white},
                  ::format_user $_->{owner},
                  $_->size,
                  $_->{handicap},
                  $_->{komi},
                  $_->moves,
                  $_->{flags},
                  $_->{observers},
                  $_->{saved},
                  $_->{notes},
      );
   }

   for (@$del) {
      $gtp->send ("kgs-game-delete $self->{channel} $_->{channel}");
   }
}

sub event_update_users {
   my ($self, $add, $upd, $del) = @_;

   for (@$add, @$upd) {
      $gtp->send (sprintf "kgs-user-update %s", ::format_user $_);
   }

   for (@$del) {
      $gtp->send (sprintf "kgs-user-remove %s", ::format_user $_);
   }
}

sub DESTROY {
   my $self = shift;

   $self->{timer}->cancel if $self->{timer};

   $self->SUPER::DESTROY;
}

#############################################################################

package game;

use Gtk2::GoBoard::Constants;

use base KGS::Listener::Game;

sub new {
   my $class = shift;
   my $self = $class->SUPER::new (@_);

   $self->listen ($self->{conn});
   $self->join;

   $self;
}

sub event_update_users {
   return;

   my ($self, $add, $upd, $del) = @_;

   for (@$add, @$upd) {
      $gtp->send (sprintf "kgs-user-update %s", ::format_user $_);
   }

   for (@$del) {
      $gtp->send (sprintf "kgs-user-remove %s", ::format_user $_);
   }
}

sub inject_resign_game {
   my ($self, $msg) = @_;

   $gtp->set_gid ($self->{channel});
   $gtp->send ("play " . (qw(b w))[$msg->{player}] . " resign");
}

sub inject_final_result {
   my ($self, $msg) = @_;

   $gtp->send (sprintf "kgs-game-score %f %f %f %f %f %f",
               $_->{whitescore}{territory}, $_->{whitescore}{captures}, $_->{whitescore}{komi},
               $_->{blackscore}{territory}, $_->{blackscore}{captures}, $_->{blackscore}{komi});
}

sub inject_set_teacher {
   my ($self, $msg) = @_;
}

sub event_update_game {
   my ($self) = @_;

   $gtp->set_gid ($self->{channel});

   # timesettings etc.
}

sub event_update_tree {
   my ($self) = @_;

   $gtp->set_gid ($self->{channel});

   my $path = $self->get_path;
   my $prev = $self->{prevpath};

   $self->{prevpath} = [ @$path ];

   if (@$prev > 1
       and @$path > @$prev
       and (join ":", @$prev) eq (join ":", @$path[0 .. $#$prev])) {

      splice @$path, @prev, $#path, ();

   } else {
      $gtp->send ("boardsize $path->[0]{rules}{size}");
      $gtp->send ("komi $path->[0]{rules}{komi}");
      $gtp->send ("clear_board");

      my $setup = shift @$path;
      my $handi;

      while (my ($k, $v) = each %$setup) {
         if ($k =~ /^(\d+),(\d+)$/) {
            $handi .= " " . ::coord $1, $2;
         }
      }

      $gtp->send ("set_free_handicap$handi");
   }

   for (@$path) {
      while (my ($k, $v) = each %$_) {
         if ($k =~ /^(\d+),(\d+)$/) {
            if ($v->[0] & MARK_MOVE) {
               if ($v->[0] & MARK_B) {
                  $gtp->send ("play b ". ::coord $1, $2);
               } else {
                  $gtp->send ("play w ". ::coord $1, $2);
               }
            }
         }
      }
   }
}

sub DESTROY {
   my $self = shift;

   $self->SUPER::DESTROY;
}

#############################################################################

package gtp;

use Gtk2::GoBoard::Constants;
use KGS::Constants;

use Fcntl;

sub new {
   my $class = shift;
   bless { @_ }, $class;
}

sub set_fh {
   my ($self, $rfh, $wfh) = @_;

   $self->{r} = $rfh;
   $self->{w} = $wfh;

   fcntl $rfh, F_SETFL, O_NONBLOCK;

   my $buf;

   Event->io (fd => $rfh, poll => 'r', cb => sub {
      my $r = sysread $rfh, $buf, 16384, length $buf;

      if (defined $r and !$r) {
         die "gtp engine sent EOF, I'm simply dying now, sorry\n";
      } else {
         $buf =~ y/\010\015/ /d;
         $buf =~ s/#[^\012](?=\012)//g; # idiotic part of gtp spec
         while () {
            if ($buf =~ s/^([=?])(?:(\d+)\s+)?(.*?)\012\012//s) { # response
               print STDERR "got response ($1|$2|$3)\n" if $verbose >= 2;

               if (my $cb = delete $self->{waitq}{$2}) {
                  $cb->($1, $3);
               } else {
                  warn "WARNING: got response if '$1 $2' without outstanding request\n";
               }
            } elsif ($buf =~ s/^(?:(\d+)\s+)?([^=?].*?)\012//s) { # command
               $self->parse_command ($1, $2);
            } elsif ($buf =~ s/^\s*\012//) {
               # ignore, idiotic part of gtp spec
            } else {
               last;
            }
         }
      }
   });

   # generate login commands
   $self->send ("protocol_version", sub { $self->{pversion} = $_[1] });
   $self->send ("name", sub { $self->{name} = $_[1] });#d#
   $self->send ("version", sub { $self->{version} = $_[1] });
}

sub run_engine {
   my ($self, @argv) = @_;

   require IPC::Open2;

   my ($r, $w);

   IPC::Open2::open2 ($r, $w, @argv)
      or die "unable to start @argv: $!";

   $self->set_fh ($r, $w);
}

sub send {
   my ($self, $cmd, $cb) = @_;

   # first check for known_command

   my $id = ++$self->{id};

   $cmd =~ y/\015//d;
   $cmd =~ s/\012/\\n/g;

   $self->{waitq}{$id} = $cb || sub { };
   print { $self->{w} } "$id $cmd\012";
}

sub reply {
   my ($self, $id, $response) = @_;

   print { $self->{w} } "=$id $response\012";
}

sub reply_err {
   my ($self, $id, $response) = @_;

   print { $self->{w} } "?$id $response\012";
}

sub parse_command {
   my ($self, $id, $cmd) = @_;

   print STDERR "got command $cmd\n" if $verbose >= 2;

   $cmd =~ s/\s+$//;

   if ($cmd eq "kgs-room-list") {
      # no args, just request all rooms
      $kgs->send (list_rooms => group => $_) for 0..5;
      $self->reply ($id, "");

   } elsif ($cmd =~ /^kgs-room-join\s+(\d+)$/) {
      $kgs->{room}{$1} = new room conn => $kgs->{conn}, channel => $1;
      $self->reply ($id, "");
   } elsif ($cmd =~ /^kgs-room-chat\s+(\d+)\s(.*)$/) {
      $kgs->{room}{$1}->say ($2);
      $self->reply ($id, "");
   } elsif ($cmd =~ /^kgs-room-part\s+(\d+)$/) {
      (delete $kgs->{room}{$1})->part ($2);
      $self->reply ($id, "");

   } elsif ($cmd =~ /^kgs-game-join\s+(\d+)$/) {
      $kgs->{game}{$1} = new game conn => $kgs->{conn}, channel => $1;
      $self->reply ($id, "");
   } elsif ($cmd =~ /^kgs-game-chat\s+(\d+)\s(.*)$/) {
      $kgs->{game}{$1}->say ($2);
      $self->reply ($id, "");
   } elsif ($cmd =~ /^kgs-game-part\s+(\d+)$/) {
      (delete $kgs->{game}{$1})->part ($2);
      $self->reply ($id, "");

   } elsif ($cmd =~ /^kgs-user-chat\s+(\S+)\s+(.*)$/) {
      $kgs->send (msg_chat =>
                  name => $kgs->{user},
                  name2 => $1,
                  message => $2);
      $self->reply ($id, "");

   } elsif ($cmd =~ /^kgs-game-new-demo\s+(\d+)\s+(\d+)$/) {
      my $tid = $conn->alloc_clientid;
      $kgs->send (new_game =>
                  channel  => $1,
                  cid      => $tid,
                  type     => 0,
                  rules => {
                     ruleset  => 0,
                     size     => $2,
                     komi     => 0,
                     timesys  => 0,
                     time     => 0,
                     interval => 0,
                     count    => 0,
                  });
      $self->reply ($id, $tid);
   } elsif ($cmd =~ /^kgs-game-edit\s+(\d+)\s+(.*)$/) {
      my $gid = $1 || $::lastnew;#d#
      my $spec = $2;
      my @tree = ();
      while ($spec =~ s/^([a-z])(\d+)\s+\+?(\S+)\s*//) { # should use mg
         my ($x, $y, $spec) = ($1, $2, $3);
         my $add = $spec !~ s/^-//;
         $x = index "abcdefghjklmnopqrstuvwxyz", lc $x;
         $y--;

         if ($spec eq "b")                { push @tree, [set_stone => 0, $x, $y];
         } elsif ($spec eq "w")           { push @tree, [set_stone => 1, $x, $y];
         } elsif ($spec eq "n")           { push @tree, [set_stone => 2, $x, $y];
         } elsif ($spec eq "sb")          { push @tree, [mark => $add, MARK_SMALL_B, $x, $y];
         } elsif ($spec eq "sw")          { push @tree, [mark => $add, MARK_SMALL_W, $x, $y];
         } elsif ($spec eq "sn")          { push @tree, [mark =>    0, MARK_SMALL_B, $x, $y];
         } elsif ($spec eq "triangle")    { push @tree, [mark => $add, MARK_TRIANGLE, $x, $y];
         } elsif ($spec eq "square")      { push @tree, [mark => $add, MARK_SQUARE, $x, $y];
         } elsif ($spec eq "circle")      { push @tree, [mark => $add, MARK_CIRCLE, $x, $y];
         } elsif ($spec =~ /label=(\S+)/) { push @tree, [mark => length $1, MARK_LABEL, $x, $y, $1];
         } elsif ($spec eq "grayed")      { push @tree, [mark => $add, MARK_GRAYED, $x, $y];
         } else {
            $self->reply_err ($id, "illegal edit spec '$spec'");
            return;
         }
      }
      $kgs->send (upd_tree =>
                  channel => $gid,
                  tree => \@tree);
      $self->reply ($id, "");
   
   } else {
      $self->reply_err ($id, "illegal command");
   }
}

sub set_gid {
   my ($self, $gid) = @_;

   if ($gid != $self->{gid}) {
      $self->send ("kgs-game-id $gid");
      $self->{gid} = $gid;
   }
}

package main;

sub usage {
   print STDERR <<EOF;
Usage: $0 [options] -- engine engine-args...
           -u username    usernmae to connect
           -p password    optional password to connect (none => guest)
           -v             increase verbosity
           -q             decrease verbosity

$0 connects to the kiseido go server, starts the named engine
and communicates with it using GTP protocol using it's stdin and stdout.

If no engine is given, uses stdin/stdout itself for communications.

The engine can optionally act as controller, too, as long as it isn't
confused by responses on it's command input stream.

Command extension used by the controller:

kgs-login message
kgs-room-update <rid> <name>          # update room info
kgs-room-chat <rid> <user> <message>  # somebody says sth.
kgs-game-update <rid> <gid> <type> <black> <white> \
                <owner> <size> <handicap> <komi> <moves> \
                <flags> <observers> <saved> <notes>
kgs-game-delete <rid> <gid>           # game removed
kgs-user-update <rid> <user>          # user added/updated   
kgs-user-delete <rid> <user>          # user removed

kgs-game-resign <gid> <color>
kgs-game-score <gid> <w-territory> <w-captures> <w-komi> <b-territory> <b-captures> <b-komi>
kgs-game-id <gid>                     # set id for following gid-less commands

kgs-user-chat <user> <message>        # got private message from user
kgs-game-new <tid> <gid>              # a new game was created with temporary id <tid>
...

Commands usable by the client as commands issued to the controller:

kgs-room-list                         # ask for roomlist update
kgs-room-join <rid>                   # join given room
kgs-room-chat <rid> <message>         # say sth. in room
kgs-room-part <rid>                   # leave gives room

kgs-game-join <gid>                   # join the given game
kgs-game-part <gid>                   # leave the given game
kgs-game-chat <gid> <message>         # say sth.

kgs-user-chat <user> <message>        # send private msg to user
kgs-game-new-demo <rid> <size>        # create new demo game (other agruments might get added)
                                      # returns a temporary game id
kgs-game-edit <gid> <coord> <editspec> <coord> <editspec>...
                                      # editspec is one of
                                      #    b|w|n        set black/white/no stone
                                      #    sb|sw|sn     set/clear black/white/no small stone
                                      #    [+-]triangle set/clear triangle
                                      #    [+-]square   set/clear square
                                      #    [+-]circle   set/clear circle
                                      #    [+-]grayed   set/clear grayed-flag
                                      #    label=xyz    set label to xyz
...

EOF
   exit shift;
}

GetOptions (
      "u=s" => \$user,
      "v"   => sub { $verbose++ },
      "q"   => sub { $verbose-- },
      "h"   => sub { usage(0) },
) or die usage(1);

$gtp = new gtp;

if (@ARGV) {
   $gtp->run_engine (@ARGV);
} else {
   $gtp->set_fh (\*STDIN, \*STDOUT);
}

$kgs = new kgs user => $user, password => $pass;

Event::loop;

1;


Revision:	1.9
Committed:	Mon Jun 7 13:44:07 2004 UTC (19 years, 11 months ago) by root
Branch:	MAIN
CVS Tags:	HEAD
Changes since 1.8:	+6 -0 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	pcg	1.1	#!/opt/bin/perl
2
3			# lots of things have been hardcoded. search for #d# to find the places
4
5	pcg	1.2	require 5.008;
6
7	pcg	1.1	use KGS::Protocol;
8			use KGS::Listener::Debug;
9
10			use IO::Socket::INET;
11			use Event;
12
13	pcg	1.2	use Getopt::Long;
14	pcg	1.1	use Carp;
15
16	pcg	1.2	our $VERSION = '0.0'; # be more confident....
17	pcg	1.1
18			$SIG{QUIT} = sub { Carp::confess "SIGQUIT" };
19
20	pcg	1.3	my $conn = new KGS::Protocol;
21	pcg	1.1	my $kgs;
22	pcg	1.2	my $gtp;
23
24	pcg	1.1	my $verbose = 1;
25	pcg	1.2	my $user = "gtpguest";
26	pcg	1.1	my $pass = undef;
27
28	pcg	1.2	$Event::DIED = sub {
29			Event::verbose_exception_handler (@_);
30			Event::unloop_all;
31			};
32
33			sub format_user($) {
34			my $format =
35			sprintf "%s\|%s\|%s",
36			$_[0]{name},
37			$_[0]->flags_string,
38			$_[0]->rank_string;
39	pcg	1.1
40	pcg	1.2	$format =~ y/ //d;
41			$format;
42			}
43	pcg	1.1
44	pcg	1.2	sub coord($$) {
45			qw(A B C D E F G H J K L M N O P Q R S T U V W X Y Z)[$_[0]] . $_[1];
46	pcg	1.1	}
47
48	pcg	1.2	#############################################################################
49	pcg	1.1
50			package kgs;
51
52			use base KGS::Listener;
53
54			sub new {
55			my $class = shift;
56			my $self = bless { @_ }, $class;
57
58			print STDERR "$0 version $VERSION connecting...\n" if $verbose;
59
60	pcg	1.4	my $sock = new IO::Socket::INET PeerHost => KGS::Protocol::KGSHOST, PeerPort => KGS::Protocol::KGSPORT
61	pcg	1.1	or die "connect: $!";
62
63			$sock->blocking (1);
64			$conn->handshake ($sock);
65
66			$self->listen ($conn, "any");
67
68			# Listener for kgs data
69			$self->{w} = Event->io (fd => $sock, poll => 'r', cb => sub {
70			my $len = sysread $sock, my $buf, 16384;
71			if ($len) {
72	pcg	1.2	$conn->feed_data ($buf);
73	pcg	1.1	} elsif (defined $len \|\| (!$!{EINTR} and !$!{EAGAIN})) {
74			print STDERR "disconnected\n" if $verbose;
75			Event::unloop;
76			}
77			});
78
79	pcg	1.2	$conn->login ("gtp-controller $VERSION", $self->{user}, delete $self->{password});
80	pcg	1.1
81			$self;
82			}
83
84			sub inject_login {
85			my ($self, $msg) = @_;
86
87	pcg	1.2	print STDERR "login: $msg->{message}\n" if $verbose >= 2;
88
89			$gtp->send ("kgs-login $msg->{message}");
90	root	1.8
91			# use KGS::Listener::User;
92			# $user = new KGS::Listener::User name => "tetra";
93			# $user->listen ($self->{conn});
94			# $user->game_record;
95	pcg	1.1	}
96
97			sub inject_msg_room {
98			my ($self, $msg) = @_;
99	pcg	1.2
100			$gtp->send ("kgs-room-chat $msg->{channel} $msg->{message}");
101	pcg	1.1	}
102
103			sub inject_any {
104			my ($self, $msg) = @_;
105	pcg	1.2	if ($verbose >= 2) {
106			print STDERR "DEBUG: $msg->{type}#$msg->{channel}";
107			for (sort keys %$msg) {
108			print STDERR" $_<$msg->{$_}>";
109			}
110			print STDERR "\n";
111			}
112			}
113
114			sub inject_upd_rooms {
115			my ($self, $msg) = @_;
116
117			for (@{$msg->{rooms}}) {
118			$gtp->send ("kgs-room-update $_->{channel} $_->{name}");
119			}
120			}
121
122			sub inject_msg_chat {
123			my ($self, $msg) = @_;
124
125			return unless (lc $self->{conn}{name}) eq (lc $msg->{name2});
126
127			$gtp->send ("kgs-user-chat $msg->{name} $msg->{message}");
128			}
129
130	pcg	1.3	sub inject_new_game {
131			my ($self, $msg) = @_;
132
133			$::lastnew = $msg->{channel};#d#
134	pcg	1.5	$gtp->send ("kgs-game-new $msg->{cid} $msg->{channel}");
135	pcg	1.3	}
136
137	root	1.9	sub inject_idle_warn {
138			my ($self, $msg) = @_;
139
140			$self->send ("idle_reset");
141			}
142
143	pcg	1.2	#############################################################################
144
145			package room;
146
147			use base KGS::Listener::Room;
148
149			sub new {
150			my $class = shift;
151			my $self = $class->SUPER::new (@_);
152
153			$self->listen ($self->{conn});
154			$self->join;
155
156			$self;
157			}
158
159			sub event_join {
160			my $self = shift;
161
162			$self->SUPER::join (@_);
163
164			$self->{timer} = Event->timer (after => 0, interval => 60, cb => sub {
165			$self->req_games;
166			});
167			}
168
169			sub event_update_games {
170			my ($self, $add, $upd, $del) = @_;
171
172			for (@$add, @$upd) {
173			$gtp->send (sprintf "kgs-game-update %d %d %s %s %s %s %d %d %f %d %d %d %d %s",
174			$self->{channel}, $_->{channel},
175			$_->type_char,
176	pcg	1.7	::format_user $_->{black},
177			::format_user $_->{white},
178			::format_user $_->{owner},
179	pcg	1.2	$_->size,
180			$_->{handicap},
181			$_->{komi},
182			$_->moves,
183			$_->{flags},
184			$_->{observers},
185			$_->{saved},
186			$_->{notes},
187			);
188			}
189
190			for (@$del) {
191			$gtp->send ("kgs-game-delete $self->{channel} $_->{channel}");
192			}
193			}
194
195			sub event_update_users {
196			my ($self, $add, $upd, $del) = @_;
197
198			for (@$add, @$upd) {
199			$gtp->send (sprintf "kgs-user-update %s", ::format_user $_);
200			}
201
202			for (@$del) {
203			$gtp->send (sprintf "kgs-user-remove %s", ::format_user $_);
204			}
205			}
206
207			sub DESTROY {
208			my $self = shift;
209
210			$self->{timer}->cancel if $self->{timer};
211
212			$self->SUPER::DESTROY;
213			}
214
215			#############################################################################
216
217			package game;
218
219			use Gtk2::GoBoard::Constants;
220
221			use base KGS::Listener::Game;
222
223			sub new {
224			my $class = shift;
225			my $self = $class->SUPER::new (@_);
226
227			$self->listen ($self->{conn});
228			$self->join;
229
230			$self;
231			}
232
233			sub event_update_users {
234			return;
235
236			my ($self, $add, $upd, $del) = @_;
237
238			for (@$add, @$upd) {
239			$gtp->send (sprintf "kgs-user-update %s", ::format_user $_);
240			}
241
242			for (@$del) {
243			$gtp->send (sprintf "kgs-user-remove %s", ::format_user $_);
244			}
245			}
246
247			sub inject_resign_game {
248			my ($self, $msg) = @_;
249
250			$gtp->set_gid ($self->{channel});
251			$gtp->send ("play " . (qw(b w))[$msg->{player}] . " resign");
252			}
253
254			sub inject_final_result {
255			my ($self, $msg) = @_;
256
257			$gtp->send (sprintf "kgs-game-score %f %f %f %f %f %f",
258			$_->{whitescore}{territory}, $_->{whitescore}{captures}, $_->{whitescore}{komi},
259			$_->{blackscore}{territory}, $_->{blackscore}{captures}, $_->{blackscore}{komi});
260			}
261
262			sub inject_set_teacher {
263			my ($self, $msg) = @_;
264			}
265
266			sub event_update_game {
267			my ($self) = @_;
268
269			$gtp->set_gid ($self->{channel});
270
271			# timesettings etc.
272			}
273
274			sub event_update_tree {
275			my ($self) = @_;
276
277			$gtp->set_gid ($self->{channel});
278
279			my $path = $self->get_path;
280			my $prev = $self->{prevpath};
281
282			$self->{prevpath} = [ @$path ];
283
284			if (@$prev > 1
285			and @$path > @$prev
286			and (join ":", @$prev) eq (join ":", @$path[0 .. $#$prev])) {
287
288			splice @$path, @prev, $#path, ();
289
290			} else {
291			$gtp->send ("boardsize $path->[0]{rules}{size}");
292			$gtp->send ("komi $path->[0]{rules}{komi}");
293			$gtp->send ("clear_board");
294
295			my $setup = shift @$path;
296			my $handi;
297
298			while (my ($k, $v) = each %$setup) {
299			if ($k =~ /^(\d+),(\d+)$/) {
300			$handi .= " " . ::coord $1, $2;
301			}
302			}
303
304			$gtp->send ("set_free_handicap$handi");
305			}
306
307			for (@$path) {
308			while (my ($k, $v) = each %$_) {
309			if ($k =~ /^(\d+),(\d+)$/) {
310			if ($v->[0] & MARK_MOVE) {
311			if ($v->[0] & MARK_B) {
312			$gtp->send ("play b ". ::coord $1, $2);
313			} else {
314			$gtp->send ("play w ". ::coord $1, $2);
315			}
316			}
317			}
318			}
319			}
320	pcg	1.1	}
321
322	pcg	1.2	sub DESTROY {
323			my $self = shift;
324
325			$self->SUPER::DESTROY;
326			}
327
328			#############################################################################
329
330	pcg	1.1	package gtp;
331
332	pcg	1.3	use Gtk2::GoBoard::Constants;
333			use KGS::Constants;
334
335	pcg	1.2	use Fcntl;
336
337	pcg	1.1	sub new {
338			my $class = shift;
339			bless { @_ }, $class;
340			}
341
342			sub set_fh {
343	pcg	1.2	my ($self, $rfh, $wfh) = @_;
344
345			$self->{r} = $rfh;
346			$self->{w} = $wfh;
347
348			fcntl $rfh, F_SETFL, O_NONBLOCK;
349	pcg	1.1
350	pcg	1.2	my $buf;
351	pcg	1.1
352	pcg	1.2	Event->io (fd => $rfh, poll => 'r', cb => sub {
353			my $r = sysread $rfh, $buf, 16384, length $buf;
354
355			if (defined $r and !$r) {
356			die "gtp engine sent EOF, I'm simply dying now, sorry\n";
357			} else {
358			$buf =~ y/\010\015/ /d;
359			$buf =~ s/#[^\012](?=\012)//g; # idiotic part of gtp spec
360			while () {
361			if ($buf =~ s/^([=?])(?:(\d+)\s+)?(.*?)\012\012//s) { # response
362			print STDERR "got response ($1\|$2\|$3)\n" if $verbose >= 2;
363
364			if (my $cb = delete $self->{waitq}{$2}) {
365			$cb->($1, $3);
366			} else {
367			warn "WARNING: got response if '$1 $2' without outstanding request\n";
368			}
369			} elsif ($buf =~ s/^(?:(\d+)\s+)?([^=?].*?)\012//s) { # command
370			$self->parse_command ($1, $2);
371			} elsif ($buf =~ s/^\s*\012//) {
372			# ignore, idiotic part of gtp spec
373			} else {
374			last;
375			}
376			}
377			}
378			});
379
380			# generate login commands
381			$self->send ("protocol_version", sub { $self->{pversion} = $_[1] });
382			$self->send ("name", sub { $self->{name} = $_[1] });#d#
383			$self->send ("version", sub { $self->{version} = $_[1] });
384	pcg	1.1	}
385
386			sub run_engine {
387	pcg	1.2	my ($self, @argv) = @_;
388
389			require IPC::Open2;
390
391			my ($r, $w);
392
393			IPC::Open2::open2 ($r, $w, @argv)
394			or die "unable to start @argv: $!";
395
396			$self->set_fh ($r, $w);
397			}
398
399			sub send {
400			my ($self, $cmd, $cb) = @_;
401
402			# first check for known_command
403
404			my $id = ++$self->{id};
405
406			$cmd =~ y/\015//d;
407			$cmd =~ s/\012/\\n/g;
408
409			$self->{waitq}{$id} = $cb \|\| sub { };
410			print { $self->{w} } "$id $cmd\012";
411			}
412
413			sub reply {
414			my ($self, $id, $response) = @_;
415
416			print { $self->{w} } "=$id $response\012";
417			}
418
419			sub reply_err {
420			my ($self, $id, $response) = @_;
421
422			print { $self->{w} } "?$id $response\012";
423			}
424
425			sub parse_command {
426			my ($self, $id, $cmd) = @_;
427
428			print STDERR "got command $cmd\n" if $verbose >= 2;
429
430			$cmd =~ s/\s+$//;
431
432			if ($cmd eq "kgs-room-list") {
433			# no args, just request all rooms
434			$kgs->send (list_rooms => group => $_) for 0..5;
435			$self->reply ($id, "");
436
437			} elsif ($cmd =~ /^kgs-room-join\s+(\d+)$/) {
438			$kgs->{room}{$1} = new room conn => $kgs->{conn}, channel => $1;
439			$self->reply ($id, "");
440			} elsif ($cmd =~ /^kgs-room-chat\s+(\d+)\s(.*)$/) {
441			$kgs->{room}{$1}->say ($2);
442			$self->reply ($id, "");
443			} elsif ($cmd =~ /^kgs-room-part\s+(\d+)$/) {
444			(delete $kgs->{room}{$1})->part ($2);
445			$self->reply ($id, "");
446
447			} elsif ($cmd =~ /^kgs-game-join\s+(\d+)$/) {
448			$kgs->{game}{$1} = new game conn => $kgs->{conn}, channel => $1;
449			$self->reply ($id, "");
450			} elsif ($cmd =~ /^kgs-game-chat\s+(\d+)\s(.*)$/) {
451			$kgs->{game}{$1}->say ($2);
452			$self->reply ($id, "");
453			} elsif ($cmd =~ /^kgs-game-part\s+(\d+)$/) {
454			(delete $kgs->{game}{$1})->part ($2);
455			$self->reply ($id, "");
456
457			} elsif ($cmd =~ /^kgs-user-chat\s+(\S+)\s+(.*)$/) {
458			$kgs->send (msg_chat =>
459			name => $kgs->{user},
460			name2 => $1,
461			message => $2);
462			$self->reply ($id, "");
463
464	pcg	1.3	} elsif ($cmd =~ /^kgs-game-new-demo\s+(\d+)\s+(\d+)$/) {
465	pcg	1.6	my $tid = $conn->alloc_clientid;
466	pcg	1.3	$kgs->send (new_game =>
467			channel => $1,
468	pcg	1.5	cid => $tid,
469	pcg	1.6	type => 0,
470	pcg	1.3	rules => {
471			ruleset => 0,
472			size => $2,
473			komi => 0,
474			timesys => 0,
475			time => 0,
476			interval => 0,
477			count => 0,
478			});
479			$self->reply ($id, $tid);
480			} elsif ($cmd =~ /^kgs-game-edit\s+(\d+)\s+(.*)$/) {
481			my $gid = $1 \|\| $::lastnew;#d#
482			my $spec = $2;
483			my @tree = ();
484			while ($spec =~ s/^([a-z])(\d+)\s+\+?(\S+)\s*//) { # should use mg
485			my ($x, $y, $spec) = ($1, $2, $3);
486			my $add = $spec !~ s/^-//;
487			$x = index "abcdefghjklmnopqrstuvwxyz", lc $x;
488			$y--;
489
490			if ($spec eq "b") { push @tree, [set_stone => 0, $x, $y];
491			} elsif ($spec eq "w") { push @tree, [set_stone => 1, $x, $y];
492			} elsif ($spec eq "n") { push @tree, [set_stone => 2, $x, $y];
493			} elsif ($spec eq "sb") { push @tree, [mark => $add, MARK_SMALL_B, $x, $y];
494			} elsif ($spec eq "sw") { push @tree, [mark => $add, MARK_SMALL_W, $x, $y];
495			} elsif ($spec eq "sn") { push @tree, [mark => 0, MARK_SMALL_B, $x, $y];
496			} elsif ($spec eq "triangle") { push @tree, [mark => $add, MARK_TRIANGLE, $x, $y];
497			} elsif ($spec eq "square") { push @tree, [mark => $add, MARK_SQUARE, $x, $y];
498			} elsif ($spec eq "circle") { push @tree, [mark => $add, MARK_CIRCLE, $x, $y];
499			} elsif ($spec =~ /label=(\S+)/) { push @tree, [mark => length $1, MARK_LABEL, $x, $y, $1];
500			} elsif ($spec eq "grayed") { push @tree, [mark => $add, MARK_GRAYED, $x, $y];
501			} else {
502			$self->reply_err ($id, "illegal edit spec '$spec'");
503			return;
504			}
505			}
506			$kgs->send (upd_tree =>
507			channel => $gid,
508			tree => \@tree);
509			$self->reply ($id, "");
510
511	pcg	1.2	} else {
512			$self->reply_err ($id, "illegal command");
513			}
514			}
515
516			sub set_gid {
517			my ($self, $gid) = @_;
518
519			if ($gid != $self->{gid}) {
520			$self->send ("kgs-game-id $gid");
521			$self->{gid} = $gid;
522			}
523	pcg	1.1	}
524
525			package main;
526
527	pcg	1.2	sub usage {
528			print STDERR <<EOF;
529			Usage: $0 [options] -- engine engine-args...
530			-u username usernmae to connect
531			-p password optional password to connect (none => guest)
532			-v increase verbosity
533			-q decrease verbosity
534
535			$0 connects to the kiseido go server, starts the named engine
536			and communicates with it using GTP protocol using it's stdin and stdout.
537
538			If no engine is given, uses stdin/stdout itself for communications.
539
540			The engine can optionally act as controller, too, as long as it isn't
541			confused by responses on it's command input stream.
542
543			Command extension used by the controller:
544
545			kgs-login message
546			kgs-room-update <rid> <name> # update room info
547			kgs-room-chat <rid> <user> <message> # somebody says sth.
548	pcg	1.7	kgs-game-update <rid> <gid> <type> <black> <white> \
549			<owner> <size> <handicap> <komi> <moves> \
550	pcg	1.2	<flags> <observers> <saved> <notes>
551			kgs-game-delete <rid> <gid> # game removed
552			kgs-user-update <rid> <user> # user added/updated
553			kgs-user-delete <rid> <user> # user removed
554
555			kgs-game-resign <gid> <color>
556			kgs-game-score <gid> <w-territory> <w-captures> <w-komi> <b-territory> <b-captures> <b-komi>
557			kgs-game-id <gid> # set id for following gid-less commands
558
559			kgs-user-chat <user> <message> # got private message from user
560	pcg	1.3	kgs-game-new <tid> <gid> # a new game was created with temporary id <tid>
561	pcg	1.2	...
562
563	pcg	1.3	Commands usable by the client as commands issued to the controller:
564	pcg	1.2
565			kgs-room-list # ask for roomlist update
566			kgs-room-join <rid> # join given room
567			kgs-room-chat <rid> <message> # say sth. in room
568			kgs-room-part <rid> # leave gives room
569
570			kgs-game-join <gid> # join the given game
571			kgs-game-part <gid> # leave the given game
572			kgs-game-chat <gid> <message> # say sth.
573
574			kgs-user-chat <user> <message> # send private msg to user
575	pcg	1.3	kgs-game-new-demo <rid> <size> # create new demo game (other agruments might get added)
576			# returns a temporary game id
577			kgs-game-edit <gid> <coord> <editspec> <coord> <editspec>...
578			# editspec is one of
579			# b\|w\|n set black/white/no stone
580			# sb\|sw\|sn set/clear black/white/no small stone
581			# [+-]triangle set/clear triangle
582			# [+-]square set/clear square
583			# [+-]circle set/clear circle
584			# [+-]grayed set/clear grayed-flag
585			# label=xyz set label to xyz
586	pcg	1.2	...
587
588			EOF
589			exit shift;
590			}
591
592			GetOptions (
593			"u=s" => \$user,
594			"v" => sub { $verbose++ },
595			"q" => sub { $verbose-- },
596			"h" => sub { usage(0) },
597			) or die usage(1);
598
599			$gtp = new gtp;
600
601			if (@ARGV) {
602			$gtp->run_engine (@ARGV);
603			} else {
604			$gtp->set_fh (\STDIN, \STDOUT);
605			}
606
607			$kgs = new kgs user => $user, password => $pass;
608	pcg	1.1
609			Event::loop;
610
611			1;
612
613