Subject: Re: Solutions and Discussion for Perl Quiz of the Week #18 (Expert Edition) - msg#00045

Previous Message by Date: click to view message preview

Re: Solutions and Discussion for Perl Quiz of the Week #18 (Expert Edition)

Selon Mark Jason Dominus <mjd-ZxR0713JXSrQT0dZR+AlfA@xxxxxxxxxxxxxxxx>: > I'm puzzled by this. I initially planned not to deal directly with > negated sets, apparently thinking the same way that Pr. Sanderson did, > but I soon concluded that my program would have to operate with > negated sets explicitly. > > My first cut at the program didn't make contraposition inferences, but > I found a behavior that I interpreted as a bug, and contraposition was > necessary to fix it. Pr. Sanderson's example program demonstrates > this same behavior: > > > All dogs are mammals > OK. > > No octopuses are mammals > OK. > > Are any octopuses dogs? > I don't know. > > But it seems to me that the answer here should be 'no', because if any > octopuses *were* dogs, then they would also be mammals, which is a > contradiction. I think that you are right. First, I noticed that I overlooked the following two inference rules in my engine: (1) No X are Y and all Y are Z => not all X are Z. (2) No X are Y and some Y are Z => not all X are Z. But this is actually not the problem :) The problem is the following: if I have the following graph (this is my representation of the knowledge from above): octopuses --no--> mammals --some--> dogs All that I can infer is that not all octopuses are dogs (from rule 2.) BUT, looking at it the other way, we can see: dogs --all--> mammals --no--> octopuses from which we can infer the more specific no dogs are octopuses, and symmetrically, no octopuses are dogs. So my fix is that when we link two terms, or ask about the relationship between two terms, to go through the graph from both terms in order to infer new rules. In this way, we can find more specific information than the one that can be inferred from only one direction. Describe is handled in the same manner, except we start from the term to describe and *all* the terms that are found to be linked by "some" and "not all" links (as they can be refined into "all" and "no"). I am not sure that this fix covers every single situation, though. More testing (and thinking!) is in order... Julien (below is my corrected solution, with a few less bugs) #!/usr/bin/perl # Perl Expert Quiz of the Week #18 # Inference engine. Run this script with no arguments, type "help" at the # prompt for usage information. # $Id: inference.pl,v 1.4 2004/07/06 03:18:49 julien Exp $ use strict; use warnings; use Term::ReadLine; # The knowledge base is a hash representing the graph of concepts my $kb = {}; my $term = new Term::ReadLine("Inference Engine"); # Main loop, read user input and respond accordingly while (defined ($_ = $term->readline("> "))) { # Normalize the input $_ = lc; s/[^\w-]+/ /g; s/^ //; s/ $//; # Recognize the input /^all ([ \w-]+) are ([ \w-]+)$/ && do { link_all($1, $2, \$kb); next; }; /^some ([ \w-]+) are ([ \w-]+)$/ && do { link_some($1, $2, \$kb); next; }; /^no ([ \w-]+) are ([ \w-]+)$/ && do { link_no($1, $2, \$kb); next; }; /^not all ([ \w-]+) are ([ \w-]+)$/ && do { link_not_all($1, $2, \$kb); next; }; /^are all ([\w-]+) ([ \w-]+)$/ && do { are_all($1, $2, $kb); next; }; /^are no ([\w-]+) ([ \w-]+)$/ && do { are_no($1, $2, $kb); next; }; # This catches both "are any X Y?" and "are any X not Y?" /^are any ([\w-]+) ([ \w-]+)$/ && do { are_any($1, $2, $kb); next; }; /^describe (.+)$/ && do { describe($1, $kb); next; }; /^help$/ && do { help(); next; }; /^quit$/ && exit; print "I don't understand. Please type \"help\" for help.\n" if /\S/; } print "\n"; # Make links between X and Y. Do nothing if they are equal, or if this # contradicts previously known facts. Get or create entries in the knowledge # base for X and Y, flatten the links from X, verify that there are no # contradictory links or already defined ones, then create the links. # All X are Y => some Y are X (and some X are Y but this doesn't need to be. # explicitly represented in the knowledge base.) sub link_all { my ($x_key, $y_key, $kbref) = @_; # Disambiguate the input ($x_key, $y_key) = disamb_are("All X are Y.", $x_key, $y_key); # If X is the same are Y, this is obvious and no link is needed return if obviously($x_key, $y_key); # Get entries for X and Y in the knowledge base, creating them if necessary my $x = kb_entry($kbref, $x_key); my $y = kb_entry($kbref, $y_key); # Flatten the entries flatten($x_key, $$kbref); flatten($y_key, $$kbref); # At this point if the relationship between X and Y is known, there is a # direct link between them. If we already know that all X are Y, no new link # is made; if we know that no X are Y or not all X are Y, the link cannot be # made as this would contradict our prior knowledge. Otherwise, create the # links between X and Y. if (exists $x->{all}->{$y_key}) { print "I know.\n"; return; } elsif (exists $x->{no}->{$y_key}) { print "Sorry, but this contradicts the fact that no $x_key are $y_key.\n"; return; } elsif (exists $x->{not_all}->{$y_key}) { print "Sorry, but this contradicts the fact that not all $x_key are $y_key.\n"; return; } else { ++$x->{all}->{$y_key}; ++$y->{some}->{$x_key}; print "OK.\n"; } } # Some X are Y => some Y are X. See "link_all". sub link_some { my ($x_key, $y_key, $kbref) = @_; ($x_key, $y_key) = disamb_are("Some X are Y.", $x_key, $y_key); return if obviously($x_key, $y_key); my $x = kb_entry($kbref, $x_key); my $y = kb_entry($kbref, $y_key); flatten($x_key, $$kbref); flatten($y_key, $$kbref); if (exists $x->{all}->{$y_key} || exists $x->{some}->{$y_key}) { print "I know.\n"; return; } elsif (exists $x->{no}->{$y_key}) { print "Sorry, but this contradicts the fact that no $x_key are $y_key.\n"; return; } else { ++$x->{some}->{$y_key}; ++$y->{some}->{$x_key}; print "OK.\n"; } } # No X are Y => no Y are X. See "link_all". sub link_no { my ($x_key, $y_key, $kbref) = @_; ($x_key, $y_key) = disamb_are("No X are Y.", $x_key, $y_key); # If X is the same as Y, this is a contradiction. return if obviously($x_key, $y_key, "contradiction"); my $x = kb_entry($kbref, $x_key); my $y = kb_entry($kbref, $y_key); flatten($x_key, $$kbref); flatten($y_key, $$kbref); if (exists $x->{all}->{$y_key}) { print "Sorry, but this contradicts the fact that all $x_key are $y_key.\n"; return; } elsif (exists $x->{no}->{$y_key}) { print "I know.\n"; return; } elsif (exists $x->{some}->{$y_key}) { print "Sorry, but this contradicts the fact that some $x_key are $y_key.\n"; return; } else { ++$x->{no}->{$y_key}; ++$y->{no}->{$x_key}; print "OK.\n"; } } # Not all X are Y. See "link_all" sub link_not_all { my ($x_key, $y_key, $kbref) = @_; ($x_key, $y_key) = disamb_are("Not all X are Y.", $x_key, $y_key); return if obviously($x_key, $y_key, "contradiction"); my $x = kb_entry($kbref, $x_key); my $y = kb_entry($kbref, $y_key); flatten($x_key, $$kbref); flatten($y_key, $$kbref); if (exists $x->{all}->{$y_key}) { print "Sorry, but this contradicts the fact that all $x_key are $y_key.\n"; return; } elsif (exists $x->{no}->{$x_key} || exists $x->{not_all}->{$y_key}) { print "I know.\n"; return; } else { ++$x->{not_all}->{$y_key}; print "OK.\n"; } } # Get an entry from the knowledge base, creating it if it does not exist. sub kb_entry { my ($kbref, $key) = @_; $$kbref->{$key} = { all => {}, some => {}, no => {}, not_all => {} } if !exists $$kbref->{$key}; return $$kbref->{$key}; } # Reply to the question from the user (are all X Y? etc.) # Are all X Y? sub are_all { my ($x_key, $y_key, $kb) = @_; # Disambiguate the input. We may get nothing here as the user might ask # about concepts that we do not know about (this is handled by the # disambiguation step.) ($x_key, $y_key) = disamb_ws("Are all X Y?", $x_key, $y_key, $kb); return if !defined $x_key || !defined $y_key; # If X is Y, the the answer is obiously yes. return if obviously($x_key, $y_key); # We know that X and Y are in the knowledge base my $x = $kb->{$x_key}; my $y = $kb->{$y_key}; # Flatten the entries flatten($x_key, $kb); # At this point we know all there is to know of the relation between X and # Y simply by looking at the X entry. if (exists $x->{all}->{$y_key}) { print "Yes, all $x_key are $y_key.\n"; } elsif (exists $x->{some}->{$y_key}) { print "No, only some $x_key are $y_key.\n"; } elsif (exists $x->{no}->{$y_key}) { print "No, no $x_key are $y_key.\n"; } elsif (exists $x->{not_all}->{$y_key}) { print "No, not all $x_key are $y_key.\n"; } else { print "I don't know.\n"; } } # Are no X Y? See "are_all". sub are_no { my ($x_key, $y_key, $kb) = @_; ($x_key, $y_key) = disamb_ws("Are no X Y?", $x_key, $y_key, $kb); return if !defined $x_key || !defined $y_key; return if obviously($x_key, $y_key, "not"); my $x = $kb->{$x_key}; my $y = $kb->{$y_key}; flatten($x_key, $kb); flatten($y_key, $kb); if (exists $x->{all}->{$y_key}) { print "No, all $x_key are $y_key.\n"; } elsif (exists $x->{some}->{$y_key}) { print "No, some $x_key are $y_key.\n"; } elsif (exists $x->{no}->{$y_key}) { print "Yes, no $x_key are $y_key.\n"; } elsif (exists $x->{not_all}->{$y_key}) { print "No, some $x_key may be $y_key.\n"; } else { print "I don't know.\n"; } } # The last two are a little different because we have to disambiguate # between them first. # Are any X Y? This is true if some X are Y and if all X are Y. See "are_all". sub are_any { my ($x_key, $y_key, $kb) = @_; # The extra return value from disamb_not tells us whether the question was # "are any X Y?" ($not is false) or "are any X not Y?" ($not is true) ($x_key, $y_key, my $not) = disamb_not("Are any X Y?", $x_key, $y_key, $kb); return if !defined $x_key || !defined $y_key; return are_any_not($x_key, $y_key, $kb) if $not; return if obviously($x_key, $y_key); my $x = $kb->{$x_key}; my $y = $kb->{$y_key}; flatten($x_key, $kb); flatten($y_key, $kb); if (exists $x->{all}->{$y_key}) { print "Yes, all $x_key are $y_key.\n"; } elsif (exists $x->{some}->{$y_key}) { print "Yes, some $x_key are $y_key.\n"; } elsif (exists $x->{no}->{$y_key}) { print "No, no $x_key are $y_key.\n"; } else { print "I don't know.\n"; } } # Are any X not Y? This is true if not all X are Y or if no X are Y. # See "are_all" sub are_any_not { my ($x_key, $y_key, $kb) = @_; return if obviously($x_key, $y_key, "not"); my $x = $kb->{$x_key}; my $y = $kb->{$y_key}; flatten($x_key, $kb); flatten($y_key, $kb); if (exists $x->{all}->{$y_key}) { print "No, all $x_key are $y_key.\n"; } elsif (exists $x->{no}->{$y_key}) { print "Yes, no $x_key are $y_key.\n"; } elsif (exists $x->{not_all}->{$y_key}) { print "Yes, not all $x_key are $y_key.\n"; } else { print "I don't know.\n"; } } # Describe X. Flatten all the links for the given concept, then describe them. # Also flatten the concepts that have been encountered along the way as more # information may be gathered (for non-symmetric relations). Ignore the "some" # links if there exists one for "all" also; same with the "not all" links and # "no". sub describe { my ($key, $kb) = @_; if (!exists $kb->{$key}) { print "I don't know anything about $key.\n"; return; } my $k = $kb->{$key}; flatten($key, $kb); flatten($_, $kb) for map { keys %{$k->{$_}} } qw/all no some not_all/; print "All $key are $_.\n" for keys %{$k->{all}}; print "No $key are $_.\n" for keys %{$k->{no}}; print "Some $key are $_.\n" for grep { !exists $k->{all}->{$_} } keys %{$k->{some}}; print "Not all $key are $_.\n" for grep { !exists $k->{no}->{$_} } keys %{$k->{not_all}}; } # Flatten the relationships for a given key. Traverse the graph starting from # the concept given by the key, using the following inference rules: # * all X are Y and all Y are Z => all X are Z # * all X are Y and no Y are Z => no X are Z # * no X are Y and all Y are Z => not all X are Z # * no X are Y and some Y are Z => not all X are Z # * some X are Y and all Y are Z => some X are Z # * some X are Y and no Y are Z => not all X are Z sub flatten { my ($key, $kb) = @_; # As there may be cycles, mark the concepts that have already been seen. # Note that we need a mark for every kind of link my %seen = (); ++$seen{$key}->{$_} for qw/all no some not_all/; # Set up a queue for the graph traversal. Annotate each element in the queue # with the kind of link that is followed. my @queue = (); for my $kind (qw/all no some not_all/) { push @queue, map { [$_, $kind] } keys %{$kb->{$key}->{$kind}}; } while (@queue) { my ($k, $kind) = @{shift @queue}; next if $seen{$k}->{$kind}++; if ($kind eq "all") { # Make new links from the source concept to the concept reached here ++$kb->{$key}->{all}->{$k}; ++$kb->{$k}->{some}->{$key}; # all X are Y and all Y are Z => all X are Z push @queue, map { [$_, "all"] } keys %{$kb->{$k}->{all}}; # all X are Y and no Y are Z => no X are Z push @queue, map { [$_, "no"] } keys %{$kb->{$k}->{no}}; } elsif ($kind eq "no") { ++$kb->{$key}->{no}->{$k}; ++$kb->{$k}->{no}->{$key}; # no X are Y and all Y are Z => not all X are Z push @queue, map { [$_, "not_all"] } keys %{$kb->{$k}->{all}}; # no X are Y and some Y are Z => not all X are Z push @queue, map { [$_, "not_all"] } keys %{$kb->{$k}->{some}}; } elsif ($kind eq "some") { ++$kb->{$key}->{some}->{$k}; ++$kb->{$k}->{some}->{$key}; # some X are Y and all Y are Z => some X are Z push @queue, map { [$_, "some"] } keys %{$kb->{$k}->{all}}; # some X are Y and no Y are Z => not all X are Z push @queue, map { [$_, "not_all"] } keys %{$kb->{$k}->{no}}; } else { ++$kb->{$key}->{not_all}->{$k}; } } } # Compare two keys, if they are equal print a message and return true sub obviously { my ($x, $y, $contradiction) = @_; if ($x eq $y) { print $contradiction ? "This is a contradiction.\n" : "Obviously.\n"; return 1; } return 0; } # Input disambiguation # Disambiguate input from "all X are Y", "no X are Y"... Since we used greedy # matching, X may contain the word "are". If this is the case, generate all # combinations and ask the user which is the correct one. Otherwise, just # return the pair of keys. sub disamb_are { my ($choice_str, $x, $y) = @_; if ($x =~ / are /) { my @choices = (); push @choices, [$`, "$' are $y"] while $x =~ / are /g; push @choices, [$x, $y]; return disamb($choice_str, @choices); } return ($x, $y); } # Disambiguate input for "are X Y" and "are no X Y". Y may contain whitespace # in which case disambiguation is necessary. The disambiguation state only # selects pairs of concepts that are known in the knowledge base, therefore # it is possible that nothing at all is returned. sub disamb_ws { my ($choice_str, $x, $y, $kb) = @_; my @choices = ([$x, $y]); push @choices, ["$x $`", $'] while $y =~ / /g; return disamb_known_choices($kb, $choice_str, @choices); } # Disambiguate input for "are any X Y" and "are any X not Y". We need to # handle these two questions together as we may ask about concepts containing # the word "not". sub disamb_not { my ($choice_str, $x, $y, $kb) = @_; # We add a third element to the output list, which is false if the question # is simply "are any X Y?" and true if it is "are any X not Y?" my @choices = ([$x, $y, ""]); push @choices, ["$x $`", $', ""] while $y =~ / /g; # This can also be "are any X not Y?" if ($y =~ / ?not /) { my $xx = "$x $`"; my $yy = $'; $xx =~ s/ $//; push @choices, [$xx, $yy, "not "]; push @choices, ["$xx not $`", $', "not "] while $yy =~ / not /g; } return disamb_known_choices($kb, $choice_str, @choices); } # Disambiguate between choices where both terms are supposed to be known in # the knowledge base. sub disamb_known_choices { my ($kb, $choice_str, @choices) = @_; my (@known, %unknown) = (); for (@choices) { if (exists $kb->{$_->[0]}) { if (exists $kb->{$_->[1]}) { push @known, $_; } else { ++$unknown{$_->[1]}; } } elsif (exists $kb->{$_->[1]}) { ++$unknown{$_->[0]}; } } if (@known == 1) { return @{$known[0]}; } elsif (@known > 1) { return disamb($choice_str, @known); } else { my $unknown = join ", ", keys %unknown; if ($unknown) { $unknown =~ s/,( [^,]+)$/ or$1/; } else { $unknown = "any of that"; } print "I don't know anything about $unknown.\n"; return undef; } } # If there are several choices, ask the user. sub disamb { my ($choice_str, @choices) = @_; # Display all the possible choices print "Do you mean:\n"; for my $i (1 .. @choices) { local $_ = "[$i] $choice_str\n"; s/X/"$choices[$i-1]->[0]"/g; if (@{$choices[$i-1]} == 3 && $choices[$i-1]->[2]) { s/Y/$choices[$i-1]->[2]"$choices[$i-1]->[1]"/g; } else { s/Y/"$choices[$i-1]->[1]"/g; } print; } # Wait for a number that corresponds to one of these choices my $choice = undef; while (defined ($_ = $term->readline("Please choose 1-" . @choices . " > "))) { if (/\d+/ && $& > 0 && $& <= @choices) { $choice = $& - 1; last; } } # Augh! no more input :( if (!defined $choice) { print "\n"; exit; } return @{$choices[$choice]}; } # Help sub help { print <<HELP; The following statements are recognized (where A and B are plural things): * "All A are B." (Every A is also a B. Conversely, some Bs are also As.) * "No A are B." (No A is a B. This relation is symmetric.) * "Some A are B." (There is at least one A which is also a B. Symmetric.) * "Not all A are B." (There is at least one A which is not a B. That's it.) Note that in all the following statements, it is always implied that there is at least one A and one B. The following questions and request are recognized: * "Are all A B?" * "Are no A B?" * "Are any A B?" * "Are any A not B?" * "Describe A." Punctuation and case are not important. Letters, digits, underscore (_), hyphen (-) and whitespace are allowed in words (although further questions may be asked if the input is ambiguous.) To quit, just type "quit" or ^D. HELP }

Next Message by Date: click to view message preview

Re: Solutions and Discussion for Perl Quiz of the Week #18 (Expert Edition)

> Ah well, maybe I'll manage to finish the next one. It's not too late to finish this one. In fact, if you can finish in less than 19 years, you will have done it faster than I did.

Previous Message by Thread: click to view message preview

Re: Solutions and Discussion for Perl Quiz of the Week #18 (Expert Edition)

Hello, On Tue, 6 Jul 2004 22:44:09 -0700, Dan Sanderson <contact-J93YBX0Jt3Yo9BUDXlsv9g@xxxxxxxxxxxxxxxx> wrote: > Randy's partial implementation codifies a table of valid syllogistic > forms from Patrick J. Hurley's _A Concise Introduction to Logic_. There is also some quite nice information on the Wikipedia: http://en.wikipedia.org/wiki/Term_logic This helped me understand what Randy was doing - although not enough to enable me to complete his code. Cheers, Adrian

Next Message by Thread: click to view message preview

Re: Solutions and Discussion for Perl Quiz of the Week #18 (Expert Edition)

> Ah well, maybe I'll manage to finish the next one. It's not too late to finish this one. In fact, if you can finish in less than 19 years, you will have done it faster than I did.