File Coverage

blib/lib/Games/Shogi.pm

Criterion	Covered	Total	%
statement	10	22	45.4
branch	0	2	0.0
condition	0	3	0.0
subroutine	4	7	57.1
pod			n/a
total	14	34	41.1

package Games::Shogi;

use strict;
use warnings;
use vars qw($VERSION);

$VERSION = '0.03';

sub size() { 9 }
sub promotion_zone() { 3 }
sub allow_drop() { 1 }
sub capture() { ['K'] }

# {{{ Board static data
my @board = (
    #    9 8 7 6 5 4 3 2 1
    [qw( L N S G K G S N L )],   # a
    [qw( _ R _ _ _ _ _ B _ )],   # b
    [qw( P P P P P P P P P )],   # c
    [qw( _ _ _ _ _ _ _ _ _ )],   # d
    [qw( _ _ _ _ _ _ _ _ _ )],   # e
    [qw( _ _ _ _ _ _ _ _ _ )],   # f
    [qw( p p p p p p p p p )],   # g
    [qw( _ b _ _ _ _ _ r _ )],   # h
    [qw( l n s g k g s n l )] ); # i
# }}}

# {{{ Pieces
my $pieces = {
  # {{{ Bishop
  b => {
    name => 'Bishop',
    romaji => 'kakugyo',
    promote => 'dh',
    neighborhood => [
      q(     ),
      q( \ / ),
      q(  ^  ),
      q( / \ ),
      q(     ) ] },
  # }}}
  # {{{ Gold General
  g => {
    name => 'Gold General',
    romaji => 'kinsho',
    neighborhood => [
      q(     ),
      q( ooo ),
      q( o^o ),
      q(  o  ),
      q(     ) ] },
  # }}}
  # {{{ King
  k => {
    name => 'King',
    romaji => 'osho',
    neighborhood => [
      q(     ),
      q( ooo ),
      q( o^o ),
      q( ooo ),
      q(     ) ] },
  # }}}
  # {{{ Knight
  n => {
    name => 'Knight',
    romaji => 'keima',
    promote => 'g',
    neighborhood => [
      q( x x ),
      q(     ),
      q(  ^  ),
      q(     ),
      q(     ) ] },
  # }}}
  # {{{ Lance
  l => {
    name => 'Lance',
    romaji => 'kyosha',
    promote => 'g',
    neighborhood => [
      q(     ),
      q(  |  ),
      q(  ^  ),
      q(     ),
      q(     ) ] },
  # }}}
  # {{{ Pawn
  p => {
    name => 'Pawn',
    romaji => 'fuhyo',
    promote => '+p',
    neighborhood => [
      q(     ),
      q(  o  ),
      q(  ^  ),
      q(     ),
      q(     ) ] },
  # }}}
  # {{{ Rook
  r => {
    name => 'Rook',
    romaji => 'hisha',
    promote => 'dk',
    neighborhood => [
      q(     ),
      q(  |  ),
      q( -^- ),
      q(  |  ),
      q(     ) ] },
  # }}}
  # {{{ Silver General
  s => {
    name => 'Silver General',
    romaji => 'ginsho',
    neighborhood => [
      q(     ),
      q( ooo ),
      q(  ^  ),
      q( o o ),
      q(     ) ] },
  # }}}

  # {{{ Dragon Horse
  dh => {
    name => 'Dragon Horse',
    romaji => 'ryume',
    neighborhood => [
      q(     ),
      q( \o/ ),
      q( o^o ),
      q( /o\ ),
      q(     ) ] },
  # }}}
  # {{{ Dragon King
  dk => {
    name => 'Dragon King',
    romaji => 'ryuo',
    neighborhood => [
      q(     ),
      q( o|o ),
      q( -^- ),
      q( o|o ),
      q(     ) ] },
  # }}}
  # {{{ Promoted Pawn
  '+p' => {
    name => 'Promoted Pawn',
    romaji => 'tokin',
    neighborhood => [
      q(     ),
      q( ooo ),
      q( o^o ),
      q(  o  ),
      q(     ) ] },
  # }}}
};
# }}}

# {{{ new
sub new {
  my $proto = shift;
  my $self = { pieces => $pieces };
  bless $self, ref($proto) || $proto;
  $self->{board} = $self->initial_board(\@board);
  return $self }
# }}}

# {{{ initial_board
sub initial_board {
  my ($self,$board) = @_;

  return [ map { [ map { $_ eq '_' ? undef : $_ } @$_ ] } @$board ] }
# }}}

# {{{ neighbor
sub neighbor {
  my ($self,$piece) = @_;
  return unless $self->{pieces}->{lc $piece};

  my $reverse = {
    U => 'D', D => 'U', R => 'L', L => 'R',
    u => 'd', d => 'u', r => 'l', l => 'r',
  };
  my @dir_map = (
    [qw( uuulll  uuull uuul uuu uuur uuurr uuurrr)],
    [qw(  uulll   uull  uul  uu uur  uurr  uurrr )],
    [qw(   ulll    ull   ul  u  ur   urr   urrr  )],
    [qw(    lll     ll    l  _  r    rr    rrr   )],
    [qw(   dlll    dll   dl  d  dr   drr   drrr  )],
    [qw(  ddlll   ddll  ddl dd  ddr  ddrr  ddrrr )],
    [qw( dddlll  dddll dddl ddd dddr dddrr dddrrr)] );
  my $dir_center = int(@dir_map/2);

  my $desc = $self->{pieces}->{lc $piece}{neighborhood};
  my @foo = map { [ split // ] } @$desc;
  my $center = int(@$desc/2);
  my $neighbors = [];

  for my $dx (-$center..+$center) {
    for my $dy (-$center..+$center) {
      next if $dx == 0 and $dy == 0; # Center
      my $move = $foo[$center+$dx][$center+$dy];
      if($move =~ /\d/) {
        my $td = $dir_map[$dir_center+$dx][$dir_center+$dy];
        if($td=~/(\w)(\w)/) {
          push @$neighbors,$1 x $move.$2 x $move }
        else {
          push @$neighbors,$td x $move } }
      elsif($move =~ /[xo]/) {
        push @$neighbors,$dir_map[$dir_center+$dx][$dir_center+$dy] }
      elsif($move =~ m{[-|\\/]} and abs($dx) < 2 and abs($dy) < 2) {
        push @$neighbors,uc $dir_map[$dir_center+$dx][$dir_center+$dy] }
      elsif($move =~ m{[-|\\/]}) { $neighbors->[-1] .= '*' } } }
use YAML;die Dump($neighbors) if lc $piece eq 'do';

 return [ map { s/([udlrUDLR])/$reverse->{$1}/g; $_ } @$neighbors ]
   if uc $piece eq $piece;
 return $neighbors }
# }}}

sub board { return shift->{board} }
sub english_name { return shift->{pieces}{lc shift()}{name} }
sub japanese_name { return shift->{pieces}{lc shift()}{romaji} }
sub promote { return shift->{pieces}{lc shift()}{promote} }

1;
__END__