The rezrov Infocom Game Interpreter

Listing 1.
The teleport() subroutine

sub teleport {
  # cheat command: move the player to a new location
  my ($self, $where) = @_;
  my $story = $self->story();
  unless ($where) {
    $story->write_text("Please tell me where you want to go.");
  } else {
    my $object_cache = $self->get_object_cache();
    my @hits = $object_cache->find($where, "-room" => 1);
    my @item_hits = $object_cache->find($where);
    if (@hits > 1) {
      # ambiguous destination
      $story->write_text(sprintf 'Hmm, where you mean: %s?',
                  nice_list(sort map {$_->[1]} @hits));
    } elsif (@hits == 1) {
      # only one possible destination: proceed
      my $room_id = $hits[0]->[0];
      my $zo = $object_cache->get($room_id);
      if ($zo->is_current_room()) {
        # destination is the current room: be rude
        $story->write_text($self->random_message(
                                 TELEPORT_HERE_MESSAGES));
      } else {
        # move to the new room
        $story->insert_obj($story->player_object(), $room_id);
        # make the player a child of the new room object
        $story->write_text($self->random_message(
                                 TELEPORT_MESSAGES));
        # print an appropriate message
        $story->push_command("look");
        # steal player's next turn to describe new location
      }
  } elsif (@item_hits == 1) {
    # user has specified an item, not a room;
    # try to teleport to the room with the item
    my $in_a_room = 0;
    my $item_id = $item_hits[0]->[0];
    my $zo = $object_cache->get($item_id);
    my $levels = 0;
    my $last;
    while (1) {
      $last = $zo;
      $zo = $zo->get_parent();
      $levels++;
      last unless defined $zo;
      if ($object_cache->is_room($zo->object_id())) {
        # aha: looks like a room; go there.
        if ($levels == 1) {
          # item is a top-level child of the room
          $story->write_text($self->random_message(
                          TELEPORT_TO_ITEM_MESSAGES));
        } else {
          # item is probably inside something visible
          my $desc = $last->print();
          $story->write_text(sprintf "I think it's
	     around here somewhere; try the %s.", $$desc);
          # describe item's toplevel container
        }
        $story->insert_obj($story->player_object(),
        $zo->object_id);
        $story->push_command("look");
        # move the player and steal turn to look around
        $in_a_room = 1;
        last;
      }
    }

    unless ($in_a_room) {
      # can't determine parent (many objects are
      # in limbo until something happens)
      my $random = $object_cache->get_random("-room" => 1);
      $story->write_text(sprintf "I don't know where
               that is; how about the %s?", $$random);
      }
    } elsif (@item_hits > 1) {
      # ambiguous item
      $story->write_text(sprintf 'Hmm, which do you mean:
            %s?',nice_list(sort map {$_->[1]} @item_hits));
    }   else {
      # no clue at all
      my $random = $object_cache->get_random("-room" => 1);
      $story->write_text(sprintf "I don't know where that is; 
                            how about the %s?", $$random);
    }
  }
}