| 1 | #!/usr/bin/perl -w |
| 2 | |
| 3 | # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # |
| 4 | # This program is distributed with GNU Go, a Go program. # |
| 5 | # # |
| 6 | # Write gnugo@gnu.org or see http://www.gnu.org/software/gnugo/ # |
| 7 | # for more information. # |
| 8 | # # |
| 9 | # Copyright 1999, 2000, 2001 by the Free Software Foundation. # |
| 10 | # # |
| 11 | # This program is free software; you can redistribute it and/or # |
| 12 | # modify it under the terms of the GNU General Public License # |
| 13 | # as published by the Free Software Foundation - version 3, # |
| 14 | # or (at your option) any later version. # |
| 15 | # # |
| 16 | # This program is distributed in the hope that it will be # |
| 17 | # useful, but WITHOUT ANY WARRANTY; without even the implied # |
| 18 | # warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR # |
| 19 | # PURPOSE. See the GNU General Public License in file COPYING # |
| 20 | # for more details. # |
| 21 | # # |
| 22 | # You should have received a copy of the GNU General Public # |
| 23 | # License along with this program; if not, write to the Free # |
| 24 | # Software Foundation, Inc., 51 Franklin Street, Fifth Floor, # |
| 25 | # Boston, MA 02111, USA. # |
| 26 | # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # |
| 27 | |
| 28 | use Tk; |
| 29 | use ttgo; |
| 30 | use FileHandle; |
| 31 | use IPC::Open2; |
| 32 | |
| 33 | # use strict; |
| 34 | |
| 35 | $| = 1; |
| 36 | |
| 37 | my $boardsize = 11; |
| 38 | |
| 39 | my $autoplay = 1; |
| 40 | |
| 41 | my @program = (); |
| 42 | my @cur_id = (); |
| 43 | |
| 44 | |
| 45 | my $Aprg_in = new FileHandle; |
| 46 | my $Aprg_out = new FileHandle; |
| 47 | $program[0] = 'gnugo --mode gtp --quiet'; |
| 48 | $cur_id[0] = 1; # starting id |
| 49 | |
| 50 | |
| 51 | my $Bprg_in = new FileHandle; |
| 52 | my $Bprg_out = new FileHandle; |
| 53 | $program[1] = 'gnugo --mode gtp --score aftermath --capture-all-dead --chinese-rules --quiet'; |
| 54 | $cur_id[1] = 1; # starting id |
| 55 | |
| 56 | |
| 57 | my $state = 'start'; # first initialization state |
| 58 | |
| 59 | open2($Aprg_out, $Aprg_in, $program[0]); |
| 60 | $flags = |
| 61 | fcntl( $Aprg_out, F_GETFL, 0) |
| 62 | or die "Error with fcntl\n"; |
| 63 | $flags = |
| 64 | fcntl( $Aprg_out, F_SETFL, $flags | O_NOBLOCK) |
| 65 | or die "Error with fcntl\n"; |
| 66 | |
| 67 | |
| 68 | open2($Bprg_out, $Bprg_in, $program[1]); |
| 69 | $flags = |
| 70 | fcntl( $Bprg_out, F_GETFL, 0) |
| 71 | or die "Error with fcntl\n"; |
| 72 | $flags = |
| 73 | fcntl( $Bprg_out, F_SETFL, $flags | O_NOBLOCK) |
| 74 | or die "Error with fcntl\n"; |
| 75 | |
| 76 | |
| 77 | |
| 78 | my $flags = 0; |
| 79 | my $consecutive_passes = 0; |
| 80 | my $ctm = 'B'; # who's turn to move? |
| 81 | my $cc = 'W'; # computers color |
| 82 | |
| 83 | |
| 84 | my $msgstr = ''; |
| 85 | |
| 86 | |
| 87 | # This handles up to 25 size boards |
| 88 | # ================================= |
| 89 | my @letter = 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 ); |
| 90 | |
| 91 | |
| 92 | # color definitions |
| 93 | # ================= |
| 94 | my %cstr = ( 'b' => '#604040', 'B' => '#604040', |
| 95 | 'w' => '#ffffff', 'W' => '#ffffff' |
| 96 | ); |
| 97 | |
| 98 | my $bkc = '#eeeeee'; |
| 99 | |
| 100 | |
| 101 | |
| 102 | |
| 103 | # get command line arguments start with defaults |
| 104 | # ============================================== |
| 105 | my $sqwh = 26; |
| 106 | my $sqwh2 = 12; # 1/2 of sqwh |
| 107 | |
| 108 | |
| 109 | |
| 110 | |
| 111 | my %toix = (); |
| 112 | foreach my $ix (0 .. $#letter) { |
| 113 | $toix{ $letter[$ix] } = $ix; |
| 114 | } |
| 115 | |
| 116 | |
| 117 | |
| 118 | |
| 119 | # initialize graphics and such |
| 120 | # ---------------------------- |
| 121 | my $top = MainWindow->new; |
| 122 | $top->title("ptkgo.pl"); |
| 123 | $top->resizable(0,0); |
| 124 | my $geox = ($boardsize-1) * $sqwh + 80; |
| 125 | my $geoy = ($boardsize-1) * $sqwh + 140; |
| 126 | |
| 127 | $top->geometry( $geox . 'x' . $geoy ); |
| 128 | $top->configure( background => $bkc ); |
| 129 | |
| 130 | |
| 131 | |
| 132 | # build the background go board |
| 133 | |
| 134 | my $backing = $top->Canvas( |
| 135 | -width => $sqwh * $boardsize + 80, |
| 136 | -height => $sqwh * $boardsize + 80, |
| 137 | -background => $bkc |
| 138 | )->place( |
| 139 | -x => 0, |
| 140 | -y => 0, |
| 141 | ); |
| 142 | |
| 143 | |
| 144 | foreach my $x ( 0 .. $boardsize-1 ) { |
| 145 | |
| 146 | $backing->createText( 40 + $x * $sqwh, |
| 147 | 25, |
| 148 | -text => $letter[$x], |
| 149 | -fill => 'black', |
| 150 | -justify => 'center', |
| 151 | -font => '-b&h-*-bold-r-*-*-11-*-*-*-*-*-*-*' |
| 152 | ); |
| 153 | |
| 154 | $backing->createText( 40 + $x * $sqwh, |
| 155 | ($boardsize-1)*$sqwh + 55, |
| 156 | -text => $letter[$x], |
| 157 | -fill => 'black', |
| 158 | -justify => 'center', |
| 159 | -font => '-b&h-*-bold-r-*-*-11-*-*-*-*-*-*-*' |
| 160 | ); |
| 161 | |
| 162 | |
| 163 | $backing->createLine( $x*$sqwh + 40, |
| 164 | 40, |
| 165 | $x*$sqwh+40, |
| 166 | ($boardsize-1)*$sqwh + 40, |
| 167 | -fill => 'black', |
| 168 | -width => 1 ); |
| 169 | } |
| 170 | |
| 171 | |
| 172 | |
| 173 | |
| 174 | foreach my $y ( 0 .. $boardsize-1 ) { |
| 175 | |
| 176 | $backing->createText( 25, |
| 177 | $y * $sqwh + 40, |
| 178 | -text => $boardsize - $y, |
| 179 | -fill => 'black', |
| 180 | -justify => 'center', |
| 181 | -font => '-b&h-*-bold-r-*-*-11-*-*-*-*-*-*-*' |
| 182 | ); |
| 183 | |
| 184 | $backing->createText( ($boardsize-1) * $sqwh + 55, |
| 185 | $y * $sqwh + 40, |
| 186 | -text => $boardsize - $y, |
| 187 | -fill => 'black', |
| 188 | -justify => 'center', |
| 189 | -font => '-b&h-*-bold-r-*-*-11-*-*-*-*-*-*-*' |
| 190 | ); |
| 191 | |
| 192 | |
| 193 | $backing->createLine( 40, |
| 194 | $y*$sqwh+40, |
| 195 | ($boardsize-1)*$sqwh+40, |
| 196 | $y*$sqwh + 40, |
| 197 | -fill => 'black', |
| 198 | -width => 1 ); |
| 199 | } |
| 200 | |
| 201 | |
| 202 | ttNewGame($boardsize); |
| 203 | ttShowBoard(); |
| 204 | |
| 205 | |
| 206 | |
| 207 | |
| 208 | # pass button |
| 209 | # ----------- |
| 210 | my $pass = $top->Button( |
| 211 | -text => 'Pass', |
| 212 | -command => sub { }, |
| 213 | -width => 2, |
| 214 | -height => 1, |
| 215 | -font => '5x7', |
| 216 | -borderwidth => 1, |
| 217 | -highlightcolor => 'black', |
| 218 | -highlightthickness => 1, |
| 219 | -highlightbackground => 'black', |
| 220 | -relief => 'flat' |
| 221 | )->place( |
| 222 | -x => 40 + 0 * 40, |
| 223 | -y => ($boardsize + 2) * $sqwh, |
| 224 | ); |
| 225 | |
| 226 | |
| 227 | |
| 228 | # undo button |
| 229 | # ----------- |
| 230 | my $undo = $top->Button( |
| 231 | -text => 'Undo', |
| 232 | -command => sub { }, |
| 233 | -width => 2, |
| 234 | -height => 1, |
| 235 | -font => '5x7', |
| 236 | -borderwidth => 1, |
| 237 | -highlightcolor => 'black', |
| 238 | -highlightthickness => 1, |
| 239 | -highlightbackground => 'black', |
| 240 | -relief => 'flat' |
| 241 | )->place( |
| 242 | -x => 40 + 1 * 40, |
| 243 | -y => ($boardsize + 2) * $sqwh, |
| 244 | ); |
| 245 | |
| 246 | |
| 247 | |
| 248 | |
| 249 | $top->bind( "<Button-1>", [ \&drop_stone, Ev('x'), Ev('y') ] ); |
| 250 | |
| 251 | |
| 252 | $top->fileevent( $Aprg_out, 'readable', [ \&getmessage, 0] ); |
| 253 | $top->fileevent( $Bprg_out, 'readable', [ \&getmessage, 1] ); |
| 254 | |
| 255 | |
| 256 | $state = 'start'; # first initialization state |
| 257 | control(); |
| 258 | |
| 259 | |
| 260 | MainLoop(); |
| 261 | |
| 262 | |
| 263 | |
| 264 | |
| 265 | my $tmpstr; |
| 266 | |
| 267 | sub getmessage |
| 268 | { |
| 269 | my ($pi) = @_; |
| 270 | |
| 271 | |
| 272 | if ($pi == 0) { |
| 273 | $tmpstr = <$Aprg_out>; |
| 274 | } else { |
| 275 | $tmpstr = <$Bprg_out>; |
| 276 | } |
| 277 | |
| 278 | if (defined $tmpstr) { |
| 279 | chomp($tmpstr); |
| 280 | |
| 281 | if ($tmpstr eq '') { # eat the line, update id |
| 282 | $cur_id[$pi] ++; |
| 283 | control( $msgstr ); |
| 284 | } else { |
| 285 | $msgstr = $tmpstr; |
| 286 | print "Came up with $msgstr\n"; |
| 287 | } |
| 288 | |
| 289 | } |
| 290 | } |
| 291 | |
| 292 | |
| 293 | |
| 294 | |
| 295 | sub xputstone |
| 296 | { |
| 297 | my ($color, $x, $y) = @_; |
| 298 | |
| 299 | |
| 300 | my $xx = $x * $sqwh + 40; |
| 301 | my $yy = $y * $sqwh + 40; |
| 302 | |
| 303 | $backing->createOval( $xx-$sqwh2, $yy-$sqwh2, |
| 304 | $xx+$sqwh2, $yy+$sqwh2, |
| 305 | -tags => $x . '_' . $y, |
| 306 | -outline => 'black', |
| 307 | -fill => $cstr{$color} ); |
| 308 | } |
| 309 | |
| 310 | |
| 311 | # This routine clears all empty squares, it does |
| 312 | # not actually draw board |
| 313 | sub xfixboard |
| 314 | { |
| 315 | my @vis = ttGetBoard(); |
| 316 | my $st; |
| 317 | |
| 318 | foreach my $y (0 .. $boardsize -1) { |
| 319 | foreach my $x (0 .. $boardsize -1) { |
| 320 | |
| 321 | $st = shift @vis; |
| 322 | |
| 323 | if ($st eq '+') { |
| 324 | $backing->delete( $x . '_' . $y ); |
| 325 | } |
| 326 | } |
| 327 | } |
| 328 | } |
| 329 | |
| 330 | |
| 331 | sub pass |
| 332 | { |
| 333 | |
| 334 | |
| 335 | } |
| 336 | |
| 337 | |
| 338 | sub drop_stone |
| 339 | { |
| 340 | my ( $w, $x, $y) = @_; |
| 341 | |
| 342 | $x = -1 + int(($x-3) / 26); |
| 343 | $y = -1 + int(($y-3) / 26); |
| 344 | |
| 345 | if ($x < 0) { return 1; } |
| 346 | if ($y < 0) { return 1; } |
| 347 | if ($x >= $boardsize) { return 1; } |
| 348 | if ($y >= $boardsize) { return 1; } |
| 349 | |
| 350 | |
| 351 | my $gn = $letter[$x] . ($boardsize - $y); |
| 352 | |
| 353 | if ( !ttPlaceStone( $ctm, $gn ) ) { |
| 354 | xputstone( $ctm, $x, $y ); |
| 355 | xfixboard(); |
| 356 | ttShowBoard(); |
| 357 | } else { return 1; } |
| 358 | |
| 359 | |
| 360 | if ($ctm eq 'W') { |
| 361 | $state = 'white'; |
| 362 | } else { |
| 363 | $state = 'black'; |
| 364 | } |
| 365 | |
| 366 | swap_ctm(); |
| 367 | |
| 368 | } |
| 369 | |
| 370 | |
| 371 | |
| 372 | |
| 373 | # This routine is called after each message is recieved |
| 374 | # ----------------------------------------------------- |
| 375 | |
| 376 | # How the control loop works: |
| 377 | # |
| 378 | # the '$state' variable determines where to jump in. |
| 379 | # control is called when a program responds to a message |
| 380 | |
| 381 | sub control |
| 382 | { |
| 383 | my ($msg) = @_; |
| 384 | |
| 385 | |
| 386 | # send boardsize 0 (prgA) |
| 387 | # send boardsize 1 (prgB) |
| 388 | # xxx |
| 389 | # send genmove_black (prgA); |
| 390 | # send black (prgB); |
| 391 | # send genmove_white (prgB); |
| 392 | # white (prgA) |
| 393 | # goto xxx |
| 394 | |
| 395 | |
| 396 | if (defined $msg) { |
| 397 | print STDERR "state/msg = $state $msg\n"; |
| 398 | } else { print STDERR "state/msg = $state NULL\n"; } |
| 399 | |
| 400 | if ($state eq 'start') { |
| 401 | snd( 0, "$cur_id[0] boardsize $boardsize" ); |
| 402 | $state = 'startb'; |
| 403 | return; |
| 404 | } |
| 405 | |
| 406 | if ($state eq 'startb') { |
| 407 | snd( 1, "$cur_id[1] boardsize $boardsize" ); |
| 408 | $state = 'genmove_black'; |
| 409 | return; |
| 410 | } |
| 411 | |
| 412 | if ( $state eq 'genmove_black' ) { |
| 413 | snd( 0, "$cur_id[0] genmove_black" ); |
| 414 | $state = 'black'; |
| 415 | return; |
| 416 | } |
| 417 | |
| 418 | if ( $state eq 'black' ) { |
| 419 | my $y; |
| 420 | my $x; |
| 421 | my $gn; |
| 422 | |
| 423 | print "msg ---> $msg\n"; |
| 424 | |
| 425 | $msg =~ /^=\d+\s+(.)(.*)/; # parse out move components |
| 426 | |
| 427 | if ( $msg =~ /PASS/ ) { |
| 428 | $consecutive_passes++; |
| 429 | $gn = 'PASS'; |
| 430 | } else { |
| 431 | $consecutive_passes = 0; |
| 432 | $y = $boardsize - $2; |
| 433 | $x = $toix{$1}; |
| 434 | $gn = $letter[$x] . ($boardsize - $y); |
| 435 | } |
| 436 | |
| 437 | |
| 438 | # show blacks move to the interface |
| 439 | # --------------------------------- |
| 440 | if ( !ttPlaceStone( $ctm, $gn ) ) { |
| 441 | xputstone( $ctm, $x, $y ) if $gn ne 'PASS'; |
| 442 | xfixboard(); |
| 443 | ttShowBoard(); |
| 444 | swap_ctm(); |
| 445 | } else { return 1; } |
| 446 | |
| 447 | # send the move along to WHITE |
| 448 | # ---------------------------- |
| 449 | snd( 1, "$cur_id[1] black $gn" ); |
| 450 | $state = 'genmove_white'; |
| 451 | |
| 452 | if ($consecutive_passes == 2) { |
| 453 | $state = 'gameover'; |
| 454 | } |
| 455 | |
| 456 | return; |
| 457 | } |
| 458 | |
| 459 | |
| 460 | if ( $state eq 'genmove_white' ) { |
| 461 | snd( 1, "$cur_id[1] genmove_white" ); |
| 462 | $state = 'white'; |
| 463 | return; |
| 464 | } |
| 465 | |
| 466 | |
| 467 | if ( $state eq 'white' ) { |
| 468 | my $y; |
| 469 | my $x; |
| 470 | my $gn; |
| 471 | |
| 472 | print "msg ---> $msg\n"; |
| 473 | |
| 474 | $msg =~ /^=\d+\s+(.)(.*)/; # parse out move components |
| 475 | |
| 476 | if ( $msg =~ /PASS/ ) { |
| 477 | $consecutive_passes++; |
| 478 | $gn = 'PASS'; |
| 479 | } else { |
| 480 | $consecutive_passes = 0; |
| 481 | $y = $boardsize - $2; |
| 482 | $x = $toix{$1}; |
| 483 | $gn = $letter[$x] . ($boardsize - $y); |
| 484 | } |
| 485 | |
| 486 | |
| 487 | # show blacks move to the interface |
| 488 | # --------------------------------- |
| 489 | if ( !ttPlaceStone( $ctm, $gn ) ) { |
| 490 | xputstone( $ctm, $x, $y ) if $gn ne 'PASS'; |
| 491 | xfixboard(); |
| 492 | ttShowBoard(); |
| 493 | swap_ctm(); |
| 494 | } else { return 1; } |
| 495 | |
| 496 | # send the move along to BLACK |
| 497 | # ---------------------------- |
| 498 | snd( 0, "$cur_id[0] white $gn" ); |
| 499 | $state = 'genmove_black'; |
| 500 | |
| 501 | if ($consecutive_passes == 2) { |
| 502 | $state = 'gameover'; |
| 503 | } |
| 504 | |
| 505 | return; |
| 506 | } |
| 507 | |
| 508 | |
| 509 | if ( $state eq 'gameover' ) { |
| 510 | print "Game Over\n"; |
| 511 | ttScore(); |
| 512 | |
| 513 | } |
| 514 | |
| 515 | |
| 516 | |
| 517 | |
| 518 | |
| 519 | |
| 520 | } |
| 521 | |
| 522 | |
| 523 | |
| 524 | |
| 525 | |
| 526 | sub snd |
| 527 | { |
| 528 | my ($who, $str) = @_; |
| 529 | |
| 530 | if ($who == 0) { |
| 531 | print $Aprg_in "$str\n"; |
| 532 | } else { |
| 533 | print $Bprg_in "$str\n"; |
| 534 | } |
| 535 | |
| 536 | print STDERR "----> $str\n"; |
| 537 | |
| 538 | } |
| 539 | |
| 540 | |
| 541 | sub swap_ctm |
| 542 | { |
| 543 | if ( $ctm eq 'B' ) { |
| 544 | $ctm = 'W'; |
| 545 | } else { |
| 546 | $ctm = 'B'; |
| 547 | } |
| 548 | |
| 549 | } |