'} $err.="Onthoud dit wachtwoord voor $KLEUR{$COLOUR{$plyr}} vanaf nu!" } #--------------------------------------------------- # 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?'':'en'} #--------------------------------------------------- # 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="Kan niet rokeren door schaak"; return} state(1); $board[$x+$dx][$y]=lc($board[$x][$y]); $board[$x][$y]='--'; if (inCheck($plyr)){$err="Kan niet rokeren door schaak"; 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="Rokeren niet mogelijk"} }else{$err="Kan niet rokeren: toren heeft bewogen"} 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 $rr #---------------------------------------------------- sub confirmResign{ my ($x,$y,$dx,$dy,$plyr,$playmv) = @_; return if not $playmv; if (not $rr){ $err=qq|Geef je echt op?
ja nee|; return }elsif($rr eq 'y'){@special=('Opgegeven')} else{$fr=''; $to=''; $err='OK, niet opgegeven'; 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! } } } 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'Opgegeven'){ $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); # Translate to dutch notation - Andre $from=$STUK{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 'Opgegeven'){print DAT "result: ".$KLEUR{$COLOUR{other($plyr)}}." won\n"} else{print DAT $COLOUR{other($plyr)}." aan zet\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))){ if ($_=int($t/43200)){$delete=1}; $timelapse="Laatste zet "; if ($_=int($t/1440)){$timelapse.=" $_ dag".pl($_);$t-=($_*1440)}; if ($_=int($t/60)) {$timelapse.=" $_ uur";$t-=($_*60)}; $_=$t; $timelapse.=" $_ minuten"." geleden" } $timelapse } #--------------------------------------------------- # notify # sends email notice to the other player # note: does nothing if $EMAILPROG is null (disabled) #--------------------------------------------------- sub notify{ $comment = $form{'comment'}; 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 -t $EMAIL{$plyr}")){ print MAIL "From: $REPLYTO\n"; print MAIL "Reply-To: $REPLYTO\n"; print MAIL "Subject: Kijk Uit e-mail schaak bord $bd: $mvno. $mv\n"; print MAIL "Je tegenstander (".$KLEUR{$COLOUR{other($plyr)}}.") heeft zojuist een zet gedaan op bord $bd\n$title:\n\n"; print MAIL "Commentaar van je tegenstander: [ "; print MAIL "$comment ]\n\n"; foreach (@moves){ print MAIL "$_\n" } print MAIL "\n$URL/$CGIPATH/$SCRIPT?bd=$bd\n\n"; print MAIL "Vragen of commentaar? - Stuur ze naar de webmaster\nmailto:webmaster\@schaakclubkijkuit.nl.\n"; print MAIL "\n-----------------------------------------\nJe bent automatisch geinformeerd door\nde BeholderBoard Virtual Chess-set $VER\n-----------------------------------------\n\n"; # print MAIL "Hosted by Reboot Support & Design Aust. Pty. Ltd. http://www.reboot.com.au\n\n"; # print MAIL "Reboot your Business - or just play a game!!\n\n"; close (MAIL); $err="Je zet is verzonden naar $KLEUR{$COLOUR{$plyr}}. $err" } else{ $err="Waarschuwing: probleem met e-mail versturen naar $KLEUR{$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="Je browser stuurde een fout $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 ; } } #--------------------------------------------------- # createBoard # Used passed vars to create board # --added by ian c rogers, not to be blamed on original author #--------------------------------------------------- sub createBoard{ my @boards=(); 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; } $_=0; while(++$_<1000){last if $boards[$_-1]!~/^$prefix0?0?$_$suffix$/} $free=$_<1000?$_:0; if (! $free) { $err = "No free boards! "; } my $NEWBOARDFILE = sprintf ">$here/$prefix%03d$suffix" , $free; my $title = $form{'title'}; my $whitename = $form{'whitename'}; my $whiteemail = $form{'whiteemail'}; my $blackname = $form{'blackname'}; my $blackemail = $form{'blackemail'}; if ( ! ( $title && $whitename && $whiteemail && $blackname && $blackemail ) ){$err = "Je hebt niet alle velden ingevuld. Geen bord gecreëerd."; } if ( ! $err ) { $player{'email'} = $form{'whiteemail'}; &checkaddress; if ($legalemail !~ 1) {$err ="Ongeldig e-mail adres! Geen bord gecreëerd."; } } if ( ! $err ) { &subscribe; } if ( ! $err ) { $player{'email'} = $form{'blackemail'}; &checkaddress; if ($legalemail !~ 1) {$err ="Ongeldig e-mail adres! Geen bord gecreëerd."; } } if ( ! $err ) { &subscribe; } if ( ! $err ) { # throw e-mail addresses in DB # $dbh = DBI->connect($dsn, $user, $password) || die $DBI::errstr; # $sth = $dbh->prepare( "INSERT fistusers_db VALUES ('$whiteemail')"); # $sth->execute; # $sth->finish; # $sth = $dbh->prepare( "INSERT fistusers_db VALUES ('$blackemail')"); # $sth->execute; # $sth->finish; # $dbh->disconnect; open ( NEWBOARDFILE, $NEWBOARDFILE) or die "Error: Can't open $NEWBOARDFILE: $!\n"; print NEWBOARDFILE "title: $title
$whitename - $blackname\n"; print NEWBOARDFILE "email: w $whiteemail\n"; print NEWBOARDFILE "email: b $blackemail\n"; close NEWBOARDFILE; $err = "Bord gecreëerd! - [ Bord Nr $free ]"; } } #--------------------------------------------------- # checkaddress # Checks validity of email addresses #--------------------------------------------------- sub checkaddress { $player{'email'} =~ s/\s//g; unless ($player{'email'} =~ /(@.*@)|(\.\.)|(@\.)|(\.@)|(^\.)|(,)/ || $player{'email'} !~ /^.+\@(\[?)[a-zA-Z0-9\-\.]+\.([a-zA-Z]{2,3}|[0-9]{1,3})(\]?)$/) { $legalemail = 1; } else { $legalemail = 0; } } #--------------------------------------------------- # subscribe # Add e-mail addresses to database #--------------------------------------------------- sub subscribe { ##&checkaddress; open (DAT,"$memberinfo/address.txt"); if ($LOCK_EX){ flock(DAT, $LOCK_EX); #Locks the file } @database_array =
$timelapse!; } else{push @moves, "
 |
E-mail Schaak Kies je bord... |
 |
Creëer een nieuw bord
Let op: Jouw bord is NIET noodzakelijkerwijs het LAATSTE bord!
Je tegenstander ontvangt een e-mailtje wanneer je je eerste zet hebt gedaan.
Als je niet wilt dat anderen zetten voor jou doen,
vul dan een wachtwoord in wanneer je je eerste zet doet.
Let op: Partijen worden automatisch verwijderd
als er binnen 30 dagen geen zet is gedaan.
\n
HTML
);
if ($err){$err="".$err." \n$_\n
b.v. e2-e4"; $fromToBoxes=qq! - !; $passwordLabel='zet vereist
wachtwoord'; $passwordBox=''; } else{ $status=$result; $fromToBoxes=''; $passwordLabel=''; $passwordBox=''; } $form=<
| $status | $fromToBoxes |
verberg labels verberg materiaal verberg zetten draai bord om veld grootte |
| $passwordLabel | $passwordBox | |
| help... | ||
| $timelapse | ||
| Commentaar: | \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 |
\n
\n"; if ($syserr){ print "
www.beholder.co.uk
Gemodificeerd, verbeterd of vernield door Ross\@reboot.com.au
www.reboot.com.au
Vertaald naar het Nederlands door andre.kunst\@GEENSPAMschaakclubkijkuit.nl
www.schaakclubkijkuit.nl 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