$board = [map {[map {'-'} 0..2]} 0..2];

sub game {
    clear($board);
    game_loop(@_);
}
sub game_loop {
    my ($player1, $player2) = @_;
    my $w;
    $player1->{put_stone}($player1->{stone});
    if ($w=check($board)) { return $w; }
    game_loop($player2,$player1);
}

sub put_stone_random {
    my $stone = shift;
    while (1) {
	my($r,$c) = (int rand @$board, int rand @$board);
	if (0<=$r and $r<@$board and
	    0<=$c and $c<@$board and
	    $board->[$r][$c] eq '-') {
	    $board->[$r][$c] = $stone;
	    last;
	}
    }
}
sub ps_prevent_losing { # ps :abbrev: put_stone
    my $stone = shift;
    my($r,$c) = pos_oppreach($board,$stone);
    if (defined($r) and defined($c)) {
	$board->[$r][$c] = $stone;
    } else {
	put_stone_random($stone);
    }
}
sub ps_grasp_chance {
    my $stone = shift;
    my($r,$c) = pos_oppreach($board,oppstone($stone));
    if (defined($r) and defined($c)) {
	$board->[$r][$c] = $stone;
    } else {
	ps_prevent_losing($stone);
    }
}
sub ps_smart {
    my $stone = shift;
    # ps_grasp_chance
    my($r,$c) = pos_oppreach($board,oppstone($stone));
    if (defined($r) and defined($c)) {
	$board->[$r][$c] = $stone;
	return;
    }
    # ps_prevent_losing
    ($r,$c) = pos_oppreach($board,$stone);
    if (defined($r) and defined($c)) {
	ps_prevent_losing($stone);
	return;
    }
    # attack dreach # dreach :abbrev: double reach
    ($r,$c) = pos_smart($board,$stone);
    if (defined($r) and defined($c)) {
	$board->[$r][$c] = $stone;
	return;
    }
    put_stone_random($stone);
}

sub pos_oppreach {
    my($board,$stone) = @_;
    my($r,$c);
    ($r,$c) = pos_oppreach_row($board,$stone);
    if (defined($r) and defined($c)) { return ($r,$c); }
    ($r,$c) = pos_oppreach_column($board,$stone);
    if (defined($r) and defined($c)) { return ($r,$c); }
    ($r,$c) = pos_oppreach_crossline($board,$stone);
    if (defined($r) and defined($c)) { return ($r,$c); }
    (undef, undef)
}
sub pos_oppreach_row {
    my($board,$stone) = @_;
    my @board_strs = join0s($board);
    for (0..(@$board-1)) {
	my $i = index_oppreach($board_strs[$_], $stone);
	if (defined($i)) {
	    return ($_, $i);
	}
    }
    (undef, undef);
}
sub pos_oppreach_column {
    my($board,$stone) = @_;
    my @board_strs = ($board->[0][0].$board->[1][0].$board->[2][0],
		      $board->[0][1].$board->[1][1].$board->[2][1],
		      $board->[0][2].$board->[1][2].$board->[2][2]);
    for (0..(@$board-1)) {
	my $i = index_oppreach($board_strs[$_], $stone);
	if (defined($i)) {
	    return ($i, $_);
	}
    }
    (undef, undef);
}
sub pos_oppreach_crossline {
    my($board,$stone) = @_;
    my @board_strs = get_crosslines($board);
    my $i = index_oppreach($board_strs[0], $stone);
    if (defined($i)) {
	return ($i,$i);
    }
    $i = index_oppreach($board_strs[1], $stone);
    if (defined($i)) {
	return (@$board-1-$i,$i);
    }
    (undef, undef);
}
sub index_oppreach { # test: index_oppreach('o-o', 'x') == 1
    my $s = $_[0];
    my $o = oppstone($_[1]);
    if ($o eq 'o') {
    	if ($s eq '-oo') { return 0; }
    	if ($s eq 'o-o') { return 1; }
    	if ($s eq 'oo-') { return 2; }
    } else { # $o eq 'o'
    	if ($s eq '-xx') { return 0; }
    	if ($s eq 'x-x') { return 1; }
    	if ($s eq 'xx-') { return 2; }
    }
    undef;
}
sub oppstone {
    $_[0] eq 'o' ? 'x' : $_[0] eq 'x' ? 'o' : undef;
}

