Data commit

Task/Tic-tac-toe/Perl/tic-tac-toe-1.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;
+}

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

@@ -0,0 +1,72 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Tk;
+use List::Util qw( shuffle );
+
+my $win = qr/(?| ^(\w)...\1...\1 | ^..(\w).\1.\1   # diagonals
+  | ^(?:...)*?(\w)\1\1 | (\w)..\1..\1 )/x;         # row or column
+my (%cache, $message, $game);
+
+my $mw = MainWindow->new( -title => 'TicTacToe' );
+$mw->geometry('+1000+300');
+$mw->Label(-textvariable => \$message, -font => 'courierbold 16',
+  )->pack(-fill => 'x');
+my $grid = $mw->Frame( -borderwidth => 5, -relief => 'ridge' )->pack;
+$mw->Button(-text => $_->[0], -command => $_->[1],
+  )->pack(-side => 'left', -fill => 'x', -expand => 1) for
+  ['Restart X first' => sub { restart(1) }],
+  ['Restart O first' => sub { restart(0) }],
+  [           'Exit' => sub { $mw->destroy }];
+my @cells = map { my $me = $_;
+  $grid->Button( -command => sub { person($me) },
+    -width => 1, -height => 1, -font => 'courierbold 40',
+    )->grid(-row => int $_ / 3, -column => $_ % 3)
+  } 0 .. 8;
+
+restart(1);
+
+MainLoop;
+
+sub show { $cells[$_]->configure(-text => substr $game, $_, 1) for 0 .. 8 }
+
+sub person
+  {
+  $message =~ /O's turn/ or return;
+  pos($game) = shift();
+  if( $game =~ s/\G /O/ )
+    {
+    $message = $game =~ $win ? "O Wins" :
+      $game !~ / / ? "Draw" : do {
+        $game = move( $game, 'X' )->[1];
+        $game =~ $win ? 'X Wins' :
+          $game !~ / / ? 'Draw' : "O's turn to move"
+      };
+    show;
+    }
+  }
+
+sub restart
+  {
+  %cache = ();
+  $game = shift() ? move( ' ' x 9, 'X' )->[1] : ' ' x 9;
+  show;
+  $message = "O's turn to move";
+  }
+
+sub move
+  {
+  (local $_, my $who, my @moves) = @_;
+  /$win/ and return [ 2 * ($1 eq 'X'), $_ ];
+  / / or return [ 1, $_ ];
+  $cache{$_ . $who} //= do
+    {
+    while( / /g )
+      {
+      my $move = "$`$who$'";
+      push @moves, [ move($move, $who ^ 'X' ^ 'O')->[0], $move ];
+      }
+    (sort {$a->[0] <=> $b->[0]} shuffle @moves)[ -($who eq 'X') ]
+    };
+  }