[SPOILER] Perl 'Expert' Quiz-of-the-Week #10

Here is my solution for the expert quiz.
I reused most of what I sent in earlier for the regular quiz.
Since I heard Perl refered to as a "write-only" language, I tried to make
the script easy to read. I used long (hopefully meaningful) names to that
end.
I have my doubts whether I really succeeded - but I'll let you all be the
judge of that.

Leon

#!/usr/bin/perl
#
# Script for "Guess the animal game" Perl Quiz #10, Expert version
#
# Developed on Linux Red Hat 7.3, Perl v5.6.1
# Date: 2/2/2003
# Author: Leon Peeters
#
# Storage: Script will store data in file persistent.dat using Data::Dumper
#
use warnings;
use strict;
use Data::Dumper;

my $tree_ref;
my %negate = ( yes => "no", no => "yes" );
#---------------------------------------------------------------------
sub get_answer {
   chomp(my $answer = <STDIN>);
   if ($answer =~ /^(yes|y)/i) { return "yes"; }
   if ($answer =~ /^(no|n)/i) { return "no"; }
   print "Please enter yes or no\n";
   return &get_answer;
   }
#----------------------------------------------------------------------
sub article_ending {
   my $subject = shift;
   if ($subject =~ /^\s*[aeiou]/) { return 'n'; }
   return '';
   }
#----------------------------------------------------------------------
sub learn_from_human {

   my ($current_leaf_ref) = @_; # The animal name in this leaf was
                                # the wrong guess

   print "I give up.\nWhat animal did you think of?\n";
   chomp(my $animal = <STDIN>);
   my $n = article_ending($animal);
   my $cn = article_ending($current_leaf_ref->{animal});

   my ($duplicate_ref, $previous_question, $previous_answer) =
                     look_for_duplicate($current_leaf_ref,$animal);
   if ($duplicate_ref != 0) {
      print "I learned before that for a$n $animal, the question:\n",
             $previous_question, "is answered with: ",
             $previous_answer, "\nDo you agree?\n";
      if (get_answer eq "no") {
         remove_duplicate($duplicate_ref);
         print "\n Removed incorrect knowledge for $animal\n";
# print Dumper($tree_ref);
         } else {
         print "Thank you for teaching me!\n";
         return 0;
         }
      }

   print "What is the question that would distinguish a$n $animal from a$cn
",
         $current_leaf_ref->{animal}, "\n";
   my $question = <STDIN>;

   print "For a$n $animal the answer would be?\n";
   my $answer = get_answer;

   print "Thank you for teaching me!\n";

   # Make a leaf for the current animal
   my $old_leaf_ref = {};
   $old_leaf_ref->{node_type} = "leaf";
   $old_leaf_ref->{question} = $current_leaf_ref->{question};
   $old_leaf_ref->{animal} = $current_leaf_ref->{animal};

   # Make a leaf for the new animal
   my $new_leaf_ref = {};
   $new_leaf_ref->{node_type} = "leaf";
   $new_leaf_ref->{question} = "Is it a$n $animal?\n";
   $new_leaf_ref->{animal} = $animal;

   # Make a new node and link the leaves into it
   my $new_node_ref = {};
   $new_node_ref->{node_type} = "branch";
   $new_node_ref->{question} = $question;
   $new_node_ref->{$answer} = $new_leaf_ref;
   $new_node_ref->{$negate{$answer}} = $old_leaf_ref;

   # Add parental info to allow movement up the tree
   $new_node_ref->{parent} = $current_leaf_ref->{parent};
   $old_leaf_ref->{parent} = $new_node_ref;
   $new_leaf_ref->{parent} = $new_node_ref;

   # Add decision that leads to this leaf/node from the parent
   $new_node_ref->{previous_decision} =
$current_leaf_ref->{previous_decision};
   $old_leaf_ref->{previous_decision} = $negate{$answer};
   $new_leaf_ref->{previous_decision} = $answer;

   return $new_node_ref;

   }
#-----------------------------------------------------------------
sub search_subtree {
   my ($node_ref, $new_animal) = @_;

   # Duplicates are located at leaf nodes
   if ($node_ref->{node_type} eq "leaf") {
      if ($node_ref->{animal} =~ /$new_animal/i) {
         return $node_ref;
         } else {
         return 0;
         }
      }

   # Recursively search yes and no branches
   my $duplicate = search_subtree($node_ref->{yes}, $new_animal);
   if ($duplicate != 0) { return $duplicate; }
   return search_subtree($node_ref->{no}, $new_animal);
   }
