#!/usr/bin/perl
#
# Welcome to the thousand pound gorilla of mooix methods: the English
# parser (the elephant of mooix methods is over in Grammar.pm, by the way).
# This method prompts for input using an avatar's session, parses it using
# a complex Parse::RecDescent grammar, looks up appropriate commands to
# handle the input, does any necessary locking, and dispatches verb methods
# to run the commands.

use strict;
use warnings;
#use Fcntl qw{:flock};
#use Mooix::Thing;
#use Mooix::Verb;
#use Mooix::Root;

# This is used to mark a Mooix::Thing as coming from a reference.
use constant ISREF => Mooix::Thing::_LAST_FIELD + 1;
# Similarly, this marks an object as having been referred to ambiguously.
use constant ISAMB => Mooix::Thing::_LAST_FIELD + 2;

# These are referenced by the grammar, and it's up to us to provide them.
use vars qw{$prepositions $pronouns $adjectives $verbs $nouns $answers
            $quantifiers};

# Some global variables used by the subs below (too many, sigh). #{{{
our @known;	  # objects the user might be referring to
our @all;         # object's we're sure the user knows about, that "all"
                  # can refer to.
our %nametoobj;   # map names to objects. Hash values are arrays.
our %adjtoobj;	  # map adjectives to the objects that have them
our %pronouns;	  # map pronouns to objects. Hash values are arrays.
our $loop;	  # set to 0 to stop the loop from looping
our $session;	  # set to the session that is being parsed for
our $caller;	  # set to the avatar that we're acting for
our $stop;	  # set to 1 to stop processing of the current command
our $parser;	  # parser object
our $anshandler;  # this sub is run if the user seems to aswer a question
our $timings;     # set to true to make timing info be output
our $failreason;  # why a command couldn't be run (short phrase)
our %incomplete;  # if a command can't be run, this holds parts of speech
                  # that might be missing
our $interceptor; # may be set to a command interceptor verb
our @prompt;      # prompt to use for command gathering (optional)
our $dynprompt;   # set if prompt is a method
our $debugger;    # set the the debugger object, if the user is debugging
#}}}

# Examine the environment for settings. This is recalled if the parser is
# hupped.
sub init { #{{{
	# Allow timing info to be output by setting a field in the avatar.
	$timings = $caller->benchmarked;
	$interceptor = $caller->command_interceptor;
	$dynprompt=0;
	if ($caller->defines("prompt")) {
		if ($caller->implements("prompt")) {
			$dynprompt=1;
			# prompt is gathered before every command
		}
		else {
			# gather prompt once
			@prompt = (prompt => $caller->prompt);
		}
	}
	# Turn debugging on or off.
	if ($caller->debugging && $caller->defines("debug")) {
		$caller->debugger($debugger = $caller->debug);
	}
	else {
		$caller->debugger($debugger = '');
	}
} #}}}

# Build up and return a list of nearby objects the caller might know about.
# The order of this is signifiicant, since the first matching object gets
# to run a command. Also sets up the @all list.
sub nearbyobjs { #{{{
	my %contentsseen;
	my @ret=($caller);
	@all=();

	if ($caller->contents) {
		$contentsseen{$caller->index}=1;
		push @all, grep ref, $caller->contents->list;
		push @ret, @all;
	}
	my $loc=$caller->location;
	if ($loc) {
		# Add the location near to front. Simple commands like "look"
		# are handled by the location often.
		$contentsseen{$loc->index}=1;
		my @list=grep ref, $loc->contents->list;
		push @ret, $loc, @list;
		push @all, @list;

		# If the caller's location is itself located somewhere,
		# drill down to that uber-location, and add its contents.
		# This makes things work properly while you're sitting on
		# furniture, etc.
		if ($loc->location) {
			while ($loc->location) {
				$loc=$loc->location;
			}
			$contentsseen{$loc->index}=1;
			@list = grep ref, $loc->contents->list;
			push @ret, $loc, @list;
			push @all, @list;
		}
	}
	
	# Recursively add the contents of every container to the list.
	foreach (@ret) {
		if (! $contentsseen{$_->index} && $_->contents) {
			next if $_->closed && ! $_->transparent;
			
			$contentsseen{$_->index}=1;
			# Newly added objects will be processed as part of
			# this very same loop.
			push @ret, grep ref, $_->contents->list;
		}
	}
	
	return @ret;
} #}}}

# Given a noun, return an object or objects that match it.
sub lookup_noun { #{{{
	my $noun = lc(shift);
	my $adjectives = shift;
	
	return unless exists $nametoobj{$noun};
	
	my %seen;
	my @matches;
	my $allplural = 1;
	if ($adjectives && @{$adjectives} > 0) {
		# Use adjectives to disambiguate. Return all objects that
		# match all the adjectives and have the right name.
		my %count;
		foreach my $adj (@{$adjectives}) {
			if (exists $adjtoobj{$adj}) {
				map { $count{$_}++ } @{$adjtoobj{$adj}};
			}
		}
		foreach (@{$nametoobj{$noun}}) {
			if (exists $count{$_->[0]} &&
			    $count{$_->[0]} == @{$adjectives} &&
		            ! $seen{$_->[0]->index}) {
				$seen{$_->[0]->index}=1;
				push @matches, $_->[0];
				$allplural = 0 if $allplural && ! $_->[1];
			}
		}
	}
	else {
		foreach (@{$nametoobj{$noun}}) {
			if (! $seen{$_->[0]->index}) {
				$seen{$_->[0]->index}=1;
				push @matches, $_->[0];
				$allplural = 0 if $allplural && ! $_->[1];
			}
		}
	}

	if (@matches > 1 && ! $allplural) {
		# Mark ambiguities.
		my @new;
		my @ambs = map { $_->index } @matches;
		foreach my $o (@matches) {
			# Create a new object pointing at the same real
			# object, so this one can be marked ambiguous
			# without it polluting other refs to the same
			# object.
			$_=bless([@{$o}], ref $o);
			$_->[ISAMB] = \@ambs;
			push @new, $_;
		}
		return \@new;
	}
	
	return (@matches ? \@matches : undef);
} #}}}

