File Coverage

blib/lib/Games/Goban.pm

Criterion	Covered	Total	%
statement	129	152	84.8
branch	40	54	74.0
condition	22	30	73.3
subroutine	24	31	77.4
pod	13	13	100.0
total	228	280	81.4

use strict;
use warnings;
package Games::Goban;
{
  $Games::Goban::VERSION = '1.102';
}
# ABSTRACT: Board for playing go, renju, othello, etc.

use 5.006;
use Carp;

my $ORIGIN     = ord('a');
my $piececlass = 'Games::Goban::Piece';

our %types = (
  go      => 1,
  othello => 2,
  renju   => 4,
  gomoku  => 4,
);

our %defaults = (
  game    => 'go',
  size    => 19,
  white   => 'Miss White',
  black   => 'Mr. Black',
  skip_i  => 0,
  referee => sub { 1 }
);


sub new {
  my $class = shift;
  my %opts = (%defaults, @_);

  unless (($opts{size} !~ /\D/) and ($opts{size} > 4) and ($opts{size} <= 26)) {
    croak "Illegal size $opts{size} (must be integer > 4)";
  }

  $opts{game} = lc $opts{game};
  croak "Unknown game $opts{game}" unless exists $types{ $opts{game} };

  my $board = bless {
    move        => 1,
    moves       => [],
    turn        => 'b',
    game        => $opts{game},
    size        => $opts{size},
    black       => $opts{black},
    white       => $opts{white},
    skip_i      => $opts{skip_i},
    referee     => $opts{referee},
    callbacks   => {},
    magiccookie => "a0000",
  }, $class;

  for (0 .. ($opts{size} - 1)) {
    push @{ $board->{board} }, [ (undef) x $opts{size} ];
  }
  $board->{hoshi} = $board->_calc_hoshi;

  return $board;
}


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

  my ($x, $y) = $self->_pos2grid($move, $self->skip_i);

  $self->_check_pos($move);
  my $stat = $self->{referee}->($self, $move);

  return $stat if !$stat;
  $self->{board}[$x][$y] = bless {
    colour => $self->{turn},
    move   => $self->{move},
    xy     => [ $x, $y ],
    board  => $self
    },
    "Games::Goban::Piece";
  push @{ $self->{moves} },
    {
    player => $self->{turn},
    piece  => $self->{board}[$x][$y]
    };
  $self->{move}++;
  $self->{turn} = $self->{turn} eq "b" ? "w" : "b";

  while (my ($key, $cb) = each %{ $self->{callbacks} }) { $cb->($key, $self) }

  return 1;
}


sub pass {
  my $self = shift;

  push @{ $self->{moves} },
    {
    player => $self->{turn},
    piece  => undef
    };
  $self->{move}++;
  $self->{turn} = $self->{turn} eq "b" ? "w" : "b";
}


sub get {
  my ($self, $pos) = @_;
  my ($x, $y) = $self->_pos2grid($pos, $self->skip_i);
  $self->_check_grid($x, $y);

  return $self->{board}[$x][$y];
}


sub size { $_[0]->{size} }


sub hoshi {
  my $self = shift;

  map { $self->_grid2pos(@$_, $self->skip_i) } @{ $self->{hoshi} };
}


sub is_hoshi {
  my $board = shift;
  my $point = shift;
  return 1 if grep { /^$point$/ } $board->hoshi;
}


sub as_sgf {
  my $self = shift;
  my $sgf;

  $sgf
    .= "(;GM[$types{$self->{game}}]FF[4]AP[Games::Goban]SZ[$self->{size}]PB[$self->{black}]PW[$self->{white}]\n";
  foreach (@{ $self->{moves} }) {
    $sgf .= q{;}
      . uc($_->{player}) . q<[>
      . ($_->{piece} ? $self->_grid2pos(@{ $_->{piece}->_xy }, 0) : q{}) . q<]>;
  }
  $sgf .= ")\n";

  return $sgf;
}


sub as_text {
  my $board = shift;
  my %opts  = @_;
  my @hoshi = $board->hoshi;
  my $text;
  for (my $y = $board->size - 1; $y >= 0; $y--) { ## no critic For
    $text .= substr($board->_grid2pos(0, $y, $board->skip_i), 1, 1) . ': '
      if $opts{coords};
    for my $x (0 .. ($board->size - 1)) {
      my $pos = $board->_grid2pos($x, $y, $board->skip_i);
      my $p = $board->get($pos);
      if (  $p
        and $p->move == $board->{move} - 1
        and $text
        and substr($text, -1, 1) ne "\n")
      {
        chop $text;
        $text .= "(";
      }
      $text .= (
        $p
        ? ($p->color eq "b" ? "X" : "O")
        : ($board->is_hoshi($pos) ? q{+} : q{.})
      ) . q{ };
      if ($p and $p->move == $board->{move} - 1) { chop $text; $text .= ")"; }
    }
    $text .= "\n";
  }
  if ($opts{coords}) {
    $text .= q{ } x 3;
    for (0 .. ($board->size - 1)) {
      $text .= substr($board->_grid2pos($_, 0, $board->skip_i), 0, 1) . q{ };
    }
    $text .= "\n";
  }
  return $text;
}