my %ptn_pos_h;
{
    my $ptn_pos_href = {
	# play first
	'--- --- ---' => [0,0],
	'ox- --- ---' => [1,1], # [2,0] is also ok : [2,0] [1,0] [2,2]
	'ox- -o- --x' => [1,0], # dreach
	'o-x --- ---' => [2,0],
	'o-x x-- o--' => [2,2], # dreach
	'o-- --x ---' => [2,0], # dreach by gc
	'o-- --- --x' => [2,0],
	'o-- x-- o-x' => [0,2], # dreach ... same as 'o-x x-- o--'
	'o-- -x- ---' => [2,2],
	'o-x -x- --o' => [2,0], # dreach
	
   	# play second / first ps pos == (0 0)
	'o-- --- ---' => [1,1],
	'o-- -x- --o' => [2,1], # draw by gc
	'o-- -x- -o-' => [2,2], # dreach by gc 1/5 , draw by gc 4/5
   	# play second / first ps pos == (1 1)	
	'--- -o- ---' => [0,0],
	'x-- -o- --o' => [0,2], # draw by gc
   	# play second / first ps pos == (0 1)
	'-o- --- ---' => [0,0],
	'xoo --- ---' => [2,0],
	'xoo o-- x--' => [2,2], # dreach
	'xo- --o ---' => [2,0], # dreach by gc
	
	'xo- --- o--' => [1,1], # draw by gc
	
	'xo- o-- ---' => [2,1],
	'xoo o-- -x-' => [2,2], # dreach
	'xo- o-- ox-' => [0,2], # draw by gc
	'xo- o-- -xo' => [0,2], # draw by gc
	
	'xo- --- --o' => [1,1], # dreach by gc 1/5 , draw by gc 4/5
    };
    %ptn_pos_h = %$ptn_pos_href;
}
sub pos_smart { # assume: play first => 'o', play second => 'x', marubatsuptn
    my($board,$stone) = @_;
    for my $m (0..1) { # means: nflip
	for my $n (0..3) { # means: nrot
	    my $ptn = match_board(brott($n,bflipt($m,$board)));
	    if (defined $ptn) {
		#print "$ptn => @{$ptn_pos_h{$ptn}} : $m $n : debugwrite";
		return to_a(pflipt($m,prott(-$n,$ptn_pos_h{$ptn})));
	    }
	}
    }
    (undef, undef);
}
sub brott {
    my($n, $board) = @_;
    dotimes($n % 4, $board, \&brot);
}
sub bflipt {
    my($n, $board) = @_;
    dotimes($n % 2, $board, \&bflip);
}
sub pflipt {
    my($n, $pos) = @_;
    dotimes($n % 2, $pos, \&pflip);
}
sub prott {
    my($n, $pos) = @_;
    dotimes($n % 4, $pos, \&prot);
}
sub dotimes {
    my($n, $obj, $coderef) = @_;
    $n==0 ? $obj : dotimes($n-1, $coderef->($obj), $coderef);
}
sub brot {
    trans(bflip($_[0]));
}
sub bflip {
    [map {[reverse @$_];} @{$_[0]}];
}
sub pflip {
    my @b = @{$_[0]};
    $b[1] = 2 - $b[1]; # pos flip
    \@b;
}
sub prot {
    my @b = @{$_[0]};
    $b[0]-=1; $b[1]-=1;
    my @c = (-$b[1], $b[0]); # pos rot ... 90 degree
    $c[0]+=1; $c[1]+=1;
    \@c;
}
sub match_board {
  my $board_str = join(' ', join0s(shift));
  my @mp = grep { $board_str eq $_; } keys %ptn_pos_h;
  (scalar @mp) ? $mp[0] : undef;
}
sub to_a {
    @{$_[0]};
}

sub check {
    my @b = @{$_[0]};
    my $w;
    # check rows
    for my $r (0..2) {
	my $l = $b[$r]->[0]; # abbrev: left of board
	if ($l ne'-' and $l eq$b[$r]->[1] and $l eq$b[$r]->[2]) { return $l; }
    }
    # check columns
    for my $c (0..2) {
	my $t = $b[0]->[$c]; # abbrev: top of board
	if ($t ne'-' and $t eq$b[1]->[$c] and $t eq$b[2]->[$c]) { return $t; }
    }
    # check crosslines
    my $p = $b[0]->[0]; # abbrev: pos
    if ($p ne'-' and $p eq$b[1]->[1] and $p eq$b[2]->[2]) { return $p; }
    $p = $b[2]->[0];
    if ($p ne'-' and $p eq$b[1]->[1] and $p eq$b[0]->[2]) { return $p; }
    # check draw
    if (filledp(\@b)) { return 'D'; } # means: draw
    undef;
}

sub join0s {
    my @b = @{$_[0]};
    my @a;
    $a[0] = join '', @{$b[0]};
    $a[1] = join '', @{$b[1]};
    $a[2] = join '', @{$b[2]};
    @a;
    # map {join '', @$_} @{$_[0]};
}
sub trans {
    my $m = shift;
    my $n = [];
    for my $r (0..2) {
	for my $c (0..2) {
	    $n->[$c][$r] = $m->[$r][$c];
	}
    }
    $n;
}
sub get_crosslines {
    my $b = shift;
    join0s [[map {$b->[      $_][$_]} 0..(@$b-1)],
	    [map {$b->[@$b-1-$_][$_]} 0..(@$b-1)]];
}
sub filledp {
    my $b = shift;
    for my $r (0..(@$b-1)) {
	for my $c (0..(@{$b->[$r]}-1)) {
	    if ($b->[$r][$c] eq '-') { return 0; }
	}
    }
    1;
}

# utilities
sub clear {
    my $b = shift;
    for my $r (0..(@$b-1)) {
	for my $c (0..(@{$b->[$r]}-1)) {
	    $b->[$r][$c] = '-';
	}
    }
}

################### run game ###################

$gc = 0; # abbrev: game count

sub game_times {
    my($player1,$player2,$ngame) = @_;
    my %wc;
    print "***** $player1 vs $player2 *****\n";
    print "game ", $gc+1, "..", $gc+$ngame, "\n";
    $gc += $ngame;
    for (1..$ngame) {
	my $w = game({put_stone=>\&$player1, stone=>'o'},
		     {put_stone=>\&$player2, stone=>'x'});
	$wc{$w}++;
    }
    while (my($k,$v) = each(%wc)) {
	print "$k=>$v ";
    }
    print "\n";    
}

$ngame = 10000;
game_times('ps_smart', 'put_stone_random', $ngame);
game_times('put_stone_random', 'ps_smart', $ngame);
game_times('ps_smart', 'ps_smart', 100);