#! /usr/bin/perl
###############################################################################
#
#  Scrabble  --  a crossword game
#
#  Version: 1.10
#
#  Written by Brian White <bcwhite@pobox.com>
#  Placed in the public domain (the only true "free")
#
###############################################################################


=head1 NAME

scrabble - popular crossword game

=head1 SYNOPSIS

B<scrabble> <I<level>>

=head1 DESCRIPTION

B<Scrabble> is a hybrid of crossword mentality, positional strategy, and a
true test of your language mastery, similar to the well known Scrabble(R) game
made by Hasbro.  You start with a board that serves for the placement for
letter tiles.  On the board there are specific squares that when used can add
to your score dramatically. These premium squares can double or triple letter
values.  Some of these squares can even double or triple your word scores!
You must position yourself to grab the squares and block your opponent from
spelling out a "killer" word.

=head2 Options

B<Scrabble> takes only one option: the play level.  This option is a number
from 1 to 9 (inclusive) with higher numbers indicating a more difficult
opponont.

=head1 COPYRIGHT

B<Scrabble> was written by Brian White <bcwhite@pobox.com> and has been placed
in the public domain (the only true "free").

=cut



###############################################################################


$Lang = "english";



if (-w "/var/state/scrabble") {
	$NewWords="/var/state/scrabble/$Lang";
} elsif (-w "/var/lib/scrabble") {
	$NewWords="/var/lib/scrabble/$Lang";
} elsif ($ENV{HOME} && -w $ENV{HOME}) {
	$NewWords=$ENV{HOME}."/.scrabble-$Lang";
} else {
	$NewWords="scrabble-words";
}

#			"/usr/share/dict/american-$Lang",
#			"/usr/share/dict/american-$Lang-small",
#			"/usr/share/dict/american-$Lang-large",
#			"/usr/local/share/dict/american-$Lang",
#			"/usr/local/share/dict/american-$Lang-small",
#			"/usr/local/share/dict/american-$Lang-large",
#			"./american-$Lang",
#			"./american-$Lang-small",
#			"./american-$Lang-large",
@WordFiles=("/usr/share/dict/scrabble-$Lang",
			"/usr/local/share/dict/scrabble-$Lang",
		   );

if ($ENV{HOME} && -d $ENV{HOME}) {
	$NewGames=$ENV{HOME}."/scrabble-games";
} else {
	$NewGames="scrabble-games";
}


$Debug=0;
%Words;
%WDefs;
$WNew;
%Parts;
@Board;
@BNear;
@BMods;
%Reserve;
$LRemain;
%LVals;
$PLetters;
$CLetters;
$PScore;
$CScore;
$Level;
$Abort=0;
@MeWords;
@YuWords;


@WordPrefixes	= ("","un","mis","p?re");
@WordSuffixes1	= ("","e[drn]","ment","ness","ish","ive","ing","ly","[ai]ble","ably");
@WordSuffixes2	= ("","s","es");



sub uniq
{
	return () unless @_;

	my($last) = undef;
	my(@new)  = ();
	foreach (@_) {
		next unless $_;
		if ($_ ne $last) {
			$last = $_;
			push(@new,$_);
		}
	}
	return @new;
}



sub DumpHash
{
	my($hash) = @_;
	my($key);

	foreach (sort keys %$hash) {
		print STDERR "$_ -> '$hash->{$_}'\n";
	}
}



###############################################################################