# Given a pronoun, return an object or objects that match it.
sub lookup_pronoun { #{{{
	my $pronoun = lc(shift);
	return $pronouns{$pronoun} if exists $pronouns{$pronoun};

	# Non-pre-calculated pronouns.
	if ($pronoun =~ /everythings?/ || $pronoun eq 'all') {
		my @ret = grep { ! $_->hidden && $_ != $caller } @all;
		return \@ret if @ret;
	}
	elsif ($pronoun eq 'here') {
		# There may be no location.
		my $loc=$caller->location;
		return [$loc] if $loc;
	}
	return;
} #}}}

# Given an object reference (sans the leading "mooix"), return 
# an array containing the object it refers to, or return undef if 
# none. The reference method of the avatar is used here to look up
# references, for more flexability as to what objects an be
# referenced, and how the referencing works.
#
# TODO memoizing this would be rather useful. It tends to be called 4 times
#      if it fails.. But the memoization needs to be undone after each
#      command that is run, since any command could change the result.
sub lookup_reference { #{{{
	my $id = shift;
	my $obj = $caller->reference(id => $id);
	if ($obj) {
		$obj->[ISREF] = 1;
		return [$obj];
	}
	return;
} #}}}

# Given a number representation (which might be the raw number, or the
# written-out form, or some ordinal form), return the number it
# represents, or undef if none.
my $word2num_loaded=0;
sub lookup_number { #{{{
	my $word=shift;
	if (! $word2num_loaded) {
		# Try to use Lingua::EN::Words2Nums, but don't depend
		# on it being installed.
		eval "use Lingua::EN::Words2Nums";
		if ($@) {
			# Install stub function that only does simple numbers.
			*::words2nums = sub {
				$_ = shift;
				return $1 if /^(\d+)(?:st|nd|rd|th)?$/;
				return;
			};
		}
		$word2num_loaded=1;
	}
	# This is a hack, for "next alias is" type of things.
	return 9999 if lc $word eq 'next';
	return words2nums($word);
} #}}}

# Called by the grammar to point out recently referred to objects that may
# set the 'it' pronoun, etc. Pass in a list of objects.
sub recent_obj { #{{{
	my @objs = @_;
	if (@objs == 1) {
		# Don't set "it" if the caller talks about themself.
		$pronouns{that} = $pronouns{thats} = $pronouns{it} = 
		$pronouns{its} = \@objs
			unless $objs[0] == $caller;
		my $gender=$objs[0]->gender;
		if ($gender) {
			$pronouns{$gender->object_pronoun} = \@objs;
		}
		$pronouns
	}
	elsif (@objs) {
		# TODO To be strictly correct, I should only set 'these' and
		# 'those' if all the objects are not people, and always set
		# 'them'.
		$pronouns{these} = $pronouns{those} = $pronouns{them} = 
		$pronouns{their} = \@objs;
	}
} #}}}

# Returns an object if it is inside some other object.
# (Actually, it might be called for several objects.)
sub is_obj_in_obj { #{{{
	my @objs=@{shift()};
	my $prepositions=shift;
	my $container=@{shift()}[0];
	
	my @ret;
OBJ:	foreach (@objs) {
		# If there are prepositions, make sure that the
		# prepositions can indeed be used. If so, it'll be in
		# the object's preposition list.
		if (ref $prepositions) {
			my %preps = map { $_ => 1 } $_->preposition;
			foreach (@$prepositions) {
				next OBJ unless $preps{$_};
			}
		}
		
		if ($_->location == $container) {
			push @ret, $_;
		}
	}
	
	# Telling where an object is this way can serve to disambiguate
	# it, if it was ambiguous.
	if (@ret == 1) {
		$ret[0]->[ISAMB] = undef;
	}
	
	return \@ret if @ret;
	return;
} #}}}

