[ViewVC] Diff of: cvs/Games-Go-SimpleBoard/SimpleBoard.pm

Comparing Games-Go-SimpleBoard/SimpleBoard.pm (file contents):
Revision 1.1 by root, Sun Jun 22 15:05:59 2008 UTC vs.
Revision 1.14 by elmex, Thu Jul 24 08:58:02 2008 UTC

…		…
17	Marker types for each board position (ORed together):	17	Marker types for each board position (ORed together):
18		18
19	MARK_TRIANGLE # triangle mark	19	MARK_TRIANGLE # triangle mark
20	MARK_SQUARE # square mark	20	MARK_SQUARE # square mark
21	MARK_CIRCLE # circle mark	21	MARK_CIRCLE # circle mark
		22	MARK_CROSS # cross mark
22	MARK_SMALL_B # small stone, used for scoring or marking	23	MARK_SMALL_B # small stone, used for scoring or marking
23	MARK_SMALL_W # small stone, used for scoring or marking	24	MARK_SMALL_W # small stone, used for scoring or marking
24	MARK_B # normal black stone	25	MARK_B # normal black stone
25	MARK_W # normal whit stone	26	MARK_W # normal whit stone
26	MARK_GRAYED # in conjunction with MARK_[BW], grays the stone	27	MARK_GRAYED # in conjunction with MARK_[BW], grays the stone
…		…
28	MARK_HOSHI # this is a hoshi point (not used much)	29	MARK_HOSHI # this is a hoshi point (not used much)
29	MARK_MOVE # this is a regular move	30	MARK_MOVE # this is a regular move
30	MARK_KO # this is a ko position	31	MARK_KO # this is a ko position
31	MARK_REDRAW # ignored, can be used for your own purposes	32	MARK_REDRAW # ignored, can be used for your own purposes
32		33
33	COLOUR_BLACK # used for $board->{last}	34	COLOUR_WHITE # guarenteed to be 0
34	COLOUR_WHITE # to mark the colour of the last move	35	COLOUR_BLACK # guarenteed to be 1
		36
		37	MOVE_HANDICAP # used as "x-coordinate" for handicap moves
		38	MOVE_PASS # can be used as "x-coordinate" for pass moves
35		39
36	=head2 METHODS	40	=head2 METHODS
37		41
38	=over 4	42	=over 4
39		43
40	=cut	44	=cut
41		45
		46	no warnings;
		47	use strict;
		48
		49	use Carp ();
		50
42	use base Exporter;	51	use base Exporter::;
43		52
44	our $VERSION = '1.0';	53	our $VERSION = '1.0';
45		54
46	@EXPORT = qw(	55	our @EXPORT = qw(
47	MARK_TRIANGLE MARK_SQUARE MARK_CIRCLE MARK_SMALL_B MARK_SMALL_W MARK_B	56	MARK_TRIANGLE MARK_SQUARE MARK_CIRCLE MARK_SMALL_B MARK_SMALL_W MARK_B
48	MARK_W MARK_GRAYED MARK_MOVE MARK_LABEL MARK_HOSHI MARK_KO	57	MARK_W MARK_GRAYED MARK_MOVE MARK_LABEL MARK_HOSHI MARK_KO MARK_CROSS
49	MARK_REDRAW	58	MARK_REDRAW
50	COLOUR_BLACK COLOUR_WHITE	59	COLOUR_BLACK COLOUR_WHITE
		60	MOVE_HANDICAP MOVE_PASS
51	);	61	);
52		62
53	# marker types for each board position (ORed together)	63	# marker types for each board position (ORed together)
54		64
55	sub MARK_TRIANGLE (){ 0x0001 }	65	sub MARK_TRIANGLE (){ 0x0001 }
…		…
62	sub MARK_GRAYED (){ 0x0080 } # in conjunction with MARK_[BW], grays the stone	72	sub MARK_GRAYED (){ 0x0080 } # in conjunction with MARK_[BW], grays the stone
63	sub MARK_LABEL (){ 0x0100 }	73	sub MARK_LABEL (){ 0x0100 }
64	sub MARK_HOSHI (){ 0x0200 } # this is a hoshi point (not used much)	74	sub MARK_HOSHI (){ 0x0200 } # this is a hoshi point (not used much)
65	sub MARK_MOVE (){ 0x0400 } # this is a regular move	75	sub MARK_MOVE (){ 0x0400 } # this is a regular move
66	sub MARK_KO (){ 0x0800 } # this is a ko position	76	sub MARK_KO (){ 0x0800 } # this is a ko position
		77	sub MARK_CROSS (){ 0x1000 }
