Initial commit of GNU Go v3.8.

[sgk-go] / interface / gtp_examples / 2ptkgo.pl

#!/usr/bin/perl -w

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# This program is distributed with GNU Go, a Go program.        #
#                                                               #
# Write gnugo@gnu.org or see http://www.gnu.org/software/gnugo/ #
# for more information.                                         #
#                                                               #
# Copyright 1999, 2000, 2001 by the Free Software Foundation.   #
#                                                               #
# This program is free software; you can redistribute it and/or #
# modify it under the terms of the GNU General Public License   #
# as published by the Free Software Foundation - version 3,     #
# or (at your option) any later version.                        #
#                                                               #
# This program is distributed in the hope that it will be       #
# useful, but WITHOUT ANY WARRANTY; without even the implied    #
# warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR       #
# PURPOSE.  See the GNU General Public License in file COPYING  #
# for more details.                                             #
#                                                               #
# You should have received a copy of the GNU General Public     #
# License along with this program; if not, write to the Free    #
# Software Foundation, Inc., 51 Franklin Street, Fifth Floor,   #
# Boston, MA 02111, USA.                                        #
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #

use Tk;
use ttgo;
use FileHandle;
use IPC::Open2;

# use strict;

$| = 1;

my $boardsize = 11;

my $autoplay = 1;

my @program = ();
my @cur_id = ();


my $Aprg_in = new FileHandle;
my $Aprg_out = new FileHandle;
$program[0] = 'gnugo --mode gtp --quiet';
$cur_id[0] = 1;   # starting id


my $Bprg_in = new FileHandle;
my $Bprg_out = new FileHandle;
$program[1] = 'gnugo --mode gtp --score aftermath --capture-all-dead --chinese-rules --quiet';
$cur_id[1] = 1;   # starting id


my $state = 'start';    # first initialization state

open2($Aprg_out, $Aprg_in, $program[0]);
$flags = 
    fcntl( $Aprg_out, F_GETFL, 0) 
    or die "Error with fcntl\n";
$flags = 
    fcntl( $Aprg_out, F_SETFL, $flags | O_NOBLOCK) 
    or die "Error with fcntl\n";


open2($Bprg_out, $Bprg_in, $program[1]);
$flags = 
    fcntl( $Bprg_out, F_GETFL, 0) 
    or die "Error with fcntl\n";
$flags = 
    fcntl( $Bprg_out, F_SETFL, $flags | O_NOBLOCK) 
    or die "Error with fcntl\n";



my $flags = 0;
my $consecutive_passes = 0;
my $ctm = 'B';   # who's turn to move?
my $cc = 'W';    # computers color


my $msgstr = '';


# This handles up to 25 size boards
# =================================
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 );


# color definitions
# =================
my %cstr = ( 'b' => '#604040', 'B' => '#604040', 
	     'w' => '#ffffff', 'W' => '#ffffff' 
	     );

my $bkc = '#eeeeee';




# get command line arguments start with defaults
# ==============================================
my $sqwh = 26;
my $sqwh2 = 12;   # 1/2 of sqwh




my %toix = ();
foreach my $ix (0 .. $#letter) {
    $toix{ $letter[$ix] } = $ix;
}




# initialize graphics and such
# ----------------------------
my $top = MainWindow->new; 
$top->title("ptkgo.pl");
$top->resizable(0,0);
my $geox = ($boardsize-1) * $sqwh + 80;
my $geoy = ($boardsize-1) * $sqwh + 140;

$top->geometry( $geox . 'x' . $geoy );
$top->configure( background => $bkc );



# build the background go board

my $backing = $top->Canvas(
			   -width => $sqwh * $boardsize + 80,
			   -height => $sqwh * $boardsize + 80,
			   -background => $bkc
			   )->place(
				    -x => 0,
				    -y => 0,
				    );


foreach my $x ( 0 .. $boardsize-1 ) {

    $backing->createText( 40 + $x * $sqwh, 
			  25,
			  -text => $letter[$x],
			  -fill => 'black',
			  -justify => 'center',
			  -font => '-b&h-*-bold-r-*-*-11-*-*-*-*-*-*-*'
			  );

    $backing->createText( 40 + $x * $sqwh, 
			  ($boardsize-1)*$sqwh + 55,
			  -text => $letter[$x],
			  -fill => 'black',
			  -justify => 'center',
			  -font => '-b&h-*-bold-r-*-*-11-*-*-*-*-*-*-*'
			  );


    $backing->createLine( $x*$sqwh + 40,
			  40,
			  $x*$sqwh+40,
			  ($boardsize-1)*$sqwh + 40,
			  -fill => 'black',
			  -width => 1 );
}




