#!/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.
# Julien Quint (Pom) <pom@graougraou.com> 5 July 2004

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 entry for X by following all the links
  flatten($x_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);
  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);
  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);
  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->{some}->{$y_key};
    ++$y->{some}->{$x_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 entry for X.
  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);
  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);
  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);
  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.
# 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);
  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
#   * 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};
    } 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
}
