Chess Boards

#!/usr/bin/perl $VER='v1.52'; # BeholderBoard Virtual Chess-set: www.beholder.co.uk 2-Aug-2000 # cgi: produces list of available chessboards or else the requested board # # v1.52: fixed bug in v1.51 bugfix # v1.51: Alan J.Pippin's bugfix - inCheckTest now prevents adjacent kings # v1.5: fixed promotion-without-Javascript bug # added Resign move - and implicit "game over" state where $plyr='' # added flip board, help url and optimised graphic files # v1.41: fixed en passant bug in v1.4 # v1.4: added "disable JavaScript" option + email notification # + some cosmetic/error handling changes # *** see the readme which accompanies this script for detailed information *** # ***-------- more help and info at http://www.beholder.co.uk/chess/ --------*** { ##------------------------------------------------------------------------------ ## LOCAL CONFIGURATION... edit these! be careful: no trailing "/"s in paths! ##------------------------------------------------------------------------------ $URL = 'http://www.amcampbell.com'; # url of your domain $GRPATH = 'chess'; # path for graphics (from server root) $CGIPATH = 'chess'; # path to this script (from server root) $SCRIPT = 'board.pl'; # name of this script $DATAPATH = 'board'; # path to data (relative to this script) $DATAFNAME = 'board.txt'; # data filename template - must have one '.' $EMAILPROG = ''; # $EMAILPROG = '/usr/lib/sendmail'; # your mailer program... # e.g. $EMAILPROG ='/usr/lib/sendmail'; # Note: to DISABLE email notification # of moves, set $EMAILPROG = ''; $HELPURL = 'http://www.beholder.co.uk/chess/help.html'; # URL to help page ##------------------------------------------------------------------------------ ## LOCAL CONFIGURATION... that's all ##------------------------------------------------------------------------------ $BACKCOLOUR = '#ffffff'; $BRDRCOLOUR = '#CCCCFF'; # used for border and behind error message $TEXTCOLOUR = '#000000'; $LINKCOLOUR = '#000000'; # text must be visible over... $ALNKCOLOUR = '#ff0000'; # ...$BACK- and $BRDR- colours $MAX_XY = 26; # limit of deviance $PLAY = 1; $PROBE = 0; %PIECE = qw(P pawn R rook N knight B bishop Q queen K king); %COLOUR = qw(b black w white); %PASSWD = ('b','','w',''); %EMAIL = ('b','','w',''); $plyr ='w'; # current player white by default (new game) # but may be set to null if game over $err =''; # error (possibly benign) message $captives =''; # list of captives (in order taken) $timestamp = 0; $title =''; $result =''; # description of result if game over $hidden = 0; $syserr = 0; $xX = 7; # edges of... $yY = 7; # ...board $| = 1; print "Content-Type: text/html\n\n\n"; use integer; foreach (qw( fr to pp bd hl hc hm sz pw dj fb cr )){$form{$_}=0} # initialise &getCGIvars; # loads global %form and sets $err if there's a problem if( $form{'fr'}=~/^\s*(\w\d|R)\s*$/i ){$fr=lc($1)}else{$fr=''} # move from... if( $form{'to'}=~/^\s*(\w\d|R)\s*$/i ){$to=lc($1)}else{$to=''} # ...to if( $form{'pp'}=~/^\s*(\w)\s*$/ ){$pp=uc($1)}else{$pp=''} # pawn promotion piece if( $form{'bd'}=~/^\s*(\d{1,3})\s*$/ ){$bd=$1} else{$bd=0 } # board number if( $form{'hl'} ){$hl=1} else{$hl=0 } # Hide Labels (0=no, 1=yes [default=not hidden]) if( $form{'hc'} ){$hc=1} else{$hc=0 } # Hide Captives if( $form{'hm'} ){$hm=1} else{$hm=0 } # Hide Moves if( $form{'pw'}=~/^\s*(\w+)\s*$/ ){$pw=$1} else{$pw=''} # password if( $form{'dj'} ){$dj=1} else{$dj=0 } # disable JavaScript (0=no, 1=yes) if( $form{'fb'} ){$fb=1} else{$fb=0 } # flip board (0=no, 1=yes) if( $form{'cr'}=~/^(y|n)/i ){$cr=lc($1)}else{$cr=0 } # confirm resign (y,n or not asked) if( $form{'sz'}=~/^\s*([1-9]\d{0,2})\s*$/){$sz=$1}else{$sz=50} # square size if (not $err){ if ($bd){ if (getdata($bd)){ if ($fr or $to){ if (allowed($pw,$plyr)){ ($x,$y)=an2sub($fr); ($x2,$y2)=an2sub($to); if ( $x<0){$err="Couldn't understand from part of Move"} elsif($x2<0){$err="Couldn't understand to part of Move"} elsif (occupied($x,$y) and (colour($x,$y) eq $plyr)){ $pc=type($x,$y); ($dx,$dy)=($x2-$x,$y2-$y); if ($dx or $dy){ if(validMove($x,$y, $dx, $dy, $plyr, $PLAY)){ if ($special[0] eq 'Resigns'){ $mv=recordMove(); if (putdata($bd)){ notify(other($plyr), $bd, $moveno, $mv, $title); $plyr='' }else{$err="System problem! Write to data-file failed ($!)"} }elsif (not collision($x,$y, $x2,$y2, $plyr)){ state(1); $capture=makeMove($fr, $to); if (not inCheck($plyr)){ $mv=recordMove($pc, $fr, $to, $capture); if ($pw and not $PASSWD{$plyr}){setpassword($pw,$plyr)} if (putdata($bd)){ notify(other($plyr), $bd, $moveno, $mv, $title); $fr=''; $to=''; $pp=''; $plyr=other($plyr) }else{$err="System problem! Write to data-file failed ($!)"; state(0)} }else{$err="Can't move in check"; state(0)} }else{$err="Move obstructed"} }else{$err||="Illegal move for ".$PIECE{uc(type($x,$y))}} }else{$err="No move made"} }else{$err="No $COLOUR{$plyr} piece at $fr"} }else{$err="Sorry, not that password"} } # else do nothing, just lookin' }else{$err="Board not available right now ($!)"; $syserr=1} } # else bd=0 so show list }else{$err="Sorry, can't play chess with you...
$err"; $syserr=1} printBoard($bd); exit } #--------------------------------------------------- # datafile returns data filename for this board #--------------------------------------------------- sub datafile{ my $bd=shift; my $datname=$DATAFNAME; $datname=~/(.*)(\.\w+)$/; if ($DATAPATH){$datname= $DATAPATH.'/'.$1.substr($bd+1000,-3).$2} else {$datname= $1.substr($bd+1000,-3).$2} } #--------------------------------------------------- # getdata # reads the data file and sets everything up # side-effect: initialises all the global variables # returns true if everything was OK #--------------------------------------------------- sub getdata{ my $bd = shift; my ($x,$y,@raw); my $datname=datafile($bd); open(DAT, "<$datname") or return 0; while(){ if (/^(b|w)\w* to move/i){$plyr=lc($1)} elsif(/^(b|w|-)/){unshift @raw, [split]} elsif(/^result:\s*(.+)/i){$result=$1; $plyr=''} elsif(/^captives:(.*)/i){$captives=$1} elsif(/^passwd:\s*(b|w)\w*\s+(\S+)/i){$PASSWD{$1}=$2} elsif(/^timestamp:\s*(\d+)/i){$timestamp=$1} elsif(/^title:(.*)/i){ $title=$1; $title=~s/^\s*(.*?)\s*$/$1/; if ($title=~/^$(.*)$$/){$hidden++; $title=$1} } elsif(/^e\-?mail:\s*(b|w)\w*\s([-~\w.]+(\@\w+[-\w.]+\w)?)\s*$/i){$EMAIL{$1}=$2} elsif(/^\d+\.\s/){chop; push @moves,$_} } $moveno=$#moves+1; if (not @raw){while (){if(/^(b|w|-)/){unshift @raw, [split]}}} if(( $xX = $#{$raw[0]}) > $MAX_XY ){$xX=$MAX_XY}; if(( $yY = $#raw ) > $MAX_XY ){$yY=$MAX_XY}; for $x (0..$yY){ for $y (0..$xX){ $_=$raw[$x][$y]; if (/^((--)|(-\+)|((b|w)[prnbqk]))$/i){$board[$y][$x]=$_} else {$board[$y][$x]='--'} } } close DAT; 1 } #--------------------------------------------------- # an2sub # converts algebraic notation to subscripts e.g. a1 -> (0,0) # cheekily allows deviant boards bigger than 8 x 8 # returns -ve x coord if either are bad #--------------------------------------------------- sub an2sub{ my $n = shift; my ($x,$y); $n=~/^(\w)(\w)$/; if(not ($1 and $2)){return (-1,-1)} else{ $_=lc($1); $x=-ord('a')+ord; $_=lc($2); $y=/^\d/?$_-1:10-ord('a')+ord; } if ( $x<0 or $x>$xX or $y<0 or $y>$yY){return (-1,-1)} else {return ($x,$y)} } #--------------------------------------------------- # allowed # checks password against the Right Word # returns true if OK # fails if no player (i.e. game over) #--------------------------------------------------- sub allowed{ my($pw, $plyr)=@_; $plyr and (not $PASSWD{$plyr} or (crypt($pw, 'bw') eq $PASSWD{$plyr})) } #--------------------------------------------------- # setpassword # sets password provided for given player #--------------------------------------------------- sub setpassword{ my ($pw, $plyr)=@_; $PASSWD{$plyr}=crypt($pw, 'bw'); if ($err){$err.='
'} $err.="Remember that password for $COLOUR{$plyr} from now on!" } #--------------------------------------------------- # board # returns contents of square eg wK #--------------------------------------------------- sub board{ my ($x,$y)=@_; if ($x<0 or $x>$xX or $y<0 or $y>$yY){return '--'} $board[$x][$y] } #-------------------------------------------------- # other returns other colour of argument #-------------------------------------------------- sub other{ $_[0]eq'b'?'w':'b' } #-------------------------------------------------- # sqcol returns colour of given square #-------------------------------------------------- sub sqcol{my ($x,$y)=@_; (($x+$y)%2-1?'b':'w')} #-------------------------------------------------- # type returns type of piece at x,y eg wB -> B #-------------------------------------------------- sub type{my ($x, $y)=@_; my $p=board($x,$y); $p=~/^.(.)/; $1} #-------------------------------------------------- # colour returns colour of piece at x,y eg wB -> w #-------------------------------------------------- sub colour{my ($x, $y)=@_; my $p=board($x,$y); $p=~/^(.)./; $1} #-------------------------------------------------- # occupied returns true if there is a piece at x,y #-------------------------------------------------- sub occupied{ my ($x, $y)=@_; type($x,$y)=~/\w/} #-------------------------------------------------- # pl returns 's' if plural, else nothing #-------------------------------------------------- sub pl{$_[0]==1?'':'s'} #--------------------------------------------------- # biggest returns max of absolute pair #--------------------------------------------------- sub biggest{my($a,$b)=@_;(($a=abs($a))>($b=abs($b)))?$a:$b} #--------------------------------------------------- # smallest returns min of absolute pair #--------------------------------------------------- sub smallest{my($a,$b)=@_;(($a=abs($a))<($b=abs($b)))?$a:$b} #--------------------------------------------------- # html # strips out leading tabs (\t) and prints it # (just to make Perl source a bit more readable) #--------------------------------------------------- sub html{ $_=shift; s/\t//gm; print} #--------------------------------------------------- # validMove # checks proposed move against type of piece # consider "special" moves only if this is a player's move # returns true if OK #--------------------------------------------------- sub validMove{ my ($x,$y,$dx,$dy,$plyr,$playmv) = @_; my $x2=$x+$dx; my $y2=$y+$dy; my $Pc=type($x,$y); my $pc=lc($Pc); if (($pc eq 'k') and (lc(board($x2,$y2)) eq other($plyr).'k')){ return unless confirmResign(@_) } elsif ($Pc eq'K' and (abs($dx)==2) and not $dy){ return unless castling(@_) } elsif ($pc eq 'k'){ return unless (biggest($dx,$dy)==1) } elsif ($pc eq 'q'){ return unless (not $dx or not $dy or abs($dx)==abs($dy)) } elsif ($pc eq 'b'){ return unless (abs($dx)==abs($dy)) } elsif ($pc eq 'n'){ return unless ((abs($dx)==2 and abs($dy)==1) or (abs($dx)==1 and abs($dy)==2)) } elsif ($pc eq 'r'){ return unless (not($dx and $dy)) } elsif ($pc eq 'p'){ return unless ((($plyr eq 'w') and ($dy>0)) or (($plyr eq 'b') and ($dy<0))); # advance only if (($Pc eq 'P') and (abs($dy)==2)){ return unless pawnFirstMove(@_); }else{ return unless ((biggest($dx,$dy)==1)); if ($dx){ # must capture return unless (occupied($x2,$y2) or enpassant(@_)) }else{ # mustn't capture return if (colour($x2,$y2) eq other($plyr)) } if ($playmv and $y2==($plyr eq 'b'?0:$yY)){return 0 unless promotion(@_)} } } 1 # ...a valid move } #--------------------------------------------------- # collision # walks between (x,y) and (x2,y2) seeking collision # -checks intermediate squares for any # -checks the end square for friendly # returns true if hit something #--------------------------------------------------- sub collision{ my($x,$y, $x2,$y2, $plyr)=@_; my $dx=($x2-$x); $dx=$dx?$dx/abs($dx):0; my $dy=($y2-$y); $dy=$dy?$dy/abs($dy):0; my $hit=0; if (lc(type($x,$y)) eq 'n'){ # knights don't collide $x=$x2; $y=$y2 }else{ $x+=$dx; $y+=$dy; while(not ($x==$x2 and $y==$y2)){ if ($hit=occupied($x,$y)){last} $x+=$dx; $y+=$dy; } } if (not $hit and occupied($x,$y)){ # target square $hit=(colour($x,$y) eq $plyr) } return $hit } #--------------------------------------------------- # sub castling # returns true if castling move was OK # side-effect: loads the @special array #--------------------------------------------------- sub castling{ my ($x,$y,$dx,$dy,$plyr,$playmv) = @_; return if not $playmv; my $x2=$x+$dx; my $y2=$y+$dy; my $rx=$dx<0?0:$xX; my $obstructed=0; my $xx; $dx=$rx?1:-1; if ((type($rx,$y) eq 'R') and (colour($rx,$y) eq $plyr)){ for (smallest($rx-$dx, $x2)..biggest($rx-$dx, $x2)){ if (occupied($_,$y2)){$obstructed=1; last} } if (not $obstructed){ if (inCheck($plyr)){$err="Can't castle out of check"; return} state(1); $board[$x+$dx][$y]=lc($board[$x][$y]); $board[$x][$y]='--'; if (inCheck($plyr)){$err="Can't castle through check"; state(0); return} state(0); # other collison/checks carried out as normal @special=($rx?'O-O':'O-O-O', 0, $x2-$dx,$y,$plyr.'r', $x2,$y2,$plyr.'k', $rx,$y,'--', $x,$y,'--'); return 1 }else{$err="Castling obstructed"} }else{$err="Can't castle: need an unmoved rook"} 0 # castling illegal } #---------------------------------------------------- # pawnFirstMove # returns true if 2-square pawn move was OK # side-effect: sets @special (marks en passant target with *) #---------------------------------------------------- sub pawnFirstMove{ my ($x,$y,$dx,$dy,$plyr,$playmv) = @_; return if not $playmv; if (not $dx and not (colour($x2,$y2) eq other($plyr))){ @special=(' ', 0, $x, $y+($dy/2), '-*'); return 1 } 0 # pawn 2-sq move illegal } #---------------------------------------------------- # promotion # returns true if OK (ie we have a promote-to type) # side effect: set $err (to request promote-to) # or load @special array with new piece # NB! this uses global $pp #---------------------------------------------------- sub promotion{ my ($x,$y,$dx,$dy,$plyr,$playmv) = @_; return if not $playmv; if ($pp!~/^([RNBQ])$/){ $err=qq|Pawn promotion: select
R N B Q|; return 0 }else{@special=("+=$1", 0, $x+$dx, $y+$dy, $plyr.$1)} 1 # promotion OK } #---------------------------------------------------- # confirmResign # returns true if OK (ie we a confirmation) # side effect: set $err (to request confirmation) # or load @special array with RESIGN # NB! this uses global $cr #---------------------------------------------------- sub confirmResign{ my ($x,$y,$dx,$dy,$plyr,$playmv) = @_; return if not $playmv; if (not $cr){ $err=qq|Really resign?
yes no|; return }elsif($cr eq 'y'){@special=('Resigns')} else{$fr=''; $to=''; $err='OK, did not resign'; return} 1 # resignation accepted } #---------------------------------------------------- # enpassant # returns true if en passant move was OK # side-effect: sets @special #---------------------------------------------------- sub enpassant{ my ($x,$y,$dx,$dy,$plyr,$playmv) = @_; return if not $playmv; if ($board[$x+$dx][$y+$dy]=~/\+/){ # +sign marks ep target @special=('+ e.p.', 'p', $x+$dx, $y, '--'); return 1 } 0 # en passant illegal } #--------------------------------------------------- # inCheck # returns true if player's king is threatenned # (actually tests *all* player's kings!) #--------------------------------------------------- sub inCheck{ my ($plyr)=shift; my ($x, $y); my @kings=findPiece($plyr, 'k'); while (@kings){ $x=shift(@kings); $y=shift(@kings); if (inCheckTest($plyr, $x, $y)){return 1} } 0 # not in check } #--------------------------------------------------- # inCheckTest # returns true if player's king is threatenned # Looks in all straight directions for a collision, # and sees if that collision is enemy and can take # If that doesn't work, test for attacking knights #--------------------------------------------------- sub inCheckTest{ my ($plyr, $x, $y)=@_; my ($dx,$dy,$dz, $x1,$y1); for $dy (-1,0,1){ for $dx (-1,0,1){ ($x1,$y1)=($x,$y); if ($dx or $dy){ while( $x1>=0 and $x1<=$xX and $y1>=0 and $y1<=$yY ){ $x1+=$dx; $y1+=$dy; if (occupied($x1,$y1)){ if ((colour($x1,$y1) eq other($plyr)) and validMove($x1, $y1, $x-$x1, $y-$y1, other($plyr),$PROBE)) {return 1} # check! last } } } } } # test for Knights - look for a knight everywhere it could take from for $dy (-1,1){ for $dx (-1,1){ for $dz (2,3){ $x1=$x+$dx*(4-$dz); $y1=$y+$dy*($dz-1); if ((lc(type($x1,$y1)) eq 'n') and (colour($x1,$y1) eq other($plyr))) {return 1} # check! } } } # test for Kings - look to see if adjacent square is the opponent's king for $dy(-1,0,1){ for $dx(-1,0,1){ if ($dy or $dx){ $x1=$x+$dx; $y1=$y+$dy; if((lc(type($x1,$y1)) and (lc(board($x1,$y1)) eq other($plyr).'k'))) {return 1} # check! } } } 0 # not in check } #---------------------------------------------------- # findPiece # returns ([x,y , [x1, y1, [x2, y2, [...]]]]) of all # pieces matching specified colour and type #---------------------------------------------------- sub findPiece{ my $pc=lc($_[0].$_[1]); my @ret; my($x,$y); for $y (0..$yY){ for $x (0..$xX){ if (lc(board($x,$y)) eq $pc){push @ret, ($x,$y)} } } return @ret } #--------------------------------------------------- # state saves board state (snapshot) # argument 1 = store, 0 = restore (i.e. revert) #--------------------------------------------------- sub state{ my ($x,$y); for $y (0..$yY){ for $x (0..$xX){ if ($_[0]){$snapshot[$x][$y]=$board[$x][$y]} else {$board[$x][$y]=$snapshot[$x][$y]} } } } #--------------------------------------------------- # makeMove # makes the move in board data structure from $fr to $to # returns type of piece taken, or null if no capture #--------------------------------------------------- sub makeMove { my($from,$to)=@_; my($x,$y)=an2sub($from); my($xt,$yt)=an2sub($to); my ($sq, $ret, $capt); $ret = occupied($xt,$yt)?lc(type($xt,$yt)):''; $board[$xt][$yt]=lc($board[$x][$y]); $board[$x][$y]='--'; if (@special){ $_=shift @special; if ($capt = shift @special){$ret=$capt} while(@special){ ($x,$y,$sq)=splice(@special,0,3); $board[$x][$y]=$sq } @special=$_; # put special move back } $timestamp=time; $ret } #--------------------------------------------------- # recordMove update the list of moves # use SAN short-form notation # returns the move string #--------------------------------------------------- sub recordMove{ my ($pc, $from, $to, $took)=@_; my ($mv, $x1, $y1); my ($ambig, $same)=(0,0); my $sp=@special?$special[0]:''; if ($sp eq'Resigns'){ $mv=$sp } else{ if ($took){$captives.=' '.other($plyr).$took} if ($sp=~/O-O/){$mv=$sp} else{ # SAN comliance: short-form ambiguity detector my ($x,$y)=an2sub($from); my ($x2,$y2)=an2sub($to); if ($pc=~/P/i){ if ($took){ $from=~s/\d//; $from.='x' } else { $from='' } }else{ my @similar=findPiece($plyr, $pc); while (@similar) { $x1=shift @similar; $y1=shift @similar; if(($x1!=$x2 or $y1!=$y2) # ignore piece itself and validMove($x1, $y1, $x2-$x1, $y2-$y1, $plyr, $PROBE) and not collision($x1,$y1, $x2,$y2, other($plyr))){ $ambig++; if($x1==$x){ $same++; last } } } $from=~/^(.)(.)/; $from=uc($pc); if ($ambig){$from.=$1 } if ($same){ $from.=$2 } if ($took){ $from.='x'} elsif ($ambig){ $from.='-' } } $mv = "$from$to"; if ($sp=~/^\+(.*)/){$mv.=$1} } if (inCheck(other($plyr))){$mv.='+'} } if ($plyr eq 'b'){ if (not @moves){push(@moves, ++$moveno.".\t ...")} $moves[$#moves].="\t $mv" } else{push(@moves, ++$moveno.".\t $mv")} return $mv } #--------------------------------------------------- # putdata # writes the data to file ready for next move # returns true if write was OK #--------------------------------------------------- sub putdata{ my $bd=shift; my $datname=datafile($bd); if (not open(DAT, ">$datname")){return 0} else{ if ($special[0] eq 'Resigns'){print DAT "result: ".$COLOUR{other($plyr)}." won\n"} else{print DAT $COLOUR{other($plyr)}." to move\n"} for $y(0..$yY){ for $x(0..$xX){ $_=board($x,$yY-$y); tr/*+/+-/; print DAT "$_ " } print DAT "\n" } print DAT "\n"; foreach $_ (@moves){print DAT $_."\n"}; print DAT "\n"; if ($hidden){ $title="($title)" } print DAT "title: $title\n" if $title; print DAT "captives: $captives\n" if $captives; print DAT "passwd: w $PASSWD{'w'} \n" if $PASSWD{'w'}; print DAT "passwd: b $PASSWD{'b'} \n" if $PASSWD{'b'}; print DAT "email: w $EMAIL{'w'} \n" if $EMAIL{'w'}; print DAT "email: b $EMAIL{'b'} \n" if $EMAIL{'b'}; print DAT "timestamp: ".time."\n"; close DAT; return 1 # write OK } } #--------------------------------------------------- # timelapse # returns time since last move ("Last move...ago") # blank if no timestamp or just seconds ago #--------------------------------------------------- sub timelapse{ my $timestamp = shift; my $timelapse=''; if ($timestamp and ($t=int((time-$timestamp)/60))){ $timelapse="Last move "; if ($_=int($t/1440)){$timelapse.=" $_ day".pl($_);$t-=($_*1440)}; if ($_=int($t/60)) {$timelapse.=" $_ hour".pl($_);$t-=($_*60)}; $_=$t; $timelapse.=" $_ minute".pl($_)." ago" } $timelapse } #--------------------------------------------------- # notify # sends email notice to the other player # note: does nothing if $EMAILPROG is null (disabled) #--------------------------------------------------- sub notify{ my ($plyr, $bd, $mvno, $mv, $title)=@_; if ($EMAILPROG and $EMAIL{$plyr}){ if ($plyr eq 'w'){$mv=" ... $mv"} $_=$title; s/<[^>]*>/ /g; s/\s+/ /g; s/(^ | $)//g; # strip out html $title=$_?qq! "$_"!:''; if (open (MAIL, "|$EMAILPROG $EMAIL{$plyr}")){ print MAIL "Subject: [$bd]Chess: $mvno. $mv\n"; print MAIL "Your opponent (".$COLOUR{other($plyr)}.") just moved on board $bd$title:\n\n"; foreach (@moves){ print MAIL "$_\n" } print MAIL "\n\n$URL/$CGIPATH/$SCRIPT?bd=$bd\n"; print MAIL "\n-----------------------------------------\nYou have been notified automatically by\nthe BeholderBoard Virtual Chess-set $VER\n-----------------------------------------\n"; close (MAIL); $err="Your move has been e-mailed to $COLOUR{$plyr}. $err" } else{ $err="Warning: had problems e-mailing $COLOUR{$plyr}. $err" } } } #--------------------------------------------------------- # getCGIvars # gets the variables passed over the web # two important side-effects: # loads up the global %form # sets $err if there was a problem #--------------------------------------------------------- sub getCGIvars { my ($in, $name, $value); if (($ENV{'REQUEST_METHOD'} eq 'GET') or ($ENV{'REQUEST_METHOD'} eq 'HEAD') ){ $in=$ENV{'QUERY_STRING'} } elsif ($ENV{'REQUEST_METHOD'} eq 'POST'){ if ($ENV{'CONTENT_TYPE'}=~ m#^application/x-www-form-urlencoded$#i){ if(length($ENV{'CONTENT_LENGTH'})){ read(STDIN, $in, $ENV{'CONTENT_LENGTH'}) }else{$err='POST request'} }else{$err='Content-Type: '.$ENV{'CONTENT_TYPE'}} }else{$err='REQUEST_METHOD'} if ($err){$err="Your browser sent a bad $err"; return} foreach (split('&', $in)) { s/\+/ /g ; ($name, $value)= split('=', $_, 2) ; $name=~ s/%(..)/chr(hex($1))/ge ; $value=~ s/%(..)/chr(hex($1))/ge ; $form{$name}=$value ; } } #--------------------------------------------------- # printListOfBoards # produces the html output for the list of available boards # print summary move info; don't print hidden boards #--------------------------------------------------- sub printListOfBoards{ my @boards=(); my ($board, $bd, $plyr, $timestamp, $title, $status); my $here=$DATAPATH?$DATAPATH:'.'; $DATAFNAME=~/^(.*)(\.\w+)$/; my ($prefix,$suffix)=($1,$2); if (opendir DATADIR, $here){ @boards = sort grep/^$prefix\d\d\d$suffix$/, readdir DATADIR; closedir DATADIR } if (not @boards){push @moves, "No boards are currently set up."} else{ foreach $board (@boards){ $board=~/^$prefix(\d\d\d)$suffix$/; $bd=$1+0; if ($bd){ if (open DAT, "$here/$board"){ $plyr='w'; $timestamp=$title=$status=''; while(){ if (/^(b|w)\w* to move/i){$plyr=lc($1)} elsif (/^timestamp:\s*(.*)/i){$timestamp=$1} elsif(/^title:\s*(.*)/i){$title=$1} elsif(/^result:\s*(.+)/i){$status=$1} } close DAT; if ($title=~/^\(/){next} # hidden board; skip it $status||="$COLOUR{$plyr} to move"; $timelapse=timelapse($timestamp); push @moves, qq!Board $bd$title$status
$timelapse!; } else{push @moves, "Problem $here/$board: $!"} } } } html(< Chess Boards

Chess

Current Games

Choose your board...

HTML ); foreach (@moves){ print "\n" } print "