# Parse the prototypes of the object and see if one matches the command. To
# match, every part of speech in the command (except prepositions) must be
# in the prototype, and if the protoype specifies an allowable value set,
# the value must be in that set.
sub checkproto { #{{{
	my $this = shift;
	my $multobj = shift;
	my %command = @_;

	my $cmdfield;
	if (exists $command{verb}) {
		$cmdfield = lc($command{verb}).".cmd";
	}
	else {
		# Check the default.cmd for weirdly formed commands that
		# lack a verb.
		$cmdfield = "default.cmd";
	}

	if (! $this) {
		use Carp;
		Carp::cluck("called on null object");
	}
	
PROTO:	foreach my $prototype ($this->$cmdfield) {
		my %remains=%command;

		next if $prototype =~ /^#/;
		next unless defined $prototype && length $prototype;
		my ($prototype, $command) = split(/\s*:\s*/, $prototype, 2);
		$command = lc($command{verb}) unless defined $command;
	
		my (@checknearby, @checktouchable, @checkvisible,
		    @lockpos, @lockmove, @checkopen);
		
		my $fail=0;
		foreach my $section (split(/\s*,\s*/, $prototype)) {
			my ($part, $limits) = $section =~ /(\w+)\s*(?:\((.*)\))?/;
			if (! exists $remains{$part}) {
				$incomplete{$part}=1;
				$fail=1;
				next;
			}
			if (defined $limits) {
				my $lockpos=0;
				my $checknearby=0;
				my $checktouchable=0;
				my $checkvisible=0;
				my $checkopen=0;
				foreach my $limit (split(/\)\(/, $limits)) {
					my %limit = map { lc($_) => 1 } split(/\s*\|\s*/, $limit);
					my $ok=0;
					if ($part eq 'direct_object' || $part eq 'indirect_object') {
						# Order is important..
						if ($limit{tomove}) {
							push @lockmove, $remains{$part}[0];
							delete $limit{tomove}; # still auto-check nearby
						}
						if ($limit{nearby} || ! %limit) {
							$ok=$lockpos=$checknearby=1;
						}
						if ($limit{touchable}) {
							$ok=$lockpos=$checknearby=$checktouchable=1;
						}
						if ($limit{visible}) {
							$ok=$lockpos=$checknearby=$checkvisible=1;
						}
						if ($limit{reference} && defined $remains{$part}[0]->[ISREF]) {
							$ok=1;
							$checknearby=0;
						}
						if ($limit{single} && (! $multobj || $part ne 'direct_object')) {
							$ok=1;
						}
						if ($limit{anywhere}) {
							$ok=1;
							$checknearby=0;
						}
						if ($limit{this} && $remains{$part}[0] == $this) {
							$ok=1;
						}
						if ($limit{open}) {
							$ok=$checkopen=1;
						}
					}
					elsif ($part eq 'verb') {
						if ($limit{this} && $this == $caller) {
							$ok=1;
						}
					}
					elsif (exists $remains{$part} &&
					       defined $remains{$part} &&
					       $limit{$remains{$part}}) {
						$ok=1;
					}
					next PROTO unless $ok;
				}
		
				if ($lockpos) {
					push @lockpos, $remains{$part}[0];
				}
				if ($checknearby) {
					push @checknearby, $remains{$part}[0];
				}
				if ($checktouchable) {
					push @checktouchable, $remains{$part}[0];
				}
				if ($checkvisible) {
					push @checkvisible, $remains{$part}[0];
				}
				if ($checkopen) {
					push @checkopen, $remains{$part}[0];
				}
			}

			delete $remains{$part};
		}
		delete $remains{do_preposition};
		delete $remains{io_preposition};
		if ($fail) {
			if (%remains) {
				%incomplete=();
			}
			next;
		}
		#print STDERR "$this $cmdfield remains: ".join(", ", keys %remains)."\n";
		return ($command, \@checknearby , \@checktouchable, \@checkvisible, 
		        \@lockpos, \@lockmove, \@checkopen) unless %remains;
	}
	return; # failure
} #}}}

# Given a reference to a sentence and a list of objects, constructs a
# question that the user could answer to disambiguate between them, and
# returns the question. Sets up $anshander and $answers.
#
# It might sometimes return undef. If it does, that means that all the
# objects are pretty much indistinguishable, and a good question cannot be
# constructed.
sub gen_disambiguator { #{{{
	my %sentence=%{shift @_};
	my @objs=@_;
	
	# Build up a hash of possible answers to the question.
	# It'll be used by the returned subroutine.
	my %answers;

	# Support "the former" and "the latter" style responses, and
	# "both".
	if (@objs == 2) {
		$answers{former} = [ $objs[0] ];
		$answers{latter} = [ $objs[1] ];
		$answers{both} = [ @objs ]; # XXX would it be better to use the quantifier sub here?
	}
	
	# Let's see if the locations of the objects vary; if so they could
	# be used to help disambiguate. The hash values will hold the names
	# of the locations.
	my %locs;
	foreach my $obj (@objs) {
		my $loc=$obj->location;
		next if ! $loc;
		my $id=$loc->id;
		if (! exists $locs{$id}) {
			my $article = $loc->article;
			$locs{$id} = "$article " if length $article;
			$locs{$id} .= $loc->name;
		}
	}

	# It's quite possible that two objects have nothing really to
	# distinguish them. So, this hash will be used to keep track of
	# unique choices.
	my %seen;
	# And this array will hold the arrays of objects that each choice
	# corresponds to.
	my @choices;
	my $count=0;
	foreach my $obj (@objs) {
		my $bit="";
		# The reason to ignore the object's stated article and use
		# "the" is because it looks weird if it asks "Do you mean
		# the red ball or a green ball".
		$bit .= "the " if length $obj->article;
		my @adj=$obj->adjective;
		# Add the adjectives to the answers list.
		map { push @{$answers{$_}}, $obj } @adj;
		$bit .= join(" ", @adj)." " if @adj;
		$bit .= $obj->name;
		if (scalar keys %locs > 1) {
			my $loc = $obj->location;
			if ($loc == $caller) {
				$bit .= " you're holding";
			}
			else {
				my @prep=$obj->preposition;
				my $prep=$prep[0];
				$prep = "in" if ! length $prep;
				$bit .= " $prep ".$locs{$loc->id};
			}
		}

		if (! $seen{$bit}) {
			$seen{$bit} = 1;
			push @choices, $bit;
			push @{$answers{++$count}}, $obj;
		}
	}
	
	# Do all objects seem to be identical?
	return undef if @choices == 1;

	# Register the answers and the handler.
	$answers=genregex(keys %answers);
	$anshandler=sub {
		my %response = @_;
		
		my $selected;
		if (exists $response{direct_object}) {
			# Trim the list down to the objects in @objs.
			my %objs = map { $_->index => $_ } @objs;
			$selected = [ grep { $objs{$_->index} } @{$response{direct_object}} ];
		}
		elsif (exists $response{number} && exists $answers{$response{number}}) {
			$selected = $answers{$response{number}};
		}
		elsif (exists $response{answer}) {
			my $answer = $response{answer};
			# Check each of the user's responses against the
			# answers, and select any that match them all.
			my $first = shift @$answer;
			my @sel = @{$answers{lc $first}};
			foreach my $a (@{$answer}) {
				my %matches = map { $_->index => 1}
				              @{$answers{lc($a)}};
				@sel = grep { $matches{$_->index} } @sel;
			}
			if (! @sel) {
				$session->write("None of the choices is ".
				                join(" and ", $first, @{$answer}).".");
				return 1;
			}
			$selected = [ @sel ];
		}

		if (! $selected) {
			$session->write("Invalid selection.");
			return 1; # question was anwered, though not well
		}

		# Register the objects as recently referred to objects now.
		recent_obj(@{$selected});
	
		# There may be multiple objects still, and this may well lead
		# to another round of disambiguation.. anyway, the user has
		# answered the question, so deregister it.
		$answers=genregex();
		$anshandler=undef;
		do_multobj_sentence(%sentence, direct_object => $selected);
		return 1; # question was answered, maybe not well
	};
	
	$choices[-1]="or ".$choices[-1];
	return "Do you mean ".join((@choices > 2) ? ', ' : ' ', @choices)."?";
} #}}}