67	sub MARK_REDRAW (){ 0x8000 }	78	sub MARK_REDRAW (){ 0x8000 }
68		79
69	sub COLOUR_BLACK (){ 0 }
70	sub COLOUR_WHITE (){ 1 }	80	sub COLOUR_WHITE (){ 0 }
		81	sub COLOUR_BLACK (){ 1 }
		82
		83	sub MOVE_PASS (){ undef }
		84	sub MOVE_HANDICAP (){ -2 }
71		85
72	=item my $board = new $size	86	=item my $board = new $size
73		87
74	Creates a new empty board of the given size.	88	Creates a new empty board of the given size.
75		89
		90	C<< $board->{size} >> stores the board size.
		91
76	C<< $board->{max} >> stores the maximum board coordinate (size-1).	92	C<< $board->{max} >> stores the maximum board coordinate (size-1).
77		93
78	C<< $board->{captures}[COLOUR] >> stores the number of captured stones for	94	C<< $board->{captures}[COLOUR_xxx] >> stores the number of captured stones for
79	the given colour.	95	the given colour.
80
81	C<< $board->{last} >> stores the colour of the last move that was played.
82		96
83	C<< $board->{board} >> stores a two-dimensional array with board contents.	97	C<< $board->{board} >> stores a two-dimensional array with board contents.
84		98
85	=cut	99	=cut
86		100
87	sub new {	101	sub new {
88	my $class = shift;	102	my $class = shift;
89	my $size = shift;	103	my $size = shift;
		104
		105	unless ($size > 0) {
		106	Carp::croak ("no board size given!");
		107	}
		108
90	bless {	109	bless {
91	max => $size - 1,	110	max => $size - 1,
		111	size => $size,
92	board => [map [(0) x $size], 1 .. $size],	112	board => [map [(0) x $size], 1 .. $size],
93	captures => [0, 0], # captures	113	captures => [0, 0], # captures
94	#timer => [],	114	#timer => [],
95	#score => [],	115	#score => [],
96	#last => COLOUR_...,
97	@_
98	},	116	@_,
99	$class;	117	}, $class
100	}	118	}
101		119
102	# inefficient and primitive, I hear you say?	120	# inefficient and primitive, I hear you say?
103	# well... you are right :)	121	# well... you are right :)
104	# use an extremely dumb floodfill algorithm to get rid of captured stones	122	# use an extremely dumb floodfill algorithm to get rid of captured stones
…		…
112		130
113	my $max = $self->{max};	131	my $max = $self->{max};
114		132
115	while (@nodes) {	133	while (@nodes) {
116	my ($x, $y) = @{pop @nodes};	134	my ($x, $y) = @{pop @nodes};
		135
117	unless ($seen{$x,$y}++) {	136	unless ($seen{$x,$y}++) {
118	if ($board->[$x][$y] & $mark) {	137	if ($board->[$x][$y] & $mark) {
119	push @found, [$x, $y];	138	push @found, [$x, $y];
120		139
121	push @nodes, [$x-1, $y] unless $seen{$x-1, $y} \|\| $x <= 0;	140	push @nodes, [$x-1, $y] unless $seen{$x-1, $y} \|\| $x <= 0;
…		…
129	}	148	}
130		149
131	@found	150	@found
132	}	151	}
133		152
134	=item $hint = $board->update ([update-structure...])	153	=item $hint = $board->update ([update-structures...])
135		154
136	Structure is	155	Each update-structure itself is also an array-ref:
137		156
138	[$x, $y, $clr, $set, $label, $hint] # update or move	157	[$x, $y, $clr, $set, $label, $hint] # update or move
		158	[MOVE_HANDICAP, $handicap] # black move, setup handicap
		159	[MOVE_PASS] # pass
139	[] # pass	160	[] # also pass (deprecated!)
140		161
141	and changes the board or executes a move, by first clearing the bits	162	It changes the board or executes a move, by first clearing the bits
142	specified in C<$clr>, then setting bits specified in C<$set>.	163	specified in C<$clr>, then setting bits specified in C<$set>.
143		164
144	If C<$set> includes C<MARK_LABEL>, the label text must be given in	165	If C<$set> includes C<MARK_LABEL>, the label text must be given in
145	C<$label>.	166	C<$label>.
146		167
		168	If C<$set> contains C<MARK_MOVE> then surrounded stones will be removed
		169	from the board and (simple) Kos are detected and marked with square
		170	symbols and C<MARK_KO>, after removing other marking symbols. The
		171	markings are also removed with the next next update structure that uses
		172	C<MARK_MOVE>, so this flag is suited well for marking, well, moves. Note
		173	that you can make invalid "moves" (such as suicide) and C<update> will
		174	try to cope with it. You can use C<is_valid_move> to avoid making illegal
		175	moves.
		176
		177	For handicap "moves", currently only board sizes 9, 13 and 19 are
		178	supported and only handicap values from 2 to 9. The placement follows the
		179	IGS rules, if you want other placements, you have to set it up yourself.
		180
147	This function modifies the hint member of the specified path to speed up	181	This function modifies the C<$hint> member of the specified structure
148	repeated board generation and updates with the same update structures.	182	to speed up repeated board generation and updates with the same update
		183	structures.
149		184
150	If the hint member is a reference the scalar pointed to by the reference	185	If the hint member is a reference the scalar pointed to by the reference
151	is updated instead.	186	is updated instead.
152		187
		188	If all this hint member thing is confusing, just ignore it and specify
		189	it as C<undef> or leave it out of the array entirely. Do make sure that
		190	you keep your update structures around as long as previous updates don't
		191	change, however, as regenerating a full board position from hinted
		192	update structures is I<much> faster then recreating it from fresh update
		193	structures.
		194
153	Example, make two silly moves:	195	Example, make two silly moves:
154		196
155	$board->update ([[0, 18, -1, MARK_B\|MARK_MOVE],	197	$board->update ([[0, 18, -1, MARK_B \| MARK_MOVE],
156	[0, 17, -1, MARK_W\|MARK_MOVE]);	198	[0, 17, -1, MARK_W \| MARK_MOVE]]);
157		199
158	=cut	200	=cut
		201
		202	our %HANDICAP_COORD = (
		203	9 => [2, 4, 6],
		204	13 => [3, 6, 9],
		205	19 => [3, 9, 15],
		206	);
		207	our %HANDICAP_XY = (
		208	2 => [qw(0,2 2,0 )],
		209	3 => [qw(0,2 2,0 0,0 )],
		210	4 => [qw(0,2 2,0 0,0 2,2 )],
		211	5 => [qw(0,2 2,0 0,0 2,2 1,1)],
		212	6 => [qw(0,2 2,0 0,0 2,2 0,1 2,1 )],
		213	7 => [qw(0,2 2,0 0,0 2,2 0,1 2,1 1,1)],
		214	8 => [qw(0,2 2,0 0,0 2,2 0,1 2,1 1,0 1,2 )],
		215	9 => [qw(0,2 2,0 0,0 2,2 0,1 2,1 1,0 1,2 1,1)],
		216	);
		217
		218	our $mark_symbols = MARK_CIRCLE \| MARK_SQUARE \| MARK_TRIANGLE \| MARK_CROSS \| MARK_KO;
159		219
160	sub update {	220	sub update {
161	my ($self, $path) = @_;	221	my ($self, $path) = @_;
162		222
163	my $board = $self->{board};	223	my $board = $self->{board};
164		224
165	for (@$path) {	225	for (@$path) {
166	my ($x, $y, $clr, $set, $label) = @$_;	226	my ($x, $y, $clr, $set, $label) = @$_;
167		227
168	my $nodemask =
169	$_ == $path->[-1]
170	? ~0
171	: ~(MARK_SQUARE \| MARK_TRIANGLE \| MARK_CIRCLE \| MARK_LABEL \| MARK_KO);
172
173	if (defined $x) {	228	if (!defined $x) {
		229	$$_ &= ~$mark_symbols for @{ delete $self->{unmark} \|\| [] };
		230	# pass
		231
		232	} elsif ($x == MOVE_HANDICAP) {
		233	$$_ &= ~$mark_symbols for @{ delete $self->{unmark} \|\| [] };
		234
		235	# $y = #handicap stones
		236	my $c = $HANDICAP_COORD{$self->{size}}
		237	or Carp::croak "$self->{size}: illegal board size for handicap";
		238	my $h = $HANDICAP_XY{$y}
		239	or Carp::croak "$y: illegal number of handicap stones";
		240
		241	for (@$h) {
		242	my ($x, $y) = map $c->[$_], split /,/;
		243	$board->[$x][$y] = MARK_B \| MARK_MOVE;
		244	}
		245
		246	} else {
174	$board->[$x][$y] =	247	my $space = \$board->[$x][$y];
175	$board->[$x][$y]	248
176	& ~$clr	249	$$space = $$space & ~$clr \| $set;
177	\| $set
178	& $nodemask;
179		250
180	$self->{label}[$x][$y] = $label if $set & MARK_LABEL;	251	$self->{label}[$x][$y] = $label if $set & MARK_LABEL;
181		252
182	if ($set & MARK_MOVE) {	253	if ($set & MARK_MOVE) {
183	$self->{last} = $set & MARK_B ? COLOUR_BLACK : COLOUR_WHITE;	254	$$_ &= ~$mark_symbols for @{ $self->{unmark} \|\| [] };
		255	@{ $self->{unmark} } = $space;
184		256
185	unless (${ $_->[5] \|\|= \my $hint }) {	257	unless (${ $_->[5] \|\|= \my $hint }) {
186	my ($own, $opp) =	258	my ($own, $opp) =
187	$set & MARK_B	259	$set & MARK_B
188	? (MARK_B, MARK_W)	260	? (MARK_B, MARK_W)
189	: (MARK_W, MARK_B);	261	: (MARK_W, MARK_B);
190		262
191	my (@capture, $suicide);	263	my (@capture, @suicide);
192		264
193	push @capture, $self->capture ($opp, $x-1, $y) if $x > 0 && $board->[$x-1][$y] & $opp;	265	push @capture, $self->capture ($opp, $x-1, $y) if $x > 0 && $board->[$x-1][$y] & $opp;
194	push @capture, $self->capture ($opp, $x+1, $y) if $x < $self->{max} && $board->[$x+1][$y] & $opp;	266	push @capture, $self->capture ($opp, $x+1, $y) if $x < $self->{max} && $board->[$x+1][$y] & $opp;
195	push @capture, $self->capture ($opp, $x, $y-1) if $y > 0 && $board->[$x][$y-1] & $opp;	267	push @capture, $self->capture ($opp, $x, $y-1) if $y > 0 && $board->[$x][$y-1] & $opp;
196	push @capture, $self->capture ($opp, $x, $y+1) if $y < $self->{max} && $board->[$x][$y+1] & $opp;	268	push @capture, $self->capture ($opp, $x, $y+1) if $y < $self->{max} && $board->[$x][$y+1] & $opp;
197		269
198	# keep only unique coordinates	270	# keep only unique coordinates
199	@capture = do { my %seen; grep !$seen{"$_->[0],$_->[1]"}++, @capture };	271	@capture = do { my %seen; grep !$seen{"$_->[0],$_->[1]"}++, @capture };
200		272
201	# remove captured stones	273	# remove captured stones
202	$self->{captures}[$self->{last}] += @capture;	274	$self->{captures}[$own == MARK_B ? COLOUR_BLACK : COLOUR_WHITE] += @capture;
203	$self->{board}[$_->[0]][$_->[1]] &= ~(MARK_B \| MARK_W \| MARK_MOVE)	275	$self->{board}[$_->[0]][$_->[1]] = 0
204	for @capture;	276	for @capture;
205		277
206	$suicide += $self->capture ($own, $x, $y);	278	push @suicide, $self->capture ($own, $x, $y);
207		279
208	${ $_->[5] } \|\|= !(@capture \|\| $suicide);	280	${ $_->[5] } \|\|= !(@capture \|\| @suicide);
209		281
		282	if (@suicide) {
		283	$self->{board}[$_->[0]][$_->[1]] = 0
		284	for @suicide;
		285
210	if (!$suicide && @capture == 1) {	286	} elsif (!@suicide && @capture == 1) {
211	# possible ko. now check liberties on placed stone	287	# possible ko. now check liberties on placed stone
212		288
213	my $libs;	289	my $libs;
214		290
215	$libs++ if $x > 0 && !($board->[$x-1][$y] & $opp);	291	$libs++ if $x > 0 && !($board->[$x-1][$y] & $opp);
216	$libs++ if $x < $self->{max} && !($board->[$x+1][$y] & $opp);	292	$libs++ if $x < $self->{max} && !($board->[$x+1][$y] & $opp);
217	$libs++ if $y > 0 && !($board->[$x][$y-1] & $opp);	293	$libs++ if $y > 0 && !($board->[$x][$y-1] & $opp);
218	$libs++ if $y < $self->{max} && !($board->[$x][$y+1] & $opp);	294	$libs++ if $y < $self->{max} && !($board->[$x][$y+1] & $opp);
219		295
220	if ($libs == 1) {	296	if ($libs == 1) {
221	$board->[$x][$y] = $board->[$x][$y] & ~MARK_CIRCLE \| (MARK_KO & $nodemask);	297	$$space = $$space & ~$mark_symbols \| MARK_KO;
		298
222	($x, $y) = @{$capture[0]};	299	($x, $y) = @{$capture[0]};
223	$board->[$x][$y] \|= MARK_KO & $nodemask;	300	$board->[$x][$y] \|= MARK_KO;
		301
		302	push @{ $self->{unmark} }, \$board->[$x][$y];
224	}	303	}
225	}	304	}
226	}	305	}
227	}	306	}
228	} else {
229	$self->{last} = $set & MARK_B ? COLOUR_BLACK : COLOUR_WHITE;
230	}	307	}
231	}	308	}
232	}	309	}
233		310
234	=item $board->is_valid_move ($colour, $x, $y[, $may_suicide])	311	=item $board->is_valid_move ($colour, $x, $y[, $may_suicide])
235		312
236	Returns true if the move of the given colour on the given coordinates is	313	Returns true if the move of the given colour on the given coordinates is
237	valid or not.	314	valid or not. Kos are taken into account as long as they are marked with
		315	C<MARK_KO>. Suicides are invalid unless C<$may_suicide> is true (e.g. for
		316	new zealand rules)
238		317
239	=cut	318	=cut
240		319
241	sub is_valid_move {	320	sub is_valid_move {
242	my ($self, $colour, $x, $y, $may_suicide) = @_;	321	my ($self, $colour, $x, $y, $may_suicide) = @_;
243		322
244	my $board = $self->{board};	323	my $board = $self->{board};
245		324
246	return if $board->[$x][$y] & (MARK_B \| MARK_W \| MARK_KO);	325	return if $board->[$x][$y] & (MARK_B \| MARK_W \| MARK_KO)
		326	&& !($board->[$x][$y] & MARK_GRAYED);
247		327
248	if ($may_suicide) {	328	if ($may_suicide) {
249	return 1;	329	return 1;
250	} else {	330	} else {
251	my ($own, $opp) = $colour == COLOUR_BLACK	331	my ($own, $opp) = $colour == COLOUR_BLACK
…		…
272		352
273	Marc Lehmann <schmorp@schmorp.de>	353	Marc Lehmann <schmorp@schmorp.de>
274		354
275	=head2 SEE ALSO	355	=head2 SEE ALSO
276		356
277	L<KGS::Protocol>, L<KGS::Game::Tree>, L<Gtk2::GoBoard>.	357	L<Gtk2::GoBoard>.
278		358
279	=cut	359	=cut
280		360

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing Games-Go-SimpleBoard/SimpleBoard.pm (file contents): Revision 1.1 by root, Sun Jun 22 15:05:59 2008 UTC vs. Revision 1.14 by elmex, Thu Jul 24 08:58:02 2008 UTC

Diff Legend

Comparing Games-Go-SimpleBoard/SimpleBoard.pm (file contents):
Revision 1.1 by root, Sun Jun 22 15:05:59 2008 UTC vs.
Revision 1.14 by elmex, Thu Jul 24 08:58:02 2008 UTC