[ViewVC] Annotation of: cvs/cvsroot/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}");
}

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