#!/usr/local/bin/perl
# Lexigraph 1.0
# copyright 1995 by Max Heiman
#  
# This program randomly picks words between 5 and 8 letters long from a
# dictionary and gives you their letter patterns.  So, the pattern for the
# word "dog" is high, middle, low.  The player types in a word which fits
# the pattern.  
#  
# Each letter carries a point value.  If your word scores more than the 
# computer's, you gain that many points.  If the computer's is 
# higher-scoring, you lose the difference.  If you guess the exact word
# the computer picked, you receive a 20 point bonus.
#   
# Typing "alphabet" at the appropriate prompt will display the following
# list of each letter's shape and point value.
#       
# _______________________________________________________________________________
#   
#    ::    ::    ::    ::       :: ::                      ::
# :: :: :: :: :: :: :: :: :: :: :: :: :: :: :: :: :: :: :: :: :: :: :: :: :: ::
#                   ::       ::                :: ::                      ::
#   
# 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
# ______________________________________________________________________________
#       
# You may redistribute this file without modification in accordance
# with the GNU General Software Public License agreement (see COPYING).
# Please send mail to maxwell@minerva.cis.yale.edu with questions or comments
#   
# This program makes use of the perl compiler.  If you run this program 
# and it says Command not found, change the path on the first line, above.  
# Try /usr/bin/perl or type "whereis perl" and use the path that that returns. 
# If it is nowhere on your system, it may be obtained by anonymous ftp
# from ftp.uu.net/gnu/perl-4.0.19.tar.Z
#   
# This program also relies upon the words file which is located on most 
# systems under /usr/share/lib/dict/words.  If the program cannot find your
# words file, type in the appropriate path and filename on the open(DICT...
# line in the program below.
#  
# There is no warranty on this software.    
#      
# Hope you like it.

