# freeman
#
# David A. Black & Arthur Jacobs
# April 1998
#
# public domain
######################################################################### # # freeman - written by David A. Black, at the request of (and with
# input from) Arthur Jacobs.
#
# Rules are a variation on hangman.
#
# For every unique letter in your word, you get a bar in front of you.
# (So, for example, if your word is "every", you'll have four bars.)
#
# You are told at the beginning how long your word is, and how many
# unique letters it has. (This is very different from hangman, but
# it seemed a good solution to the reversal of the good/bad progression
# as between that game and this game.)
#
# Each correct guess causes one bar to disappear.
# # Each wrong guess adds to the wrong guess counter. You get
# eight wrong guesses, before the bars come back.
#
# You can guess the entire word any time. A wrong whole-word guess
# counts as one wrong guess.
########################################################################## use strict;
# Set to 1 if you want to see what the word is, 0 otherwise.
my $debug = 0;
# Replace this string with the word-file of your choice.
my $dict = "wds";
# Get words.
my $words = getwords($dict) or die "Can't read dictionary: $!";
print welcome();
print "press return to continue";
my $z =
# Big play loop.
my $play = 1;
PLAY:
while ($play) {
my $word;
do { $word = $$words[int(rand(@{$words}))] }
until $word =~ /^[a-z]+$/;
print $word if $debug;
my $lets = letters($word);
my @elements = @{elements($lets)};
print wordinfo($word, $lets, \@elements);
# $free is sort of an alias for # of bars (same as $lets)
my $free = $lets;
# Placeholder for guess under construction:
my $guess = '*' x length($word);
# $level is how close to freedom we are.
# $alive is how far from losing we are.
my $level = 0;
my $alive = 10; # set to maximum number of wrong guesses allowed
# Keep track of used letters:
my @used = ();
# Inner guessing loop.
GUESS:
while ( ($level < $free) && ($guess ne $word) && ($alive)) {
print ("Guessed letters: ", join ('-', sort @used), "\n\n") if $#used >= 0;
print "THE WORD IS: $guess\n";
print "Guess one letter or whole word): ";
chomp (my $let =
# Is it a letter, or a whole word?
my $isalet = (length $let == 1);
my $res;
if ($let eq $word) { $guess = $word; last }
elsif (!$isalet) { $res = 0 }
else {
(message("You already guessed that letter"),
print "\n\n$elements[$level]\n\n\n\n"), next
if grep /$let/, @used;
$res = update_guess(\$guess, $word, $let);
}
last if $guess eq $word;
# Did we have any letter hits on this guess?
$res?
do { message("\aYes!"); print $elements[++$level],
"\n\n$res hit",'s'x($res>1),"\n\n" }
:
do { message("No!");
last unless --$alive;
print "\n\n$elements[$level]\n\n";
print "You have ", $alive, " guesses left.\n\n";
};
push (@used, $let) if $isalet;
}
if (not $alive) {
print "$elements[0]\n\nYou lose!\n\nThe word was $word\n"
}
elsif ($guess eq $word) {
print "\n\n$elements[-1]\n\n\n\nYou win! It's \"$word\"\n\n"
}
elsif ($level == $free) {
print "You made it! The whole word is $word\n\n"
}
else { print "Something weird happened - ?\n\n" }
print "\n\nAnother game? (ENTER for yes, any letter for no) ";
$play =
}
print "Bye!\n";
# Update the guess string to reflect any hits on current guess:
sub update_guess{
my ($gref,$w,$l) = @_;
($$gref = join '', map { substr($w,$_,1) eq $l?
$l : substr($$gref,$_,1) } (0..length $w)) =~ s/$l/$l/g;
}
# Return an array of all the "snapshots" which will be displayed.
sub elements {
# Create the basic cross-section of the bars:
my $n = shift; # number of unique letters in word ( = # of bars)
my $gap = int((18 - $n) / 2); # calculate a decent bar spacing
$gap++ unless $gap % 2;
my $bar = (('H' . (' ' x $gap)) x ($n-1)) . 'H';
my $pad = ' ' x ((80 - length($bar)) / 2);
$bar = "$pad$bar$pad";
$bar .= ' ' if length $bar < 80;
# It's very convenient if all body parts are of the same width:
my $lpad = ' ' x 31;
my $rpad = ' ' x 32 . "\n";
my $hair = $lpad . ' ### ' . $rpad;
my $eyes1 = $lpad . ' * * ' . $rpad;
my $eyes2 = $lpad . ' o * ' . $rpad;
my $eyes3 = $lpad . ' 0 0 ' . $rpad;
my $nose = $lpad . ' ) ' . $rpad;
my $mouth1 = $lpad . ' ~ ' . $rpad;
my $mouth2 = $lpad . ' O ' . $rpad;
my @lower = map { "$lpad$_$rpad" }
('=------ ------=', # lower body is a list
' ! ',
' ! ',
' ! ',
' / \ ',
' / \ ' );
my @lower2 = map { "$lpad$_$rpad" }
('\____ ____/ ',
' ! ',
' ! ',
' ! ',
' / \ ',
' / / ',);
my ($man1,$man2,$man3) = map { join '', @$_ }
( [ $hair, $eyes1, $nose, $mouth1, @lower ],
[ $hair, $eyes2, $nose, $mouth1, @lower ],
[ $hair, $eyes3, $nose, $mouth2, @lower2 ] ) ;
# Put the men in order - i.e., for eye-opening:
my @men = map { $_<$n-1? \$man1 : ($_ < $n? \$man2 : \$man3) } (0..$n);
# Fill @els with the actual snapshots, generated by cell(). Strip
# one H from the bar cross-section each time - one step closer to freedom.
my (@els, $man);
for $man (@men) {
push (@els, cell($$man,$bar));
$bar = reduce($bar);
}
return \@els;
}
# This strips off a random 'H' from the bar.
sub reduce {
my $b = shift;
my $c = $b =~ tr/H/H/;
if ($c) {
my @parts = $b =~ /^(\s+)(H?.*H)(\s+)$/;
my (@hs) = $parts[1] =~ /([^H]*H)/g;
$hs[int(rand($c))] =~ s/H/ /;
$b = join ('', $parts[0], @hs, $parts[2]);
}
return $b;
}
# Make the actual snapshot of the man behind bars.
sub cell {
my ($man, $bar) = @_;
join "\n",
map { my $m = $_; join ('',
(map { substr($bar,$_,1) eq 'H'?
'H' : substr($m,$_,1)
} (0..length $bar)))
} split "\n", $man
}
# Return number of unique letters in a word:
sub letters {
my $w = shift;
length (($w = join '', sort split '', $w) =~ tr/[a-z]//s, $w);
}
# General purpose message format:
sub message { print "\n\n\t\t\t===> " . shift() . " <===\n\n"; }
sub wordinfo {
my ($w,$l,$eref) = @_;
my $len = length($w);
return <
Your word is $len letters long.
It uses a total of $l different letters.\n\n\n
$$eref[0]\n
EOM
}
sub getwords {
my $d = shift;
open (DICT, $dict) or return 0;
my $w = [ map { chomp; $_ }
close DICT;
return $w;
}
sub welcome {
return <
Welcome to FREEMAN!
So you are behind bars and have time on your hands. Might as well strengthen
your vocabulary. You will use your vocabulary your whole life. It will help you
be free!
Guess one letter at a time, or the whole word if you think you know it. With
each correct guess a bar will vanish until you are free!
You have eight wrong guesses before you have to start your time behind bars over!
Made for my friends at Sierra Youth Center!
EOM
}