sub register {
  my ($board, $cb) = @_;
  my $key = ++$board->{magiccookie};
  $board->{callbacks}{$key} = $cb;
  $board->{notes}->{$key} = {};
  return $key;
}


sub notes {
  my ($board, $key) = @_;
  return $board->{notes}->{$key};
}


sub hash {
  my $board = shift;
  my $hash  = chr(0) x 91;
  my $bit   = 0;
  $board->_iterboard(
    sub {
      my $piece = shift;
      vec($hash, $bit, 2) = $piece->color eq "b" ? 1 : 2 if $piece;
      $bit += 3;
    }
  );
  return $hash;
}


sub skip_i { return (shift)->{skip_i} }

# This method accepts a position string and checks whether it is a valid
# position on the given board.  If it is, 1 is returned.  Otherwise, it carps
# that the position is not on the board.  It does this by calling _check_grid,
# also below.

sub _check_pos {
  my $self = shift;
  my $pos  = shift;

  my ($x, $y) = $self->_pos2grid($pos, $self->skip_i);

  return $self->_check_grid($x, $y);
}

sub _check_grid {
  my $self = shift;
  my ($x, $y) = @_;

  return 1
    if (($x < $self->size) and ($y < $self->size));

  croak "position '"
    . $self->_grid2pos($x, $y, $self->skip_i)
    . "' not on board";
}

# This method returns a list of the hoshi points that should be found on the
# board, given its size.

sub _calc_hoshi {
  my $self = shift;
  my $size = $self->size;
  my $half = ($size - 1) / 2;

  my @hoshi = ();

  if ($size % 2) { push @hoshi, [ $half, $half ]; }  # middle center

  my $margin = ($size > 11 ? 4 : ($size > 6 ? 3 : ($size > 4 ? 2 : undef)));

  return \@hoshi unless $margin;

  push @hoshi, (
    [ $margin - 1, $margin - 1 ],                    # top left
    [ $size - $margin, $margin - 1 ],                # top right
    [ $margin - 1, $size - $margin ],                # bottom left
    [ $size - $margin, $size - $margin ]             # bottom right
  );

  if (($size % 2) && ($size > 9)) {
    push @hoshi, (
      [ $half, $margin - 1 ],                        # top center
      [ $margin - 1, $half ],                        # middle left
      [ $size - $margin, $half ],                    # middle right
      [ $half, $size - $margin ]                     # bottom center
    );
  }

  return \@hoshi;
}

# This subroutine passes every findable square on the board to the supplied
# subroutine reference.

sub _iterboard {
  my ($self, $sub) = @_;
  for my $x ('a' .. chr($self->size + ord("a") - 1)) {
    for my $y ('a' .. chr($self->size + ord("a") - 1)) {
      $sub->($self->get("$x$y"));
    }
  }

}

# This method accepts an (x,y) position, starting with (0,0) and returns the
# 'xy' text representing it.
# The third parameter, if true, indicates that 'i' should be skipped.

sub _grid2pos {
  my $self = shift;
  my ($x, $y, $skip_i) = @_;

  if ($skip_i) {
    for ($x, $y) {
      $_++ if ($_ >= 8);
    }
  }

  return chr($ORIGIN + $x) . chr($ORIGIN + $y);
}

# This method accepts an 'xy' position string and returns the (x,y) indexes
# where that position falls in the board.
# The second parameter, if true, indicates that 'i' should be skipped.

sub _pos2grid {
  my $self = shift;
  my ($pos, $skip_i) = @_;

  my ($xc, $yc) = (lc($pos) =~ /^([a-z])([a-z])$/);
  my ($x, $y);

  $x = ord($xc) - $ORIGIN;
  $x-- if ($skip_i and ($x > 8));

  $y = ord($yc) - $ORIGIN;
  $y-- if ($skip_i and ($y > 8));

  return ($x, $y);
}

package Games::Goban::Piece;
{
  $Games::Goban::Piece::VERSION = '1.102';
}



sub color  { $_[0]->{colour} }
sub colour { $_[0]->{colour} }


sub notes { $_[0]->{notes}->{ $_[1] } }


sub position {
  my $piece = shift;

  ## no critic Private
  $piece->board->_grid2pos(@{ $piece->_xy }, $piece->board->skip_i);
}

sub _xy { $_[0]->{xy} }


sub move { $_[0]->{move} }


sub board { $_[0]->{board} }

1;

__END__