pygo/gnugo/interface/gtp_examples/ttgo.pm

#!/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.                                        #
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #

package ttgo;
require Exporter;

use strict;


our @ISA    = qw(Exporter);
our @EXPORT = qw(ttNewGame ttShowBoard ttPlaceStone ttGetBoard ttScore);

my @bd = ();
my @sbd = ();   # working board
my $white = 1;
my $black = 2;
my $bs;
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 );
my %tocol = ( 'b' => 2, 'B' => 2, 'w' => 1, 'W' => 1  );
my %toix = ();
foreach my $ix (0 .. $#letter) {
    $toix{ $letter[$ix] } = $ix;
}

my %hashed_boards = ();  # for convenient rep testing
my @all_boards = ();     # for move takebacks


my %tovisual = ( 2 => 'W',  1 => 'B', 0 => '+' );

my @dir = ();



sub ttNewGame
{
    ($bs) = @_;

    my $s = ($bs+2) * ($bs+1);

    foreach my $i (0 .. $s-1) {
	$bd[$i] = 3;                            # w+b
    }

    foreach my $x (0 .. $bs - 1) {
	foreach my $y (0 .. $bs - 1) {
	    $bd[ ($y+1) * ($bs+1) + $x ] = 0;   # empty
	}
    }

    @dir = ();

    $dir[0] = -1;
    $dir[1] =  1;
    $dir[2] = $bs + 1;
    $dir[3] = -($bs + 1);

    push( @all_boards, join(',', @bd) );
}



sub ttPlaceStone
{
    my ($c, $loc) = @_;

    my @prev_board = @bd;        # to take back if needed
    $hashed_boards{join(',',@prev_board)} = 1;  # hash previous board

    if ($loc eq 'PASS') {
	return(0);
    }

    $loc =~ /^(.)(.*)/;
    my $y = $bs - $2;
    my $x = $toix{$1};

    my $sq = ($y+1) * ($bs+1) + $x;


    # occupied?
    # =========
    if ($bd[ ($y+1) * ($bs+1) + $x ] != 0) {
	print "Illegal move, square occupied\n";
	return(1);
    }

    # Make move 
    # =========
    $bd[$sq] = $tocol{$c};

    # did we capture anything?
    # ========================
    my $cc = $tocol{$c};   # current color
    my $cap = 0;
    foreach my $d (@dir) {
  	if ($bd[$sq+$d] == (3 ^ $cc)) {
  	    @sbd = @bd;
  	    my $lc = lib_count( 3 ^ $cc, $sq + $d );
  	    if ($lc == 0) {
		$cap = 1;
		print "Capture possible\n";
  		capture( 3 ^ $cc, $sq+$d );
  	    }
  	}
    }

    # if capture not possible, it might be suicide
    # ============================================

    if (!$cap) {   
	$bd[$sq] = 0;   # make it empty again
	@sbd = @bd;
	$sbd[$sq] = $tocol{$c};
	my $lc = lib_count($tocol{$c}, $sq );
	print "liberty count = $lc\n";
	if ($lc == 0) {
	    print "Illegal move,  suicide!\n";
	    return(2);
	}
	# Make move
	# =========
	$bd[$sq] = $tocol{$c};    
    }


    if ( defined( $hashed_boards{ join(',',@bd) } ) ) {
	print "Illegal move, repeated positions\n";
	# @bd = @prev_board;
	# return(0);        
    }

    push( @all_boards, join(',', @bd) );

    ttScore();
	
    return 0;
}




sub lib_count
{
    my ($c, $sq) = @_;
    my $count = 0;

    foreach my $d (@dir) {
	if ($sbd[ $sq + $d ] == 0) { 
	    $count++; 
	    $sbd[$sq + $d ] = 9;
	    next;
	}
	if ($sbd[ $sq + $d ] == 3)  { next; }
	if ($sbd[ $sq + $d ] == $c) { 
	    $sbd[$sq + $d ] = 9;
	    $count += lib_count( $c, $sq + $d );
	}
    }

    return $count;
}


sub capture
{
    my ($c, $sq) = @_;

    $bd[$sq] = 0;
    foreach my $d (@dir) {
	if ( $bd[ $sq + $d ] == $c ) {
	    capture( $c, $sq + $d );
	}
    }
}



sub ttShowBoard
{
    foreach my $y (0 .. $bs + 1) {
	foreach my $x (0 .. $bs) {
	    printf ( "%2d", $bd[ $y * ($bs+1) + $x ] );
	}
	print "\n";
    }

    print "\n";
}



sub ttGetBoard
{
    my @tbd = ();

    foreach my $y (0 .. $bs-1) {
	foreach my $x (0 .. $bs-1) {
	    push @tbd, $tovisual{ $bd[ ($y+1) * ($bs+1) + $x ] };
	}
    }
    return @tbd;
}



sub ttScore
{
    @sbd = @bd;

    my $who = 0;
    my @ter = (0, 0, 0);
    my @stc = (0, 0, 0);

    foreach my $sq (0 .. (($bs+2) * ($bs+1))-1 ) {
	if ( $bd[$sq]==1 || $bd[$sq]==2 ) { $stc[$bd[$sq]] ++; }
	if ($sbd[$sq] == 0) {
	    my ($cnt, $who) = count_space($sq);
	    if ($who == 1 || $who == 2) {
		$ter[$who] += $cnt;
	    }
	}  
    }

    print "white stones=$stc[$white]   territory=$ter[$white]\n";
    print "black stones=$stc[$black]   territory=$ter[$black]\n";

    return( ($stc[$black] + $ter[$black])-($stc[$white] + $ter[$white]) );
}




# return count
# ------------
sub count_space
{
    my ($sq) = @_;
    my $count = 0;
    my $who = 0;

    if ( $sbd[$sq] == 9 || $sbd[$sq] == 3) {
	return (0,0);
    } elsif ( $sbd[$sq] != 0 ) {
	$who |= $sbd[$sq];
	return( 0, $who);
    } else {  # must be zero	       
	$count++;
	$sbd[$sq] = 9;   # mark it
	foreach my $d (@dir) {
	    my ($c, $w) = count_space( $sq + $d );
	    $count += $c;
	    $who |= $w;
	}
    }
    return ( $count, $who );
}


1;