Games-Go-SimpleBoard/SimpleBoard.pm

package Games::Go::SimpleBoard;

=head1 NAME

Games::Go::SimpleBoard - represent a simple go board

=head1 SYNOPSIS

   use Games::Go::SimpleBoard;

=head1 DESCRIPTION

Please supply a description )

=head2 EXPORTED CONSTANTS

Marker types for each board position (ORed together):

   MARK_TRIANGLE # triangle mark
   MARK_SQUARE   # square mark
   MARK_CIRCLE   # circle mark
   MARK_SMALL_B  # small stone, used for scoring or marking
   MARK_SMALL_W  # small stone, used for scoring or marking
   MARK_B        # normal black stone
   MARK_W        # normal whit stone
   MARK_GRAYED   # in conjunction with MARK_[BW], grays the stone
   MARK_LABEL    # a text label
   MARK_HOSHI    # this is a hoshi point (not used much)
   MARK_MOVE     # this is a regular move
   MARK_KO       # this is a ko position
   MARK_REDRAW   # ignored, can be used for your own purposes

   COLOUR_BLACK  # used for $board->{last}
   COLOUR_WHITE  # to mark the colour of the last move

=head2 METHODS

=over 4

=cut

use base Exporter;

our $VERSION = '1.0';

@EXPORT = qw(
   MARK_TRIANGLE MARK_SQUARE MARK_CIRCLE MARK_SMALL_B MARK_SMALL_W MARK_B
   MARK_W MARK_GRAYED MARK_MOVE MARK_LABEL MARK_HOSHI MARK_KO
   MARK_REDRAW
   COLOUR_BLACK COLOUR_WHITE
);

# marker types for each board position (ORed together)

sub MARK_TRIANGLE (){ 0x0001 }
sub MARK_SQUARE   (){ 0x0002 }
sub MARK_CIRCLE   (){ 0x0004 }
sub MARK_SMALL_B  (){ 0x0008 } # small stone, used for scoring or marking
sub MARK_SMALL_W  (){ 0x0010 } # small stone, used for scoring or marking
sub MARK_B        (){ 0x0020 } # normal black stone
sub MARK_W        (){ 0x0040 } # normal whit stone
sub MARK_GRAYED   (){ 0x0080 } # in conjunction with MARK_[BW], grays the stone
sub MARK_LABEL    (){ 0x0100 }
sub MARK_HOSHI    (){ 0x0200 } # this is a hoshi point (not used much)
sub MARK_MOVE     (){ 0x0400 } # this is a regular move
sub MARK_KO       (){ 0x0800 } # this is a ko position
sub MARK_REDRAW   (){ 0x8000 }

sub COLOUR_BLACK  (){ 0 }
sub COLOUR_WHITE  (){ 1 }

=item my $board = new $size

Creates a new empty board of the given size.

C<< $board->{max} >> stores the maximum board coordinate (size-1).

C<< $board->{captures}[COLOUR] >> stores the number of captured stones for
the given colour.

C<< $board->{last} >> stores the colour of the last move that was played.

C<< $board->{board} >> stores a two-dimensional array with board contents.

=cut

sub new {
   my $class = shift;
   my $size = shift;
   bless {
         max      => $size - 1,
         board    => [map [(0) x $size], 1 .. $size],
         captures => [0, 0], # captures
        #timer    => [],
        #score    => [],
        #last     => COLOUR_...,
         @_
      },
      $class;
}

# inefficient and primitive, I hear you say?
# well... you are right :)
# use an extremely dumb floodfill algorithm to get rid of captured stones
sub capture {
   my ($self, $mark, $x, $y) = @_;

   my %seen;
   my @found;
   my @nodes = ([$x,$y]);
   my $board = $self->{board};

   my $max = $self->{max};

   while (@nodes) {
      my ($x, $y) = @{pop @nodes};
      unless ($seen{$x,$y}++) {
         if ($board->[$x][$y] & $mark) {
            push @found, [$x, $y];

            push @nodes, [$x-1, $y] unless $seen{$x-1, $y} || $x <= 0;
            push @nodes, [$x+1, $y] unless $seen{$x+1, $y} || $x >= $max;
            push @nodes, [$x, $y-1] unless $seen{$x, $y-1} || $y <= 0;
            push @nodes, [$x, $y+1] unless $seen{$x, $y+1} || $y >= $max;
         } elsif (!($board->[$x][$y] & (MARK_B | MARK_W))) {
            return;
         }
      }
   }

   @found
}

