diff --git a/03_Animal/perl/animal.pl b/03_Animal/perl/animal.pl new file mode 100755 index 00000000..a7c8bf9e --- /dev/null +++ b/03_Animal/perl/animal.pl @@ -0,0 +1,223 @@ +#!/usr/bin/env perl + +use 5.010; # To get 'state' and 'say' + +use strict; # Require explicit declaration of variables +use warnings; # Enable optional compiler warnings + +use English; # Use more friendly names for Perl's magic variables +use Term::ReadLine; # Prompt and return user input + +our $VERSION = '0.000_01'; + +# The Perl ref() built-in returns 'HASH' for a hash reference. But we +# make it a manifest constant just to avoid typos. +use constant REF_HASH => ref {}; + +print <<'EOD'; + ANIMAL + Creative Computing Morristown, New Jersey + + + +Play 'Guess the Animal' +Think of an animal and the computer will try to guess it. + +EOD + +# We keep the accumulated data in a tree structure, initialized here. As +# we accumulate animals, we replace the 'yes' or 'no' keys with new hash +# references. +my $database = { + question => 'Does it swim', # Initial question + yes => 'fish', # Result of answering 'y' + no => 'bird', # Result of answering 'n' +}; + +while ( 1 ) { + + my $resp = get_input( + 'Are you thinking of an an animal? [y/n/list]: ' + ); + + if ( $resp =~ m/ \A y /smxi ) { + # If we got an answer beginning with 'y', walk the database + walk_tree( $database ); + } elsif ( $resp =~ m/ \A list \z /smxi ) { + # If we got 'list', list the currently-known animals. + say ''; + say 'Animals I already know are:'; + say " $_" for sort( list_animals( $database ) ); + } +} + +# Get input from the user. The arguments are: +# * The prompt +# * A reference to validation code. This code receives the response in +# $ARG and returns true for a valid response. +# * A warning to print if the response is not valid. This must end in a +# return. +# The first valid response is returned. An end-of-file terminates the +# script. +sub get_input { + my ( $prompt, $validate, $warning ) = @ARG; + + # If no validator is passed, default to one that always returns + # true. + $validate ||= sub { 1 }; + + # Create the readline object. The 'state' causes the variable to be + # initialized only once, no matter how many times this subroutine is + # called. The do { ... } is a compound statement used because we + # need to tweak the created object before we store it. + state $term = do { + my $obj = Term::ReadLine->new( 'animal' ); + $obj->ornaments( 0 ); + $obj; + }; + + while ( 1 ) { # Iterate indefinitely + + # Read the input into the topic variable, localized to prevent + # Spooky Action at a Distance. We exit on undef, which signals + # end-of-file. + exit unless defined( local $ARG = $term->readline( $prompt ) ); + + # Return the input if it is valid. + return $ARG if $validate->(); + + # Issue the warning, and go around the merry-go-round again. + warn $warning; + } +} + +# Get a yes-or-no answer. The argument is the prompt, which will have +# '? [y/n]: ' appended. The donkey work is done by get_input(), which is +# requested to validate the response as beginning with 'y' or 'n', +# case-insensitive. The return is a true value for 'y' and a false value +# for 'n'. +sub get_yes_no { + my ( $prompt ) = @ARG; + state $map_answer = { + n => 0, + y => 1, + }; + my $resp = lc get_input( + "$prompt? [y/n]: ", + sub { m/ \A [yn] /smxi }, + "Please respond 'y' or 'n'\n", + ); + return $map_answer->{ substr $resp, 0, 1 }; +} + +# Recurse through the database, returning the names of all animals in +# it, in an undefined order. +sub list_animals { + my ( $node ) = @ARG; + return $node unless REF_HASH eq ref $node; + return( map { list_animals( $node->{$_} ) } qw{ yes no } ); +} + +# Find or create the desired animal. +# Ask the question stored in the node given in its argument. If the key +# selected by the answer ('yes' or 'no') is another node, recurse. If it +# is an animal name, confirm it, or add a new animal as appropriate. +sub walk_tree { + my ( $node ) = @ARG; + + # Ask the question associated with this node. Turn the true/false + # response into 'yes' or 'no', since those are the names of the + # respective keys. + my $resp = get_yes_no ( $node->{question} ) ? 'yes' : 'no'; + + # Chose the datum for the response. + my $choice = $node->{ $resp }; + + # If the datum is a hash reference + if ( REF_HASH eq ref $choice ) { + + # Recurse into it + walk_tree( $choice ); + + # Otherwise it is an actual animal (i.e. terminal node). Check it. + } else { + + # If this is not the animal the player was thinking of + unless ( get_yes_no( "Is it a $choice" ) ) { + + # Find out what animal the player was thinking of + my $animal = lc get_input( + 'The animal you were thinking of was a ', + ); + + # Get a yes/no question that distinguishes the animal the + # player was thinking of from the animal we found in the + # tree. + say 'Please type in a question that would distinguish a'; + my $question = get_input( "$animal from a $choice: " ); + + # Find out whether the new animal is selected by 'yes' or + # 'no'. If 'no', swap the original animal with the new one + # for convenience. + ( $choice, $animal ) = ( $animal, $choice ) if get_yes_no( + "For a $animal the answer would be", + ); + + # Replace the animal we originally found by a new node + # giving the original animal, the new animal, and the + # question that distinguishes them. + $node->{ $resp } = { + question => $question, + no => $animal, + yes => $choice, + }; + } + + # Find out if the player wants to play again. If not, exit. If + # so, just return. + say ''; + exit unless get_yes_no( 'Why not try another animal' ); + return; + } +} + +__END__ + +=head1 TITLE + +animal.pl - Play the game 'animal' from Basic Computer Games + +=head1 SYNOPSIS + + animal.pl + +=head1 DETAILS + +This Perl script is a port of C, which is the 3ed entry in Basic +Computer Games. + +The original BASIC was greatly complicated by the need to emulate a +binary tree with an array. The implementation using hashes as nodes in +an actual binary tree is much simpler. + +=head1 PORTED BY + +Thomas R. Wyant, III F + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2022 by Thomas R. Wyant, III + +This program is free software; you can redistribute it and/or modify it +under the same terms as Perl 5.10.0. For more details, see the Artistic +License 1.0 at +L, and/or the +Gnu GPL at L. + +This program is distributed in the hope that it will be useful, but +without any warranty; without even the implied warranty of +merchantability or fitness for a particular purpose. + +=cut + +# ex: set expandtab tabstop=4 textwidth=72 :