#!/usr/bin/perl -w
# experiments for a virtual scrabble letter bag
# rand - returns a random number [0;1[ or [0;x[ if x given, auto-seed
# chr - returns char with ascii code x
# ord - returns ascii of char x
# pack/unpack: w (BER) feels like utf-8... u uuencode, H hex, ...
# Regeln: http://www.brostedt.de/webscrabble/regeln.asp
# Buchstabensatz ist also: siehe unten :-)
use strict;
# --------------------- configure the file locaton here ******
my $bagfile = "scrabblesack.txt";
my $errheader = "Content-type: text/plain
Error: ";
my $log = "";
# --------------------- configure the html template here ******
my $htmlheader = "Content-type: text/html
Homepage von Eric Auer: virtueller Scrabblesack
";
# --------------------- configure the fresh-bag-contents here ******
my $newbag = "aaaaaäbbccddddeeeeeeeeeeeeeeeffggghhhhiiiiiijkk";
$newbag .= "lllmmmmnnnnnnnnnoooöpqrrrrrrsssssssttttttuuuuuu";
$newbag .= "üvwxyz..";
# contents of the bag for a new game (for German)
# 5x A (1) 1x AE (6) 2x B (3) 2x C (4) 4x D (1) 15x E (1)
# 2x F (4) 3x G (2) 4x H (2) 6x I (1) 1x J (6) 2x K (4)
# 3x L (2) 4x M (3) 9x N (1) 3x O (2) 1x OE (8) 1x P (4)
# 1x Q (10) 6x R (1) 7x S (1) 6x T (1) 6x U (1) 1x UE (6)
# 1x V (6) 1x W (3) 1x X (8) 1x Y (10) 1x Z (3) 2x Joker (0)
my $dutchbag = "aaaaaabbccdddddeeeeeeeeeeeeeeeeeefgggghhhiiiijjkk";
$dutchbag .= "lllmmnnnnnnnnnnooooooppqrrrrrrsssttttttuu";
$dutchbag .= "vvwwxyzz..";
# Dutch Scrabble letters, values, frequency (plus 2 jokers, value 0):
# a b C D e f G H i J K L m n O P Q R S T U V W x Y Z
# 1 3 5 2 1 4 3 4 1 4 3 3 3 1 1 3 10 2 2 2 4 4 5 8 8 4
# - - - - - - - - - - - - - - - - - -
# 6 2 2 5 18 1 4 3 6 2 2 3 2 10 6 2 1 6 3 6 2 2 2 1 1 2
# - - - - - - - - - - - - - - - -
# The - signs mark differences to the German Scrabble set above.
my $ukbag = "aaaaaaaaabbccddddeeeeeeeeeeeeffggghhiiiiiiiiijk";
$ukbag .= "llllmmnnnnnnooooooooppqrrrrrrssssttttttuuuu";
$ukbag .= "vvwwxyyz..";
# English Scrabble letters, values, frequency (plus 2 jokers, value 0):
# a b C D e f G H i J K L m n O P Q R S T U V W x Y Z
# 1 3 3 2 1 4 2 4 1 8 5 1 3 1 1 3 10 1 1 1 1 4 4 8 4 10
# 9 2 2 4 12 2 3 2 9 1 1 4 2 6 8 2 1 6 4 6 4 2 2 1 2 1
# (from Li 9/2004 or 10/2004)
# --------------------- read the command in the CGI way
my $command = "";
my $var;
foreach $var ('REQUEST_METHOD', 'QUERY_STRING', 'CONTENT_LENGTH',
'REMOTE_HOST', 'REMOTE_ADDR', 'HTTP_USER_AGENT') {
$ENV{$var} = "(none)" if (!defined($ENV{$var}));
}
if ( $ENV{'REQUEST_METHOD'} eq "(none)" ) {
print "Not called as a CGI, simulating...\n";
$ENV{'REQUEST_METHOD'} = "GET";
$ENV{'QUERY_STRING'} = join(' ',@ARGV);
print "QUERY_STRING set to $ENV{'QUERY_STRING'}\n";
}
if ( $ENV{'REQUEST_METHOD'} eq "GET")
{ $command=$ENV{'QUERY_STRING'};}
else { read(STDIN,$command,$ENV{'CONTENT_LENGTH'});}
# could do @foo = split(/&/,$command); foreach $item (@foo) {
# my ($key,$what)=split(/=/,$item,2); ... $bar{$key}=$what; } here
$command =~ tr/A-Z/a-z/;
$command =~ tr/ÄÖÜ/äöü/;
my $answer = "";
my $who = "$ENV{'REMOTE_HOST'} [$ENV{'REMOTE_ADDR'}] with ";
$who .= "$ENV{'HTTP_USER_AGENT'}";
# --------------------- read the bag from file
open(BAG,"<$bagfile") || die "$errheader" . "Bag not readable\n";
$/ = undef; # ignore line breaks while reading
my $bagdump = ; # read the bag
close(BAG);
# --------------------- load and decode the bag
$bagdump = "0 64" unless $bagdump =~ /^[0-9 ]+$/; # handle errors
my ($bagkey,@bagparts) = split(/ /,$bagdump); # fetch the key
my $that;
my $bag = "";
$log .= "Key($bagkey)";
foreach $that (@bagparts) {
my $onechar = "" . (chr($that) ^ chr($bagkey)); # decode the bag
# Stupid... ^ only works right for chars, not for numbers!?!?
if ($onechar =~ /[a-zäöü.]/) {
$log .= " Decode($that = " . $onechar . ")";
$bag .= $onechar;
} else {
$log .= " Invalid($that ^ $bagkey = " . ord($onechar) . " ($onechar))";
}
}
$log .= "\nBagRead($bag)\n\n";
$bagkey = int(rand(256)); # new key for the next save
# --------------------- reset the bag if needed or requested
my $oldbagsize = length($bag);
if ( ($oldbagsize == 0) && ($command =~ /^[1-9]$/) ) {
$bag = $newbag; # fill up empty bag to start new game
$answer = "Starting with a new bag, old was empty...
\n";
$log .= "\nNewBag($bag)\n";
}
if ($command =~ /^[*]$/) {
$bag = $newbag; # fill up empty bag to start new game
$answer = "Cheatcode *: Refilling bag with German letter set!
\n";
}
if ($command =~ /^[!]$/) {
$bag = $dutchbag; # fill up empty bag to start new game
$answer = "Cheatcode !: Refilling bag with Dutch letter set!
\n";
}
if ($command =~ /^[?]$/) {
$bag = $ukbag; # fill up empty bag to start new game
$answer = "Cheatcode ?: Refilling bag with English letter set!
\n";
}
my $bagsize = length($bag);
# --------------------- fetch from bag
if ($command =~ /^[1-9]$/) { # fetch N random bag elements
# $command = ord($command) - ord('0');
if ($command > $bagsize) {
$answer .= "You got only the following $bagsize items: ";
$answer .= "\n
(not $command, the bag was too empty)
\n";
$command = $bagsize;
} else {
$answer .= "You got the following $command items: ";
}
my @bagarray = split(//,$bag);
$answer .= "
";
for (1 .. $command) {
my @gotten = splice( @bagarray, int(rand($bagsize)), 1 );
# splice 1 element out at random position and return it
$answer .= join(' ',@gotten) . " ";
$bagsize--;
$bag = join('',@bagarray);
}
$answer .= "
";
}
# $bagsize = length($bag);
# --------------------- fill the bag
if ($command =~ /^[a-zäöü.]+$/) { # put the listed chars into the bag
$bag .= $command;
$answer .= "Your choice $command has been added to the bag";
$bagsize = length($bag);
}
# --------------------- complain about all other commands
if ($command =~ /[^a-z1-9äöü.*!?]/) {
$answer .= "\nCommand ignored. Must be a number or letters\n";
$answer .= "Letters: a-z äöü and . (for joker).\n";
$answer .= "Number: 1-9\n";
$answer .= "(Or cheatcode * or ! or ? for German or Dutch or English refill!)\n";
}
if (length($command) < 1) {
$answer .= "\nNo command given. Just showing bag status.\n";
}
# --------------------- write the new version of the bag:
open(BAG,">$bagfile") || print "$errheader"
. "Bag not writeable!!! CONTENTS COULD NOT BE UPDATED!\n";
print BAG "$bagkey" || print "$errheader"
. "Could not write bag key:\n$bagkey\n";
my $codebag = "";
$log .= "Written($bagkey)\n";
if ($bagsize > 0) {
foreach $that (split(//,$bag)) {
$codebag .= " " . ( ord($that ^ chr($bagkey)) ) # encode the bag
# Strange: ^ works better for chars than for numbers!?
}
print BAG "$codebag" || print "$errheader"
. "Could not write bag letters:\n$codebag\n";
}
$log .= "Written($codebag)\n";
close(BAG);
# --------------------- output the results to the user:
print $htmlheader;
print "Erics virtual Scrabble bag:
\n$answer\n";
print "
old size: $oldbagsize new size: $bagsize
\n";
# for debugging:
# print "
Current bag contents:
$bag
\n";
print "
Current bag contents, encoding key $bagkey:
\n";
print "$codebag
\n";
print "
This transaction is done for:
$who
\n
\n";
print ""
. "Regeln bei Brostedts Web-Scrabble
\n";
print ""
. "Kurzübersicht Brett und Buchstabenvorrat
\n";
print "Buchstabenvorrat zu Spielbeginn:
5x A (1) 1x Ä (6) 2x B (3) 2x C (4) 4x D (1) 15x E (1)
2x F (4) 3x G (2) 4x H (2) 6x I (1) 1x J (6) 2x K (4)
3x L (2) 4x M (3) 9x N (1) 3x O (2) 1x Ö (8) 1x P (4)
1x Q (10) 6x R (1) 7x S (1) 6x T (1) 6x U (1) 1x Ü (6)
1x V (6) 1x W (3) 1x X (8) 1x Y (10) 1x Z (3) 2x Joker (0)
Dutch Scrabble letters, values, frequency (plus 2 jokers, value 0):
a b C D e f G H i J K L m n O P Q R S T U V W x Y Z
1 3 5 2 1 4 3 4 1 4 3 3 3 1 1 3 10 2 2 2 4 4 5 8 8 4 (value)
6 2 2 5 18 1 4 3 6 2 2 3 2 10 6 2 1 6 3 6 2 2 2 1 1 2 (frequency)
English Scrabble letters, values, frequency (plus 2 jokers, value 0):
a b C D e f G H i J K L m n O P Q R S T U V W x Y Z
1 3 3 2 1 4 2 4 1 8 5 1 3 1 1 3 10 1 1 1 1 4 4 8 4 10 (value)
9 2 2 4 12 2 3 2 9 1 1 4 2 6 8 2 1 6 4 6 4 2 2 1 2 1 (frequency)
Fetch 4 letters:
| scrabblesack.cgi?4
|
Put an a, two e and a Joker back:
| scrabblesack.cgi?a.ee
|
Check the contents:
| scrabblesack.cgi
|
Refill, start a new German game:
| scrabblesack.cgi?*
|
Refill, start a new Dutch game:
| scrabblesack.cgi?!
|
Refill, start a new English game:
| scrabblesack.cgi??
|
\n";
# *** print "
\nDEBUG LOG:\n$log\n
\n";
print "\n\n\n";