#! /usr/local/bin/perl
# Author: Peter Loeb 1995
# revised July 1999
# This perl program, along with tform.html and six small graphics work together to
# make a tic-tac-toe game for the web.
#
# I use this convention for the board:
#
# 1 | 2 | 3
# - + - + -
# 4 | 5 | 6
# - + - + -
# 7 | 8 | 9
#
# The tir array (see the settir subroutine) names the various "rows"
# The cmb array (see the setcmb subroutine) names the "double play" possibilities
#
# subroutine declarations
sub figmov;
sub dp;
sub getbx;
sub some_in_row;
sub settir;
sub setcmb;
sub applmov;
sub gamovr;
sub one_gif;
sub one_box;
sub hsep;
sub one_row;
sub drawbrd;
sub countem;
sub makmov;
# subroutines
# **********************************************************************************
#
# subroutine: figmov
#
# **********************************************************************************
sub figmov {
# takes three arguments: pos (9 byte string), my color, and opponent's color (X or O)
# returns new mov (or 0 if error)
#
# local variables:
# $cps - picks up the first argument. This is the "board", a nine character string.
# $wm - picks up the second argument. This is "X" or "O", played by the program.
# $om - picks up the third argument. This is "X" or "O", played by the opponent (user).
# $i - a "work" variable; used to hold intermediate results temporarily.
# $xt - a "work" variable; used to hold intermediate results temporarily.
my ($cps, $wm, $om) = @_;
my $i, $xt;
# if only one blank, then move there!
$i = $cps =~ tr/ / /;
if ($i == 1) {
$i = index($cps," ");
return $i+1;
}
# have any moves been made?
if ($cps !~ /$wm/) { # have I not moved yet?
if ($cps !~ /$om/) { # has opp not moved yet?
$i = int(9 * rand) + 1; # nobody has moved; make a random move
return $i;
}
else { # opponent has moved, but I haven't yet
$i = index($cps,$om); # find opp's move
if ($i == 4) { # if opp moved in center
$i = int(4 * rand); # then move to random corner
my @t = (1, 3, 7, 9);
return $t[$i];
}
else { # opp moved, but not to center; move to center
return 5;
}
}
}
# if I have two in a row, then finish three in row (win)
$xt = &some_in_row($wm,$cps,2);
if ($xt > 0) {
return $xt;
}
# if opp has two in a row, then finish three in row (block)
$xt = &some_in_row($om,$cps,2);
if ($xt > 0) {
return $xt;
}
# check "trick" position
if (($cps eq 'X O X') || ($cps eq ' X O X ')) { # if "trick" position
$i = int(4 * rand); # then move to random side
my @t = (2, 4, 6, 8);
return $t[$i];
}
# see if I have "double-play" opportunity
$xt = &dp($wm,$cps,"D");
if ($xt > 0) {
return $xt;
}
# see if opp has "double-play" opportunity
$xt = &dp($om,$cps,"D");
if ($xt > 0) {
return $xt;
}
# look for "next-move" double play
$xt = &dp($wm,$cps,"N");
if ($xt > 0) {
return $xt;
}
# look for opp "next-move" double play
$xt = &dp($om,$cps,"N");
if ($xt > 0) {
return $xt;
}
# look for one in row
$xt = &some_in_row($wm,$cps,1);
if ($xt > 0) {
return $xt;
}
# look for opp one in row
$xt = &some_in_row($om,$cps,1);
if ($xt > 0) {
return $xt;
}
# return random blank
my @r;
foreach ($i = 0; $i < 9; $i ++) {
if (substr($cps,$i,1) eq " ") {
$r[++$#r] = $i + 1;
}
}
$i = int($#r * rand); # then move to random blank
return $r[$i];
};
# **********************************************************************************
#
# subroutine: dp
#
# **********************************************************************************
sub dp {
# look for "double play"
# arguments:
# $zm - "X" or "O"; which color we are looking at
# $brd - board
# $nd - "D" double play on this move or "N" double play on next move
my ($zm, $brd, $nd) = @_;
my $i, $j, @s, $xm, $c, $d;
$xm = $zm;
$xm =~ tr/XO/OX/; # make xm opposite of zm
# look at each combination
foreach $i (0 .. 21) {
# set $s to the board contents corresponding to the elements of the combination
foreach $j (0 .. 4) {
$s[$j] = substr($brd,$cmb[$i][$j]-1,1);
}
if ($s[0] eq " ") { # if the "common" square is blank
if ($nd eq "D") { # if we are looking at this move
$c = &countem($zm, $xm, $s[1], $s[2]);
$d = &countem($zm, $xm, $s[3], $s[4]);
if (($c eq 1) && ($d eq 1)) { # if both rows of combination have one
return $cmb[$i][0]; # then move at "common" square
}
}
elsif ($nd eq "N") { # we are looking at next move
$c = &countem($zm,$xm,$s[1],$s[2],$s[3],$s[4]); # count how many
if ($c eq 1) { # if one
$d = &getbx($i,$s[1],$s[2],$s[3],$s[4]);
return $d;
}
}
}
}
return 0;
};
# **********************************************************************************
#
# subroutine: getbx
#
# **********************************************************************************
sub getbx {
# return move to make double play possibility
# arguments:
# $i - combination number (index into $cmb)
# $s1 - contents of board for $cmb[$i][1]
# $s2 - contents of board for $cmb[$i][2]
# $s3 - contents of board for $cmb[$i][3]
# $s4 - contents of board for $cmb[$i][4]
# keep in mind that the nature of $cmb is such that s1 and s2 form a row with s0 and so do s3 and s4.
# when we enter this routine, we know that s0 is blank and one of s1-s4 has the color we want.
# we want to find the row which has nothing filled in, yet. then pick one from that row.
my ($i,$s1, $s2, $s3, $s4) = @_;
if ($s1 eq " " && $s2 eq " ") { # if the "s1,s2" row is all blank
return $cmb[$i][1]; # then move to s1
}
elsif ($s4 eq " " && $s3 eq " ") { # if the "s3,s4" row is all blank
return $cmb[$i][3]; # then move to s3
}
else {
print "
error in getbx; $i $s1 $s2 $s3 $s4\n";
}
return 0;
};
# **********************************************************************************
#
# subroutine: some_in_row
#
# **********************************************************************************
sub some_in_row {
# return the move number for a blank in a row which has the requested number filled
# arguments:
# $qm - color ("X" or "O")
# $brd - board
# $n - requested number
# logic:
# look for a row with $n squares filled with $qm and the other squares blank
my ($qm, $brd, $n) = @_;
my $i, $j, @s, $xm;
# set $xm to be the opposite of $qm
$xm = $qm;
$xm =~ tr/XO/OX/;
foreach $i (0 .. 7) { # for each set in $tir
foreach $j (0 .. 2) { # for each element in the set
$s[$j] = substr($brd,$tir[$i][$j]-1,1); # $s contains the board contents for the set
}
if (&countem($qm, $xm, @s) == $n) { # if $s contains the requested number
foreach $j (0 .. 2) { # for each element in the set
if ($s[$j] eq " ") { # if the element is blank
return $tir[$i][$j]; # return the move
}
}
}
}
return 0; # no row has the right configuration, return 0
};
# **********************************************************************************
#
# subroutine: settir
#
# **********************************************************************************
sub settir {
# set the "tir" (three in_a row) array. each three-element "set" (within square brackets)
# represents a "row" either vertical, horizontal, or diagonal.
# the order within the set is irrelevant; [1,2,3]=[3,2,1]=[2,3,1], etc.
# to the best of my knowlege, all rows are accounted for.
@tir = (
[1, 2, 3],
[4, 5, 6],
[7, 8, 9],
[1, 4, 7],
[2, 5, 8],
[3, 6, 9],
[1, 5, 9],
[3, 5, 7],
);
};
# **********************************************************************************
#
# subroutine: setcmb
#
# **********************************************************************************
sub setcmb {
# each "set" of five numbers in the cmb array represents two "rows" (as described in
# the "tir" array) with one square in common. The first element of each set is the
# "common" element. Thus, the two rows consist of the 1st, 2nd, 3rd; and the 1st, 4th
# 5th. This makes it easier to spot "double plays". (see the dp subroutine).
@cmb = (
[1,2,3,4,7],
[2,1,3,5,8],
[3,1,2,6,9],
[1,2,3,5,9],
[3,1,2,5,7],
[4,5,6,1,7],
[5,4,6,2,8],
[6,4,5,3,9],
[5,4,6,1,9],
[5,4,6,3,7],
[7,8,9,1,4],
[8,7,9,2,5],
[9,7,8,3,6],
[9,7,8,1,5],
[7,8,9,3,5],
[1,4,7,5,9],
[7,1,4,3,5],
[5,4,6,1,9],
[5,4,6,3,7],
[9,3,6,1,5],
[3,6,9,5,7],
[5,1,9,3,7],
);
};
# **********************************************************************************
#
# subroutine: applmov
#
# **********************************************************************************
sub applmov {
# apply a move to a board; return the updated board
# arguments:
# $brd - the board
# $mv - the move (1-9) to apply
# $cl - the color ("X" or "O") to apply
my ($brd, $mv, $cl) = @_; # pick up args
substr($brd,$mv-1,1) = $cl; # set the square to the required color
return $brd; # return the updated board
};
# **********************************************************************************
#
# subroutine: gamovr
#
# **********************************************************************************
sub gamovr {
# determine whether or not the game is over, and if so who won
# argument: board
# return values:
# 0 - game not yet over
# 1 - "X" wins
# 2 - "O" wins
# 3 - tie; game over, but nobody wins
my $xbor = shift(@_);
my $i, $j, @tb, $xxs, @s, $gflg;
foreach $i (0 .. 7) { # for each "row" (tir)
foreach $j (0 .. 2) { # for each element in row
$s[$j] = substr($xbor,$tir[$i][$j]-1,1); # set $s to board values for that row
}
if ($s[0] eq $s[1] && $s[1] eq $s[2]) { # if all equal
if ($s[1] eq "X") { # if "X" then
return 1; # return 1
}
elsif ($s[1] eq "O") { # if "O" then
return 2; # return 2
}
}
}
# we have looked at all "rows" and not found a winner.
# now check and see if there are any squares left to play
$gflg = $xbor =~ tr/ / /; # count blanks
if ($gflg == 0) { # if none then
return 3; # return 3
}
# the game is not yet over, so return 0
return 0;
};
# **********************************************************************************
#
# subroutine: one_gif
#
# **********************************************************************************
sub one_gif {
# create (and output) the html for one image
# argument:
# $ch - "c" (center), "h" (horizontal), or "v" vertical
# the graphic files are linc.gif, linh.gif and linv.gif
my $ch = shift(@_); # get the argument
my $c = $ch; # copy the arg
$c =~ tr/hvc/-|+/; # set up for the "alt"
print "\n";
};
# **********************************************************************************
#
# subroutine: one_box
#
# **********************************************************************************
sub one_box {
# create and output the html for one square (or box)
# arguments:
# $ch - the character ("X", "O", or " ") to represent
# $px - the board
# $p - the position of the character within the board
# $f - 0 or 1; zero means that the square (blank) should not be a link, while
# one means that it should be a link.
my ($ch, $px, $p, $f) = @_;
my $gfil, $glin, $c;
$c = $ch; # make $c the opposite color from $ch
$c =~ tr/XO /XO_/;
$px =~ s/ /B/g; # change "B"s to blanks
if ($ch eq "X") { # do "X"; display sqx.gif
$gfil = "sqx.gif";
$glin = "\n";
}
elsif ($ch eq "O") { # do "O"; display sqo.gif
$gfil = "sqo.gif";
$glin = "\n";
}
elsif ($ch eq " ") { # do " "; display sqb.gif, but see whether or not it will be a link
$gfil = "sqb.gif"; # set $gfil
if ($f == 1) { # if square is to be link
# this is where the position (board) and the move are passed to the next invocation
$glin = "\n";
}
elsif ($f == 0) { # if square is not link (like at the end of game)
$glin = "";
}
else { # something is wrong, here
print "
error in one_box; f=$f\n";
}
}
else { # something is wrong, here
print "
error in one_box $ch $pos $p $px\n";
}
print $glin; # display the line
};
# **********************************************************************************
#
# subroutine: hsep
#
# **********************************************************************************
sub hsep {
# create and output the horizontal lines between rows of squares (boxes)
print "
\n";
&one_gif("h"); # display horizontal line
&one_gif("c"); # display little connector
&one_gif("h"); # display horizontal line
&one_gif("c"); # display little connector
&one_gif("h"); # display horizontal line
print "
\n";
};
# **********************************************************************************
#
# subroutine: one_row
#
# **********************************************************************************
sub one_row {
# create and output one horizontal "row"
# arguments:
# $strt - 1, 4, or 7 - starting position within board
# $brd - board
# $g - whether (1) or not (0) to display blank squares as links
my ($strt, $brd, $g) = @_;
my ($i, $c);
print "
\n";
for ($i = 1; $i <= 3; $i ++) { # for each square in row
$c = substr($brd,$strt + $i - 2,1); # get character ("X", "O", or "B")
&one_box($c,$brd,$strt + $i - 1,$g); # call one_box to display graphic for square
if ($i < 3) { # if not at end of row then
&one_gif("v"); # display vertical separator
}
}
print "
\n";
};
# **********************************************************************************
#
# subroutine: drawbrd
#
# **********************************************************************************
sub drawbrd {
# draw the board
# arguments:
# $brd - board
# $msg - message to display
# $h - show blank squares as links (1) or not (0)
my ($brd, $msg, $h) = @_;
# do html stuff including message
print "Tic Tac Toe\n";
print "
\n";
};
# **********************************************************************************
#
# subroutine: countem
#
# **********************************************************************************
sub countem {
# arguments
# $col - color ("X" or "O") program is playing
# $oppcol - color ("X" or "O") opponent is playing
# @vals - all other arguments; this is a variable number, but is probably 2 or 5
# logic:
# if any of the @vals contain $oppcol, return -1
# return the number of $col found within @vals
my ($col, $oppcol, @vals) = @_; # pick up arguments
my $i, $vs;
# concatenate @vals elements into a simple scalar $vs
$vs = "";
foreach $i (0 .. $#vals) {
$vs .= $vals[$i];
}
# if any $oppcol then return -1
if ($vs =~ /$oppcol/) {
return -1;
}
# return number of $col found in $vs
$_ = $vs; # set default for eval
$i = eval"tr/$col/$col/"; # count
if ($@) { # check for errors
print "
$@\n";
}
return $i; # return count
};
# **********************************************************************************
#
# subroutine: dofinal
#
# **********************************************************************************
sub dofinal {
# end of game processing
# arguments:
# $brd - board
# $gm - return code from gamovr (1 - "X" wins, 2 - "O" wins, 3 - tie)
# $mc - color ("X" or "O") played by program
# $oc - color ("X" or "O") played by opponent (user)
my ($brd, $gm, $mc, $oc) = @_;
my $xmsg;
if ($gm == 1) { # "X" wins
if ($mc eq "X") { # I'm playing "X"
$xmsg = "you lose!"; # therefore you lose
}
else { # I'm playing "O"
$xmsg = "you win!"; # therefore you win
}
}
elsif ($gm == 2) { # "O" wins
if ($oc eq "X") { # you are playing "X"
$xmsg = "you lose!"; # therefore you lose
}
else { # you are playing "O"
$xmsg = "you win!"; # therefore you win
}
}
else { # tie
$xmsg = "no one wins!";
}
&drawbrd($brd,$xmsg,0); # go draw the board with the results and no links
};
# **********************************************************************************
#
# subroutine: makmov
#
# **********************************************************************************
sub makmov {
# make a move
# arguments:
# $br - board
# $m - position of opponent's move within the board
my ($br, $m) = @_;
my $gm, $mc, $oc, $x, $o, $c, $xbr, $d;
# translate blanks to "B"s
$br =~ s/B/ /g;
# now let's figure out who is playing what color. note that the board represents
# the position before the opponents move has been applied!
$x = $br =~ tr/X/X/; # count "X"s
$o = $br =~ tr/O/O/; # count "O"s
if ($x == $o) { # if counts are the same
$mc = "O"; # then I'm playing "O"
$oc = "X"; # and opponent is playing "X"
}
elsif ($x == $o+1) { # if one more "X" than "O"
$mc = "X"; # then I'm playing "X"
$oc = "O"; # and opponent is playing "O"
}
else { # error
print "
error-bad number of x\'s and o\'s: $x $o $br\n";
};
# let the game begin
if (length($br) != 9) {
print "
board invalid length\n";
}
$d = $m - 1; # translate position to offset within board
$c = substr($br,$d,1); # $c is the character at that position
if ($c ne " ") { # if it is not blank, then we have a problem
$xbr = $br;
$xbr =~ s/ /B/g;
print "
makmov opp move invalid: $xbr, $m, $c, $d\n";
}
$br = &applmov($br,$m,$oc); # apply opponent's move to the board
$gm = &gamovr($br); # check for game over
if ($gm > 0) { # if the game is over
&dofinal($br,$gm,$mc,$oc); # then do final processing
}
else { # the game is not over
$m = &figmov($br,$mc,$oc); # get my next move
$c = substr($br,$m-1,1); # get character at that position
if ($c ne " ") { # if it is not blank, then we have a problem
$xbr = $br;
$xbr =~ s/ /B/g;
print "
makmov my move invalid: $xbr, $m, $c, $d \n";
}
$br = applmov($br,$m,$mc); # apply my move to board
$gm = &gamovr($br); # check for game over
if ($gm > 0) { # if game is over
&dofinal($br,$gm,$mc,$oc); # then do final processing
}
else { # game is not over
&drawbrd($br,"Your move (you are playing $oc)",1); # draw board
}
}
};
# **********************************************************
#
# MAINLINE code
#
# **********************************************************
# use strict 'sub';
&settir; # set up the tir array
&setcmb; # set up the cmb array
$basepth = "http://palserv.com/"; # set the base path for "full" urls
$gpth = $basepth."tttgifs/"; # set the path for graphics
$prm = shift(@ARGV); # pick up command line arguments, if any
srand(time^$$); # randomize
$len = $ENV{'CONTENT_LENGTH'}; # get length of form data
read(STDIN,$bufx,$len); # get form data
#
@info = split(/[&;]/,$bufx); # get the name=value pairs
$br = "t"; # set up "dummy" board
print "Content-type: text/html\n\n"; # output necessary first line
# there should be only one name/value pair (that matters)
# the first three characters of the "name" should be:
# "STX" - start with opponent playing "X"
# "STO" - start with opponent playing "O"
# "pos" - we are in the middle of a game; here is the position and
# the opponent's move
# I used a foreach loop to insure that I get something;
# during the loop, I look for the needed "prefix"
# as soon as it is found, we take appropriate action and exit
foreach $pair (@info) {
($name, $value) = split(/=/,$pair); # create name and value
$value =~ s/\+/ /g;
$value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
$value =~ s///g;
# form of 'name' is "posvvvvvvvvv.sqx" where vvvvvvvvv is board and x is move
# alternate form is "STX" or "STO" (see tform.htm)
$pre = substr($name,0,3); # get prefix
if ($pre eq "pos") { # look at position
$br = substr($name,3,9); # get the "board"
$m = substr($name,16,1); # get opponent's move
&makmov($br,$m); # make a move
exit;
}
elsif ($pre eq "STX") { # start; opponent makes first move
&drawbrd(" ","Your move (you are playing X)",1);
exit;
}
elsif ($pre eq "STO") { # start
$r = int(9 * rand) + 1; # pick a random move
$br = &applmov(" ",$r,"X"); # apply the move to a blank board
&drawbrd($br,"Your move (you are playing O)",1); #draw the board and prompt for next move
exit;
}
}
# if we get here, there is an error; we never got the required prefix
print "
vas iss das? length=$len; file=$fil; $bufx\n";
if ($br eq "t") {
print "
![$c](\"$gpth"."lin$ch\.gif\")
\n";
};
# **********************************************************************************
#
# subroutine: one_box
#
# **********************************************************************************
sub one_box {
# create and output the html for one square (or box)
# arguments:
# $ch - the character ("X", "O", or " ") to represent
# $px - the board
# $p - the position of the character within the board
# $f - 0 or 1; zero means that the square (blank) should not be a link, while
# one means that it should be a link.
my ($ch, $px, $p, $f) = @_;
my $gfil, $glin, $c;
$c = $ch; # make $c the opposite color from $ch
$c =~ tr/XO /XO_/;
$px =~ s/ /B/g; # change "B"s to blanks
if ($ch eq "X") { # do "X"; display sqx.gif
$gfil = "sqx.gif";
$glin = "