print "\nPlease wait while the dictionary loads...";
open(DICT, "</usr/share/lib/dict/words") || open(DICT, "</usr/lib/dict/words") || open(DICT, "</usr/share/dict/words") || die "Couldn't find dictionary file\n"; 
while (<DICT>) {
	chop;
	if (!(/[A-Z0-9]/) && length($_)>4 && length($_)<7) {
		$words[$#words+1] = $_;}
	elsif (!/[A-Z0-9]/) {
		$extras[$#extras+1] = $_;
			}
		}
print "\n\n";
&header;
open(DIR, "pwd|");
while (<DIR>) {chop $_; $dir = $_;}
close DIR;
while (!$again) {
srand;
reset(pl);
$coded="";
$anscode="";
$word = $words[int(rand($#words))];

sub translate {
	if ($_ =~ /[tbdfhkl]/) {
		$picture[0] .= ":: ";
		$picture[1] .= ":: ";
		$picture[2] .= "   ";
		$coded .= "h";	
			}
	elsif ($_ =~ /[gjpqy]/) {
		$picture[0] .= "   ";
		$picture[1] .= ":: ";
		$picture[2] .= ":: ";
		$coded .= "j";
				}
	else {
		$picture[0] .= "   ";
		$picture[1] .= ":: ";
		$picture[2] .= "   ";
		$coded .= "o";
				}
		}
$total++;
@letters = split(//, $word);
grep (&translate, @letters);
print "\n\n$picture[0]\n$picture[1]\n$picture[2]\n";
print "\nWhat word has this pattern? ";
$answer=<STDIN>;
chop $answer;
@ansletter = split (//, $answer);
grep(&transans, @ansletter);

sub transans {
	if ($_ =~ /[bdfhklt]/) {
			$anscode .= "h";
			} elsif ($_ =~ /[gjpqy]/) {
			$anscode .= "j";
			} else {$anscode .= "o";}
		}
@anscap = split(//,$answer);
$anscap[0] =~ tr/[a-z]/[A-Z]/;
$anscap = $answer;
$anscap =~ s/\b\w/$anscap[0]/;
if (!$answer) {
	print "\nI was thinking of $word.\n";}
elsif ($answer eq $word) {
	print "\nExcellent! $word is exactly the answer I had in mind.\n";
	$score++;
	$percent = int($score/$total*100);
	print "That makes $score right out of $total.\n";
	print "20 point bonus for guessing my word!\n";
	$sum += 20;
	print "You have $percent percent right, with a score of $sum.\n";
			} elsif ($anscode eq $coded) {
	print "\n$anscap matches the pattern - let me make sure it's a word.  One moment...\n"; 
	if (&lookup) {
			print "Very good! I was thinking of $word, but $answer fits the pattern, too.\n";
		        $score++;
			$percent = int($score/$total*100);
        print "\nThat makes $score right out of $total.\n";	
	&AddBonus;
	if ($bonus>0) {print "$anscap is worth $bonus points more than $word ($answer: $ascore, $word: $wscore).\n";}
	if ($bonus<0) {print "$anscap is worth $lbonus points less than $word ($word: $wscore, $answer: $ascore).\n";}
	if ($bonus==0) {print "$anscap and $word are both worth $wscore.\n";}
	print "\nYou have $percent percent right, with a score of $sum.\n";
		}
	else {print "\n$anscap matches the pattern, but I don't think it's a real word.\nThe dictionary doesn't list too many plurals or participles,\nthough, so maybe it is.  In any case, I was thinking of $word.\n";
					}
			}
else {print "\n$anscap doesn't match the pattern.  I was thinking of $word.\n";
			}
print "\n", 'Type return, "alphabet", "help", or "quit"  ';
$again=<STDIN>;
chop $again;
if ($again =~ /help/i) {
	open(RME, "<$dir/ReadMe.lex") || &MakeReadMe;
	print "\n\n";
	while (<RME>) {
	print STDOUT $_;
		 }
close RME;
print "\n[Press return to go on] ";
$again=<STDIN>;
chop($again);
                }
if ($again eq "alphabet") {&alphabet; $again = "";}
}

sub header {
print "\n\n\n";
print "::::\n";
print "::::\n";
print "::::\n";
print "::::		:::::		::  ::		:::\n";
print "::::	       ::   ::		 :  :		\n";
print "::::	       :::::::		  ::		:::	\n";
print "::::::::       ::   .. 	    	 :  :		:::\n";
print ":::::::: 	:::::		::  ::		:::\n\n";



print "								::\n";
print "								::\n";
print " .:::.		::.::..		::::..		:::::		::\n"; 
print "::  ::		:::  :: 	   :::		::  ::		:: :::.\n";
print "::  ::		::    		 ..:::		::  ::		:::  ::\n";
print " :::::		::		::  ::		:::::		::   ::\n";
print "    ::		::	 	 ::::::		::		::   :::\n";
print "..  ::						::\n";
print " :::::						::	\n";
print "\nLexigraph 1.0, by Max Heiman, copyright 1995\n\n";
&alphabet;
}
sub alphabet {
reset(p);
$word = "abcdefghijklmnopqrstuvwxyz";
@letters = split(//, $word);
grep (&translate, @letters);
print "_______________________________________________________________________________\n";
print "\n$picture[0]\n$picture[1]\n$picture[2]\n";
print "\na  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\n";  
print "\n1  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\n";
print "______________________________________________________________________________\n";
}

sub lookup {
	if (grep(/\b$answer\b/, @words)) {return 1;}
	else {$abbrev=$answer;
		if ($abbrev =~ s/ed\b//) {
			if (grep(/\b$abbrev[e]?\b/, @words)) {return 1;}
			elsif (grep(/\b$abbrev[e]?\b/, @extras)) {return 1;}
			else {return 0;}}
		elsif ($abbrev =~ s/s\b//) {
			if (grep(/\b$abbrev\b/, @words)) {return 1;}
			elsif (grep(/\b$abbrev\b/,@extras)) {return 1;}
			else {return 0;}}
		elsif ($abbrev =~ s/ing\b//) {
			if (grep(/\b$abbrev[e]?\b/, @words)) {return 1;}
			elsif (grep(/\b$abbrev[e]?\b/, @extras)) {return 1;}
			else {return 0;}}
		elsif ($abbrev =~ s/ly\b//) {
			if (grep(/\b$abbrev\b/, @words)) {return 1;}
			elsif (grep(/\b$abbrev\b/, @extras)) {return 1;}}
		else {return 0;}
	}
}

sub AddBonus {
	@wletters = split(//,$word);
	@aletters = split(//,$answer);
	$wscore=0;
	$ascore=0;
	foreach $i (0..$#wletters) {
		if ($wletters[$i] =~ /[aeilnorstu]/) {$wscore+=1;}
		elsif ($wletters[$i] =~ /[dg]/) {$wscore+=2;}
		elsif ($wletters[$i] =~ /[bcmp]/) {$wscore+=3;}
		elsif ($wletters[$i] =~ /[fhvwy]/) {$wscore+=4;}
		elsif ($wletters[$i] =~ /[k]/) {$wscore+=5;}
		elsif ($wletters[$i] =~ /[jx]/) {$wscore+=8;}
		elsif ($wletters[$i] =~ /[qz]/) {$wscore+=10;}

                if ($aletters[$i] =~ /[aeilnorstu]/) {$ascore+=1;}
                elsif ($aletters[$i] =~ /[dg]/) {$ascore+=2;}
                elsif ($aletters[$i] =~ /[bcmp]/) {$ascore+=3;}
                elsif ($aletters[$i] =~ /[fhvwy]/) {$ascore+=4;}
                elsif ($aletters[$i] =~ /[k]/) {$ascore+=5;}
                elsif ($aletters[$i] =~ /[jx]/) {$ascore+=8;}
                elsif ($aletters[$i] =~ /[qz]/) {$ascore+=10;}
		}
	$bonus = $ascore - $wscore;
	$sum += $bonus;
	$lbonus = $wscore - $ascore;
}

sub MakeReadMe {
        open(LEX, "<$dir/lexi");
        open(RM, ">>$dir/ReadMe.lex");
	while (<LEX>) {
                if (/#\s([\w\W]*)/) {print RM $1;}
                        }
        close LEX;
        close RM;
        open(RME, "<$dir/ReadMe.lex");
}