# This takes care of a sentence that has multiple direct objects in it.
# Detecting ambiguously referred to direct objects and properly dispatching
# everything is a mite complicated.
sub do_multobj_sentence { #{{{
	my %sentence = @_;
	
	# Putting things in a hash prevents operating on the same direct
	# object twice.
	my %dobjs = map { $_->index => $_ } @{$sentence{direct_object}};
	
	# Check to see if there are any possibly ambiguous references to
	# objects.
	my $first_time = 1;
	my @list=values %dobjs;
	foreach my $direct_object (@list) {
		next unless $direct_object->[ISAMB];
		if ($first_time && $direct_object->[ISAMB] &&
		    grep { $_ ne $direct_object->index && $dobjs{$_} } @{$direct_object->[ISAMB]}) {
			# Check to see which of the direct objects this
			# sentence can actually be run on, and ignore the
			# rest. That might elminiate the ambiguities. It is
			# a bit expensive though.
			$first_time = 0;
			foreach my $direct_object (values %dobjs) {
				# Test, don't do it.
				if (! do_sentence(0, 0, "", %sentence, direct_object => [ $direct_object ])) {
					delete $dobjs{$direct_object->index};
				}
			}
			last if ! %dobjs; # whoops, none can be used.
		}
		if ($direct_object && $dobjs{$direct_object->index} &&
		    grep { $_ ne $direct_object->index && $dobjs{$_} } @{$direct_object->[ISAMB]}) {
			my @possibles=map { $dobjs{$_} } grep { $dobjs{$_} } @{$direct_object->[ISAMB]};
			my $disambiguator=gen_disambiguator(\%sentence, @possibles);
			if (! defined $disambiguator) {
				# Act on only one of the objects, since
				# they are all much the same.
				$session->write("(Picking one of them at random ...)");
				return do_sentence(1, 0, '', %sentence, direct_object => [ $possibles[rand @possibles] ]);
			}
			else {
				$session->write($disambiguator);
				# The ISAMB flag needs to be unset now; these
				# objects might be used again and it shouldn't
				# taint them.
				$_->[ISAMB] = undef foreach @list;
				return;
			}
		}
		$direct_object->[ISAMB] = undef; # not any more
	}

	if (! %dobjs) {
		showfailure("", %sentence);
		return;
	}
	
	if (scalar values %dobjs == 1) {
		# There is only one d.o. left after deduping and so on.
		if (! do_sentence(1, 0, '', %sentence, direct_object => [ values %dobjs ])) {
			showfailure('', %sentence, direct_object => [ values %dobjs ]);
			return;
		}
		return 1;
	}

	# Do the sentence once per direct object. Do it in the original order
	# the user requested, skipping items that aren't in the hash. Delay
	# failures until end; if everything failed just show one failure.
	my @failed;
	my $tried = 0;
	foreach my $direct_object (@{$sentence{direct_object}}) {
		next unless $dobjs{$direct_object->index};
		$tried++;
		if (! do_sentence(1, 1, $direct_object->name.": ", %sentence, direct_object => [ $direct_object ])) {
			push @failed, $direct_object;
		}
		# Don't operate on this object again..
		delete $dobjs{$direct_object->index};
	}
	if (@failed) {
		if (@failed == $tried) {
			showfailure("", %sentence, direct_object => $sentence{direct_object}->[0]);
		}
		else {
			showfailure($_->name.": ", %sentence, direct_object => [ $_ ])
				foreach @failed;
		}
		return;
	}
	else {
		return 1;
	}
} #}}}
	
