lasker-2.2.3/testplay/play2.pl

   1 #!/usr/bin/perl
   2 #
   3 # Quick and nasty script to load a game record and play it
   4 # through via a FICS server.
   5 #
   6 # Anthony Wesley and Andrew Tridgell, July 2004
   7 #
   8 # Usage: play2.pl server client1/passwd1 client2/passwd2
   9 #
  10 # Reads game records on stdin.
  11 #
  12
  13 use IO::Socket;
  14
  15 my $server = shift @ARGV;
  16 my ($client1,$pass1) = split(/\//, shift @ARGV);
  17 my ($client2,$pass2) = split(/\//, shift @ARGV);
  18
  19 print "Connecting to $server , port 5000\n";
  20 print "[$client1 / $pass1 ] , [$client2 / $pass2 ]\n";
  21
  22 my $S1 = new IO::Socket::INET(
  23                               PeerAddr => $server,
  24                               PeerPort => 5000,
  25                               Proto => 'tcp',
  26                               ReuseAddr => 1
  27                               ) or die "Could not connect";
  28
  29 my $S2 = new IO::Socket::INET(
  30                               PeerAddr => $server,
  31                               PeerPort => 5000,
  32                               Proto => 'tcp',
  33                               ReuseAddr => 1
  34                               ) or die "Could not connect";
  35
  36 $S1->setsockopt(&Socket::IPPROTO_TCP, &Socket::TCP_NODELAY, 1) || die;
  37 $S2->setsockopt(&Socket::IPPROTO_TCP, &Socket::TCP_NODELAY, 1) || die;
  38
  39 print "Connection opened. Logging in...\n";
  40
  41 Login($S1,$client1,$pass1) or die "Could not login $client1";
  42 Login($S2,$client2,$pass2) or die "Could not login $client2";
  43
  44 sleep(3);
  45
  46 print "Logged in\n";
  47
  48 # ensure we don't have any left over games
  49 $S1->print("resign $client2\n");
  50
  51 print "Reading game record from stdin...\n";
  52 my $game = "";
  53 my $game_comment = "";
  54 my $game_num = 0;
  55
  56 while(my $line = <STDIN>) {
  57         chomp $line;
  58         if ($line =~ /^\[/ || $line eq "") {
  59                 if ($game eq "") {
  60                         $game_comment .= "$line\n";
  61                         next;
  62                 }
  63                 $game = extract_moves($game);
  64                 $game_num++;
  65                 print "Starting game $game_num\n";
  66                 PlayGame($S1,$S2,$game);
  67                 $game = "";
  68                 $game_comment = "";
  69                 next;
  70         }
  71         $game .= $line . " ";
  72 }
  73
  74 sub PlayGame($$$)
  75 {
  76         my $s1 = shift;
  77         my $s2 = shift;
  78         my $game = shift;
  79
  80         Challenge($s1,$client1,$s2,$client2) or die "Could not setup game";
  81
  82         my $res = Play($s1, $s2, $game);
  83         if ($res ne "OK") {
  84                 $s1->print("resign\n");
  85
  86                 print "Writing bad game - $res\n";
  87
  88                 local(*FILE);
  89                 open(FILE, ">>badgames.txt") || die "can't open badgames.txt";
  90                 print FILE "[$res]\n$game\n\n";
  91                 close(FILE);
  92         }
  93
  94         WaitFor($s1, "$client1 vs. $client2");
  95         WaitFor($s2, "$client1 vs. $client2");
  96
  97         WaitFor($s1, "No ratings adjustment done");
  98         WaitFor($s2, "No ratings adjustment done");
  99 }
 100
 101
 102 sub Login($$$)
 103 {
 104         my $s = shift;
 105         my $name = shift;
 106         my $pass = shift;
 107
 108         $s->print($name . "\n");
 109         $s->print($pass . "\n");
 110         $s->print("set style 12\n\n");
 111
 112         return 1;
 113 }
 114
 115 sub extract_moves($)
 116 {
 117         my $txt = shift;
 118         my $moves = "";
 119
 120         my @lines = split(/[\n\r]+/, $txt);
 121         foreach my $l (@lines) {
 122                 # Strip
 123                 $l =~ s/^\s+//; $l =~ s/\s+$//;
 124
 125                 # Maybe metadata?
 126                 next if $l =~ /^\s+\[/;
 127
 128                 # Maybe contains moves?
 129                 $moves .= $l . " ";
 130         }
 131
 132         # Strip out the move numbers
 133 #       $moves =~ s/\d+\.\s+//g;
 134
 135         return $moves;
 136 }
 137
 138 sub Challenge($$$$)
 139 {
 140         my $s1 = shift;         # socket for client1
 141         my $client1 = shift;    # username for initiator
 142         my $s2 = shift;         # socket for receipient
 143         my $client2 = shift;    # name of receipient
 144
 145         $s1->print("match $client2 1 1 w u\n");
 146
 147         WaitFor($s1, "Issuing: $client1");
 148         WaitFor($s2, "Challenge: $client1");
 149         WaitFor($s2, "You can \"accept\"");
 150         $s2->print("accept\n");
 151         WaitFor($s2,"You accept the challenge of $client1");
 152         WaitFor($s1,"$client2 accepts your challenge");
 153         WaitFor($s1,"Creating: $client1");
 154         WaitFor($s1,".$client1 vs. $client2. Creating");
 155         WaitFor($s2,"Creating: $client1");
 156         WaitFor($s2,".$client1 vs. $client2. Creating");
 157
 158         return 1;
 159 }
 160
 161 sub Play($$$)
 162 {
 163         my $s1 = shift;
 164         my $s2 = shift;
 165         my $game = shift;
 166
 167         my $who_to_move = "w";
 168         my @moves = split(/\s+/, $game);
 169
 170         my $movenum = 1;
 171         my $res = "OK";
 172
 173         CheckMove($s1,"none") || return "Initialisation failed for white";
 174         CheckMove($s2,"none") || return "Initialisation failed for black";
 175
 176         foreach my $m (@moves) {
 177                 next if ($m =~ /^\d/);
 178                 last if ($m =~ /^\[/);
 179                 my $p1, $p2;
 180
 181                 if ($who_to_move eq "w") {
 182                         $p1 = $s1;
 183                         $p2 = $s2;
 184 #                       print "White moves $movenum. $m\n";
 185                 } else {
 186                         $p1 = $s2;
 187                         $p2 = $s1;
 188 #                       print "Black moves $movenum ... $m\n";
 189                 }
 190
 191                 SendMove($p1,$m);
 192
 193                 $res = CheckMove($p1,$m);
 194                 if ($res ne "OK") {
 195                         return "Failed on move $movenum - $res";
 196                 }
 197
 198                 $res = CheckMove($p2,$m);
 199                 if ($res ne "OK") {
 200                         return "Failed on move $movenum - $res";
 201                 }
 202
 203                 # Change sides
 204                 if ($who_to_move eq "b") {
 205                         $movenum++;
 206                         $who_to_move = "w";
 207                 } else {
 208                         $who_to_move = "b";
 209                 }
 210         }
 211
 212         # Resign
 213         if ($who_to_move eq "w") {
 214                 Resign($s1);
 215         } else {
 216                 Resign($s2);
 217         }
 218
 219         return "OK";
 220 }
 221
 222 sub SendMove($$)
 223 {
 224         my $s = shift;
 225         my $m = shift;
 226
 227         $s->print($m . "\n");
 228
 229         return 0;
 230 }
 231
 232 sub CheckMove($$)
 233 {
 234         my $s = shift;
 235         my $m = shift;
 236
 237         # Readback to check
 238         while ($l = $s->getline) {
 239                 chomp $l;
 240 #               print "line3=\n[[[$l\n]]]\n";
 241                 if ($l =~ /^\s+fics%\s+$/) {
 242                         next;
 243                 }
 244                 if ($l =~ /^\s+$/) {
 245                         next;
 246                 }
 247                 if ($l =~ /Illegal Move/i) {
 248                         return "Server reports illegal move $m";
 249                 }
 250                 if ($l =~ /Ambiguous Move/i) {
 251                         return "Server reports ambiguous move $m";
 252                 }
 253                 my $rmove = ParseStyle12($l);
 254                 if ($rmove eq "") {
 255                         print "$l\n";
 256                         next;
 257                 }
 258                 if (!MoveEqual($rmove,$m)) {
 259                         return "wrong RecvMove $rmove should be $m";
 260                 }
 261                 return "OK";
 262         }
 263
 264         return "eof from server";
 265 }
 266
 267 sub ParseStyle12($)
 268 {
 269         my $s = shift;
 270         my $m = "";
 271         if ($s =~ /\<12\>.*\(\d+\:\d\d\)\s(\S+)/m) {
 272                 $m = $1;
 273 #               print "Move=$m\n";
 274         }
 275         return $m;
 276 }
 277
 278 sub Resign($)
 279 {
 280         my $s = shift;
 281
 282         $s->print("resign\n");
 283 }
 284
 285 sub MoveEqual($$)
 286 {
 287         my $m1 = shift;
 288         my $m2 = shift;
 289
 290         # remove check and good move markers
 291         if ($m1 =~ /^(.*)[+!]/) {
 292                 $m1 = $1;
 293         }
 294
 295         if ($m2 =~ /^(.*)[+!]/) {
 296                 $m2 = $1;
 297         }
 298
 299         if ($m1 eq $m2) {
 300                 return 1;
 301         }
 302
 303         return 0;
 304 }
 305
 306 sub WaitFor($$)
 307 {
 308         my $s = shift;
 309         my $str = shift;
 310
 311
 312         while (my $l = $s->getline) {
 313                 chomp $l;
 314                 if ($l =~ /$str/) {
 315 #                       print "GOT: $str\n";
 316                         return;
 317                 }
 318                 if ($l =~ /^\s+fics%\s+$/) {
 319                         next;
 320                 }
 321                 if ($l =~ /^\s+$/) {
 322                         next;
 323                 }
 324                 print "$l\n";
 325         }
 326 }