| 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 | package ttgo; |
| 29 | require Exporter; |
| 30 | |
| 31 | use strict; |
| 32 | |
| 33 | |
| 34 | our @ISA = qw(Exporter); |
| 35 | our @EXPORT = qw(ttNewGame ttShowBoard ttPlaceStone ttGetBoard ttScore); |
| 36 | |
| 37 | my @bd = (); |
| 38 | my @sbd = (); # working board |
| 39 | my $white = 1; |
| 40 | my $black = 2; |
| 41 | my $bs; |
| 42 | 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 ); |
| 43 | my %tocol = ( 'b' => 2, 'B' => 2, 'w' => 1, 'W' => 1 ); |
| 44 | my %toix = (); |
| 45 | foreach my $ix (0 .. $#letter) { |
| 46 | $toix{ $letter[$ix] } = $ix; |
| 47 | } |
| 48 | |
| 49 | my %hashed_boards = (); # for convenient rep testing |
| 50 | my @all_boards = (); # for move takebacks |
| 51 | |
| 52 | |
| 53 | my %tovisual = ( 2 => 'W', 1 => 'B', 0 => '+' ); |
| 54 | |
| 55 | my @dir = (); |
| 56 | |
| 57 | |
| 58 | |
| 59 | sub ttNewGame |
| 60 | { |
| 61 | ($bs) = @_; |
| 62 | |
| 63 | my $s = ($bs+2) * ($bs+1); |
| 64 | |
| 65 | foreach my $i (0 .. $s-1) { |
| 66 | $bd[$i] = 3; # w+b |
| 67 | } |
| 68 | |
| 69 | foreach my $x (0 .. $bs - 1) { |
| 70 | foreach my $y (0 .. $bs - 1) { |
| 71 | $bd[ ($y+1) * ($bs+1) + $x ] = 0; # empty |
| 72 | } |
| 73 | } |
| 74 | |
| 75 | @dir = (); |
| 76 | |
| 77 | $dir[0] = -1; |
| 78 | $dir[1] = 1; |
| 79 | $dir[2] = $bs + 1; |
| 80 | $dir[3] = -($bs + 1); |
| 81 | |
| 82 | push( @all_boards, join(',', @bd) ); |
| 83 | } |
| 84 | |
| 85 | |
| 86 | |
| 87 | sub ttPlaceStone |
| 88 | { |
| 89 | my ($c, $loc) = @_; |
| 90 | |
| 91 | my @prev_board = @bd; # to take back if needed |
| 92 | $hashed_boards{join(',',@prev_board)} = 1; # hash previous board |
| 93 | |
| 94 | if ($loc eq 'PASS') { |
| 95 | return(0); |
| 96 | } |
| 97 | |
| 98 | $loc =~ /^(.)(.*)/; |
| 99 | my $y = $bs - $2; |
| 100 | my $x = $toix{$1}; |
| 101 | |
| 102 | my $sq = ($y+1) * ($bs+1) + $x; |
| 103 | |
| 104 | |
| 105 | # occupied? |
| 106 | # ========= |
| 107 | if ($bd[ ($y+1) * ($bs+1) + $x ] != 0) { |
| 108 | print "Illegal move, square occupied\n"; |
| 109 | return(1); |
| 110 | } |
| 111 | |
| 112 | # Make move |
| 113 | # ========= |
| 114 | $bd[$sq] = $tocol{$c}; |
| 115 | |
| 116 | # did we capture anything? |
| 117 | # ======================== |
| 118 | my $cc = $tocol{$c}; # current color |
| 119 | my $cap = 0; |
| 120 | foreach my $d (@dir) { |
| 121 | if ($bd[$sq+$d] == (3 ^ $cc)) { |
| 122 | @sbd = @bd; |
| 123 | my $lc = lib_count( 3 ^ $cc, $sq + $d ); |
| 124 | if ($lc == 0) { |
| 125 | $cap = 1; |
| 126 | print "Capture possible\n"; |
| 127 | capture( 3 ^ $cc, $sq+$d ); |
| 128 | } |
| 129 | } |
| 130 | } |
| 131 | |
| 132 | # if capture not possible, it might be suicide |
| 133 | # ============================================ |
| 134 | |
| 135 | if (!$cap) { |
| 136 | $bd[$sq] = 0; # make it empty again |
| 137 | @sbd = @bd; |
| 138 | $sbd[$sq] = $tocol{$c}; |
| 139 | my $lc = lib_count($tocol{$c}, $sq ); |
| 140 | print "liberty count = $lc\n"; |
| 141 | if ($lc == 0) { |
| 142 | print "Illegal move, suicide!\n"; |
| 143 | return(2); |
| 144 | } |
| 145 | # Make move |
| 146 | # ========= |
| 147 | $bd[$sq] = $tocol{$c}; |
| 148 | } |
| 149 | |
| 150 | |
| 151 | if ( defined( $hashed_boards{ join(',',@bd) } ) ) { |
| 152 | print "Illegal move, repeated positions\n"; |
| 153 | # @bd = @prev_board; |
| 154 | # return(0); |
| 155 | } |
| 156 | |
| 157 | push( @all_boards, join(',', @bd) ); |
| 158 | |
| 159 | ttScore(); |
| 160 | |
| 161 | return 0; |
| 162 | } |
| 163 | |
| 164 | |
| 165 | |
| 166 | |
| 167 | sub lib_count |
| 168 | { |
| 169 | my ($c, $sq) = @_; |
| 170 | my $count = 0; |
| 171 | |
| 172 | foreach my $d (@dir) { |
| 173 | if ($sbd[ $sq + $d ] == 0) { |
| 174 | $count++; |
| 175 | $sbd[$sq + $d ] = 9; |
| 176 | next; |
| 177 | } |
| 178 | if ($sbd[ $sq + $d ] == 3) { next; } |
| 179 | if ($sbd[ $sq + $d ] == $c) { |
| 180 | $sbd[$sq + $d ] = 9; |
| 181 | $count += lib_count( $c, $sq + $d ); |
| 182 | } |
| 183 | } |
| 184 | |
| 185 | return $count; |
| 186 | } |
| 187 | |
| 188 | |
| 189 | sub capture |
| 190 | { |
| 191 | my ($c, $sq) = @_; |
| 192 | |
| 193 | $bd[$sq] = 0; |
| 194 | foreach my $d (@dir) { |
| 195 | if ( $bd[ $sq + $d ] == $c ) { |
| 196 | capture( $c, $sq + $d ); |
| 197 | } |
| 198 | } |
| 199 | } |
| 200 | |
| 201 | |
| 202 | |
| 203 | sub ttShowBoard |
| 204 | { |
| 205 | foreach my $y (0 .. $bs + 1) { |
| 206 | foreach my $x (0 .. $bs) { |
| 207 | printf ( "%2d", $bd[ $y * ($bs+1) + $x ] ); |
| 208 | } |
| 209 | print "\n"; |
| 210 | } |
| 211 | |
| 212 | print "\n"; |
| 213 | } |
| 214 | |
| 215 | |
| 216 | |
| 217 | sub ttGetBoard |
| 218 | { |
| 219 | my @tbd = (); |
| 220 | |
| 221 | foreach my $y (0 .. $bs-1) { |
| 222 | foreach my $x (0 .. $bs-1) { |
| 223 | push @tbd, $tovisual{ $bd[ ($y+1) * ($bs+1) + $x ] }; |
| 224 | } |
| 225 | } |
| 226 | return @tbd; |
| 227 | } |
| 228 | |
| 229 | |
| 230 | |
| 231 | sub ttScore |
| 232 | { |
| 233 | @sbd = @bd; |
| 234 | |
| 235 | my $who = 0; |
| 236 | my @ter = (0, 0, 0); |
| 237 | my @stc = (0, 0, 0); |
| 238 | |
| 239 | foreach my $sq (0 .. (($bs+2) * ($bs+1))-1 ) { |
| 240 | if ( $bd[$sq]==1 || $bd[$sq]==2 ) { $stc[$bd[$sq]] ++; } |
| 241 | if ($sbd[$sq] == 0) { |
| 242 | my ($cnt, $who) = count_space($sq); |
| 243 | if ($who == 1 || $who == 2) { |
| 244 | $ter[$who] += $cnt; |
| 245 | } |
| 246 | } |
| 247 | } |
| 248 | |
| 249 | print "white stones=$stc[$white] territory=$ter[$white]\n"; |
| 250 | print "black stones=$stc[$black] territory=$ter[$black]\n"; |
| 251 | |
| 252 | return( ($stc[$black] + $ter[$black])-($stc[$white] + $ter[$white]) ); |
| 253 | } |
| 254 | |
| 255 | |
| 256 | |
| 257 | |
| 258 | # return count |
| 259 | # ------------ |
| 260 | sub count_space |
| 261 | { |
| 262 | my ($sq) = @_; |
| 263 | my $count = 0; |
| 264 | my $who = 0; |
| 265 | |
| 266 | if ( $sbd[$sq] == 9 || $sbd[$sq] == 3) { |
| 267 | return (0,0); |
| 268 | } elsif ( $sbd[$sq] != 0 ) { |
| 269 | $who |= $sbd[$sq]; |
| 270 | return( 0, $who); |
| 271 | } else { # must be zero |
| 272 | $count++; |
| 273 | $sbd[$sq] = 9; # mark it |
| 274 | foreach my $d (@dir) { |
| 275 | my ($c, $w) = count_space( $sq + $d ); |
| 276 | $count += $c; |
| 277 | $who |= $w; |
| 278 | } |
| 279 | } |
| 280 | return ( $count, $who ); |
| 281 | } |
| 282 | |
| 283 | |
| 284 | 1; |
| 285 | |
| 286 | |
| 287 | |
| 288 | |
| 289 | |