Commit | Line | Data |
---|---|---|
7eeb782e AT |
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 |