#!/usr/bin/perl
# Hypotheses have the form
#   % A $ B
#   % B $ C
#   % A $ C
#
# Where  % = "all/some/no" and $ = "are/are not".
#
# There are only 27*8 of these.
#
# Then we construct one example at a time, discarding all the 
# rejectable hypotheses.
#
#
use strict 'vars';
my %q_ok = (all => 1, some => 1, no => 1);
my %e_ok = (are => 0, "are not" => 1);

my @pairs = ([['A','B'], ['B','C'], ['A','C']],
             [['A','B'], ['B','C'], ['C','A']],
             [['A','B'], ['A','C'], ['B','C']],
             [['A','B'], ['C','B'], ['A','C']],
             );

my @H;                          # Hypotheses
{ my $h_it = cart_prod(\@pairs,
                       [keys %q_ok], [keys %e_ok],
                       [keys %q_ok], [keys %e_ok],
                       [keys %q_ok], [keys %e_ok],
                      );
  while (my ($p, @h) = $h_it->()) {
    my $H = Hypothesis->new($p, @h) ;
    push @H, $H if $H->is_interesting;
  }
}

{ my @colors = qw(red yellow green blue);
  my @sets = pow_set(@colors);
  my $m_id = cart_prod(\@sets, \@sets, \@sets);
 MODEL:
  while (my @model = $m_id->()) {

    { my %colors;
      for (@model) {
        $colors{$_} = 1 for @$_;
      }
      for my $c (@colors) {
        last unless $colors{$c};
        delete $colors{$c};
      }
      next MODEL if %colors;
    }

    my @true;
    my $m = {A => $model[0], B => $model[1], C => $model[2] };
    my $elim;
    for my $h (@H) {
      1;
      if ($h->is_true_for($m)) {
        push @true, $h;
      } else {
        print $h->to_str(), " is falsified by:\n";
        local $" = ', ';
        print "  A = {@{$m->{A}}}, B = {@{$m->{B}}}, C = {@{$m->{C}}}\n";
        $elim++;
      }
    }
    print "** ", scalar(@true), " hypotheses remain.\n" if $elim;
    @H = @true;
  }
}

print "\n\nVALID RULES OF INFERENCE:\n\n";
for my $h (@H) {
  print $h->to_str(), "\n";
}

sub pow_set {
  my @a = @_;
  return [] unless @a;
  my $f = shift @a;
  my @p = pow_set(@a);
  my @r = map {$_, [$f, @$_]} @p;
}

sub cart_prod {
  my (@S) = @_;
  my $choice = [(0) x @S];
  my $DONE;
  return sub {
    return if $DONE;
    my @result;
    my $do_inc = 1;
    for my $n (0 .. $#$choice) {
      for ($choice->[$n]) {
        push @result, $S[$n][$_];
        $_++ if $do_inc;
        if ($_ == @{$S[$n]}) {
          $_ = 0;
        }  else {
          $do_inc = 0;
        }
      }
    }
    $DONE = $do_inc;
    return @result;
  };
}


package Hypothesis;

sub new {
  my ($class, $keys, @terms) = @_;
  @terms == 6 
    and grep(exists $q_ok{$_}, @terms[0,2,4]) == 3 
    and grep(exists $e_ok{$_}, @terms[1,3,5]) == 3 
      or die;
  @$keys == 3 or die;
  bless [$keys, @terms] => $class;
}

sub to_str {
  my $self = shift;
  my $k = $self->[0];
  "\u$self->[1] $k->[0][0] $self->[2] $k->[0][1]; $self->[3] $k->[1][0] $self->[4] $k->[1][1] => $self->[5] $k->[2][0] $self->[6] $k->[2][1]"
}

# Hypothetical deductions involving "All x is not y"
# or "No x is not y" are uninteresting because they are equivalent
# respectively to "No x is y" and "All x is y".
sub is_interesting {
  my $self = shift;
  for (1, 3, 5) {
    next unless $self->[$_+1] eq 'are not';
    return if $self->[$_] eq 'all' || $self->[$_] eq 'no';
  }
  return 1;
}

sub is_true_for {
  my ($self, $model) = @_;
  my @keys = @{$self->[0]};
  for (0..2) {
    my $t = clause_is_true_for($self->[$_*2+1], $keys[$_][0],
                               $self->[$_*2+2], $keys[$_][1],
                               $model);
    return $t if $_ == 2;
    return 1 unless $t;
  }
}

sub clause_is_true_for {
  my ($q, $s1, $e, $s2, $model) = @_;
  eval_clause($q, $model->{$s1}, $e, $model->{$s2});
}


sub eval_clause {
  my ($q, $s1, $e, $s2) = @_;
  
  use strict 'police'->can('kiss'), my @ass;
  $q->($s1, $e_ok{$e}, $s2);
}

sub all {
  my ($s1, $neg, $s2) = @_;
  for (@$s1) {
    return unless $neg ^ is_in($_, $s2);
  }
  return 1;
}

sub some {
  my ($s1, $neg, $s2) = @_;
  for (@$s1) {
    return 1 if $neg ^ is_in($_, $s2);
  }
  return;
}

sub no {
  my ($s1, $neg, $s2) = @_;
  all($s1, !$neg, $s2);
}

sub is_in {
  my ($e, $s) = @_;
  for (@$s) {
    return 1 if $e eq $_;
  }
  return;
}