sub InitGame
{
	my($y,$x,$i);

	foreach $x (split(//,"0123456789ABCDE")) {
		foreach $y (split(//,"0123456789ABCDE")) {
			$i = hex($y.$x);
			$Board[$i] = " ";
			$BNear[$i] = "";
		}
	}

	$LRemain = 100;
	%Reserve = (
		A => 9,	H => 2,	O => 8,	V => 2,
		B => 2,	I => 9,	P => 2,	W => 2,
		C => 2,	J => 1,	Q => 1,	X => 1,
		D => 4,	K => 1,	R => 6,	Y => 2,
		E =>12,	L => 4,	S => 4,	Z => 1,
		F => 2,	M => 2,	T => 6, _ => 2,
		G => 3,	N => 6,	U => 4
	);

	%LVals = (
		A => 1,	H => 4,	O => 1,	V => 4,
		B => 3,	I => 1,	P => 3,	W => 4,
		C => 3,	J => 8,	Q =>10,	X => 8,
		D => 2,	K => 5,	R => 1,	Y => 4,
		E => 1,	L => 1,	S => 1,	Z =>10,
		F => 4,	M => 3,	T => 1, _ => 0,
		G => 2,	N => 1,	U => 1
	);

	@BMods = split(//,
				  "@  -   @   -  @ ".
				  " *   +   +   *  ".
				  "  *   - -   *   ".
				  "-  *   -   *  - ".
				  "    *     *     ".
				  " +   +   +   +  ".
				  "  -   - -   -   ".
				  "@  -   *   -  @ ".
				  "  -   - -   -   ".
				  " +   +   +   +  ".
				  "    *     *     ".
				  "-  *   -   *  - ".
				  "  *   - -   *   ".
				  " *   +   +   *  ".
				  "@  -   @   -  @ ");

	$PLetters = ""; $PScore = 0;
	$CLetters = ""; $CScore = 0;

	srand();
}



sub StoreWord
{
	my($word,$defn) = @_;

	# add definition if provided
	$WDefs{$word} = $defn if ($defn);

	# stop now if word has already been added
	next if (exists $Words{$word});
	$Words{$word} = 0;
	print "added word '$word', defn: $defn\n" if ($Debug);

	# add all the prefixes leading up to full word (makes for fast search)
	chop($word);
	while ($word ne "") {
		$Parts{$word} += 1;
		chop($word);
	}
}


sub ReadWords
{
	my(@files) = @_;
	my($wcount,$dcount,$words,$lastword);

	print STDERR "Reading words... ";

	foreach $file (@files) {
		$lastword = "";
		next unless open(WORDFILE,"<$file");
		while (<WORDFILE>) {
			chomp;
			s/\#.*//;
			next if (m/^\s*$/);

			$words = $_;
			while ($words) {
				$group = 0;
#				print STDERR ".";

				# handle compressed word lists
				if ($words =~ s/^(\d+)([A-Z]?)//) {
					$words = substr($lastword,0,$1) . $words;
					$group = ord($2) - ord('A') + 1 if ($2);
				}
				$groups{$group}++;

				# handled concatinated word lists (no CR/LF between)
				if ($words =~ s/^([a-z]+)(\d+)/$2/) {
					$_ = $1;
				} else {
					$_ = $words;
					$words = "";
				}

				# allow improper words to be removed
				if (m/^-([a-z]+)/) {
					delete $Words{$1};
					next;
				}

				# ignore unless it a word of just lower-case letterts
				next unless m/^([a-z]+)(\s+(.*?)\s*)?$/;

				# word has been found
				$lastword = $1;

				# add definition if one doesn't already exist
				if ($3 && !exists $WDefs{$1}) {
					$WDefs{$1} = $3;
					$dcount++;
				}

				# stop now if word has already been added
				next if (exists $Words{$1});
				$Words{$1} = $group;
				$wcount++;

				# add all the prefixes leading up to full word (makes for fast search)
				$_ = $1;
				chop;
				while ($_ ne "") {
					$Parts{$_} += 1;
					chop;
				}

			}
		}
		close(WORDFILE);
	}

	$wcount = "0" unless $wcount;
	$dcount = "0" unless $dcount;
#	print STDERR "($wcount found, $dcount w/ definitions, $groups{0}/$groups{1}/$groups{2}/$groups{3}/$groups{4}/$groups{5}/$groups{6}/$groups{7}/$groups{8}/$groups{9})\n";
	print STDERR "($wcount found, $dcount w/ definitions)\n";
}



sub SaveNewWords
{
	if ($WNew ne "") {
		if (open(WORDS,">>$NewWords")) {
			print WORDS $WNew;
			close(WORDS);
		} else {
			print STDERR "Error: could not write new words to '$NewWords' -- $!\n";
		}
		$WNew = "";
	}
}



sub DisplayBoard
{
	my($y,$x,$c);

	print "\n";
	if ($LRemain > 0) {
		print "         $LRemain letter",($LRemain == 1 ? "":"s")," remain\n";
	} else {
		print " no letters remain  (",length($CLetters)," in my rack)\n";
	}
	print "   0 1 2 3 4 5 6 7 8 9 A B C D E\n";
	print "   - - - - - - - - - - - - - - -\n";
	foreach $y (split(//,"0123456789ABCDE")) {
		print "$y| ";
		foreach $x (split(//,"0123456789ABCDE")) {
			$c = $Board[hex($y.$x)];
			if ($c eq " ") {
				$c = $BMods[hex($y.$x)];
			}
			print $c," ";
		}
		print "|$y  ";
		if (hex($y) < 8) {
			if ($y eq "0") {
				print "My Words:\n";
			} else {
				print " ".$MeWords[hex($y)-1],"\n";
			}
		} else {
			if ($y eq "8") {
				print "Your Words:\n";
			} else {
				print " ".$YuWords[hex($y)-9],"\n";
			}
		}
	}
	print  "   - - - - - - - - - - - - - - -\n";
	print  "   0 1 2 3 4 5 6 7 8 9 A B C D E\n\n";
	printf " me:%-3d    ",$CScore;
	foreach $c (split(//,$PLetters)) {
		print $c," ";
	}
	print  " "x((7-length($PLetters))*2);
	printf "  you:%-3d\n\n",$PScore;
}


sub DrawLetters
{
	my($rack) = @_;
	my($count,$rand,$char,$letr);

	$count = 7 - length($$rack);
	while ($count--) {
		return if ($LRemain == 0);
		$rand = int(rand($LRemain)) + 1;
		foreach $char (split(//,"ABCDEFGHIJKLMNOPQRSTUVWXYZ_*")) {
			if ($char eq "*") {
				print STDERR "Fatal: $LRemain letters remaining but Reserve is short\n";
				DumpHash(\%Reserve);
				exit(1);
			}
			$letr  = $char;
			last if ($rand <= $Reserve{$char});
			$rand -= $Reserve{$char};
		}

		$LRemain--;
		$Reserve{$letr}--;
		$$rack .= $letr;
	}
}



sub UnplayedLetters
{
	my($letters) = @_;
	my($minus);

	foreach (split(//,$letters)) {
		$minus += $LVals{$_};
	}

	return $minus;
}



#-----------------------------------------------------------------------------



sub PlaceWord
{
	my($loc,$word,$letters) = @_;
	my($y,$x,$d) = ($loc =~ m/(.)(.)(.)/);
	my($i,$c);

	$i = hex($y.$x);
	$x = hex($x);
	$y = hex($y);

	foreach $c (split(//,$word)) {
		die "Error: can't place '$word' at '$loc' ('$Board[$i]' at $i [$c])\n" if ($Board[$i] ne " " && $Board[$i] ne "-" && uc($Board[$i]) ne uc($c));

		if ($Board[$i] eq " " || $Board[$i] eq "-") {
			if ($$letters !~ s/$c//) {
				$c = lc($c);
				if ($$letters !~ s/_//) {
					die "Fatal: could not find letter '$c' in '$$letters' (word=$word)\n";
				}
			}
		}

		$Board[$i]	   = $c if ($Board[$i] !~ m/[a-z]/i);
		$BNear[$i-16] .= $c if ($y != 0);
		$BNear[$i+16] .= $c if ($y != 14);
		$BNear[$i-1]  .= $c if ($x != 0);
		$BNear[$i+1]  .= $c if ($x != 14);
		$i += ($d eq "d" ? 16 : 1);
	}
}



sub VerifyWord
{
	my($loc,$word,$maxlevel) = @_;
	my($y,$x,$d)   = ($loc =~ m/(.)(.)(.)/);
	my($i,$j,$k,$c,$left,$rght,$mtch,@bad);
	$maxlevel = 9 unless ($maxlevel);

	$i = hex($y.$x);
	$x = hex($x);
	$y = hex($y);

	foreach $c (split(//,$word)) {
		if ($BNear[$i] ne "") {
			$left = $rght = "";
			if ($d eq "d") {
				for ($j=$x-1,$k=$i-1; $j >=  0 && $Board[$k] ne " "; --$j,$k-=1) {
					$left = $Board[$k].$left;
				}
				for ($j=$x+1,$k=$i+1; $j <= 14 && $Board[$k] ne " "; ++$j,$k+=1) {
					$rght = $rght.$Board[$k];
				}
			} else {
				for ($j=$y-1,$k=$i-16; $j >= 0  && $Board[$k] ne " "; --$j,$k-=16) {
					$left = $Board[$k].$left;
				}
				for ($j=$y+1,$k=$i+16; $j <= 14 && $Board[$k] ne " "; ++$j,$k+=16) {
					$rght = $rght.$Board[$k];
				}
			}
			$mtch = $left.$c.$rght;
#			print "\n$word [$loc]: additional word '$mtch'..." if ($Debug);
			unless (length($mtch) == 1 || (exists $Words{lc($mtch)} && $Words{lc($mtch)} <= $maxlevel)) {
#				print " (unknown)" if ($Debug);
				push @bad,$mtch;
			}
#			print " (okay)" if ($Debug);
		}
		$i += ($d eq "d" ? 16 : 1);
	}

	return (wantarray ? @bad : (scalar(@bad) == 0));
}



sub CountWord
{
	my($loc,$word,$words) = @_;
	my($y,$x,$d)   = ($loc =~ m/(.)(.)(.)/);
	my($i,$c,$b,$l,$p,$v,$e,$w,$m,$a,$s);
	my($lmod,$wmod,$left,$rght);

	$i = hex($y.$x);	# board index
	$x = hex($x);		# column
	$y = hex($y);		# row

	$l = 0;
	$p = 0;
	$e = 0;
	$s = 0;

	$wmod = 1;
	foreach $c (split(//,$word)) {
		$lmod = 1;

		$b  = $Board[$i];
		$v  = $LVals{$b ne " " ? $b : $c}; $v = 0 unless (defined $v);
		$m  = ($b =~ m/[a-z]/i ? "" : $BMods[$i]);
		$s += ($b =~ m/[a-z]/i ? 0  : 1) if ($c eq "S");
		$s += ($b =~ m/[a-z]/i ? 0  : 2) if ($c =~ m/[a-z]/);
		$w  = undef;
#		print STDERR "c=$c; b=$b; v=$v; m=$m; s=$s; w=$w\n";

		# count extra words
		if ($b eq " " && $BNear[$i] ne "") {
			$left = $rght = "";
			if ($d eq "d") {
				for ($j=$x-1,$k=$i-1; $j >= 0  && $Board[$k] ne " "; --$j,$k-=1) {
					$left = $Board[$k].$left;
					$w	 += $LVals{$Board[$k]};
				}
				for ($j=$x+1,$k=$i+1; $j <= 14 && $Board[$k] ne " "; ++$j,$k+=1) {
					$rght = $rght.$Board[$k];
					$w	 += $LVals{$Board[$k]};
				}
			} else {
				for ($j=$y-1,$k=$i-16; $j >= 0  && $Board[$k] ne " "; --$j,$k-=16) {
					$left = $Board[$k].$left;
					$w	 += $LVals{$Board[$k]};
				}
				for ($j=$y+1,$k=$i+16; $j <= 14 && $Board[$k] ne " "; ++$j,$k+=16) {
					$rght = $rght.$Board[$k];
					$w	 += $LVals{$Board[$k]};
				}
			}
		}

		# determine letter adjustments
		if ($m eq '-') {
			$lmod  = 2;
		} elsif ($m eq '+') {
			$lmod  = 3;
		}

		# add letter values
		$p += $v * $lmod;
		$w += $v * $lmod if defined($w);

		# adjust for big letters on weak (non-multiplier) spaces
		if ($v >= 4 && $LRemain > 7) {
			$a += int($v*(3-$lmod)/2);
		}

		# determine word adjustments
		if ($m eq '*') {
			$wmod *= 2;
			$w    *= 2;
		} elsif ($m eq '@') {
			$wmod *= 3;
			$w    *= 3;
		}

		$words->{$left.$c.$rght} += $w if ($w && ref($words) eq "HASH");

		$e += $w if $w;
		$l += 1 unless ($b =~ m/[a-z]/i);
		$i += ($d eq "d" ? 16 : 1);
	}

	# add word multiplier
	$p *= $wmod;

	# see if a 7-letter word has been made
	$p += 50 if ($l == 7);
	die "Fatal: used more than 7 letters?\n" if ($l > 7);

	$words->{$word} += $p if (ref($words) eq "HASH");
	return (wantarray ? ($p,$e,$a,$s) : $p+$e);
}



sub DisplayWords
{
	my($who,$total,$words,$main,$lines) = @_;
	my($word,$defn,$maxl,@list,$print,$extra,$line);

	push @list,$main;
	push @list,sort(grep(!/^$main$/,keys(%$words)));
	foreach (@list) {
		$maxl = length($_) if (length($_) > $maxl);
	}

	for ($line=0; length($$lines[$line+1]) != 0; ++$line) {};

	$extra = 0;
	print "\n$who placed:\n";
	foreach $word (@list) {
		printf "  %3d  %-${maxl}s",$words->{$word},"$word";
		$defn = $WDefs{lc($word)};
		if (defined $defn) {
			print "  - ";
			print $WDefs{$1}," " if ($defn =~ m/^\[(.*?)-(.*)\]$/);
			print $defn;
		}
		print  "\n";
		$print = lc($word)."(".$words->{$word}.")";
		$print = "[$print" if ($word ne $main && $extra++ == 0);
		$$lines[$line] .= " " if (length($$lines[$line]) != 0 && $extra < 2);
		$$lines[$line] .= "," if (length($$lines[$line]) != 0 && $extra > 1);
		$line++ if (length($$lines[$line]) >= 42-length($print));
		$$lines[$line] .= $print;
	}
	$$lines[$line] .= "]" if ($extra != 0);
	printf "for a total of %d points.\n",$total;
}



###############################################################################



sub Anagrams
{
	my($level,$pattern,$part,$letters,$minlen,$maxlevel) = @_;
	my(@found,%done,$char,$mtch,$i,$left,$rght,$long,$plen);

	$plen = length($part);
	$long = ($plen+1 >= $minlen && substr($pattern,$plen+1,1) !~ m/[a-z]/i);
	$char = substr($pattern,$plen,1);
	$level++;
#	print "\n${level}: pattern=$pattern; part=$part; letters=$letters; minlen=$minlen; maxlevel=$maxlevel : ";

	if ($char eq "-" || $char eq ".") {
		$i = length($letters);
		while ($i--) {
			($left,$char,$rght) = ($letters =~ m/^(.{$i})(.)(.*)/);
			$left .= $rght;
			next if $done{$char};
			$done{$char} = 1;
			if ($char eq "_") {
				next if ($maxlevel < 99 && $plen < 3 && $part =~ m/[a-z]/); # computer: only 1 blank in first 3 letters
				foreach $char (split(//,"abcdefghijklmnopqrstuvwxyz")) {
					$mtch = $part.$char;
#					print " [$part+$char ($left)] ";
					if ($long) {
						if (exists $Words{lc($mtch)} && $Words{lc($mtch)} <= $maxlevel) {
#							print "{word}";
							push @found,$mtch;
						}
					}
					if (exists $Parts{lc($mtch)} && length($mtch) < length($pattern)) {
#						print "{part}";
						push @found,Anagrams($level,$pattern,$mtch,$left,$minlen,$maxlevel);
					}
				}
			} else {
				$char = uc($char);
				$mtch = $part.$char;
#				print " [$part+$char ($left)] ";
				if ($long) {
					if (exists $Words{lc($mtch)} && $Words{lc($mtch)} <= $maxlevel) {
#						print "{word}";
						push @found,$mtch;
					}
				}
				if (exists $Parts{lc($mtch)} && length($mtch) < length($pattern)) {
#					print "{part}";
					push @found,Anagrams($level,$pattern,$mtch,$left,$minlen,$maxlevel);
				}
			}
		}
	} else {
		$mtch = $part.uc($char);
		if ($long) {
			if (exists $Words{lc($mtch)} && $Words{lc($mtch)} <= $maxlevel) {
				push @found,$mtch;
			}
		}
		if (exists $Parts{lc($mtch)} && length($mtch) < length($pattern)) {
			push @found,Anagrams($level,$pattern,$mtch,$letters,$minlen,$maxlevel);
		}
	}

	return @found;
}


sub FindAnagrams
{
	my($letters,$pattern,$maxlevel) = @_;
	my($minlen,@found);
	$maxlevel = 99 unless ($maxlevel);

	if ($pattern =~ m/^(\.+[A-Z\-]+?)\-?/i) {
		$minlen = length($1);
	} elsif ($pattern =~ m/^([A-Z]*[\-\.])/i) {
		$minlen = length($1);
	} else {
		return ();
	}

#	print "\n${pattern} [$minlen]: ";
	@found = Anagrams(0,$pattern,"",$$letters,$minlen,$maxlevel);
	@found = uniq(sort(@found));
	print "\n${pattern} [$minlen]: @found\n" if ($Debug);
	return @found;
}



#------------------------------------------------------------------------------



sub ChoiceWeight
{
	my($loc,$word,$pattern,$letters) = @_;
	my($points,$extra,$adjust,$scount,$sweight);

	# Make sure word is legal
	return 0 unless VerifyWord($loc,$word,$Level);

	# Level #1 is really, really simple
	return length($word) if ($Level == 1);

	# Limit pattern length to match word
	$pattern = substr($pattern,0,length($word));

	# Real weightings start with the point-value of the word
	($points,$extra,$adjust,$scount) = CountWord($loc,$word);
#	print "\n$word [$loc]: points=$points; extra=$extra; adjust=$adjust; scount=$scount ";

	# Level #2 is just number of points for the base word
	return $points if ($Level == 2);

	# Level #3 is just number of points for all words
	return $points+$extra if ($Level == 3);

	# Level #4 includes postponement of "s" for double-word forming
	$sweight  = 1.00;
	$sweight *= 0.75 while ($scount--);
	return ($points*$sweight)+$extra if ($Level == 4);

	# Level #5 includes "better-use" delay of letters
	return 0 if ($letters=~m/Q/ && $word!~m/Q/ && $letters=~m/^[^U]*[U_][^U]*$/ && $word=~m/U/i && $pattern!~m/U/i);
	return (($points-$adjust)*$sweight)+$extra if ($Level == 5);

	# Level #6 tries to avoid allowing access to 3-word scores

	# Level #7 will try to block 3-word scores if nothing can be placed there

	return (($points-$adjust)*$sweight)+$extra;
}



#------------------------------------------------------------------------------



sub SearchBoard
{
	my($y,$x,$d) = @_;
	my($i,$c,$p,$q,$l,$n);

	$i = hex($y.$x);				# board index
	$x = hex($x);					# column
	$y = hex($y);					# row
	$c = 15 - ($d eq "d" ? $y : $x);# max char count
	$n = 1;							# allow "near"

	# stop now if there is letter just before start (can't start word directly after another)
	if ($c != 15) {
		return undef if ($Board[$i - ($d eq "d" ? 16 : 1)] ne " ");
	}

	# gather existing letters (note if there are letters adjacent to a square)
	while ($c) {
		$l  = $Board[$i];
		$l  = "-" if ($n && $l eq " " && $BNear[$i] ne "");
		$n  = 0   if ($l eq "-");
		$p .= $l;
		$i += ($d eq "d" ? 16 : 1);
		$c -= 1;
	}

	$i = 0;
	while ($p =~ s/^(.)//) {
		last if ($1 eq " " && $i == 7);
		$i += 1 if ($1 eq " ");
		$q .= $1;
	}

	if ($q =~ m/[A-Z\-]/) {
		$q =~ s/ /./g;
		return $q;
	} else {
		return undef;
	}
}



sub ChangeLetters
{
	my($letters) = @_;

	return if ($LRemain == 0);

	foreach (split(//,$$letters)) {
		$LRemain++;
		$Reserve{$_}++;
	}

	$$letters = "";
}



sub ComputerTurn
{
	my($letters,$score) = @_;
	my($y,$x,$opt,$pat,$loc,$think,$match,$weight,$bestm,$bestw,$bestl,$bestp);
	my(@found,%words,%wordloc);

	return unless $$letters;

#	print "${$letters}: ";
	print "Looking";
	foreach $x (split(//,"0123456789ABCDE")) {
		print ".";
		foreach $y (split(//,"0123456789ABCDE")) {
			$opt = SearchBoard($y,$x,"a");
			if ($opt) {
				$wordloc{$opt} = [] unless exists $wordloc{$opt};
				push @{$wordloc{$opt}},$y.$x."a";
#				print "$y$x a $opt\n" if $opt;
			}
			$opt = SearchBoard($y,$x,"d");
			if ($opt) {
				$wordloc{$opt} = [] unless exists $wordloc{$opt};
				push @{$wordloc{$opt}},$y.$x."d";
#				print "$y$x d $opt\n" if $opt;
			}
		}
	}
	print "\n";

	$think = 0;
	print "Thinking";
	foreach $pat (keys %wordloc) {
		print "." if ($think++ % 10 == 0);
		@found = FindAnagrams($letters,$pat,$Level);
#		print "\n$pat -> @found [@{$wordloc{$pat}}] ";
		foreach $match (@found) {
			foreach $loc (@{$wordloc{$pat}}) {
				$weight = ChoiceWeight($loc,$match,$$letters);
				if ($weight > $bestw || ($weight == $bestw && hex($loc) < hex($bestl))) {
#					print "{$match [$loc] = $weight} ";
					$bestw = $weight;
					$bestm = $match;
					$bestl = $loc;
					$bestp = $pat;
				}
			}
		}
	}
	print "\n";

	if ($bestw == 0) {
		ChangeLetters($letters);
		print "No words -- changed letters instead\n";
		return;
	}

	die "Fatal: word length exceeded pattern length ('$bestm' vs '$bestp')\n" if (length($bestp) < length($bestm));
#	print "${$letters}: $bestm @ $bestl [$bestp/$bestw]\n";

	$think = CountWord($bestl,$bestm,\%words);
	PlaceWord($bestl,$bestm,$letters);
	DisplayWords("I",$think,\%words,$bestm,\@MeWords);

	$$score += $think;
}



###############################################################################



sub WordDefn
{
	my($word) = @_;
	my($defn,$root);
	$word = lc($word);

	print "\n",
	"The word '$word' is unknown to me.  Please give the definition of the word\n",
	"so it can be used now and in future games.  Also give the [rootword-suffix]\n",
	"if possible.  For example:\n",
	"    damply    - <adv> in a damp manner\n",
	"    hagriding - <v> to harass [hagride-ing]\n",
	"    phenoxy   - <adj> containing a radical derived from phenol\n",
	"    qat       - <n> an evergreen shrub\n",
	"    spaes     - <v> to fortell [spae-s]\n",
	"    ye        - <pron> you\n",
	"Press <return> if this isn't really a word.\n\n";

	print "$word - ";
	$defn = <STDIN>;
	chomp($defn);
	return 0 if ($defn =~ m/^\s*$/);

	unless ($defn =~ m/<\S+>/) {
		print "Unknown definition format -- word ignored\n";
		return 0;
	}

	if ($defn =~ m/^(.*?)\s*\[([^\[\]]+)-([^\[\]]+)\]\s*(.*?)$/) {
		$defn  = $1." ".$4;
		$root  = $2;
		$WNew .= "$word [$2-$3]\n";
		print "1=$1; 2=$2; 3=$3; 4=$4; defn=$defn; root=$root; wnew=$WNew" if ($Debug);
		StoreWord($word,"[$2-$3]");
		$defn  =~ s/^\s+|\s+$//g;
		$defn  =~ s/\s+/ /g;
		$word  =  $root;
		print "rootword=$word; defn=$defn\n" if ($Debug);
		return 1 unless ($defn);
		print "storing root word...\n" if ($Debug);
	}

	print "word=$word; defn=$defn\n" if ($Debug);
	StoreWord($word,$defn);
	$WNew .= "$word $defn\n";
	print "wnew=$WNew\n" if ($Debug);
	return 1;
}



sub PlayerTurn
{
	my($letters,$score) = @_;
	my(@found,%words,$turn,$word,$loc,$patn,$best);

	print "Enter word as \"YXd <word>\" (Y=row, X=col, D=a/d) or \"help\" for other commands.\n";

	while (1) {
		print ": ";
		$turn = lc(<STDIN>);
 		$turn =~s/^\s+|\s+$//gs;

		# catch help
		if ($turn eq "help") {
			print "\n",
			"To enter a word, give the Y (row) and X (column) coordinates as well as the\n",
			"direction (a/d = across/down), a space, and the full word to be placed.\n\n",
			"    e.g.  37d words\n\n",
			"Other known commands are:\n\n",
			"    ?                - display the board\n",
			"    change <letters> - drop given letters from rack and draw new ones\n",
			"    info             - display letter and scoring information\n",
			"    help             - display this information\n",
			"    pass             - skip this turn (only useful at the end of the game)\n",
			"    debug            - show debugging information (for bug reports, etc.)\n",
			"    quit             - end the game now\n",
			"\n";
			next;
		}

		# catch quit
		if ($turn eq "quit") {
			$Abort = 1;
			last;
		}

		# catch pass
		if ($turn eq "pass") {
			last;
		}

		# catch refresh
		if ($turn eq "?") {
			DisplayBoard();
			next;
		}

		# catch info
		if ($turn eq "info") {
			print "\n",
			"Bonus Score Squares\n",
			"@ => Triple Word Score\n",
			"* => Double Word Score\n",
			"+ => Triple Letter Score\n",
			"- => Double Letter Score\n\n",
			"Letter Values\n",
			"A => 1  H => 4  O => 1  V => 4\n",
			"B => 3  I => 1  P => 3  W => 4\n",
			"C => 3  J => 8  Q =>10  X => 8\n",
			"D => 2  K => 5  R => 1  Y => 4\n",
			"E => 1  L => 1  S => 1  Z =>10\n",
			"F => 4  M => 3  T => 1  _ => 0\n",
			"G => 2  N => 1  U => 1\n\n",
			"Letter Distribution\n",
			"A => 9  H => 2  O => 8  V => 2\n",
			"B => 2  I => 9  P => 2  W => 2\n",
			"C => 2  J => 1  Q => 1  X => 1\n",
			"D => 4  K => 1  R => 6  Y => 2\n",
			"E =>12  L => 4  S => 4  Z => 1\n",
			"F => 2  M => 2  T => 6  _ => 2\n",
			"G => 3  N => 6  U => 4\n";
			next;
		}


		# catch debug
		if ($turn eq "debug") {
			$Debug = !$Debug;
			next;
		}

		# parse command
		($loc,$word) = ($turn =~ m/^(\S+)\s+(\S+)$/);
		next unless ($loc =~ m/^(change|[0-9A-E][0-9A-E][ad])$/i);
		next unless ($word=~ m/^[a-z]+$/i);

		# change letters if so requested
		if ($loc eq "change") {
			if ($word !~ m/^[$$letters]+$/i) {
				print "You don't have all of '$word' in your rack.\n";
				next;
			}
			$loc = "";
			foreach $patn (split(//,uc($word))) {
				next unless ($$letters =~ s/$patn//);
				$loc .= $patn;
			}
			ChangeLetters(\$loc);
			$$letters .= $loc;
			last;
		}

		# check that the word is really a word
		unless (exists $Words{$word}) {
			next unless WordDefn($word);
		}

		# see if it is possible to place this word as requested
		$word  = uc($word);
		$patn  = SearchBoard(split(//,$loc));
		@found = FindAnagrams($letters,$patn);
		$best  = 0;
		foreach $patn (grep(/^$word$/i,@found)) {
			$turn = CountWord($loc,$patn);
			print "$patn @ $loc = $turn (best=$best)\n" if ($Debug);
			if ($best < $turn) {
				$best = $turn;
				$word = $patn;
			}
		}
		unless ($best) {
			print "The word '$word' cannot be placed at location '$loc'.\n";
			next;
		}

		# verify that all created words are valid
		@found = VerifyWord($loc,$word);

		# prompt for all unknown words
		$turn = 1;
		foreach (@found) {
			$turn = 0 unless WordDefn($_);
		}
		next unless $turn;

		# everything is okay -- store it
		$patn = CountWord($loc,$word,\%words);
		PlaceWord($loc,$word,$letters);
		DisplayWords("You",$patn,\%words,$word,\@YuWords);

		# add total score
		$$score += $patn;

		# make used words available at all levels of play
		foreach (keys %words) {
			if ($Words{lc($_)} > $Level) {
				$Words{lc($_)} = 0;
				$WNew .= lc($_)."\n";
			}
		}
		SaveNewWords();

		# turn is done
		last;
	}
}



###############################################################################



select(STDOUT); $|=1;



if ($ARGV[0] eq "--filter-words") {
	shift @ARGV;
	$freqfile = shift @ARGV;
	print STDERR "External Dictionaries:  ";
	ReadWords(grep(!/\bscrabble\b/,@WordFiles));
	%StockWords = %Words; undef %Words;
	%StockWDefs = %WDefs; undef %WDefs;
	foreach (@ARGV) {
		print STDERR $_,":  ";
		ReadWords($_);
	}

	open(FREQ,"<$freqfile") || die "error: could not read '$freqfile' ($!)\n";
	$total = 0;
	while (<FREQ>) {
		m/^(\w+)/;
		$freq{$1} = $total++ if (exists $Words{$1});
	}
	close(FREQ);
	print STDERR "Order file of $total words.\n";

	$lastword = "";
	$linelen  = 0;
	$wcount = 0;
	$dcount = 0;
	foreach $word (sort keys %Words) {
#		$word = "acerose";
		if (!$StockWords{$word} || $WDefs{$word} ne $StockWDefs{$word}) {
			for ($prefix=length($lastword); $prefix != 0; --$prefix) {
				last if (substr($word,0,$prefix) eq substr($lastword,0,$prefix));
			}
			$wcount++;
			undef $index;
			print STDERR "($word" if ($Debug);
			if (exists $freq{$word}) {
#				$index = int($freq{$word} * 8 / $total);
				$index = int(sqrt(1+80*$freq{$word}/$total)) - 1;
			} elsif (1) {
				foreach $pre (@WordPrefixes) {
					foreach $suf1 (@WordSuffixes1) {
						foreach $suf2 (@WordSuffixes2) {
							undef $b;
							if ($suf1 =~ m/^e/ || ($suf1 eq "" && $suf2 =~ m/^e/)) {
								print STDERR " [$word =~ m/^($pre)(.*?)e?($suf1)($suf2)\$/]" if ($Debug);
								print STDERR "*$2$3*" if $word =~ m/^($pre)(.*?)e?($suf1)($suf2)$/ && ($Debug);
								($a,$b,$c,$d,$e) = ($1,$2,"e",$3,$4);
							} else {
								print STDERR " [$word =~ m/^($pre)(.*)($suf1)($suf2)\$/]" if ($Debug);
								print STDERR "*$2*" if $word =~ m/^($pre)(.*)($suf1)($suf2)$/ && ($Debug);
								($a,$b,$c,$d,$e) = ($1,$2,"",$3,$4);
							}
							print STDERR " -> $pre-$b($c)-$suf1-$suf2" if ($Debug);
							$b .= $c if (!exists $freq{$b});
							if (exists $freq{$b}) {
								$index = int(sqrt(1+80*$freq{$b}/$total)) - 1;
								$index++ if ($a);
								$index++ if ($d);
							#	$index++ if ($e);	# plural shouldn't increase level
								last;
							}
						}
						last if (defined $index);
					}
					last if (defined $index);
				}
				if (!defined $index) {
					# search for compound words
					for ($i=length($word)-4; $i >= 4; --$i) {
						$a = substr($word,0,$i);
						$b = substr($word,$i);
						print STDERR " -> $a+$b" if ($Debug);
						if (exists $Words{$a} && exists $freq{$a} && exists $Words{$b} && exists $freq{$b}) {
							$index  = int(sqrt(1+80*$freq{$a}/$total)) - 1;
							$index += int(sqrt(1+80*$freq{$b}/$total)) - 1;
							$index += 2;
							last;
						}
					}
				}
			}
			$index = 7 if ($index > 7);
			$index = 0 if ($index < 0);
			if (!defined $index) {
				print STDERR " -> XXX" if ($Debug);
				$index = 8;
			}
			print STDERR " => ",$index+1,")\n" if ($Debug);
			print STDERR $index+1 unless ($Debug);
			$index = chr($index + ord('A'));
			$counts{$index}++;
			print $prefix,$index,substr($word,$prefix);
			$linelen += length($word) - $prefix + 2;
			if ($WDefs{$word}) {
				print " ",$WDefs{$word},"\n";
				$linelen = 0;
				$dcount++;
			}
			if ($linelen > 1000) {
				print "\n";
				$linelen = 0;
			}
			$lastword = $word;
		}
	}
	print STDERR "\nSaving words... ($wcount found, $dcount w/ definitions, $counts{A}/$counts{B}/$counts{C}/$counts{D}/$counts{E}/$counts{F}/$counts{G}/$counts{H}/$counts{I})\n";
	exit(0);
}



$Level = shift @ARGV;
unless ($Level =~ m/^\d+$/) {
	$Level = 1;
	print "Use: $0 <level>   (where level is 1 to 9)\n";
	print "Level \#1 (easiest) assumed...\n";
	sleep(3);
}
if ($Level > 9) {
	print "(level reduced to 9 [hardest])\n";
	$Level = 9;
}

push @WordFiles,$NewWords;
ReadWords(@WordFiles);
InitGame();
DrawLetters(\$PLetters);
DrawLetters(\$CLetters);
DisplayBoard();

$Board[hex("77")] = "-";
if (int(rand(2)) == 0) {
	print "I go first...\n";
	ComputerTurn(\$CLetters,\$CScore);
	DrawLetters(\$CLetters);
	DisplayBoard();
} else {
	print "You go first...\n";
}

while ($CLetters ne $clast || $PLetters ne $plast) {
#	print STDERR "$LRemain letters remain:  $CLetters  $PLetters  ($CScore vs $PScore)\n";
	$clast = $CLetters;
	$plast = $PLetters;
	PlayerTurn(\$PLetters,\$PScore);
#	ComputerTurn(\$PLetters,\$PScore);
	DrawLetters(\$PLetters);
	DisplayBoard();
	last unless $PLetters;
	last if $Abort;

	sleep(2);
	ComputerTurn(\$CLetters,\$CScore);
	DrawLetters(\$CLetters);
	DisplayBoard();
	last unless $CLetters;
}


print "Game over:  I have ",
	($CLetters ? "\"$CLetters\"" : "no letters")," in my rack and you have ",
	($PLetters ? "\"$PLetters\"" : "no letters")," in yours.\n";

if (!$Abort && $CLetters) {
	$amount  = UnplayedLetters($CLetters);
	$CScore -= $amount;
	$PScore += $amount unless $PLetters;
	print "I have to ",($PLetters ? "remove" : "give you")," $amount point",($amount==1 ? "":"s")," from my score.\n";
}
if (!$Abort && $PLetters) {
	$amount  = UnplayedLetters($PLetters);
	$PScore -= $amount;
	$CScore += $amount unless $CLetters;
	print "You have to ",($CLetters ? "remove" : "give me")," $amount point",($amount==1 ? "":"s")," from your score.\n";
}

print "\nFinal board:\n";
DisplayBoard();
SaveNewWords();

if ($NewGames && open(STDOUT,">>$NewGames")) {
	print "-------------------------------------------------------------------------------\n";
	print "level \#$Level; computer rack: \"$CLetters\"; player rack: \"$PLetters\"\n";
	DisplayBoard();
}
