March 2014 update

Task/Tic-tac-toe/Perl/tic-tac-toe.pl

@@ -0,0 +1,99 @@
+use warnings;
+use strict;
+
+my $initial = join ",", qw(abc def ghi);
+my %reverse = qw(X O O X);
+
+# In list context, returns best move,
+# In scalar context, returns the score of best move.
+my %cache;
+sub best_move {
+	my ($b, $me) = @_;
+	if( exists $cache{$b,$me,wantarray} ) {
+		return $cache{$b,$me,wantarray};
+	} elsif( my $s = score( $b, $me ) ) {
+		return $cache{$b,$me,wantarray} = (wantarray ? undef : $s);
+	}
+	my $him = $reverse{$me};
+	my ($best, @best) = (-999);
+	for my $m (moves($b)) {
+		(my $with_m = $b) =~ s/$m/$me/ or die;
+		# The || operator supplies scalar context to best_move(...)
+		my $s = -(score($with_m, $him) || best_move($with_m, $him));
+		if( $s > $best ) {
+			($best, @best) = ($s, $m);
+		} elsif( $s == $best ) {
+			push @best, $m;
+		}
+	}
+	$cache{$b,$me,wantarray} = wantarray ? $best[rand @best] : $best;
+}
+
+my $winner = q[([XOxo])(?:\1\1|...\1...\1|..\1..\1|....\1....\1)];
+sub score {
+	my ($b, $me) = @_;
+	$b =~ m/$winner/o or return 0;
+	return $1 eq $me ? +1 : -1;
+}
+
+sub moves {
+	my ($b) = @_;
+	$b =~ /([^xoXO,\n])/g;
+}
+
+sub print_board {
+	my ($b) = @_;
+	$b =~ s/\B/|/g;
+	$b =~ s/,/\n-+-+-\n/g;
+	print $b, "\n";
+}
+
+sub prompt {
+	my ($b, $color) = @_;
+	my @moves = moves($b);
+	unless( @moves ) {
+		return;
+	}
+	while( 1 ) {
+		print "Place your $color on one of [@moves]: ";
+		defined(my $m = <>) or return;
+		chomp($m);
+		return $m if grep $m eq $_, @moves;
+	}
+}
+
+my @players = (
+	{ whose => "your", name => "You",
+	  verb => "You place", get_move => \&prompt },
+	{ whose => "the computer's", name => "Computer",
+	  verb => "The computer places", get_move => \&best_move },
+);
+my $whose_turn = int rand 2;
+
+my $color = "X";
+my $b = $initial;
+
+while( 1 ) {
+	my $p = $players[$whose_turn];
+	print_board($b);
+	print "It is $p->{whose} turn.\n";
+	# The parens around $m supply list context to the right side
+	# or the = operator, which causes sub best_move to return the
+	# best move, rather than the score of the best move.
+	my ( $m ) = $p->{get_move}->($b, $color);
+	if( $m ) {
+		print "$p->{verb} an $color at $m\n";
+		$b =~ s/$m/$color/;
+		my $s = score($b, $color) or next;
+		print_board($b);
+		print "$p->{name} ", $s > 0 ? "won!\n" : "lost!\n";
+	} else {
+		print "$p->{name} cannot move.\n";
+	}
+	print "Game over.\nNew Game...\n";
+	($b, $color, $whose_turn) = ($initial, "X", int rand 2);
+	redo;
+} continue {
+	$color = $reverse{$color};
+	$whose_turn = !$whose_turn;
+}