=item $hint = $board->update ([update-structures...])

Each update-structure itself is also an array-ref:

   [$x, $y, $clr, $set, $label, $hint] # update or move
   []                                  # pass

It changes the board or executes a move, by first clearing the bits
specified in C<$clr>, then setting bits specified in C<$set>.

If C<$set> includes C<MARK_LABEL>, the label text must be given in
C<$label>.

This function modifies the hint member of the specified path to speed up
repeated board generation and updates with the same update structures.

If the hint member is a reference the scalar pointed to by the reference
is updated instead.

If all this hint member thing is unclear, just ignore it and specify it
as C<undef> or leave it out of the array entirely. Do make sure that you
keep your update structures around, however, as regenerating a full board
position from hinted update structures is I<much> faster then recreating
it from fresh update structures.

Example, make two silly moves:

  $board->update ([[0, 18, -1, MARK_B|MARK_MOVE],
                   [0, 17, -1, MARK_W|MARK_MOVE]);

=cut

sub update {
   my ($self, $path) = @_;

   my $board = $self->{board};

   for (@$path) {
      my ($x, $y, $clr, $set, $label) = @$_;

      my $nodemask =
            $_ == $path->[-1]
               ? ~0
               : ~(MARK_SQUARE | MARK_TRIANGLE | MARK_CIRCLE | MARK_LABEL | MARK_KO);

      if (defined $x) {
         $board->[$x][$y] =
            $board->[$x][$y]
            & ~$clr
            | $set
            & $nodemask;

         $self->{label}[$x][$y] = $label if $set & MARK_LABEL;

         if ($set & MARK_MOVE) {
            $self->{last} = $set & MARK_B ? COLOUR_BLACK : COLOUR_WHITE;

            unless (${ $_->[5] ||= \my $hint }) {
               my ($own, $opp) =
                  $set & MARK_B
                     ? (MARK_B, MARK_W)
                     : (MARK_W, MARK_B);

               my (@capture, $suicide);

               push @capture, $self->capture ($opp, $x-1, $y) if $x > 0            && $board->[$x-1][$y] & $opp;
               push @capture, $self->capture ($opp, $x+1, $y) if $x < $self->{max} && $board->[$x+1][$y] & $opp;
               push @capture, $self->capture ($opp, $x, $y-1) if $y > 0            && $board->[$x][$y-1] & $opp;
               push @capture, $self->capture ($opp, $x, $y+1) if $y < $self->{max} && $board->[$x][$y+1] & $opp;

               # keep only unique coordinates
               @capture = do { my %seen; grep !$seen{"$_->[0],$_->[1]"}++, @capture };

               # remove captured stones
               $self->{captures}[$self->{last}] += @capture;
               $self->{board}[$_->[0]][$_->[1]] &= ~(MARK_B | MARK_W | MARK_MOVE)
                  for @capture;

               $suicide += $self->capture ($own, $x, $y);

               ${ $_->[5] } ||= !(@capture || $suicide);

               if (!$suicide && @capture == 1) {
                  # possible ko. now check liberties on placed stone

                  my $libs;

                  $libs++ if $x > 0            && !($board->[$x-1][$y] & $opp);
                  $libs++ if $x < $self->{max} && !($board->[$x+1][$y] & $opp);
                  $libs++ if $y > 0            && !($board->[$x][$y-1] & $opp);
                  $libs++ if $y < $self->{max} && !($board->[$x][$y+1] & $opp);
                  
                  if ($libs == 1) {
                     $board->[$x][$y] = $board->[$x][$y] & ~MARK_CIRCLE | (MARK_KO & $nodemask);
                     ($x, $y) = @{$capture[0]};
                     $board->[$x][$y] |= MARK_KO & $nodemask;
                  }
               }
            }
         }
      } else {
         $self->{last} = $set & MARK_B ? COLOUR_BLACK : COLOUR_WHITE;
      }
   }
}

=item $board->is_valid_move ($colour, $x, $y[, $may_suicide])

Returns true if the move of the given colour on the given coordinates is
valid or not.

=cut

sub is_valid_move {
   my ($self, $colour, $x, $y, $may_suicide) = @_;

   my $board = $self->{board};

   return if $board->[$x][$y] & (MARK_B | MARK_W | MARK_KO);

   if ($may_suicide) {
      return 1;
   } else {
      my ($own, $opp) = $colour == COLOUR_BLACK
                           ? (MARK_B, MARK_W)
                           : (MARK_W, MARK_B);

      # try the move
      local $board->[$x][$y] = $board->[$x][$y] | $own;

      return 1 if $x > 0            && $board->[$x-1][$y] & $opp && $self->capture ($opp, $x-1, $y, 1);
      return 1 if $x < $self->{max} && $board->[$x+1][$y] & $opp && $self->capture ($opp, $x+1, $y, 1);
      return 1 if $y > 0            && $board->[$x][$y-1] & $opp && $self->capture ($opp, $x, $y-1, 1);
      return 1 if $y < $self->{max} && $board->[$x][$y+1] & $opp && $self->capture ($opp, $x, $y+1, 1);

      return !$self->capture ($own, $x, $y, 1);
   }
}

1;

=back

=head2 AUTHOR

Marc Lehmann <schmorp@schmorp.de>

=head2 SEE ALSO

L<KGS::Protocol>, L<KGS::Game::Tree>, L<Gtk2::GoBoard>.

=cut

Revision:	1.2
Committed:	Mon Jun 23 00:38:35 2008 UTC (15 years, 11 months ago) by root
Branch:	MAIN
Changes since 1.1:	+9 -3 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	package Games::Go::SimpleBoard;
2
3			=head1 NAME
4
5			Games::Go::SimpleBoard - represent a simple go board
6
7			=head1 SYNOPSIS
8
9			use Games::Go::SimpleBoard;
10
11			=head1 DESCRIPTION
12
13			Please supply a description )
14
15			=head2 EXPORTED CONSTANTS
16
17			Marker types for each board position (ORed together):
18
19			MARK_TRIANGLE # triangle mark
20			MARK_SQUARE # square mark
21			MARK_CIRCLE # circle mark
22			MARK_SMALL_B # small stone, used for scoring or marking
23			MARK_SMALL_W # small stone, used for scoring or marking
24			MARK_B # normal black stone
25			MARK_W # normal whit stone
26			MARK_GRAYED # in conjunction with MARK_[BW], grays the stone
27			MARK_LABEL # a text label
28			MARK_HOSHI # this is a hoshi point (not used much)
29			MARK_MOVE # this is a regular move
30			MARK_KO # this is a ko position
31			MARK_REDRAW # ignored, can be used for your own purposes
32
33			COLOUR_BLACK # used for $board->{last}
34			COLOUR_WHITE # to mark the colour of the last move
35
36			=head2 METHODS
37
38			=over 4
39
40			=cut
41
42			use base Exporter;
43
44			our $VERSION = '1.0';
45
46			@EXPORT = qw(
47			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
49			MARK_REDRAW
50			COLOUR_BLACK COLOUR_WHITE
51			);
52
53			# marker types for each board position (ORed together)
54
55			sub MARK_TRIANGLE (){ 0x0001 }
56			sub MARK_SQUARE (){ 0x0002 }
57			sub MARK_CIRCLE (){ 0x0004 }
58			sub MARK_SMALL_B (){ 0x0008 } # small stone, used for scoring or marking
59			sub MARK_SMALL_W (){ 0x0010 } # small stone, used for scoring or marking
60			sub MARK_B (){ 0x0020 } # normal black stone
61			sub MARK_W (){ 0x0040 } # normal whit stone
62			sub MARK_GRAYED (){ 0x0080 } # in conjunction with MARK_[BW], grays the stone
63			sub MARK_LABEL (){ 0x0100 }
64			sub MARK_HOSHI (){ 0x0200 } # this is a hoshi point (not used much)
65			sub MARK_MOVE (){ 0x0400 } # this is a regular move
66			sub MARK_KO (){ 0x0800 } # this is a ko position
67			sub MARK_REDRAW (){ 0x8000 }
68
69			sub COLOUR_BLACK (){ 0 }
70			sub COLOUR_WHITE (){ 1 }
71
72			=item my $board = new $size
73
74			Creates a new empty board of the given size.
75
76			C<< $board->{max} >> stores the maximum board coordinate (size-1).
77
78			C<< $board->{captures}[COLOUR] >> stores the number of captured stones for
79			the given colour.
80
81			C<< $board->{last} >> stores the colour of the last move that was played.
82
83			C<< $board->{board} >> stores a two-dimensional array with board contents.
84
85			=cut
86
87			sub new {
88			my $class = shift;
89			my $size = shift;
90			bless {
91			max => $size - 1,
92			board => [map [(0) x $size], 1 .. $size],
93			captures => [0, 0], # captures
94			#timer => [],
95			#score => [],
96			#last => COLOUR_...,
97			@_
98			},
99			$class;
100			}
101
102			# inefficient and primitive, I hear you say?
103			# well... you are right :)
104			# use an extremely dumb floodfill algorithm to get rid of captured stones
105			sub capture {
106			my ($self, $mark, $x, $y) = @_;
107
108			my %seen;
109			my @found;
110			my @nodes = ([$x,$y]);
111			my $board = $self->{board};
112
113			my $max = $self->{max};
114
115			while (@nodes) {
116			my ($x, $y) = @{pop @nodes};
117			unless ($seen{$x,$y}++) {
118			if ($board->[$x][$y] & $mark) {
119			push @found, [$x, $y];
120
121			push @nodes, [$x-1, $y] unless $seen{$x-1, $y} \|\| $x <= 0;
122			push @nodes, [$x+1, $y] unless $seen{$x+1, $y} \|\| $x >= $max;
123			push @nodes, [$x, $y-1] unless $seen{$x, $y-1} \|\| $y <= 0;
124			push @nodes, [$x, $y+1] unless $seen{$x, $y+1} \|\| $y >= $max;
125			} elsif (!($board->[$x][$y] & (MARK_B \| MARK_W))) {
126			return;
127			}
128			}
129			}
130
131			@found
132			}
133
134	root	1.2	=item $hint = $board->update ([update-structures...])
135	root	1.1
136	root	1.2	Each update-structure itself is also an array-ref:
137	root	1.1
138			[$x, $y, $clr, $set, $label, $hint] # update or move
139			[] # pass
140
141	root	1.2	It changes the board or executes a move, by first clearing the bits
142	root	1.1	specified in C<$clr>, then setting bits specified in C<$set>.
143
144			If C<$set> includes C<MARK_LABEL>, the label text must be given in
145			C<$label>.
146
147			This function modifies the hint member of the specified path to speed up
148			repeated board generation and updates with the same update structures.
149
150			If the hint member is a reference the scalar pointed to by the reference
151			is updated instead.
152
153	root	1.2	If all this hint member thing is unclear, just ignore it and specify it
154			as C<undef> or leave it out of the array entirely. Do make sure that you
155			keep your update structures around, however, as regenerating a full board
156			position from hinted update structures is I<much> faster then recreating
157			it from fresh update structures.
158
159	root	1.1	Example, make two silly moves:
160
161			$board->update ([[0, 18, -1, MARK_B\|MARK_MOVE],
162			[0, 17, -1, MARK_W\|MARK_MOVE]);
163
164			=cut
165
166			sub update {
167			my ($self, $path) = @_;
168
169			my $board = $self->{board};
170
171			for (@$path) {
172			my ($x, $y, $clr, $set, $label) = @$_;
173
174			my $nodemask =
175			$_ == $path->[-1]
176			? ~0
177			: ~(MARK_SQUARE \| MARK_TRIANGLE \| MARK_CIRCLE \| MARK_LABEL \| MARK_KO);
178
179			if (defined $x) {
180			$board->[$x][$y] =
181			$board->[$x][$y]
182			& ~$clr
183			\| $set
184			& $nodemask;
185
186			$self->{label}[$x][$y] = $label if $set & MARK_LABEL;
187
188			if ($set & MARK_MOVE) {
189			$self->{last} = $set & MARK_B ? COLOUR_BLACK : COLOUR_WHITE;
190
191			unless (${ $_->[5] \|\|= \my $hint }) {
192			my ($own, $opp) =
193			$set & MARK_B
194			? (MARK_B, MARK_W)
195			: (MARK_W, MARK_B);
196
197			my (@capture, $suicide);
198
199			push @capture, $self->capture ($opp, $x-1, $y) if $x > 0 && $board->[$x-1][$y] & $opp;
200			push @capture, $self->capture ($opp, $x+1, $y) if $x < $self->{max} && $board->[$x+1][$y] & $opp;
201			push @capture, $self->capture ($opp, $x, $y-1) if $y > 0 && $board->[$x][$y-1] & $opp;
202			push @capture, $self->capture ($opp, $x, $y+1) if $y < $self->{max} && $board->[$x][$y+1] & $opp;
203
204			# keep only unique coordinates
205			@capture = do { my %seen; grep !$seen{"$_->[0],$_->[1]"}++, @capture };
206
207			# remove captured stones
208			$self->{captures}[$self->{last}] += @capture;
209			$self->{board}[$_->[0]][$_->[1]] &= ~(MARK_B \| MARK_W \| MARK_MOVE)
210			for @capture;
211
212			$suicide += $self->capture ($own, $x, $y);
213
214			${ $_->[5] } \|\|= !(@capture \|\| $suicide);
215
216			if (!$suicide && @capture == 1) {
217			# possible ko. now check liberties on placed stone
218
219			my $libs;
220
221			$libs++ if $x > 0 && !($board->[$x-1][$y] & $opp);
222			$libs++ if $x < $self->{max} && !($board->[$x+1][$y] & $opp);
223			$libs++ if $y > 0 && !($board->[$x][$y-1] & $opp);
224			$libs++ if $y < $self->{max} && !($board->[$x][$y+1] & $opp);
225
226			if ($libs == 1) {
227			$board->[$x][$y] = $board->[$x][$y] & ~MARK_CIRCLE \| (MARK_KO & $nodemask);
228			($x, $y) = @{$capture[0]};
229			$board->[$x][$y] \|= MARK_KO & $nodemask;
230			}
231			}
232			}
233			}
234			} else {
235			$self->{last} = $set & MARK_B ? COLOUR_BLACK : COLOUR_WHITE;
236			}
237			}
238			}
239
240			=item $board->is_valid_move ($colour, $x, $y[, $may_suicide])
241
242			Returns true if the move of the given colour on the given coordinates is
243			valid or not.
244
245			=cut
246
247			sub is_valid_move {
248			my ($self, $colour, $x, $y, $may_suicide) = @_;
249
250			my $board = $self->{board};
251
252			return if $board->[$x][$y] & (MARK_B \| MARK_W \| MARK_KO);
253
254			if ($may_suicide) {
255			return 1;
256			} else {
257			my ($own, $opp) = $colour == COLOUR_BLACK
258			? (MARK_B, MARK_W)
259			: (MARK_W, MARK_B);
260
261			# try the move
262			local $board->[$x][$y] = $board->[$x][$y] \| $own;
263
264			return 1 if $x > 0 && $board->[$x-1][$y] & $opp && $self->capture ($opp, $x-1, $y, 1);
265			return 1 if $x < $self->{max} && $board->[$x+1][$y] & $opp && $self->capture ($opp, $x+1, $y, 1);
266			return 1 if $y > 0 && $board->[$x][$y-1] & $opp && $self->capture ($opp, $x, $y-1, 1);
267			return 1 if $y < $self->{max} && $board->[$x][$y+1] & $opp && $self->capture ($opp, $x, $y+1, 1);
268
269			return !$self->capture ($own, $x, $y, 1);
270			}
271			}
272
273			1;
274
275			=back
276
277			=head2 AUTHOR
278
279			Marc Lehmann <schmorp@schmorp.de>
280
281			=head2 SEE ALSO
282
283			L<KGS::Protocol>, L<KGS::Game::Tree>, L<Gtk2::GoBoard>.
284
285			=cut
286