Discourse


      So far, our program responds to simple commands and questions related to our miniature block world. However, it can only process one sentence at a time. Humans, on the other hand, keep track of many types of information over the course of a conversation. People, it seems, are naturally curious about who did what with their friends. We track references to people and objects mentioned in previous sentences, and refer back to them in later sentences. We also track references to specific events, and put the events into a temporal order. Winograd’s shrdlu program displays a similar ability as shown in the following dialogue:

 

Person: HAD YOU TOUCHED ANY PYRAMID BEFORE YOU PUT THE GREEN ONE ON THE LITTLE CUBE?

Computer: YES, THE GREEN ONE.

Person: WHEN DID YOU PICK IT UP?

Computer: WHILE I WAS STACKING UP THE RED CUBE, A LARGE RED BLOCK AND A LARGE GREEN CUBE.

Person: WHY?

Computer: TO GET RID OF IT.


The program responds as if it understands the referents of the pronouns you and one. The phrase green one refers to the green pyramid mentioned in the beginning of the sentence. The pronoun you, when used by the user, refers to the computer. The program also recognizes the referent for the pronoun it in the user’s question ‘When did you pick it up?’ Here, the pronoun it ultimately refers back to the green pyramid.

      We can begin to tackle this problem in our miniature world by implementing a routine that tracks pronoun reference. A user might begin a dialogue with the program by asking the computer to put something somewhere. A subsequent command or question involving the same object would naturally use the pronoun it to refer back to the same object. We have several objects in our miniature world, and the pronoun could refer to either the object that was moved or the location it was moved to. In the course of a typical discussion of moving objects, though, the object would have a greater pragmatic salience than its location. Consider the following example.


      Put the egg on the blue block.

      Where is it?


We are more likely to be interested in the location of the egg rather than the block since we had just asked to move the egg. On the other hand, if we were already holding the egg, then we would be asking about the block. The actual pragmatic situation has priority over linguistic preferences.

      The structure of our program makes it relatively easy to implement a discourse tracking routine for interpreting pronouns. The pronoun it will refer to either the direct object or the location, and our program already tracks this information with the variables $Object and $Location. We only need to introduce the discourse variable, $Referent, to track references to objects between sentences. When the program receives a command such as ‘Put the egg on the blue block’, it assigns the value in $Object to the discourse variable $Referent. If the program then encounters the pronoun it in a subsequent sentence, the program can refer to the $Referent variable for an interpretation of the pronoun. One way to implement this procedure would be to simply convert any instances of the pronoun in the input sentence to the referent stored in the variable $Referent via a substitution statement like the following.


      $input =~ s/it/$Referent/;


I only needed to add the following statement to the imperative block of the parse subroutine to implement reference tracking.


      $Referent = $Object;


We will have to give the $Referent variable global scope in the main program block to enable it to track references between inputs. With these statements in place, the program produces the following responses.


      User: put the egg on the blue block.

      Computer: Ok, the egg is on the blue block.

      User: put it on the table.

      Computer: Ok, the egg is on the table.

      User: move it.

      Computer: Ok, consider the egg moved.

      User: where is it?

      Computer: The egg is on the floor.



Past Actions


      Besides tracking pronoun reference, we also remember previous actions. Winograd’s program displays this ability in the section of dialogue I quoted earlier. When the user asks ‘When did you pick it up?’, the computer responds ‘While I was stacking up the red cube, a large red block and a large green cube.’ Tracking previous actions requires a memory of the actions the computer has already carried out.

      One solution to remembering the computer’s actions is to add an array that tracks the subject, action, object and location tied to each event. If we call this an events array, we can add the relevant information with the statement


      push( @events, [ $Subject, $Action, $Object, $Loc ] );


This statement actually produces an array of array references, since the expression


      [ $Subject, $Action, $Object, $Loc ]


is technically a reference to an array. We can access the individual elements in the array by either of the following statements


      $events[1][2]

      $events[1]->[2]


These equivalent expressions refer to the third element of the second array reference, i.e. the object of the second action.

      We would like the program to add this information to its memory every time it carries out an action, but we need to recognize that not all commands to the computer result in an action. If we tell the computer to put the blue block in the bowl, the computer will respond by saying that the blue block is too big to fit in the bowl. If we then ask the computer if it put the blue block in the bowl, we would want the computer to respond ‘no’ rather than ‘yes’. Thus, it would be a mistake to add the action to the events array in the imperative subroutine where the program initiates a response since the response will not necessarily result in an action. The best place to jog the computer’s memory of events is in the lexical entry for each action. At that point, we can be certain the computer has actually carried out the requested action. I provide an example of the revised lexical entry for move in Figure 12.1 to show how this change can be accomplished.


Figure 12.1 A revised lexical entry for ‘move’


action=>sub{

   if($lex{move}{can}->($_[0])eq"yes"){

      $lex{$_[0]}{loc} = "floor";

      push( @events, [ $Subject, $Action, $Object, $Loc ] );

      push( @events, [ $Subject, "put", $Object, "floor" ] );

      if ( $plural eq '' ) {

         $reply = "Ok, consider the $_[0] moved."; }

      else {

         push( @events, [ $Subject, $Action, $plural, $Loc ] );

         push( @events, [ $Subject, "put", $plural, "floor" ] );

         $reply = "Ok, consider the $plural moved."; }

      }

   else{$reply=$lex{move}{can}->($_[0])}}},


      At this point in the program’s development we need to add two events to the computer’s memory every time we tell the computer to move an object. I’ve assumed that anytime the computer is asked to move something, it moves the object to the floor. If we tell the computer to move the bowl, we might then ask if it put the bowl on the floor. Every move command entails putting the object somewhere. I captured this entailment by adding another push statement to each verb’s lexical entry. A more elegant approach would be to look for a general way to state lexical entailments. This is a problem that we can postpone for the moment.

      We still need to provide the program with a way to reference its event array. We can begin with a simple yes/no question such as ‘Did you put the egg on the table?’ In this type of question, the fronted auxiliary verb did signals a question about a previous action. We can add an action subroutine to the lexical entry for the auxiliary to address such questions. Figure 12.2 provides an example.