# Given a sentence finds the object that can handle the command and runs
# it. Returns true if something could be done, and false otherwise.
sub do_sentence { #{{{
	my $reallydo = shift;     # set if the command should really be executed
	my $multobj = shift;      # set if there are really multiple d.o.'s
	my $prefix = shift;	  # prefix text to display before output
	my %sentence = @_;
	
	my @objs=@known;
	
	# The caller's command_intercept can, as a special case, intercept
	# *anything*.
	if (defined $interceptor && length $interceptor) {
		my $ret=runcommand($caller, $interceptor, \%sentence);
		return $ret if $ret;
	}
	
	# First, look for verbs on the direct or indirect object. Doing
	# this first optimizes for the common case. It also means that is
	# the direct or indirect object was referred to using mooix:, and 
	# is not nearby, they still can have verbs run on them.
	if ($sentence{direct_object} && @{$sentence{direct_object}}) {
		if (dispatch($reallydo, $multobj, $sentence{direct_object}->[0], $prefix, %sentence)) {
			return 1;
		}
		@objs=grep { $_ != $sentence{direct_object} } @objs;
	}
	elsif ($sentence{indirect_object} && @{$sentence{indirect_object}}) {
		if (dispatch($reallydo, $multobj, $sentence{indirect_object}->[0], $prefix, %sentence)) {
			return 1;
		}
		@objs=grep { $_ != $sentence{indirect_object} } @objs;
	}
	
	# Failing all the above, just try checking all other nearby objects.
	foreach my $obj (@objs) {
		if (dispatch($reallydo, $multobj, $obj, $prefix, %sentence)) {
			return 1;
		}
	}

	# If we have only a verb and a preposition, then it could be that
	# instead of a preposition, they meant to refer to an object. For
	# example, "go down" causes down to be parsed as a preposition.
	if (! grep { $_ ne 'verb' && $_ ne 'preposition' } keys %sentence) {
		my $direct_object = lookup_noun($sentence{preposition});
		if ($direct_object) {
			return do_sentence($reallydo, 0, $prefix,
			                   verb => $sentence{verb},
					   direct_object => $direct_object);
		}
	}
	
	return; # failure
} #}}}
	
# This is called when the user's command cannot be run for some reason. If
# $failreason is set, then it is just displayed, telling them why whatever
# they wanted to do can't work. If it is empty, then if %incomplete has
# stuff in it, we'll try to prompt the user for more data. Failing all of
# this, a generic failure message is displated.
#
# The first parameter is an optional prefix to prepend to the output.
# The sentence is required.
sub showfailure { #{{{
	my $prefix = shift;
	my %sentence = @_;
	$prefix = "" unless defined $prefix;
	# These parts of speech almost never matter.
	delete $incomplete{io_preposition};
	delete $incomplete{do_preposition};
		 
	if (length $failreason) {
		$session->write($prefix.$failreason);
	}
	elsif (%incomplete) {
		# Build up a question indicating what parts of speech they
		# were missing.
		my @message;
		if (! $sentence{verb}) {
			# Whee, they typed something really weird.
			$session->write("Beg pardon?");
			return;
		}
		elsif ($incomplete{direct_object}) {
			push @message, $sentence{verb}, "what";
			if ($incomplete{indirect_object}) {
				push @message, "where";
			}

			# Set up answer handler.
			$anshandler=sub {
				my %response = @_;
				if (exists $response{direct_object}) {
					$sentence{direct_object} = $response{direct_object};
					recent_obj(@{$response{direct_object}});
					$answers=genregex();
					$anshandler=undef;
					do_multobj_sentence(%sentence);
					return 1;
				}
				return;
			};
		}
		elsif ($incomplete{indirect_object}) {
			push @message, $sentence{verb};
			push @message, "it"; 
			push @message, "where";
			
			# Set up answer handler.
			$anshandler=sub {
				my %response = @_;
				if (exists $response{direct_object}) {
					$sentence{indirect_object} = $response{direct_object};
					recent_obj(@{$response{direct_object}});
					$sentence{io_preposition} = $response{do_preposition}
						if exists $response{do_preposition};
					$answers=genregex();
					$anshandler=undef;
					do_multobj_sentence(%sentence);
					return 1;
				}
				return;
			};
		}
		else {
			$session->write("You need to supply ".
			                 join(" and ", map { s/_/ /g; "a $_" }
					               keys %incomplete).".");
			return;
		}
		$session->write(ucfirst join(" ", @message)."?");
	}
	else {
		$session->write($prefix."You can't do that.");
	}
} #}}}

