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-structure...])

Structure is

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

and 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.

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.1
Committed:	Sun Jun 22 15:05:59 2008 UTC (18 years, 2 months ago) by root
Branch:	MAIN
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			=item $hint = $board->update ([update-structure...])
135
136			Structure is
137
138			[$x, $y, $clr, $set, $label, $hint] # update or move
139			[] # pass
140
141			and changes the board or executes a move, by first clearing the bits
142			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			Example, make two silly moves:
154
155			$board->update ([[0, 18, -1, MARK_B\|MARK_MOVE],
156			[0, 17, -1, MARK_W\|MARK_MOVE]);
157
158			=cut
159
160			sub update {
161			my ($self, $path) = @_;
162
163			my $board = $self->{board};
164
165			for (@$path) {
166			my ($x, $y, $clr, $set, $label) = @$_;
167
168			my $nodemask =
169			$_ == $path->[-1]
170			? ~0
171			: ~(MARK_SQUARE \| MARK_TRIANGLE \| MARK_CIRCLE \| MARK_LABEL \| MARK_KO);
172
173			if (defined $x) {
174			$board->[$x][$y] =
175			$board->[$x][$y]
176			& ~$clr
177			\| $set
178			& $nodemask;
179
180			$self->{label}[$x][$y] = $label if $set & MARK_LABEL;
181
182			if ($set & MARK_MOVE) {
183			$self->{last} = $set & MARK_B ? COLOUR_BLACK : COLOUR_WHITE;
184
185			unless (${ $_->[5] \|\|= \my $hint }) {
186			my ($own, $opp) =
187			$set & MARK_B
188			? (MARK_B, MARK_W)
189			: (MARK_W, MARK_B);
190
191			my (@capture, $suicide);
192
193			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;
195			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;
197
198			# keep only unique coordinates
199			@capture = do { my %seen; grep !$seen{"$_->[0],$_->[1]"}++, @capture };
200
201			# remove captured stones
202			$self->{captures}[$self->{last}] += @capture;
203			$self->{board}[$_->[0]][$_->[1]] &= ~(MARK_B \| MARK_W \| MARK_MOVE)
204			for @capture;
205
206			$suicide += $self->capture ($own, $x, $y);
207
208			${ $_->[5] } \|\|= !(@capture \|\| $suicide);
209
210			if (!$suicide && @capture == 1) {
211			# possible ko. now check liberties on placed stone
212
213			my $libs;
214
215			$libs++ if $x > 0 && !($board->[$x-1][$y] & $opp);
216			$libs++ if $x < $self->{max} && !($board->[$x+1][$y] & $opp);
217			$libs++ if $y > 0 && !($board->[$x][$y-1] & $opp);
218			$libs++ if $y < $self->{max} && !($board->[$x][$y+1] & $opp);
219
220			if ($libs == 1) {
221			$board->[$x][$y] = $board->[$x][$y] & ~MARK_CIRCLE \| (MARK_KO & $nodemask);
222			($x, $y) = @{$capture[0]};
223			$board->[$x][$y] \|= MARK_KO & $nodemask;
224			}
225			}
226			}
227			}
228			} else {
229			$self->{last} = $set & MARK_B ? COLOUR_BLACK : COLOUR_WHITE;
230			}
231			}
232			}
233
234			=item $board->is_valid_move ($colour, $x, $y[, $may_suicide])
235
236			Returns true if the move of the given colour on the given coordinates is
237			valid or not.
238
239			=cut
240
241			sub is_valid_move {
242			my ($self, $colour, $x, $y, $may_suicide) = @_;
243
244			my $board = $self->{board};
245
246			return if $board->[$x][$y] & (MARK_B \| MARK_W \| MARK_KO);
247
248			if ($may_suicide) {
249			return 1;
250			} else {
251			my ($own, $opp) = $colour == COLOUR_BLACK
252			? (MARK_B, MARK_W)
253			: (MARK_W, MARK_B);
254
255			# try the move
256			local $board->[$x][$y] = $board->[$x][$y] \| $own;
257
258			return 1 if $x > 0 && $board->[$x-1][$y] & $opp && $self->capture ($opp, $x-1, $y, 1);
259			return 1 if $x < $self->{max} && $board->[$x+1][$y] & $opp && $self->capture ($opp, $x+1, $y, 1);
260			return 1 if $y > 0 && $board->[$x][$y-1] & $opp && $self->capture ($opp, $x, $y-1, 1);
261			return 1 if $y < $self->{max} && $board->[$x][$y+1] & $opp && $self->capture ($opp, $x, $y+1, 1);
262
263			return !$self->capture ($own, $x, $y, 1);
264			}
265			}
266
267			1;
268
269			=back
270
271			=head2 AUTHOR
272
273			Marc Lehmann <schmorp@schmorp.de>
274
275			=head2 SEE ALSO
276
277			L<KGS::Protocol>, L<KGS::Game::Tree>, L<Gtk2::GoBoard>.
278
279			=cut
280