[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}");
}

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

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.8
Committed:	Mon Jun 7 13:37:07 2004 UTC (19 years, 11 months ago) by root
Branch:	MAIN
Changes since 1.7:	+5 -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	pcg	1.2	#############################################################################
138
139			package room;
140
141			use base KGS::Listener::Room;
142
143			sub new {
144			my $class = shift;
145			my $self = $class->SUPER::new (@_);
146
147			$self->listen ($self->{conn});
148			$self->join;
149
150			$self;
151			}
152
153			sub event_join {
154			my $self = shift;
155
156			$self->SUPER::join (@_);
157
158			$self->{timer} = Event->timer (after => 0, interval => 60, cb => sub {
159			$self->req_games;
160			});
161			}
162
163			sub event_update_games {
164			my ($self, $add, $upd, $del) = @_;
165
166			for (@$add, @$upd) {
167			$gtp->send (sprintf "kgs-game-update %d %d %s %s %s %s %d %d %f %d %d %d %d %s",
168			$self->{channel}, $_->{channel},
169			$_->type_char,
170	pcg	1.7	::format_user $_->{black},
171			::format_user $_->{white},
172			::format_user $_->{owner},
173	pcg	1.2	$_->size,
174			$_->{handicap},
175			$_->{komi},
176			$_->moves,
177			$_->{flags},
178			$_->{observers},
179			$_->{saved},
180			$_->{notes},
181			);
182			}
183
184			for (@$del) {
185			$gtp->send ("kgs-game-delete $self->{channel} $_->{channel}");
186			}
187			}
188
189			sub event_update_users {
190			my ($self, $add, $upd, $del) = @_;
191
192			for (@$add, @$upd) {
193			$gtp->send (sprintf "kgs-user-update %s", ::format_user $_);
194			}
195
196			for (@$del) {
197			$gtp->send (sprintf "kgs-user-remove %s", ::format_user $_);
198			}
199			}
200
201			sub DESTROY {
202			my $self = shift;
203
204			$self->{timer}->cancel if $self->{timer};
205
206			$self->SUPER::DESTROY;
207			}
208
209			#############################################################################
210
211			package game;
212
213			use Gtk2::GoBoard::Constants;
214
215			use base KGS::Listener::Game;
216
217			sub new {
218			my $class = shift;
219			my $self = $class->SUPER::new (@_);
220
221			$self->listen ($self->{conn});
222			$self->join;
223
224			$self;
225			}
226
227			sub event_update_users {
228			return;
229
230			my ($self, $add, $upd, $del) = @_;
231
232			for (@$add, @$upd) {
233			$gtp->send (sprintf "kgs-user-update %s", ::format_user $_);
234			}
235
236			for (@$del) {
237			$gtp->send (sprintf "kgs-user-remove %s", ::format_user $_);
238			}
239			}
240
241			sub inject_resign_game {
242			my ($self, $msg) = @_;
243
244			$gtp->set_gid ($self->{channel});
245			$gtp->send ("play " . (qw(b w))[$msg->{player}] . " resign");
246			}
247
248			sub inject_final_result {
249			my ($self, $msg) = @_;
250
251			$gtp->send (sprintf "kgs-game-score %f %f %f %f %f %f",
252			$_->{whitescore}{territory}, $_->{whitescore}{captures}, $_->{whitescore}{komi},
253			$_->{blackscore}{territory}, $_->{blackscore}{captures}, $_->{blackscore}{komi});
254			}
255
256			sub inject_set_teacher {
257			my ($self, $msg) = @_;
258			}
259
260			sub event_update_game {
261			my ($self) = @_;
262
263			$gtp->set_gid ($self->{channel});
264
265			# timesettings etc.
266			}
267
268			sub event_update_tree {
269			my ($self) = @_;
270
271			$gtp->set_gid ($self->{channel});
272
273			my $path = $self->get_path;
274			my $prev = $self->{prevpath};
275
276			$self->{prevpath} = [ @$path ];
277
278			if (@$prev > 1
279			and @$path > @$prev
280			and (join ":", @$prev) eq (join ":", @$path[0 .. $#$prev])) {
281
282			splice @$path, @prev, $#path, ();
283
284			} else {
285			$gtp->send ("boardsize $path->[0]{rules}{size}");
286			$gtp->send ("komi $path->[0]{rules}{komi}");
287			$gtp->send ("clear_board");
288
289			my $setup = shift @$path;
290			my $handi;
291
292			while (my ($k, $v) = each %$setup) {
293			if ($k =~ /^(\d+),(\d+)$/) {
294			$handi .= " " . ::coord $1, $2;
295			}
296			}
297
298			$gtp->send ("set_free_handicap$handi");
299			}
300
301			for (@$path) {
302			while (my ($k, $v) = each %$_) {
303			if ($k =~ /^(\d+),(\d+)$/) {
304			if ($v->[0] & MARK_MOVE) {
305			if ($v->[0] & MARK_B) {
306			$gtp->send ("play b ". ::coord $1, $2);
307			} else {
308			$gtp->send ("play w ". ::coord $1, $2);
309			}
310			}
311			}
312			}
313			}
314	pcg	1.1	}
315
316	pcg	1.2	sub DESTROY {
317			my $self = shift;
318
319			$self->SUPER::DESTROY;
320			}
321
322			#############################################################################
323
324	pcg	1.1	package gtp;
325
326	pcg	1.3	use Gtk2::GoBoard::Constants;
327			use KGS::Constants;
328
329	pcg	1.2	use Fcntl;
330
331	pcg	1.1	sub new {
332			my $class = shift;
333			bless { @_ }, $class;
334			}
335
336			sub set_fh {
337	pcg	1.2	my ($self, $rfh, $wfh) = @_;
338
339			$self->{r} = $rfh;
340			$self->{w} = $wfh;
341
342			fcntl $rfh, F_SETFL, O_NONBLOCK;
343	pcg	1.1
344	pcg	1.2	my $buf;
345	pcg	1.1
346	pcg	1.2	Event->io (fd => $rfh, poll => 'r', cb => sub {
347			my $r = sysread $rfh, $buf, 16384, length $buf;
348
349			if (defined $r and !$r) {
350			die "gtp engine sent EOF, I'm simply dying now, sorry\n";
351			} else {
352			$buf =~ y/\010\015/ /d;
353			$buf =~ s/#[^\012](?=\012)//g; # idiotic part of gtp spec
354			while () {
355			if ($buf =~ s/^([=?])(?:(\d+)\s+)?(.*?)\012\012//s) { # response
356			print STDERR "got response ($1\|$2\|$3)\n" if $verbose >= 2;
357
358			if (my $cb = delete $self->{waitq}{$2}) {
359			$cb->($1, $3);
360			} else {
361			warn "WARNING: got response if '$1 $2' without outstanding request\n";
362			}
363			} elsif ($buf =~ s/^(?:(\d+)\s+)?([^=?].*?)\012//s) { # command
364			$self->parse_command ($1, $2);
365			} elsif ($buf =~ s/^\s*\012//) {
366			# ignore, idiotic part of gtp spec
367			} else {
368			last;
369			}
370			}
371			}
372			});
373
374			# generate login commands
375			$self->send ("protocol_version", sub { $self->{pversion} = $_[1] });
376			$self->send ("name", sub { $self->{name} = $_[1] });#d#
377			$self->send ("version", sub { $self->{version} = $_[1] });
378	pcg	1.1	}
379
380			sub run_engine {
381	pcg	1.2	my ($self, @argv) = @_;
382
383			require IPC::Open2;
384
385			my ($r, $w);
386
387			IPC::Open2::open2 ($r, $w, @argv)
388			or die "unable to start @argv: $!";
389
390			$self->set_fh ($r, $w);
391			}
392
393			sub send {
394			my ($self, $cmd, $cb) = @_;
395
396			# first check for known_command
397
398			my $id = ++$self->{id};
399
400			$cmd =~ y/\015//d;
401			$cmd =~ s/\012/\\n/g;
402
403			$self->{waitq}{$id} = $cb \|\| sub { };
404			print { $self->{w} } "$id $cmd\012";
405			}
406
407			sub reply {
408			my ($self, $id, $response) = @_;
409
410			print { $self->{w} } "=$id $response\012";
411			}
412
413			sub reply_err {
414			my ($self, $id, $response) = @_;
415
416			print { $self->{w} } "?$id $response\012";
417			}
418
419			sub parse_command {
420			my ($self, $id, $cmd) = @_;
421
422			print STDERR "got command $cmd\n" if $verbose >= 2;
423
424			$cmd =~ s/\s+$//;
425
426			if ($cmd eq "kgs-room-list") {
427			# no args, just request all rooms
428			$kgs->send (list_rooms => group => $_) for 0..5;
429			$self->reply ($id, "");
430
431			} elsif ($cmd =~ /^kgs-room-join\s+(\d+)$/) {
432			$kgs->{room}{$1} = new room conn => $kgs->{conn}, channel => $1;
433			$self->reply ($id, "");
434			} elsif ($cmd =~ /^kgs-room-chat\s+(\d+)\s(.*)$/) {
435			$kgs->{room}{$1}->say ($2);
436			$self->reply ($id, "");
437			} elsif ($cmd =~ /^kgs-room-part\s+(\d+)$/) {
438			(delete $kgs->{room}{$1})->part ($2);
439			$self->reply ($id, "");
440
441			} elsif ($cmd =~ /^kgs-game-join\s+(\d+)$/) {
442			$kgs->{game}{$1} = new game conn => $kgs->{conn}, channel => $1;
443			$self->reply ($id, "");
444			} elsif ($cmd =~ /^kgs-game-chat\s+(\d+)\s(.*)$/) {
445			$kgs->{game}{$1}->say ($2);
446			$self->reply ($id, "");
447			} elsif ($cmd =~ /^kgs-game-part\s+(\d+)$/) {
448			(delete $kgs->{game}{$1})->part ($2);
449			$self->reply ($id, "");
450
451			} elsif ($cmd =~ /^kgs-user-chat\s+(\S+)\s+(.*)$/) {
452			$kgs->send (msg_chat =>
453			name => $kgs->{user},
454			name2 => $1,
455			message => $2);
456			$self->reply ($id, "");
457
458	pcg	1.3	} elsif ($cmd =~ /^kgs-game-new-demo\s+(\d+)\s+(\d+)$/) {
459	pcg	1.6	my $tid = $conn->alloc_clientid;
460	pcg	1.3	$kgs->send (new_game =>
461			channel => $1,
462	pcg	1.5	cid => $tid,
463	pcg	1.6	type => 0,
464	pcg	1.3	rules => {
465			ruleset => 0,
466			size => $2,
467			komi => 0,
468			timesys => 0,
469			time => 0,
470			interval => 0,
471			count => 0,
472			});
473			$self->reply ($id, $tid);
474			} elsif ($cmd =~ /^kgs-game-edit\s+(\d+)\s+(.*)$/) {
475			my $gid = $1 \|\| $::lastnew;#d#
476			my $spec = $2;
477			my @tree = ();
478			while ($spec =~ s/^([a-z])(\d+)\s+\+?(\S+)\s*//) { # should use mg
479			my ($x, $y, $spec) = ($1, $2, $3);
480			my $add = $spec !~ s/^-//;
481			$x = index "abcdefghjklmnopqrstuvwxyz", lc $x;
482			$y--;
483
484			if ($spec eq "b") { push @tree, [set_stone => 0, $x, $y];
485			} elsif ($spec eq "w") { push @tree, [set_stone => 1, $x, $y];
486			} elsif ($spec eq "n") { push @tree, [set_stone => 2, $x, $y];
487			} elsif ($spec eq "sb") { push @tree, [mark => $add, MARK_SMALL_B, $x, $y];
488			} elsif ($spec eq "sw") { push @tree, [mark => $add, MARK_SMALL_W, $x, $y];
489			} elsif ($spec eq "sn") { push @tree, [mark => 0, MARK_SMALL_B, $x, $y];
490			} elsif ($spec eq "triangle") { push @tree, [mark => $add, MARK_TRIANGLE, $x, $y];
491			} elsif ($spec eq "square") { push @tree, [mark => $add, MARK_SQUARE, $x, $y];
492			} elsif ($spec eq "circle") { push @tree, [mark => $add, MARK_CIRCLE, $x, $y];
493			} elsif ($spec =~ /label=(\S+)/) { push @tree, [mark => length $1, MARK_LABEL, $x, $y, $1];
494			} elsif ($spec eq "grayed") { push @tree, [mark => $add, MARK_GRAYED, $x, $y];
495			} else {
496			$self->reply_err ($id, "illegal edit spec '$spec'");
497			return;
498			}
499			}
500			$kgs->send (upd_tree =>
501			channel => $gid,
502			tree => \@tree);
503			$self->reply ($id, "");
504
505	pcg	1.2	} else {
506			$self->reply_err ($id, "illegal command");
507			}
508			}
509
510			sub set_gid {
511			my ($self, $gid) = @_;
512
513			if ($gid != $self->{gid}) {
514			$self->send ("kgs-game-id $gid");
515			$self->{gid} = $gid;
516			}
517	pcg	1.1	}
518
519			package main;
520
521	pcg	1.2	sub usage {
522			print STDERR <<EOF;
523			Usage: $0 [options] -- engine engine-args...
524			-u username usernmae to connect
525			-p password optional password to connect (none => guest)
526			-v increase verbosity
527			-q decrease verbosity
528
529			$0 connects to the kiseido go server, starts the named engine
530			and communicates with it using GTP protocol using it's stdin and stdout.
531
532			If no engine is given, uses stdin/stdout itself for communications.
533
534			The engine can optionally act as controller, too, as long as it isn't
535			confused by responses on it's command input stream.
536
537			Command extension used by the controller:
538
539			kgs-login message
540			kgs-room-update <rid> <name> # update room info
541			kgs-room-chat <rid> <user> <message> # somebody says sth.
542	pcg	1.7	kgs-game-update <rid> <gid> <type> <black> <white> \
543			<owner> <size> <handicap> <komi> <moves> \
544	pcg	1.2	<flags> <observers> <saved> <notes>
545			kgs-game-delete <rid> <gid> # game removed
546			kgs-user-update <rid> <user> # user added/updated
547			kgs-user-delete <rid> <user> # user removed
548
549			kgs-game-resign <gid> <color>
550			kgs-game-score <gid> <w-territory> <w-captures> <w-komi> <b-territory> <b-captures> <b-komi>
551			kgs-game-id <gid> # set id for following gid-less commands
552
553			kgs-user-chat <user> <message> # got private message from user
554	pcg	1.3	kgs-game-new <tid> <gid> # a new game was created with temporary id <tid>
555	pcg	1.2	...
556
557	pcg	1.3	Commands usable by the client as commands issued to the controller:
558	pcg	1.2
559			kgs-room-list # ask for roomlist update
560			kgs-room-join <rid> # join given room
561			kgs-room-chat <rid> <message> # say sth. in room
562			kgs-room-part <rid> # leave gives room
563
564			kgs-game-join <gid> # join the given game
565			kgs-game-part <gid> # leave the given game
566			kgs-game-chat <gid> <message> # say sth.
567
568			kgs-user-chat <user> <message> # send private msg to user
569	pcg	1.3	kgs-game-new-demo <rid> <size> # create new demo game (other agruments might get added)
570			# returns a temporary game id
571			kgs-game-edit <gid> <coord> <editspec> <coord> <editspec>...
572			# editspec is one of
573			# b\|w\|n set black/white/no stone
574			# sb\|sw\|sn set/clear black/white/no small stone
575			# [+-]triangle set/clear triangle
576			# [+-]square set/clear square
577			# [+-]circle set/clear circle
578			# [+-]grayed set/clear grayed-flag
579			# label=xyz set label to xyz
580	pcg	1.2	...
581
582			EOF
583			exit shift;
584			}
585
586			GetOptions (
587			"u=s" => \$user,
588			"v" => sub { $verbose++ },
589			"q" => sub { $verbose-- },
590			"h" => sub { usage(0) },
591			) or die usage(1);
592
593			$gtp = new gtp;
594
595			if (@ARGV) {
596			$gtp->run_engine (@ARGV);
597			} else {
598			$gtp->set_fh (\STDIN, \STDOUT);
599			}
600
601			$kgs = new kgs user => $user, password => $pass;
602	pcg	1.1
603			Event::loop;
604
605			1;
606
607