#-----------------------------------------------------------------
sub look_for_duplicate {
   my ($decision_node_ref, $new_animal) = @_;
   my $previous_decision_node_ref;
   if ($decision_node_ref->{parent}) {
      $previous_decision_node_ref = $decision_node_ref->{parent};
      } else {
      return (0,0,0);
      }

   # Walk back thru the decisions selected by the human and
   # for each, check the subtree below the "other" choice for a duplicate

   while (1) {
      my $other_choice = $negate{$decision_node_ref->{previous_decision}};
      my $duplicate_node_ref =
            search_subtree($previous_decision_node_ref->{$other_choice},
                               $new_animal);
      if ($duplicate_node_ref != 0) {
         return ($duplicate_node_ref,
                 $previous_decision_node_ref->{question},
                 $other_choice); }

      # Nothing found in the subtree, backup one more decision
      if ($previous_decision_node_ref->{parent}) {
         $decision_node_ref = $previous_decision_node_ref;
         $previous_decision_node_ref = $decision_node_ref->{parent};
         } else {
         return (0,0,0);
         }
      }
   }
#-----------------------------------------------------------------
sub remove_duplicate {
   my $duplicate_node_ref = shift;
   # the replacement node is the one linked to the "other choice"
   # at the parent of the duplicate node
   my $other_choice = $negate{$duplicate_node_ref->{previous_decision}};
   my $parent_ref = $duplicate_node_ref->{parent};
   my $replacement_node_ref = $parent_ref->{$other_choice};
   # the replacement node is linked into the grandparent of the duplicate
   my $grandparent_ref = $parent_ref->{parent};
   if ($grandparent_ref) {
      $grandparent_ref->{$parent_ref->{previous_decision}} =
                             $replacement_node_ref;
      $replacement_node_ref->{parent} = $grandparent_ref;
      $replacement_node_ref->{previous_decision} =
                             $parent_ref->{previous_decision};
      } else {
      # there is no grandparent - the replacement node becomes
      # the new root
      $tree_ref = $replacement_node_ref;
      $tree_ref->{parent} = undef;
      $tree_ref->{previous_decision} = undef;
      }
   return;
   }
#-----------------------------------------------------------------
# main program
# Interact with human to build tree of knowledge about animals
#
my $tree;
$/ = undef;
open STORAGE, "persistent.dat"
   and $tree = <STORAGE>
   and eval $tree
   and close STORAGE
 or do {
   print "I found no existing knowledge, you'll need to teach me a lot.\n";
   $tree_ref->{node_type} = "leaf";
   $tree_ref->{question} = "Is it an elephant?\n";
   $tree_ref->{animal} = "elephant";
   $tree_ref->{parent} = undef;
   };
$/ = "\n";

my $node_ref = $tree_ref;

my $match_answer = '';

print "Think of an animal, then answer the following questions:\n";

WALK:
while (1) {

#print "\nnode_ref\n";
#print Dumper($node_ref);

   print $node_ref->{question};
   $match_answer = get_answer;

   if ($node_ref->{node_type} eq "leaf") {

      if ($match_answer eq "no") {
         # program guessed wrong, ask human for input
         # and update tree of knowledge
         if (my $new_node_ref = learn_from_human($node_ref)) {
            if ($node_ref->{parent}) {
               my $previous_decision = $node_ref->{previous_decision};
               $node_ref->{parent}->{$previous_decision} = $new_node_ref;
               } else {
               $tree_ref = $new_node_ref;
               }
            }
         }

      print "Would you like to play again?\n";
      if (get_answer eq "yes") {
         # start from beginning
         $node_ref = $tree_ref;
         } else {
         # end game, save tree
         last WALK;
         }

      } else {
      # go down tree nodes, based on answer from human
      $node_ref = $node_ref->{$match_answer};
      }
   }

# Store the tree in the file "persistent.dat"
$Data::Dumper::Purity=1;
my $flat_tree = Data::Dumper->Dump([$tree_ref],["tree_ref"]);
open STORAGE, ">persistent.dat"
   and print STORAGE $flat_tree
   and close STORAGE
 or die "cannot save knowledge tree: $!";

print "Bye\n";