\n$_\n

\n\n"; } #--------------------------------------------------- # printBoard # produces the html output for the board # # note: suppress move/password boxes if not $plyr (game over) #--------------------------------------------------- sub printBoard{ my $bd=shift; my ($y,$x,$isz,$timelapse,$t,$hlch,$hcch,$hmch,$fbch,$form,$status); my $onUnload=''; if (not ($bd or $syserr)){printListOfBoards} else{ if ($err){$err="".$err.""} else {$err=''}; $timelapse=timelapse($timestamp); $hlch=$hl?'checked':''; $hcch=$hc?'checked':''; $hmch=$hm?'checked':''; $fbch=$fb?'checked':''; $isz=$sz<=50?$sz:50; # images shrink but never grow > 50 if ($plyr){ $status="$COLOUR{$plyr} to move
e.g. e2-e4"; $fromToBoxes=qq! - !; $passwordLabel='move requires
password'; $passwordBox=''; } else{ $status=$result; $fromToBoxes=''; $passwordLabel=''; $passwordBox=''; } $form=< $err

$status	$fromToBoxes	hide labels hide captives hide moves flip board square size
$passwordLabel	$passwordBox
help...
$timelapse

HTML_Form ; if (not ($syserr or $dj)){ $onUnload=qq!onUnload="killw()"!; $form=~s/\t//g; $form=~s/\n/\\n/g; $form=~s/'/\\'/g; html(< HTML )} html(<

Chess

$title

HTML ); if (not $hl){ html(<

HTML ); for $yLoop (0..$yY){ $y=$fb? $yLoop:$yY-$yLoop; $_=$y<9?$y+1:chr(ord('a')+$y-9); print qq! \n! } html(<

HTML )} html(<

HTML ); for $yLoop (0..$yY){ $y=$fb? $yY-$yLoop:$yLoop; print " \n"; for $xLoop (0..$xX){ $x=$fb? $xX-$xLoop:$xLoop; $sq=sqcol($x,$yY-$y); print " \n" } print " \n"; } html(<

!} else{print '> '} print "