foreach my $y ( 0 .. $boardsize-1 ) {

    $backing->createText( 25,
			  $y * $sqwh + 40,
			  -text => $boardsize - $y,
			  -fill => 'black',
			  -justify => 'center',
			  -font => '-b&h-*-bold-r-*-*-11-*-*-*-*-*-*-*'
			  );

    $backing->createText( ($boardsize-1) * $sqwh + 55,
			  $y * $sqwh + 40,
			  -text => $boardsize - $y,
			  -fill => 'black',
			  -justify => 'center',
			  -font => '-b&h-*-bold-r-*-*-11-*-*-*-*-*-*-*'
			  );


    $backing->createLine( 40,
			  $y*$sqwh+40,
			  ($boardsize-1)*$sqwh+40,
			  $y*$sqwh + 40,
			  -fill => 'black',
			  -width => 1 );
}


ttNewGame($boardsize);
ttShowBoard();




# pass button
# -----------
my $pass = $top->Button(
			-text => 'Pass',
			-command => sub {   },
			-width => 2,
			-height => 1,
			-font => '5x7',
			-borderwidth => 1,
			-highlightcolor => 'black',
			-highlightthickness  => 1,
			-highlightbackground => 'black',
			-relief => 'flat'
			)->place(
				 -x => 40 + 0 * 40,
				 -y => ($boardsize + 2) * $sqwh,
				 );



# undo button
# -----------
my $undo = $top->Button(
			-text => 'Undo',
			-command => sub {   },
			-width => 2,
			-height => 1,
			-font => '5x7',
			-borderwidth => 1,
			-highlightcolor => 'black',
			-highlightthickness  => 1,
			-highlightbackground => 'black',
			-relief => 'flat'
			)->place(
				 -x => 40 + 1 * 40,
				 -y => ($boardsize + 2) * $sqwh,
				 );




$top->bind( "<Button-1>", [ \&drop_stone, Ev('x'), Ev('y') ] );


$top->fileevent( $Aprg_out, 'readable', [ \&getmessage, 0] );
$top->fileevent( $Bprg_out, 'readable', [ \&getmessage, 1] );


$state = 'start';    # first initialization state
control();


MainLoop();




my $tmpstr;

sub getmessage
{
    my ($pi) = @_;


    if ($pi == 0) {
	$tmpstr = <$Aprg_out>;
    } else {
	$tmpstr = <$Bprg_out>;	
    }
    
    if (defined $tmpstr) {
	chomp($tmpstr);

	if ($tmpstr eq '') {   # eat the line, update id
	    $cur_id[$pi] ++; 
	    control( $msgstr );
	}  else {
	    $msgstr = $tmpstr;
	    print "Came up with $msgstr\n";
	}

    }
}




sub xputstone
{
    my ($color, $x, $y) = @_;
    

    my $xx = $x * $sqwh + 40;
    my $yy = $y * $sqwh + 40;

    $backing->createOval( $xx-$sqwh2, $yy-$sqwh2, 
			  $xx+$sqwh2, $yy+$sqwh2,
			  -tags => $x . '_' . $y,
			  -outline => 'black',
			  -fill => $cstr{$color} );
}


# This routine clears all empty squares, it does 
# not actually draw board
sub xfixboard
{
    my @vis = ttGetBoard();
    my $st;

    foreach my $y (0 .. $boardsize -1) {
	foreach my $x (0 .. $boardsize -1) {

	    $st = shift @vis;

	    if ($st eq '+') {
		$backing->delete( $x . '_' . $y );
	    }
	}
    }
}


sub pass
{


}