Figure 12.2 A lexical entry for the auxiliary verb did


"did" => { pos => "AUX/0/_np_vp;V/0/_np",

   action=>sub{

         foreach ( 0 .. $#events ) {

      if ( $events[$_][1] eq $Action && $events[$_][2] eq $Object && $events[$_][3] eq $Loc ) {

         $reply = "Yes"; }

      }

      if ( $reply ne 'Yes' ) {

         $reply = "No"; }

}},


The action subroutine simply cycles through the events array to see if the indicated action moved the designated object to a specified location. If true, the program responds ‘yes’, and if not, the program responds ‘no’.

      The only other change we need make to the program is to add a subroutine to the parser that will initiate the response to fronted auxiliary questions. I provide an example in Figure 12.3.


Figure 12.3 A ‘did you’ subroutine


sub did_you {

   $Aux = $_[0];

   $Subject = $_[1];

   $Action = $_[2];

   $Object = $_[3];

   $Loc = $_[4];

   process();


   if ( $Aux eq 'did' ) {

      $lex{$Aux}{action}->($Object);

   }


} # end sub did_you


With these changes in place, the program will produce the following dialogue


      User: put the red block on the blue block.

      Computer: Ok, the red block is on the blue block.

      User: did you move the red block?

      Computer: Yes

      User: put the blocks in the bowl

      Computer: the blue block is too big to fit in the bowl

      User: did you move the blocks?

      Computer: No.

      User: where are the blocks?

      Computer: The red block is on the blue block,

                    and the blue block is on the table.



Inference


      Reasoning provides another dimension of relevance to extended dialogues. Over the course of their lives, people develop many ideas about causal connections between events. We will need to provide the computer with some primitive inference abilities to enable it to discuss the causal connections between its actions. Of course, in a computer world there is nothing that corresponds to the causal connections of reality. We will have to provide the program with descriptions of every causal connection it requires to discuss the causal connections in its miniature world.

      The program already uses the relative sizes of the objects to limit certain actions. For example, if we ask the program to put the blue block in the bowl, the program will respond ‘The blue block is too big to fit in the bowl.’ If we tell the program to move the table, it responds ‘The table is too heavy!’ If we ask the program to move the floor, it responds ‘You can’t move the floor.’

      We can easily add a routine that accesses these size restrictions in response to questions like ‘Can you put the blue block on the egg?’ Such questions are another instance of our fronted auxiliary question that asks about previous events. If we add a test for the auxiliary can to this routine, we can access the size constraints in the lexical entries of the verbs. I provide the revised version of the fronted auxiliary subroutine in Figure 12.4.


Figure 12.4 The ‘can_you’ subroutine


sub can_you { # can you ...

   $Aux = $_[0];

   $Subject = $_[1];

   $Action = $_[2];

   $Object = $_[3];

   $Loc = $_[4];

   process();


   if ( $Aux eq 'can' ) {

      if(exists $lex{$Action}{can}){

         $reply=$lex{$Action}{can}->($Object)}

      else{$reply="I don't understand"}

   }


   elsif ( $Aux eq 'did' ) {

      $lex{$Aux}{action}->($Object);

   }


} # end sub can_you



With the revised subroutine, the program can respond as follows:


      User: can you put the red block in the bowl?

      Computer: The egg is in the bowl.

I need to move it.

      User: can you put the blue block in the bowl?

      Computer: The blue block is too big to fit in the bowl.

      User: can you move the floor?

      Computer: You can’t move a floor



      Shrdlu also draws inferences about the support relation between the various objects in its world as seen in the following section of dialogue.


Person: WHAT IS THE PYRAMID SUPPORTED BY?

Computer: THE BOX.

Person: HOW MANY BLOCKS ARE NOT IN THE BOX?

Computer: FOUR OF THEM.

Person: IS AT LEAST ONE OF THEM NARROWER THAN THE ONE WHICH I TOLD YOU TO PICK UP?

Computer: YES, THE RED CUBE.

Person: IS IT SUPPORTED?

Computer: YES, BY THE TABLE.


It is relatively easy to implement a routine which tracks the support relation since each of the objects in our miniature world comes with a specified location. Figure 12.5 provides the lexical entry for the verb support that allows access to the support relations between the objects.


Figure 12.5 The lexical entry for the verb support


"support" => { pos => "V/2/_np",

   can=>sub{

      if( $lex{$Object}{size}<$lex{$Subject}{size} ){

         $cansupport="yes"}

      else{$cansupport="You must be kidding!"}

         return $cansupport},

   what=>sub{

       if ( $plural eq '' ) {

          if(exists $lex{$Object}{loc}) {

             $reply = "The $lex{$Object}{loc} supports the $Object."; }

          else{$reply="I don\'t know."}

       }

       elsif ( $loc{$objects[0]} eq $loc{$objects[1]} ) {

          $reply = "The $loc{$objects[0]} supports the $plural."; }

       else {

          $reply = "The $loc{$objects[0]} supports the $objects[0],\n and the $loc{$objects[1]} supports the $objects[1].\n";}

   },

   action=>sub{

      if($lex{move}{can}->($Object)eq"yes"){

         $reply = "Definitely.";

      }

      else{$reply=$lex{move}{can}->($Object)}

}},