# Tries to find a prototype in an object to match a command, and if it
# finds one, does necessary locking, runs the command and returns true.
sub dispatch { #{{{
	my $reallydo = shift;     # really lock and run command
	my $multobj = shift;      # set if there are really multiple d.o's
	my $this = shift;	  # object to check
	my $prefix = shift;	  # prefix text to display before output
	my %sentence = @_;	  # the parameters of the command

	my ($command, $checknearby, $checktouchable, $checkvisible,
	    $lockpos, $lockmove, $checkopen) = 
    		checkproto($this, $multobj, %sentence);
	return 0 unless defined $command;
	
	# Now we have to lock some objects in position, and maybe
	# check to make sure they're still nearby (to avoid races).
	#
	# Keeps locks open until the function returns, and keeps
	# track of what is locked.
	my %locked;

	if ($reallydo) {
		# First, handle any objects that need to be locked for move.
		# This is an exclusive lock.
		foreach my $obj (@{$lockmove}) {
			next if $locked{$obj->index};
			return unless $locked{$obj->index} =
				$obj->getlock(LOCK_EX);
		}

		# Then, lock any remaining objects that need to be locked,
		# to prevent moving by third parties. This is a shared lock.
		foreach my $obj (@{$lockpos}) {
			next if $locked{$obj->index};
			return unless $locked{$obj->index} =
				$obj->getlock(LOCK_SH);
		}
	}
	
	# The caller's location.
	my $cloc=$caller->location;
	# If the caller's location is itself in some location, use its
	# location.
	while ($cloc && $cloc->location) {
		$cloc = $cloc->location;
	}
	
	# Check to see if objects that must be touchable are. That means
	# that every container between the user and the object must be
	# open.
	foreach my $obj (@{$checktouchable}) {
		my $loc=$obj->location;
		if (! $loc) {
			next if $cloc == $obj;
			return;
		}
		while ($loc && ($loc != $caller && $cloc != $loc && $cloc != $obj)) {
			# The container the object is in needs to be locked
			# in position to prevent it from being moved in
			# the middle of a command.
			if ($locked{$obj->index}) {
				if (! $locked{$loc->index}) {
					$locked{$loc->index} = $loc->getlock(LOCK_SH);
				}
			}
			# And the container must be locked open, to prevent
			# it from closing during the command.
			if ($loc && ! $locked{"closed".$loc->index}) {
				$locked{"closed".$loc->index} = $loc->getlock(LOCK_SH, "closed");
			}
			# Only check its state after taking the lock.
			if (! $loc || $loc->closed) {
				$failreason="You can't touch that.";
				return;
			}
			$loc=$loc->location; # advance to next container
		}
		return unless $loc;
	}
	
	# Check to see if objects that must be nearby are.
	foreach my $obj (@{$checknearby}) {
		my $loc=$obj->location;
		if (! $loc) {
			next if $cloc == $obj;
			return;
		}
		while ($loc && ($loc != $caller && $cloc != $loc && $cloc != $obj)) {
			# The container the object is in needs to be locked
			# in position to prevent it from being moved in
			# the middle of a command.
			if ($locked{$obj->index}) {
				if (! $locked{$loc->index}) {
					$locked{$loc->index} = $loc->getlock(LOCK_SH);
				}
			}
			$loc=$loc->location; # advance to next container
		}
		return unless $loc;
	}

	# Check to see if objects that must be visible are. This is nearly
	# the same as the touchable test, except the contents of
	# transparent containers are visible too, and so are things seem
	# out of windows and so on.
	foreach my $obj (@{$checkvisible}) {
		my $loc=$obj->location;
		my $lastloc;
		if (! $loc) {
			next if $cloc == $obj;
			return;
		}
		
		while ($loc && ($loc != $caller && $cloc != $loc && $cloc != $obj)) {
			# The container the object is in needs to be locked
			# in position to prevent it from being moved in
			# the middle of a command.
			if ($locked{$obj->index}) {
				if (! $locked{$loc->index}) {
					$locked{$loc->index} = $loc->getlock(LOCK_SH);
				}
			}
			
			# And the container must be locked open and
			# transparent, to prevent any changes while the
			# command runs.
			if ($loc && ! $locked{"closed".$loc->index}) {
				$locked{"closed".$loc->index} = $loc->getlock(LOCK_SH, "closed");
			}
			if ($loc && ! $locked{"transparent".$loc->index}) {
				$locked{"transparent".$loc->index} = $loc->getlock(LOCK_SH, "transparent");
			}
			# Only check its state after taking the lock.
			if (! $loc || ($loc->closed && ! $loc->transparent)) {
				$lastloc=$loc if $loc;
				# Before giving up, check to see if the
				# object is visible through a window or
				# something. A container can indicate
				# windowlike things by simply listing the
				# objects out the window in its contents
				# list.
				if (grep { $_ == $lastloc || $_ == $obj }
				         $cloc->contents->list) {
					last; # success
				}
				return; # failure
			}
			
			$loc=$loc->location; # advance to next container
		}
		return unless $loc;
	}
	
	# Check to see if containers that should be open are, and lock them
	# to keep them open.
	foreach my $obj (@{$checkopen}) {
		if (! $locked{"closed".$obj->index}) {
			$locked{"closed".$obj->index} = $obj->getlock(LOCK_SH, "closed");
		}
		if ($obj->closed) {
			return;
		}
	}
	
	return 1 unless $reallydo;

	$command=$command."_verb";
	# Fix up direct and indirect objects, removing the array
	# they're nested in. Assuming they are parameters..
	$sentence{direct_object} = $sentence{direct_object}[0]
		if ref $sentence{direct_object} eq 'ARRAY';
	$sentence{indirect_object} = $sentence{indirect_object}[0]
		if ref $sentence{indirect_object} eq 'ARRAY';
		
	finished("prepping command");

	if (length $prefix) {
		$session->write($prefix);
	}

	return runcommand($this, $command, \%sentence);
} #}}}

# Runs a particular command and deals with its return code.
sub runcommand { #{{{
	my $this=shift;
	my $command=shift;
	my %sentence=%{shift()};
	
	my @ret = $this->$command(avatar => $caller, session => $session, %sentence);
	my $retcode = $? >> 8;
	return 1 unless $retcode;

	if ($retcode == Mooix::Verb::SETIT) {
		# Set "it". Actually, just call recent_obj, and this could be
		# used to set "them" too.
		recent_obj(@ret);
		return 1;
	}
	elsif ($retcode == Mooix::Verb::SETITREF) {
		# Set "it", but this is for objects that can be treated as
		# references.
		foreach (@ret) {
			$_->[ISREF] = 1;
		}
		recent_obj(@ret);
		return 1;
	}
	elsif ($retcode == Mooix::Verb::FAIL) {
		if (@ret && length $ret[0]) {
			$session->write(@ret);
		}
		$stop = 1; # stop processing of any other pending commands..
		return 1;
	}
	elsif ($retcode == Mooix::Verb::EXIT) {
		$loop = 0;
		return 1;
	}
	return 0;
} #}}}

