'} $err.="Remember that password for $COLOUR{$plyr} from now on!" } #--------------------------------------------------- # board # returns contents of square eg wKb #--------------------------------------------------- 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 max 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 (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 } #---------------------------------------------------- # 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! } } } 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 ($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{ 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, $graphicL, $graphicR); my $here=$DATAPATH?$DATAPATH:'.'; $DATAFNAME=~/^(.*)(\.\w+)$/; my ($prefix,$suffix)=($1,$2); if ($tx) {$graphicL='<<<'} else {$graphicL=qq!
!}
if ($tx) {$graphicR='>>>'} else {$graphicR=qq!
!}
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='';
while($timelapse!; } else{push @moves, "
| $graphicL | Current GamesChoose your board... |
$graphicR |
| \n$_\n |
$title
|
| |||||||||||||
|
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(<
| ||||||||||||||
!}
else{print '> '}
print "| $1 | $2 | $3 |
The BeholderBoard Virtual Chess-set bug reports or grunts of approval to cartoons\@beholder.co.uk www.beholder.co.uk HTML ) } #--------------------------------------------------- # printTextOnlyBoard # text only, for those Lynx people out there #--------------------------------------------------- sub printTextOnlyBoard{ my $bd = shift; my ($x,$y); my ($timelapse, $hlch, $hcch, $hmch); $timelapse=timelapse($timestamp); $hlch=$hl?'checked':''; $hcch=$hc?'checked':''; $hmch=$hm?'checked':''; print"\nBeholderBoard Text-Only output:\n $title\n"; if ($syserr){print $err} else{ print "\n\n";
foreach $y (reverse 0..$yY){
print $hl?" ":substr(" ".($y<9?$y+1:chr(ord('a')+$y-9))."|",-3);
foreach $x (0..$xX){
print ' ', occupied($x,$y)? lc(colour($x,$y)).uc(type($x,$y)):'--';
}
print "\n";
}
if (not $hl){
print " "; foreach $x (0..$xX){print "___";}
print "\n "; foreach $x (0..$xX){print substr(" ".chr(ord('a')+$x),-3);}
}
print "\n\n";
print"\n";
if (not $syserr){
html(<HTML_FORM ); if (not $hc){ print " \nWhite has captured: "; while ( $captives=~/\s+b(\w)/g ){print uc(" $1")}; print " \nBlack has captured: "; while ( $captives=~/\s+w(\w)/g ){print uc(" $1")}; } if (not $hm){print " \n\nMove List:\n\n"; foreach (@moves){print "$_\n"} print""}
print" | ||||||||||||||||||