The subroutines in the lexical entry for support allow the computer to respond to such questions as ‘Can the table support the bowl?’ as well as ‘What supports the egg?’ The following dialogue provides an idea of the program’s responses


      User: What supports the egg?

      Computer: The bowl supports the egg.

      User: What supports the blocks?

      Computer: The table supports the blocks.

      User: What supports the table?

      Computer: The floor supports the table.

      User: Can the egg support the blue block?

      Computer: You must be kidding!



      We can provide the program with the insight necessary to tackle a problem like the classic question of transporting a cabbage, goat and fox across a river in a boat that is only big enough to hold a farmer and one of his possessions. If the farmer takes the fox across the river first, the goat will eat the cabbage, and if the farmer takes the cabbage across the river first, the fox will eat the goat. We can create a simple analogue to this problem by limiting the number of objects that can fit in the bowl or be stacked on the blue block at any given moment.

      The program begins with the egg already in the bowl. We can begin by assuming that the bowl is only big enough to hold one object. If we ask the program to put another object into the bowl, such as the red block, the program should respond by saying that it will need to move the egg first. We can permit the user to allow the action by replying ‘ok’. Otherwise, the program will assume that the user does not want the egg moved. Our use of ‘ok’ in this instance is highly contextualized. Its interpretation requires the program to keep track of which object to move out of the bowl and which object to put into the bowl.

      To implement this change to our program, we will need to augment the lexical entry for the verb put. Each time this action is invoked, it will have to check if another object is already in the specified location. We should only restrict the number of objects that can be placed in small containers. We can assume, for now, that an unlimited number of objects can be put on the table and on the floor. I provide the new lexical entry for the verb put in Figure 12.6.


Figure 12.6. The revised lexical entry for put