# Given a number or one of a few known words that can be used to quantify a
# set of objects, and an array of objects that might be meant, returns
# either undef if the two don't make sense together, or an array of
# unambiguously quantified objects.
sub check_quantification { #{{{
	my $quant = lc(shift);
	my @objs = @{shift()};
	
	if ($quant eq 'all' || $quant eq 'every') {
		# easy enough; all match
	}
	elsif ($quant eq 'both') {
		# so there must be exactly two objects
		if (@objs > 2) {
			$failreason = "There are more than two.";
			return;
		}
		elsif (@objs < 2) {
			$failreason = "There is only one.";
			return;
		}
	}
	elsif ($quant eq 'any' || $quant eq 'either' || $quant eq 'either one') {
		# pick one of the objects at random, ditch the rest
		@objs=$objs[rand @objs]
	}
	elsif ($quant eq 'several') {
		# "Consisting of a number more than two, but not very many"
		#  -- websters
		#  TODO I should really permute the array first. Same with
		#  next two elsifs.
		my $num=3 + rand(2); # 3 to 5
		@objs=grep { $_ } @objs[0..$num - 1];
	}
	elsif ($quant eq 'some') {
		# Whatever, between a third and a fifth?
		my $num = @objs / (3 + rand(2));
		if ($num < 2) { $num = 2 }
		@objs=grep { $_ } @objs[0..$num - 1];
	}
	elsif ($quant eq 'most') {
		@objs=grep { $_ } @objs[0..$#objs / 0.9];
	}
	elsif ($quant eq 'couple' || $quant eq 'few') {
		# Take two.
		@objs=grep { $_ } @objs[0..1];
	}
	elsif ($quant + 0 != 0) {
		if ($quant > @objs) {
			$failreason="There ".(@objs == 1 ? "is" : "are").
			            " only ".scalar @objs.".";
			return;
		}
		@objs=@objs[0..$quant - 1];
	}
	else {
		return;
	}

	# Quantifying objects disambiguates them.
	map { delete $_->[ISAMB] } @objs;
	return \@objs;
} #}}}

# Prepare for parsing by populating $nouns with all the names
# of the passed objects (and recently referred to objects, sometimes).
# At the same time, build up a name -> object hash. Do the same stuff
# for adjectives.
sub prepparser { #{{{
	my @objs=@_;

	# Dedup list and add to @known, preserving order.
	my %seen;
	@known=();
	foreach (@objs) {
		push @known, $_ unless exists $seen{$_->index};
		$seen{$_->index}=1;
	}
	
	%nametoobj=();
	%adjtoobj=();
	foreach (@known) {
		# Note the values of the nametoobj hash are array refs,
		# where the second array element is 1 if the name is
		# plural.
		foreach my $name (map { lc $_ } $_->name, $_->alias) {
			push @{$nametoobj{$name}}, [ $_, 0 ];
			# Stupid pluralization.
			push @{$nametoobj{$name."s"}}, [ $_, 1 ];
		}
		# Non-stupid pluralization.
		foreach my $name ($_->plural_name) {
			push @{$nametoobj{lc($name)}}, [ $_, 1 ];
		}

		foreach my $adjective ($_->adjective) {
			push @{$adjtoobj{lc($adjective)}}, $_;
		}
	}
	
	$nouns=genregex(keys %nametoobj);
	$adjectives=genregex(keys %adjtoobj);
} #}}}

# Given a list of words, this generates and returns a regex that matches
# any of the words.
sub genregex { #{{{
	# The sort ensures that it matches long words even if a shorter
	# word is a subset of the long one.
	# An empty item in the alternation can make the parser hang, if
	# so detect them and skip em.
	$_=join('|', reverse sort { $a cmp $b } grep { length $_ } @_);
	if (! length $_) {
		# An expty regex could make the parser hang..
		$_="\n\n"; # impossible string
	}
	$_=qr/$_/i; # is this really useful?
	return $_;
} #}}}

# These subs collect and output timing info, if $timings is set.
my %timepoints;
my $lasttime;
my $starttime;
sub starting { #{{{
	return unless $timings;
	require Time::HiRes;
	$lasttime=$starttime=$timepoints{start} = Time::HiRes::time();
} #}}}
sub finished { #{{{
	return unless $timings;
	my $point = shift;
	require Time::HiRes;
	$timepoints{$point} = Time::HiRes::time();
	print STDERR "[$point took ".($timepoints{$point} - $lasttime)." secs (".($timepoints{$point} - $starttime)." secs total)]\n";
	$lasttime = $timepoints{$point};
} #}}}

# The main subroutine.
run sub { #{{{
	my $this=shift;
	%_=@_;

	$session = $_{session} or $this->parser_usage("bad session");
	$caller = $this;
	$pronouns{me} = $pronouns{my} = $pronouns{myself} = $pronouns{i} = [$caller];
	
	# To cut down on startup speed, use the precompiled Grammar.pm, unless
	# the grammar file is newer.
	my $gpm = $this->parser->fieldfile("Grammar.pm");
	my $gra = $this->parser->fieldfile("grammar");
	if (! $gpm || (stat($gpm))[9] < (stat($gra))[9]) {
		$session->write("Compiling grammar, please wait..");
		$this->parser->compilegrammar;
		$gpm = $this->parser->fieldfile("Grammar.pm");
	}
	require $gpm; #sorta gross, but what the hey
	# It's "myGrammar" because that's the module name used. See
	# compilegrammar.
	$parser = myGrammar->new;
	
	# Load in file and compile a sub to do preparsing substitutions.
	my $subst = eval 'sub { $_=shift;'.$this->parser_shortcuts."\n".';$_}';
	if ($@) {
		$subst = sub {return shift}; # do nothing sub
		warn "shortcuts broken: $@";
	}

	# Set up a few of the parts of speech that don't change
	# dynamically. These are referenced by the grammar.
	$prepositions = genregex($this->parser_prepositions);
	$pronouns = genregex($this->parser_pronouns);
	$quantifiers=genregex(qw{all both any every several some few couple 
	                         most either}, "either one");
	
	# There are no answers, at first.
	$answers = genregex();
	
	# Let a verb be anything that looks like a word. Starting the
	# beginning of a sentence is enough of a disambiguator.
	$verbs = qr/\w+/;

	# Init now, and reinit on HUP.
	init();
	$SIG{HUP}=\&init;
	
	$loop = 1;
	while ($loop) {
		if ($dynprompt) {
			@prompt=(prompt => $caller->prompt);
		}
		my $command = $session->prompt(
			# Pass in pronouns as completions.
			completions => join('|', 'here', 'all', 'everything',
			                         grep { $_ ne 'i' } keys %pronouns),
			@prompt
		);
		starting();
		last unless defined $command;
		$command=~s/\s+$//;
		chomp $command;
		next if ! length $command;
		$command=$subst->($command);

		finished('preprocessing');
	
		# Do this after the prompt, and not before, so that any
		# changes that occur while the user is entering text can be
		# understood.
		my @nearbyobjs=nearbyobjs();
		prepparser(@nearbyobjs);
	
		# Unset the ISREF field, it is no longer relevant if the
		# object is nearby now. This takes care of 'teleport mooix:foo
		# here and look at it'.
		if ($pronouns{it} && grep { $pronouns{it}->[0] == $_ } @nearbyobjs) {
			$pronouns{it}->[0]->[ISREF] = undef;
		}
		
		# Various functions will try to set this to something
		# sane depending on type of failure.
		$failreason="";
		%incomplete=();
	
		finished("gathering info");
		
		# Do parsing, trap errors and display portion that failed
		# to match.
		my $origcommand=$command;
		my $pt = $parser->input(\$command);
		
		if ($failreason) {
			$session->write($failreason);
		}
		elsif (length $command) {
			if ($command !~ /"/ && $command !~ /\{.*\}/) {
				# So there was something at the end that could not
				# be parsed. Most likely it was intended to be a
				# quote, so quote it and re-inject it into the
				# parser. Note that I re-inject, instead of just
				# adding a quote to the existing parsed sentence,
				# because it often parses it wrong w/o the known
				# quote at the end.
				$command=~s/^\s*//;
				my $quote=$command;
				my $command=$origcommand;
				$command=~s/\Q$quote\E$/"$quote"/;
				my $incommand=$command;
				$pt = $parser->input(\$command);
				if ($failreason) {
					$session->write($failreason);
				}
				if (length $command) {
					$session->write("It's not clear what you mean by \"$quote\".");
					next;
				}
				else {
					# Help the user learn.
					$session->write("(Guessing that you meant to type: $incommand ...)");
				}
			}
			else {
				# Let the block below handle this failure.
				$pt = undef;
			}
		}
		if (! defined $pt) {
			# Whole command failed to parse, but was all
			# consumed by parser.
			$command=$origcommand;
			$command=~s/^\s*\w+\s+//;
			$session->write("It's not clear what you mean by \"$command\".");
		}
		next unless ref $pt; # null command
		
		finished("parsing");
		
		# Find an object that can handle each command and dispatch
		# to them.
		$stop = 0;
		foreach my $sentence (@{$pt}) {
			last if $stop;
			
			$caller->debuglog(type => "command", message => sub {
				# This sub is a callback that will be
				# called only if the log is sent to the
				# debugger.
				my @dbg;
				foreach my $part (keys %$sentence) {
					my $val=$sentence->{$part};
					next unless defined $val;
					if (ref $val eq 'ARRAY') {
						$val=join(" ", @$val);
					}
					elsif ($val !~ /^[A-Za-z0-9_]+$/) {
						$val=qq{"$val"};
					}
					push @dbg, "$part($val)";
				}
				return join(", ", @dbg);
			});
			
			# Did the user perhaps answer a question?
			if ($anshandler) {
				if (! exists $sentence->{verb}) {
					next if $anshandler->(%$sentence);
				}
				$anshandler=undef;
			}

			# Multiple direct objects?
			if ($sentence->{direct_object} &&
			    @{$sentence->{direct_object}} > 1) {
				next if do_multobj_sentence(%$sentence);
			}
			else {
				next if do_sentence(1, 0, "", %$sentence);
				showfailure("", %$sentence);
			}
			
			last;
		}
	
		if ($debugger && ! $Mooix::Thing::debugging) {
			# Force debugging back on. In case the user had 
			# disallowed all debugging, or debugging by this
			# object, and the command turned it back on. If
			# debugging is still off, it will be turned off
			# again next time something is logged.
			$caller->debugger($debugger);
		}
		
		finished("running command");
	}
	return;
}; #}}}
