ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/kgsueme/bin/gtp-controller
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 ***

File Contents

# Content
1 #!/opt/bin/perl
2
3 # lots of things have been hardcoded. search for #d# to find the places
4
5 require 5.008;
6
7 use KGS::Protocol;
8 use KGS::Listener::Debug;
9
10 use IO::Socket::INET;
11 use Event;
12
13 use Getopt::Long;
14 use Carp;
15
16 our $VERSION = '0.0'; # be more confident....
17
18 $SIG{QUIT} = sub { Carp::confess "SIGQUIT" };
19
20 my $conn = new KGS::Protocol;
21 my $kgs;
22 my $gtp;
23
24 my $verbose = 1;
25 my $user = "gtpguest";
26 my $pass = undef;
27
28 $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
40 $format =~ y/ //d;
41 $format;
42 }
43
44 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 }
47
48 #############################################################################
49
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 my $sock = new IO::Socket::INET PeerHost => KGS::Protocol::KGSHOST, PeerPort => KGS::Protocol::KGSPORT
61 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 $conn->feed_data ($buf);
73 } elsif (defined $len || (!$!{EINTR} and !$!{EAGAIN})) {
74 print STDERR "disconnected\n" if $verbose;
75 Event::unloop;
76 }
77 });
78
79 $conn->login ("gtp-controller $VERSION", $self->{user}, delete $self->{password});
80
81 $self;
82 }
83
84 sub inject_login {
85 my ($self, $msg) = @_;
86
87 print STDERR "login: $msg->{message}\n" if $verbose >= 2;
88
89 $gtp->send ("kgs-login $msg->{message}");
90
91 # use KGS::Listener::User;
92 # $user = new KGS::Listener::User name => "tetra";
93 # $user->listen ($self->{conn});
94 # $user->game_record;
95 }
96
97 sub inject_msg_room {
98 my ($self, $msg) = @_;
99
100 $gtp->send ("kgs-room-chat $msg->{channel} $msg->{message}");
101 }
102
103 sub inject_any {
104 my ($self, $msg) = @_;
105 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 sub inject_new_game {
131 my ($self, $msg) = @_;
132
133 $::lastnew = $msg->{channel};#d#
134 $gtp->send ("kgs-game-new $msg->{cid} $msg->{channel}");
135 }
136
137 sub inject_idle_warn {
138 my ($self, $msg) = @_;
139
140 $self->send ("idle_reset");
141 }
142
143 #############################################################################
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 ::format_user $_->{black},
177 ::format_user $_->{white},
178 ::format_user $_->{owner},
179 $_->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 }
321
322 sub DESTROY {
323 my $self = shift;
324
325 $self->SUPER::DESTROY;
326 }
327
328 #############################################################################
329
330 package gtp;
331
332 use Gtk2::GoBoard::Constants;
333 use KGS::Constants;
334
335 use Fcntl;
336
337 sub new {
338 my $class = shift;
339 bless { @_ }, $class;
340 }
341
342 sub set_fh {
343 my ($self, $rfh, $wfh) = @_;
344
345 $self->{r} = $rfh;
346 $self->{w} = $wfh;
347
348 fcntl $rfh, F_SETFL, O_NONBLOCK;
349
350 my $buf;
351
352 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 }
385
386 sub run_engine {
387 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 } elsif ($cmd =~ /^kgs-game-new-demo\s+(\d+)\s+(\d+)$/) {
465 my $tid = $conn->alloc_clientid;
466 $kgs->send (new_game =>
467 channel => $1,
468 cid => $tid,
469 type => 0,
470 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 } 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 }
524
525 package main;
526
527 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 kgs-game-update <rid> <gid> <type> <black> <white> \
549 <owner> <size> <handicap> <komi> <moves> \
550 <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 kgs-game-new <tid> <gid> # a new game was created with temporary id <tid>
561 ...
562
563 Commands usable by the client as commands issued to the controller:
564
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 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 ...
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
609 Event::loop;
610
611 1;
612
613