"put" => { pos => "V/2/_np_pp",

   can=>sub{

      @match = grep { $Loc =~ $lex{$_}{loc} } @things;

      if($lex{$Object}{size}<6){

         if($lex{$Object}{size}<4){

            if( $lex{$Object}{size} < $lex{$Loc}{size} ){

               if ($match[0] eq '' || $lex{$Loc}{size} >= 4 ) {

                  $canput="yes"}

               else {

                  $Referent = $match[0];

            $canput = "The $match[0] is $lex{$Loc}{prep} $locdet$Loc.\nI need to move it."; }

            }

            else {$canput = "The $Object is too big to fit $lex{$Loc}{prep} $locdet$Loc."; }

         }

         else{$canput="The $Object is too heavy!"}}

      else{$canput="You can't move $objdet$Object"}

   return $canput},

   action=>sub{

      if($lex{put}{can}->($Object)eq"yes"){

         $lex{$Object}{loc} = $Loc;

         push( @events, [ $Subject, $Action, $Object, $Loc ] );

         push( @events, [ $Subject, "move", $Object ] );

         if ( $plural eq '' ) {

            $reply = "Ok, $objdet$Object is $lex{$Loc}{prep} the $Loc."; }

         else {

            push( @events, [ $Subject, $Action, $plural, $Loc ] );

            push( @events, [ $Subject, "move", $plural ] );

            $reply = "Ok, $objdet$plural are $lex{$Loc}{prep} the $Loc."; }

      }

      else{$reply=$lex{put}{can}->($Object)}

}},



      Once again I’ve made use of the grep function to search for objects already located in the container specified by the user. If such an object exists, it can be found in the first item of the @match array. I am assuming that our “containers” can only hold one item. The containers consist of the bowl, the blue block, the table, and the floor–in short, any item that can support another item. The bowl and the blue block are the only containers that are limited to holding a single object.

      If the user asks the program to put the red block into the bowl, the program will respond “The egg is in the bowl. I need to move it.” If the bowl is empty, the program will put the red block into the bowl.

      I used the statement


     if ($match[0] eq '' || $lex{$Loc}{size} >= 4 ) {


to test if the container already contains an object or if the container is greater or equal to the size of the table. If the container is empty, or if it is large enough, the program will put the object on the container. If these conditions do not hold, the program will output the statement that an object is already in the container.

      We will need to add a lexical entry for the word ok in addition to changing the lexical entry for put. When the user responds ok, the program should remove the old object from the container and add the new object to the container. This operation can be performed by embedding a call to the put action in the entry for ok. Figure 12.7 provides the statements for ok.


Figure 12.7 Lexical entry for ok


"ok" => { pos => "EXC//",

   action=>sub{

      $match[0] =~ s/ /_/;

      $lex{$match[0]}{loc} = $lex{$lex{$match[0]}{loc}}{loc};

      $lex{"put"}{action}->($Object);

}},


      I classified ok as an exclamation, since it is normally found outside of the regular sentence structure. Since our parsing routine does not recognize exclamations, we will have to add an additional routine for exclamations. I provide this routine in Figure 12.8.


Figure 12.8 Parsing routine for exclamations


      if ($string1 eq "EXC.;") {

         $Action = "ok";

         imperative ($Action, $Object, $Location);

      }


I took advantage of the object and location variables from the previous parse to help in the interpretation of the exclamation. Setting the action variable to ok insures that the imperative subroutine will direct the program to instructions stored in the lexical entry for the exclamation. With these changes in place, the program will produce dialogues like the following:


      User: put the red block in the bowl.

      Computer: The egg is in the bowl.

                  I need to move it.

      User: ok.

      Computer: Ok, the red block is in the bowl.

      User: where is the egg?

      Computer: The egg is on the table.


A complete listing for the program is provided in Figure 12.9.


Figure 12.9 Final program listing


#!/usr/local/bin/perl

# block13.pl

# Did you ...?


use English;

use Stem3;

use Ambi3;


# Initialize parameters

my @string = ''; my $word = ''; @Object = ''; @Loc = ''; our $Referent = '';

my %pos = (); my %number = (); my %subcat = (); my %loc = ();

my %action = (); my %can = (); @objects = ''; @events = '';


@cat = ''; #the parsed words

@things = ("bowl", "red block", "blue block", "egg", "table", "floor");


# Block 1. Set the scene

print "\nWelcome to the miniature block world.\n";

print "\nThis world has a room with a table in it. On the table\n";

print "is a block and a bowl. The bowl contains an egg. Type in\n";

print "an instruction to manipulate the objects, but be careful!\n";

print "Don't break anything!\n";


# Block 2. The Lexicon

%lex = (

     "I" => { pos => "N/1/", loc => "room", },

     "me" => { pos => "N/2/", },

     "found" => { pos => "V/0/_np:_pp:", },

     "find" => { pos => "V/2/_np:_pp:", },

     "move" => { pos => "V/2/_np:_pp:",

        can=>sub{

           if($lex{$_[0]}{size}<6){

              if($lex{$_[0]}{size}<4){

                 $canmove="yes"}

              else{$canmove="The $_[0] is too heavy!"}}

           else{$canmove="You can't move a $_[0]"}

              return $canmove},

        action=>sub{

           if($lex{move}{can}->($_[0])eq"yes"){

              $lex{$_[0]}{loc} = "floor";

              push( @events, [ $Subject, $Action, $Object, $Loc ] );

              push( @events, [ $Subject, "put", $Object, "floor" ] );

              if ( $plural eq '' ) {

                 $reply = "Ok, consider the $_[0] moved."; }

              else {

                 push( @events, [ $Subject, $Action, $plural, $Loc ] );

                 push( @events, [ $Subject, "put", $plural, "floor" ] );

                 $reply = "Ok, consider the $plural moved."; }

           }

           else{$reply=$lex{move}{can}->($_[0])}}},


     "support" => { pos => "V/2/_np",

        can=>sub{

           if( $lex{$Object}{size}<$lex{$Subject}{size} ){

              $cansupport="yes"}

           else{$cansupport="You must be kidding!"}

              return $cansupport},

        what=>sub{

           if ( $plural eq '' ) {

              if(exists $lex{$Object}{loc}) {

                 $reply = "The $lex{$Object}{loc} supports the $Object."; }

              else{$reply="I don\'t know."}

           }

           elsif ( $loc{$objects[0]} eq $loc{$objects[1]} ) {

              $reply = "The $loc{$objects[0]} supports the $plural."; }

           else {

              $reply = "The $loc{$objects[0]} supports the $objects[0],\n and the $loc{$objects[1]} supports the $objects[1].\n";}

        },

        action=>sub{

           if($lex{move}{can}->($Object)eq"yes"){

              $reply = "Definitely.";

           }

           else{$reply=$lex{move}{can}->($Object)}}},


     "moved" => { pos => "V/2/_np:_pp:", },

     "put" => { pos => "V/2/_np_pp",

        can=>sub{

           @match = grep { $Loc =~ $lex{$_}{loc} } @things;

           if($lex{$Object}{size}<6){

              if($lex{$Object}{size}<4){

                 if( $lex{$Object}{size} < $lex{$Loc}{size} ){

                    if ($match[0] eq '' || $lex{$Loc}{size} >= 4 ) {

                       $canput="yes"}

                    else {

                       $Referent = $match[0];

                   $canput = "The $match[0] is $lex{$Loc}{prep} $locdet$Loc.\nI need to move it."; }

                 }

                 else {$canput = "The $Object is too big to fit $lex{$Loc}{prep} $locdet$Loc."; }

              }

              else{$canput="The $Object is too heavy!"}}

           else{$canput="You can't move $objdet$Object"}

           return $canput},

        action=>sub{

           if($lex{put}{can}->($Object)eq"yes"){

              $lex{$Object}{loc} = $Loc;

              push( @events, [ $Subject, $Action, $Object, $Loc ] );

              push( @events, [ $Subject, "move", $Object ] );

              if ( $plural eq '' ) {

                 $reply = "Ok, $objdet$Object is $lex{$Loc}{prep} the $Loc."; }

              else {

                 push( @events, [ $Subject, $Action, $plural, $Loc ] );

                 push( @events, [ $Subject, "move", $plural ] );

                 $reply = "Ok, $objdet$plural are $lex{$Loc}{prep} the $Loc."; }

           }

           else{$reply=$lex{put}{can}->($Object)}

    }},


     "give" => { pos => "V/2/_np_pp;V/2/_np_np", },

     "gave" => { pos => "V/0/_np_pp", },

     "block" => {pos => "N/3/",object => "category",color => "red",

      loc => "table",size => 2,shape => "square", },

     "red block" => {pos => "N/3/",color => "red",prep => "on",

      loc => "table",size => 2,shape => "square",isa => "block", },

     "blue block" => {pos => "N/3/",color => "blue",prep => "on",

      loc => "table",size => 3,shape => "square",isa => "block", },

     "egg" => {pos => "N/3/",color => "brown",loc => "bowl",

      size => 2,shape => "round", },

     "table" => {pos => "N/3/",color => "brown",prep => "on",

            loc => "floor",size => 4,shape => "square", },

     "bowl" => {pos => "N/3/",color => "blue",prep => "in",

            loc => "table",size => 3,shape => "square", },

     "floor" => {pos => "N/3/",color => "yellow",prep => "on",

            loc => "ground",size => 7,shape => "square", },

     "a" => { pos => "DET/3/", },

     "an" => { pos => "DET/3/", },

     "the" => { pos => "DET/0/", },

     "has" => { pos => "V/3/_np", },

     "red" => { pos => "ADJ//", },

     "blue" => { pos => "ADJ//", },

     "on" => { pos => "P//", },

     "in" => { pos => "P//", },

     "to" => { pos => "P//", },

     "with" => { pos => "P//", },

     "at" => { pos => "P//", },

     "it" => { pos => "N/3/", },

     "you" => { pos => "N/2/", },

     "anyone" => { pos => "N/3/", },

     "we" => { pos => "N/2/", },

     "ok" => { pos => "EXC//",

        action=>sub{

            $lex{$match[0]}{loc} = $lex{$lex{$match[0]}{loc}}{loc};

            push( @events, [ $Subject, "put", $match[0], $lex{$match[0]}{loc} ] );

            push( @events, [ $Subject, "move", $match[0] ] );

            $lex{"put"}{action}->($Object);

        }},

     "is" => { pos => "AUX/3/_np_pp;V/3/_pp",

         action=>sub{

            # where is the block

            if ( $Loc eq 'where' ) {

               $reply = "The $_[0] $Action $lex{$lex{$_[0]}{loc}}{prep} the $lex{$_[0]}{loc}.";

            } # end where is


            # what is on the table?

            elsif ( $Object eq 'what' ) {

               my @match = grep { $Loc =~ $lex{$_}{loc} } @things;

               if ( $match[1] eq '' ) {

                  $reply = "The @match $Action $lex{$Loc}{prep} $locdet$Loc."; }

               else {

                  my $last = pop( @match );

                  my $set = '';

                  foreach my $item ( @match ) {

                     $set = $set . "$item, ";

                  }

                  $reply = "The $set" . "and $last are $lex{$Loc}{prep} $locdet$Loc."; }

            } # end what is


            elsif ( $Loc =~ /$lex{$_[0]}{loc}/ ) {

               $reply = "yes"; }

            else { $Loc = $lex{$_[0]}{loc};

               $reply = "No, the $_[0] $Action $lex{$Loc}{prep} the $Loc.";

                        } # end else


         }},

     "am" => { pos => "AUX/1/_np_pp;V/1/_pp", },

     "are" => { pos => "AUX/3/_np_pp;V/3/_pp",

        action=>sub{


            # where are the blocks

            if ( $Loc eq 'where' ) {

               if ( $loc{$objects[0]} eq $loc{$objects[1]} ) {

       $reply = "The $plural $Action $lex{$loc{$objects[0]}}{prep} the $loc{$objects[0]}.";

               }

               else {

       $reply = "The $objects[0] is $lex{$loc{$objects[0]}}{prep} the $loc{$objects[0]},\n and the $objects[1] is $lex{$loc{$objects[1]}}{prep} the $loc{$objects[1]}.\n";

               }

            } # end where is


            elsif ( $Loc eq $loc{$objects[0]} && $Loc eq $loc{$objects[1]} ) {

               $reply = "Yes"; }

            elsif ( $Loc ne $loc{$objects[0]} && $loc{$objects[0]} eq $loc{$objects[1]} ) {

      $reply = "No, the $plural $Action $lex{$loc{$objects[0]}}{prep} the $loc{$objects[0]}."; }

            elsif ( $Loc ne $loc{$objects[0]} && $Loc ne $loc{$objects[1]} ) {

      $reply = "No, the $objects[0] is $lex{$loc{$objects[0]}}{prep} the $loc{$objects[0]},\n and the $objects[1] is $lex{$loc{$objects[1]}}{prep} the $loc{$objects[1]}.\n";}

            elsif ( $Loc ne $loc{$objects[0]} ) {

      $reply = "No, the $objects[0] is $lex{$loc{$objects[0]}}{prep} the $loc{$objects[0]}."; }

            else {

      $reply = "No, the $objects[1] is $lex{$loc{$objects[1]}}{prep} the $loc{$objects[1]}.\n";

      } # end else


         }},

     "where" => { pos => "Pwh/2/", },

     "who" => { pos => "Nwh/3/", },

     "what" => { pos => "Nwh/3/", },

     "which" => { pos => "DET/0/", },

     "did" => { pos => "AUX/0/_np_vp;V/0/_np",

        action=>sub{

           foreach ( 0 .. $#events ) {

      if ( $events[$_][1] eq $Action && $events[$_][2] eq $Object && $events[$_][3] eq $Loc ) {

               $reply = "Yes"; }

           }

           if ( $reply ne 'Yes' ) {

              $reply = "No"; }

        }},

     "do" => { pos => "AUX/2/_np_vp;V/2/_np", },

     "does" => { pos => "AUX/3/_np_vp;V/3/_np", },

     "can" => { pos => "AUX/0/_np_vp", },

     "go" => { pos => "V/2/_pp", },

     "goes" => { pos => "V/3/_pp", },

     "have" => { pos => "V/2/_np", },

     "has" => { pos => "V/3/_np", },

     "saw" => { pos => "V/0/:_np:", },

     "see" => { pos => "V/2/:_np:", },

);


foreach $word (keys %lex) {

   $lex{$word}{pos} =~ /(.*)\/(.*)\/(.*)/ ;

   $pos{$word} = $1;

   $number{$word} = $2;

   $subcat{$word} = $3;

} # end foreach word


#The Grammar


$NP = "(DET(\.[0-3]); )?(ADJ\.; )*N(\.[0-3]?)?;";

$PP = "P(?:\.; )($NP)";

$NPwh = "(DET(\.[0-3]); )?(ADJ )*Nwh(\.3);( $PP)*";

$NP2 = "$NP( $PP)*";

$V1 = "(V(\.[0-3])(;[:np_]*)) ?($NP)? ?";

$V2 = "(V(\.[0-3])(;[:np_]*)) ?";

$Swh = "([NP]wh(\.[2-3]))?(?:; )?(AUX(\.[0-3])(;[:nvp_]*)) ($NP2)? ?";


print "Please type a sentence\n\n";

chop( $input = <> );


# Main program loop

until ( $input eq 'thanks' ) {


   $input =~ s/it/$Referent/;


   @words = split / /, $input;


   my @copy = stem(\@words, \%lex, \%pos, \%number, \%subcat);


   my @string = ambilex(\@copy);


   parse(@string);


   print "\n";


   chop( $input = <> );


   $plural = '';

} #end until



#################### Subroutines #######################


sub parse {


   our @parse = '';

   my @string = @_;

   my $string1 = '';

   my $string2 = '';

   my $string3 = '';

       

   $i = 0; # initialize the string index (lexical ambiguity)

   foreach $string (@string) {

      chop($string);

      $j = 0; # initialize the parse index (structural ambiguity)

      $string1 = $string;

      $string2 = $string1;

      $string3 = $string2;


      if ($string1 eq "EXC.;") {

         $Action = "ok";

         imperative ($Action, $Object, $Location);

      }


      #SVOP

      if ( $string1 =~s/^($NPwh) ($V1)// || $string1 =~ s/^($NP2)? ?($V1)// ) {                      # VP with object NP

         my $subject = $1; my $object = $16;

         my $det_agr = $3; my $n_agr = $5; my $v_agr = $14;

         my $subcat = $15;

         #There's another verb!

         if ( $string1 =~m/$V2/ ) {

            $parse[$j] = "SENTENCE FAILS GRAMMAR CHECK!\n";

         }

         #A question?

         elsif ( $subject eq 'Nwh.3;' ) {

            $parse[$j] = "NP[$subject] VP[V$v_agr" . NP ($object) . PP ($string1) . "]\n";

            relex($parse[$j], \@words);

            $Subject = $con[1]; $Action = $con[2]; $Object = $con[3]; $Loc = $con[4];

            if ($object eq '' && $string1 eq '') {

               $parse[$j] = "NP[$con[1]] VP[$con[2]]\n";

            }

            #what supports the bowl?

            elsif ($object ne '' && $string1 eq '') {

               $parse[$j] = "NP[$con[1]] VP[$con[2] NP[$con[3]]]\n";

               substr($Action, -1) = ''; # remove the -s suffix

               question ($Action, $Object);

            }

            elsif ($object eq '' && $string1 ne '') {

               $Location = $con[4];

               $parse[$j] = "NP[$con[1]] VP[$con[2] PP[$con[3] NP[$con[4]]]\n";

            }

            elsif ($object ne '' && $string1 ne '') {

               $Object = $con[3]; $Location = $con[5];

               $parse[$j] = "NP[$con[1]] VP[$con[2] NP[$con[3]] PP[$con[4] NP[$con[5]]]\n";

            }

         }

         #Declaratives & Imperatives

         else {

            $parse[$j] = NP ($subject) . " VP[V$v_agr" . NP ($object) . PP ($string1) . "]\n";

            relex($parse[$j], \@words);

            if ( $subject ne '' ) {

               $Subject = $con[1]; $Action = $con[2]; $Object = $con[3];

               if ($object eq '' && $string1 eq '') {

                  $parse[$j] = "NP[$con[1]] VP[$con[2]]\n";

               }

               elsif ($object ne '' && $string1 eq '') {

                  $Object = $con[3];

                  $parse[$j] = "NP[$con[1]] VP[$con[2] NP[$con[3]]]\n";

               }

               elsif ($object eq '' && $string1 ne '') {

                  $Location = $con[4];

                  $parse[$j] = "NP[$con[1]] VP[$con[2] PP[$con[3] NP[$con[4]]]\n";

               }

               elsif ($object ne '' && $string1 ne '') {

                  $Object = $con[3]; $Location = $con[5];

                  $parse[$j] = "NP[$con[1]] VP[$con[2] NP[$con[3]] PP[$con[4] NP[$con[5]]]\n";

               }

            } # if overt subject

            else {

               $Action = $con[1];

               if ($object eq '' && $string1 eq '') {

                  $parse[$j] = "VP[$con[1]]\n";

               }

               elsif ($object ne '' && $string1 eq '') {

                  $Object = $con[2];

                  $parse[$j] = "VP[$con[1] NP[$con[2]]]\n";

               }

               elsif ($object eq '' && $string1 ne '') {

                  $Location = $con[3];

                  $parse[$j] = "VP[$con[1] PP[$con[2] NP[$con[3]]]\n";

               }

               elsif ($object ne '' && $string1 ne '') {

                  $Object = $con[2]; $Location = $con[4];

                  $parse[$j] = "VP[$con[1] NP[$con[2]] PP[$con[3] NP[$con[4]]]\n";

               }

               $Referent = $Object;

               imperative ($Action, $Object, $Location);

            } # end else

         }

         agreechk($det_agr, $n_agr, $v_agr);

         subcatchk($subcat, $object, $string1);

      }

      else {

         $parse[$j] = "SENTENCE FAILS GRAMMAR CHECK!\n";

      }

      $j = $j + 1;

 

      #SVO

      if ( $string2 =~s/^($NPwh) ($V2)// || $string2 =~s/^($NP2)? ?($V2)// ) { # plain VP

         my $subject = $1; my $object = $string2;

         my $det_agr = $3; my $n_agr = $5; my $v_agr = $14;

         my $subcat = $15;


      if ( $string2 =~m/$V2/ ) {

            $parse[$j] = "SENTENCE FAILS GRAMMAR CHECK!\n";

         }

         #who moved the egg?

      elsif ( $subject eq 'Nwh.3;' && $string2 =~ /^$NP/ ) {

            $parse[$j] = "NP[$subject] VP[V$v_agr" . NP ($string2) . "]\n";

            relex($parse[$j], \@words);

            $Subject = $con[1]; $Action = $con[2]; $Object = $con[3];

            $parse[$j] = "NP[$con[1]] VP[$con[2] NP[$con[3]]]\n";

         }

         #what is in the egg?

      elsif ( $subject eq 'Nwh.3;' && $string2 =~ /^$PP/ ) {

            $parse[$j] = "NP[$subject] VP[V$v_agr" . PP ($string2) . "]\n";

            relex($parse[$j], \@words);

            $Subject = $con[1]; $Action = $con[2]; $Loc = $con[4];

            $parse[$j] = "NP[$con[1]] VP[$con[2] PP[$con[3] NP[$con[4]]]\n";

         }

         #A PP verb complement?

        elsif ( $string2 =~ /^$PP/ ) {

            $parse[$j] = NP ($subject) . " VP[V$v_agr" . PP ($string2) . "]\n";

            relex($parse[$j], \@words);

            $Subject = $con[1]; $Action = $con[2]; $Loc = $con[4];

            $parse[$j] = "NP[$con[1]] VP[$con[2] PP[$con[3] NP[$con[4]]]\n";

        }

         #No direct object?

        elsif ( $string2 !~ /$NP/ ) {

            $parse[$j] = NP ($subject) . " VP[V$v_agr]\n";

            relex($parse[$j], \@words);

            $Subject = $con[1]; $Action = $con[2];

            $parse[$j] = "NP[$con[1]] VP[$con[2]]\n";

         }

         #Declaratives & Imperatives

         else {

            $parse[$j] = NP ($subject) . " VP[V$v_agr" . NP ($string2) . "]\n";

            relex($parse[$j], \@words);

            if ( $subject ne '' ) {

               $Subject = $con[1]; $Action = $con[2];

               if ($object eq '' ) {

                  $parse[$j] = "NP[$con[1]] VP[$con[2]]\n";

               }

               elsif ($object ne '' && $string2 eq '') {

                  $Object = $con[3];

                  $parse[$j] = "NP[$con[1]] VP[$con[2] NP[$con[3]]]\n";

               }

               elsif ($object ne '' ) {

                  $Object = $con[3]; $Loc = $con[5];

                  $parse[$j] = "NP[$con[1]] VP[$con[2] NP[$con[3] PP[$con[4] NP[$con[5]]]]]\n";

               }

            } # if overt subject

            else {

               $Action = $con[1];

               if ($object eq '' ) {

                  $parse[$j] = "VP[$con[1]]\n";

               }

               elsif ($object ne '' ) {

                  $Object = $con[2]; $Loc = $con[4];

                  $parse[$j] = "VP[$con[1] NP[$con[2] PP[$con[3] NP[$con[4]]]]]\n";

               }

            } # end else

         }

         agreechk($det_agr, $n_agr, $v_agr);

         subcatchk($subcat, $string2);

      }

      else {

         $parse[$j] = "SENTENCE FAILS GRAMMAR CHECK!\n";

      }

      $j = $j + 1;


      # a question?

      if ( $string3 =~ s/$Swh// ) {

         my $comp = $1; my $aux = $3; my $subject = $6;

         my $det_agr = $8; my $n_agr = $10; my $v_agr = $4;

         my $subcat = $5;

         # what do you see?

         if ( $subject ne '' && $comp eq 'Nwh.3' && $string3 =~ s/$V2// ) {

    $parse[$j] = "CP[$comp] AUX[$aux]" . NP($subject) . " VP[V$v_agr" . PP ($string3) . "]\n";

            relex($parse[$j], \@words);

            $Subject = $con[3]; $Action = $con[4]; $Object = $con[1]; $Loc = $con[6];

            $parse[$j] = "CP[$con[1]] AUX[$con[2]] NP[$con[3]] VP[$con[4] PP[$con[5] NP[$con[6]]]]\n";

            agreechk($8, $10, $4); }

         # is the bowl on the table?

         elsif ( $comp eq '' && $subject ne '' && $subject =~ /$PP/ ) {

            $subject =~ s/($NP)//;

            $location = $subject; $subject = $1;

            $parse[$j] = "AUX[$aux] NP[$subject]" . PP ($location) . "\n";

            relex($parse[$j], \@words);

            $Subject = $con[2]; $Action = $con[1]; $Loc = $con[4];

            $parse[$j] = "AUX[$con[1]] NP[$con[2]] PP[$con[3] NP[$con[4]]]\n";

            agreechk($det_agr, $n_agr, $v_agr); }

         # can you put the egg in the bowl?

         elsif ( $comp eq '' && $aux ne '' && $subject ne '' && $string3 =~ s/$V1// ) {

            my $object = $4; my $location = $string3;

   $parse[$j] = "AUX[$aux]" . NP ($subject) . " VP[V$v_agr NP[$object]" . PP ($string3) . "]\n";

            relex($parse[$j], \@words);

   $Aux = $con[1]; $Subject = $con[2]; $Action = $con[3]; $Object = $con[4]; $Loc = $con[6];

            $parse[$j] = "AUX[$con[1]] NP[$con[2]] VP[$con[3] NP[$con[4]] PP[$con[5] NP[$con[6]]]]\n";

            agreechk($det_agr, $n_agr, $v_agr);

            can_you ($Aux, $Subject, $Action, $Object, $Loc); }

         # where is the bowl?

         elsif ( $subject ne '' && $string3 eq '' && $comp eq 'Pwh.2' ) {

            $parse[$j] = "CP[$comp] AUX[$aux]" . NP($subject) . "\n";

            relex($parse[$j], \@words);

            $Object = $con[3]; $Action = $con[2]; $Loc = $con[1];

            $parse[$j] = "CP[$con[1]] AUX[$con[2]] NP[$con[3]]\n";

            agreechk($8, $10, $4);

            imperative ($Action, $Object, $Loc); }

         # where did you put the eggs?

         elsif ( $subject ne '' && $comp eq 'Pwh.2' && $string3 =~ s/$V2// ) {

            my $object = $string3;

  $parse[$j] = "CP[$comp] AUX[$aux]" . NP($subject) . " VP[V$v_agr" . NP ($string3) . "]\n";

            relex($parse[$j], \@words);

            $Subject = $con[3]; $Action = $con[4]; $Object = $con[5]; $Loc = $con[1];

            $parse[$j] = "CP[$con[1]] AUX[$con[2]] NP[$con[3]] VP[$con[4] NP[$con[5]]]\n";

            agreechk($8, $10, $4); }

         # what is in the bowl?

        elsif ( $subject eq '' && $string3 ne '' && $comp eq 'Nwh.3' ) {

            $parse[$j] = "CP[$comp] AUX[$aux]" . PP ($string3) . "\n";

            relex($parse[$j], \@words);

            $Object = $con[1]; $Action = $con[2]; $Loc = $con[4];

            $parse[$j] = "CP[$con[1]] AUX[$con[2]] PP[$con[3] NP[$con[4]]]\n";

            agreechk($6, $2, $4);

            imperative ($Action, $Object, $Loc); }

         else {

            $parse[$j] = "SENTENCE FAILS GRAMMAR CHECK!\n";

         }

      }

      else {

         $parse[$j] = " SENTENCE FAILS GRAMMAR CHECK!\n";

      }


      &print;


      $i = $i + 1; # increment the string index


   } #end foreach string


} #end sub parse


sub NP {

   my $string = shift;

   my $parse;

   if ( $string =~ s/($NP)// ) {

      $parse = " NP[$1" . PP ($string) . "]"; # call PP

       }

} # end sub NP


sub PP {

   my $string = shift;

   my $parse;

   if ( $string !~ s/(P\.;) ($NP)// ) { # end recursion

      return;

   }

   else {

      $parse = " PP[$1 NP[$2" . PP($string) . "]]";

   }

} # end sub PP


# Check agreement

sub agreechk {


# NP Agreement Check

   my($det_agr, $n_agr, $v_agr) = @_;

   if ( ( $det_agr eq '.3' ) && ( $n_agr ne '.0' ) && ( $n_agr ne $det_agr ) ) {

      $parse[$j] = $parse[$j] . " NP PARSE FAILS AGREEMENT CHECK!\n";

      return;}

   else {

      $np_agr = $n_agr; }

               

# Subject-Verb Agreement Check

   if ( $np_agr ne '.3' && $np_agr ne '.0' && $v_agr eq '.3' ) {

      $parse[$j] = $parse[$j] . " PARSE FAILS SUBJ-VERB AGREEMENT CHECK!\n";

      return; }


   elsif (( $np_agr eq '.3' ) && ( $v_agr ne '.0' ) && ( $v_agr ne '.3' )) {

      $parse[$j] = $parse[$j] . " PARSE FAILS SUBJ-VERB AGREEMENT CHECK!\n";

      return; }


} # end sub agreechk


# check subcategory restrictions

sub subcatchk {

   

   my($subcat, $object, $pp) = @_;

   if ( ($subcat eq ";_np" || $subcat eq ";_np:_pp:") && $object eq '' ) {

      $parse[$j] = $parse[$j] . " PARSE FAILS SUBCAT CHECK!\n"; }

   elsif ( ($subcat eq ";_pp" || $subcat eq ";:_np:_pp") && $pp eq '' ) {

      $parse[$j] = $parse[$j] . " PARSE FAILS SUBCAT CHECK!\n"; }

   elsif ( $subcat eq ";_np_pp" && ( $object eq '' || $pp eq '' ) ) {

      $parse[$j] = $parse[$j] . " PARSE FAILS SUBCAT CHECK!\n"; }

        

} # end sub subcatchk


sub relex {

   @con = ''; # constituent array

   my $con = 0; # constituent count

       my $pattern = "[NVPC]P";

   my @parsed = split / /, $_[0];

   if ( $parsed[0] eq '' ) {

      shift( @parsed ); }

   my @words = @{ $_[1] };

   foreach $parsed (@parsed) {

          my $word = shift( @words );

      if ( $parsed =~ /($pattern)/ || $parsed =~ /(AUX)/ ) {

         $con++;

         $con[$con] = $con[$con] . $word;

      }

      else {

         $con[$con] = $con[$con] . ' ' . $word;}

   } # end foreach

} # end sub relex


sub can_you { # can you ...

   $Aux = $_[0];

   $Subject = $_[1];

   $Action = $_[2];

   $Object = $_[3];

   $Loc = $_[4];

   process();


   if ( $Aux eq 'can' ) {

      if(exists $lex{$Action}{can}){

         $reply=$lex{$Action}{can}->($Object)}

      else{$reply="I don't understand"}

   }


   elsif ( $Aux eq 'did' ) {

      $lex{$Aux}{action}->($Object);

   }


} # end sub can_you


sub imperative {

   $Action = $_[0];

   $Object = $_[1];

   $Loc = $_[2];

   process();

   if(exists $lex{$Action}{action}){

      if ( substr($Object, -1) eq 's' ) {

         $stem = $plural = $Object;

         substr($stem, -1) = ''; # remove the -s suffix

         @objects = grep { $_ =~ $stem } @things;

         foreach (@objects) {

            $Object = $_;

            $loc{$_} = $lex{$_}{loc};

            $lex{$Action}{action}->($Object);

         }

      }

      else {

         $lex{$Action}{action}->($Object); }

   }

   else{$reply="I don't know how to \'$Action the $Object\'."}

} # end sub imperative


sub question {

   $Action = $_[0];

   $Object = $_[1];

   $Loc = $_[2];

   process();

   if(exists $lex{$Action}{what}){

      if ( substr($Object, -1) eq 's' ) {

         $stem = $plural = $Object;

         substr($stem, -1) = ''; # remove the -s suffix

         @objects = grep { $_ =~ $stem } @things;

         foreach (@objects) {

            $Object = $_;

            $loc{$_} = $lex{$_}{loc};

            $lex{$Action}{what}->($Object);

         }

      }

      else {

         $lex{$Action}{what}->($Object); }

   }

   else{$reply="I don't understand."}

} # end sub question


sub process {


   if ( $Subject =~ s/the // ) {

      $subjdet = "the "; }

       else { $subjdet = ''; }


   if ( $Object =~ s/the // ) {

      $objdet = "the "; }

       else { $objdet = ''; }


   if ( $Loc =~ s/the // ) {

      $locdet = "the "; }

       else { $locdet = ''; }

}


sub print {


   print "\nstring[$i] is: $string\n";


   my $j = 0;

   for ( $j = 0; $j <= 2; $j = $j + 1 ) {

      print " parse[$j] = $parse[$j]"; }

      print "$reply\n";

      $reply = '';

      @parse = '';

} #end sub print