HTML ); if (not $hl){ html(<

HTML ); for $xLoop (0..$xX){ $x=$fb? $xX-$xLoop:$xLoop; $_=chr(ord('a')+$x); print qq! \n! } html(<

HTML )} html(<

HTML ); if (not $hc){ print "

\n"; while ( $captives=~/\s+w(\w)/g ){ print qq!

\n! } } html(<

HTML ); if (not $hc){ while ( $captives=~/\s+b(\w)/g ){ print qq!

\n! } } html(<

HTML ); if ((not $hm) and $moves[0]){ print " \n"; foreach $_ (@moves){ /(\d+.)\s+([^\t]+)*(?:\Z|\t(.*))/; print " \n" } print "

\n" } print "\n\n\n\n
\n
\n"; if ($syserr){ print "$err

\n" } elsif ($dj){ html(<
HTML ); } } &printFooter } #--------------------------------------------------- # printFooter # slaps HTML footer onto bottom of page #--------------------------------------------------- sub printFooter{ my $listOption=$bd?qq!| List Boards!:''; my $js; if ($dj){$js='0">Enable'} else {$js='1">Disable'} html(<\n\n\n\n\n\n cartoons\@beholder.co.uk
www.beholder.co.uk
HTML ) } # start position data follows: __END__ bR bN bB bQ bK bB bN bR bP bP bP bP bP bP bP bP -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- wP wP wP wP wP wP wP wP wR wN wB wQ wK wB wN wR