sub drop_stone
{
    my ( $w, $x, $y) = @_;

    $x = -1 + int(($x-3) / 26);
    $y = -1 + int(($y-3) / 26);

    if ($x < 0) { return 1; }
    if ($y < 0) { return 1; }
    if ($x >= $boardsize) { return 1; }
    if ($y >= $boardsize) { return 1; }


    my $gn = $letter[$x] . ($boardsize - $y);

    if ( !ttPlaceStone( $ctm, $gn ) ) {
	xputstone( $ctm, $x, $y );
	xfixboard();
	ttShowBoard();
    } else {  return 1; }


    if ($ctm eq 'W') { 
	$state = 'white';
    } else {
	$state = 'black';
    } 

    swap_ctm();    

}




# This routine is called after each message is recieved
# -----------------------------------------------------

# How the control loop works:
#
# the '$state' variable determines where to jump in.
# control is called when a program responds to a message

sub  control
{
    my ($msg) = @_;


    # send boardsize 0    (prgA)
    # send boardsize 1    (prgB)
    # xxx
    # send genmove_black  (prgA);
    # send black          (prgB);
    # send genmove_white  (prgB);
    # white               (prgA)
    # goto                xxx
    

    if (defined $msg) {
	print STDERR "state/msg = $state $msg\n";
    } else { print STDERR "state/msg = $state NULL\n"; }

    if ($state eq 'start') {
	snd( 0, "$cur_id[0] boardsize $boardsize" );
	$state = 'startb';
	return;	
    }

    if ($state eq 'startb') {
	snd( 1, "$cur_id[1] boardsize $boardsize" );
	$state = 'genmove_black';
	return;
    }

    if ( $state eq 'genmove_black' ) {
	snd( 0, "$cur_id[0] genmove_black" );
	$state = 'black';
	return;
    }

    if ( $state eq 'black' ) {
	my $y;
	my $x;
	my $gn;

	print "msg ---> $msg\n";

	$msg =~ /^=\d+\s+(.)(.*)/;    # parse out move components

	if ( $msg =~ /PASS/ ) {
	    $consecutive_passes++;
	    $gn = 'PASS';
	} else {
	    $consecutive_passes = 0;
	    $y = $boardsize - $2;
	    $x = $toix{$1};
	    $gn = $letter[$x] . ($boardsize - $y);
	}


	# show blacks move to the interface 
	# ---------------------------------
	if ( !ttPlaceStone( $ctm, $gn ) ) {
	    xputstone( $ctm, $x, $y ) if $gn ne 'PASS';
	    xfixboard();
	    ttShowBoard();
	    swap_ctm();
	} else {  return 1; }

	# send the move along to WHITE
	# ----------------------------
	snd( 1, "$cur_id[1] black $gn" );
	$state = 'genmove_white';

	if ($consecutive_passes == 2) {
	    $state = 'gameover';
	}

	return;
    }


    if ( $state eq 'genmove_white' ) {
	snd( 1, "$cur_id[1] genmove_white" );
	$state = 'white';
	return;
    }


    if ( $state eq 'white' ) {
	my $y;
	my $x;
	my $gn;

	print "msg ---> $msg\n";

	$msg =~ /^=\d+\s+(.)(.*)/;    # parse out move components

	if ( $msg =~ /PASS/ ) {
	    $consecutive_passes++;
	    $gn = 'PASS';
	} else {
	    $consecutive_passes = 0;
	    $y = $boardsize - $2;
	    $x = $toix{$1};
	    $gn = $letter[$x] . ($boardsize - $y);
	}


	# show blacks move to the interface 
	# ---------------------------------
	if ( !ttPlaceStone( $ctm, $gn ) ) {
	    xputstone( $ctm, $x, $y ) if $gn ne 'PASS';
	    xfixboard();
	    ttShowBoard();
	    swap_ctm();
	} else {  return 1; }

	# send the move along to BLACK
	# ----------------------------
	snd( 0, "$cur_id[0] white $gn" );
	$state = 'genmove_black';

	if ($consecutive_passes == 2) {
	    $state = 'gameover';
	}

	return;
    }


    if ( $state eq 'gameover' ) {    
	print "Game Over\n";
	ttScore();

    }






}





sub snd
{
    my ($who, $str) = @_;

    if ($who == 0) {
	print $Aprg_in "$str\n";
    } else {
	print $Bprg_in "$str\n";
    }

    print STDERR "----> $str\n";

}


sub swap_ctm
{
    if ( $ctm eq 'B' ) { 
	$ctm = 'W'; 
    } else { 
	$ctm = 'B'; 
    }

}