#!/usr/bin/perl
##########################################
# Playing around with parsing 
# and evaluating propositional infix logic.
# Mar 7, 2003 - Jim Mahoney
##############################################
use warnings;
use strict;
use Parse::RecDescent;
$::RD_HINT=1;
our $DEBUG=0;

# - - - define some short logic routines - - - - -

sub true  { return 1 }
sub false { return 0 }
sub Not   { return not $_[0] }		# Usage: Not(true)
sub And   { return $_[0] and $_[1] }    # Usage: And(true,false)
sub Or    { return $_[0] or $_[1] }     # Usage: Or(true,true)

# - - - define the grammer for Parse::RecDescent - - - - - 
# see for example http://search.cpan.org/dist/Parse-RecDescent/

my $grammar = <<'EOG';
  sentence   : atomic | complex
  atomic     : 'true' | 'false' | symbol
  symbol     : /[A-Z]/
  complex    : logicalNot | logicalAnd | logicalOr
  logicalNot : '~' sentence	             {$return="not($item[2])"}
  logicalAnd : '(' sentence '&' sentence ')' {$return="and($item[2],$item[4])"}
  logicalOr  : '(' sentence '|' sentence ')' {$return="or($item[2],$item[4])"}
EOG

# - - - apply the grammer to a specific sentence in "infix" form.
#    infix:    ( A | ( B & C ) ) 
#    prefix:   or(A,and(B,C))
# Notes:
#   *  parens are required in infix style notation
#   * "prefix" here is function-call format, not lisp-like lists.

# Exercise for the reader:
#   Put precedence rules into grammar instead of required parens.
#   Can you do that without getting "left recursion" errors?

my $infix  = " ( Q | ( R & ~ S ) ) ";
my $parser = new Parse::RecDescent($grammar);
my $prefix = $parser->sentence($infix);
my %model  = ( Q => true,  R => false, S => true, );
my $answer = evalModel( $prefix, \%model );

print "infix is '$infix'\n";
print "prefix is '$prefix'\n";
print "model is ";
print "$_ => ".$model{$_}." " for keys %model;
print "\n";
print "evalModel gives " . ( $answer ? "true" : "false" ) . "\n";

# -- didn't finish this.
# print "Here's the full truth table:\n";
# truthTable($prefixString, qw( Q R S ) );

# - - To do: add some more strings, such as tautologies


# - - - subroutines - - - - - - - - - - - - - - -

# Apply a specific world model to a logic sentence.
# Usage: $answer = evalModel($prefixString, $model)
sub evalModel {
  my ($prefixString, $model) = @_;
  my %M = %$model;
  for ($prefixString) {
    s/([A-Z])/\$M{$1}/g;
    s/or/Or/g;
    s/not/Not/g;
    s/and/And/g;
  }
  print "after hash sub, prefix is now '$prefixString'\n" if $DEBUG;
  return eval($prefixString);
}

# Generate the full truth table for a given logic sentence.
# Usage: truthTable($prefixString, @symbols);
sub truthTable {
   # didn't finish this.  Loop over all binary 1,0 assignments for elements
   # of @symbol, printing out a line for each.				      
}


