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

As mentioned in my message about the regular quiz, my script uses a tree
where the internal nodes (questions) and the leaf nodes (animals) are
hashes, so that changing a node is very simple.

The code for removing an animal and a question from the tree looks like
this:

  my $replace = $fix->{$other};

  %$fix = %$replace;


In addition to the tree, this script stores a hash mapping animals to their
paths through the tree.  This is used to find the current location of an
animal when a contradiction occurs.  When a question is removed from the
tree, that question is spliced out of the paths of all the animals below it
in the tree.

Ronald


#!/usr/local/bin/perl -w

use strict;

use Storable;

my $data_file = $ARGV[0] || 'animal2.data';

my $data;

if (-e $data_file) {
  $data = retrieve($data_file);
}


# create a new data file with the provided animal name

if (not $data) {
  my $animal =
    ask("I don't know any animals!  Please tell me the name of an
  animal.");

  $data = { tree => { animal => $animal }, animals => { $animal => [] } };

  store $data, $data_file;

  print "Thank you!\n";

  exit;
}

my @path;


# play the game, asking questions until the end of a branch is reached

my $node = $data->{'tree'};
while (exists $node->{'question'}) {
  my $response = ask($node->{'question'});

  push @path, { question => $node->{'question'}, answer => $response };

  $node = $node->{$response};

}


# did I guess the animal?

my $response = ask_yn("Is it a $node->{'animal'}?");

if ($response eq 'y') {
  print "I win!\n";
  exit;
}


my $animal = lc ask("I give up.  What animal were you thinking of?");

if (my $old_path = $data->{'animals'}{$animal}) {

  # the animal is already in the tree somewhere else!

  my $div = find_divergence($data->{'animals'}{$animal}, \@path);

  if (not defined $div) {
    print "You just said it wasn't a $animal!\n";
    exit;
  }

  # verify the contradicted answer

  my $question = $div->{'question'};
  my $previous = $div->{'answer'};
  my $current  = $previous eq 'y' ? 'n' : 'y';

  my $response = ask_yn("Someone told me that for a $animal, the answer to
  " .
                        "'$question' is '$previous'.  Are you sure the " .
                        "answer is '$current'?");

  if ($response eq 'n') {
    print "Okay, please try again.\n";
    exit;
  }


  # remove the animal from its original location

  my $fix = $data->{'tree'};
  for (my $i = 0; $i < $#{$old_path}; ++$i) {
    $fix = $fix->{$old_path->[$i]{'answer'}};
  }
  my $other = $old_path->[-1]{'answer'} eq 'y' ? 'n' : 'y';

  my $replace = $fix->{$other};

  %$fix = %$replace;


  # update the paths of all the other affected animals

  splice_path($fix, $#{$old_path});

  if ($node == $replace) {
    # the contradiction was at the final question
    $node = $fix;

    pop @path;
  }

}


# add the animal to the tree with a new question

my $question =
  ask("What is a question that would distinguish a $animal " .
      "from a $node->{'animal'}?");

$question = ucfirst $question;
$question =~ s/[.?]$/?/;

my $answer = ask_yn("For a $animal, what would the answer be to " .
                    "'$question'?");

my $other = $answer eq 'y' ? 'n' : 'y';

$node->{'question'} = $question;
$node->{$answer}    = { animal => $animal };
$node->{$other}     = { animal => $node->{'animal'} };
delete $node->{'animal'};


# add the path for the new animal and update the path of the guessed animal

$data->{'animals'}{$animal} =
  [ @path, { question => $question, answer => $answer } ];
push @{$data->{'animals'}{$node->{$other}{'animal'}}},
  { question => $question, answer => $other };

store $data, $data_file;

print "Thank you!\n";

exit;


# ask a question until a response is given that contains non-whitespace
# remove leading and trailing whitespace from the response
sub ask {
  my($question) = @_;

  my $response = '';

  while (not($response or $response =~ /\S/)) {
    print "$question\n> ";
    chomp($response = <>);
  }

  if ($response eq 'q') {
    exit;
  }

  $response =~ s/^\s+//;
  $response =~ s/\s+$//;

  return $response;
}

# ask a question until a response is given that begins with y or n
# return y or n, respectively
sub ask_yn {
  my($question) = @_;

  my $response;
  while (not $response) {
    $response = ask($question);
    ($response) = $response=~ /^([yn])/i;
  }

  return $response;
}

# given two paths of questions and answers,
# find the position where the answers diverge
sub find_divergence {
  my($path1, $path2) = @_;

  for (my $i = 0; $i <= $#{$path1}; ++$i) {
    if ($path1->[$i]{'answer'} ne $path2->[$i]{'answer'}) {
      return $path1->[$i];
    }
  }

  return;
}

# remove the element at the given position
# from the paths of all animals under the given node
sub splice_path {
  my($node, $pos) = @_;

  if (my $animal = $node->{'animal'}) {
    splice(@{$data->{'animals'}{$animal}}, $pos, 1);
    return;
  }

  splice_path($node->{'y'}, $pos);
  splice_path($node->{'n'}, $pos);
}