# -*- Perl -*-
#
# logic expression related routines. see Logic::Expr::Parser for how the
# expressions are built

package Logic::Expr;
our $VERSION = '0.02';
use Scalar::Util 'refaddr';
use parent qw(Exporter);

# 'atoms' contains a name to a scalar reference in 'bools'; 'bools' is
# an array of unique atoms in an expression (for easy iteration by the
# "solutions" method); 'expr' is the parse tree of the expression as
# probably generated by Logic::Expr::Parser. 'bools' must be modified
# in-place to not break the scalar references from the other two
# structures. for example, given X&Y,
#  * atoms - { X => \$bools[0], Y => \$bools[1] }
#  * bools - [ 1, 1 ]
#  * expr  - [ LE_AND, ... ]
our ( @EXPORT_OK, %EXPORT_TAGS, %atoms, @bools );

BEGIN {
    my @all = qw(TRUE FALSE LE_NOT LE_AND LE_OR LE_COND LE_BICOND);
    @EXPORT_OK   = @all;
    %EXPORT_TAGS = ( all => \@all );
}

sub TRUE ()  { 1 }
sub FALSE () { 0 }
# -1 is reserved for testing (FAKE_OP); 0 or 1 for ops would conflate
# with the prior should a truth value be assigned to an op slot
sub LE_NOT ()    { 2 }    # ! ~
sub LE_AND ()    { 3 }    # &
sub LE_OR ()     { 4 }    # | v
sub LE_COND ()   { 5 }    # ->
sub LE_BICOND () { 6 }    # ==

sub expr { $_[0]->{expr} }

# generate a function that with suitable arguments evaluates the expr
sub codex
{
    my ($self) = @_;
    my %atom2symbol = map { refaddr($atoms{$_}) => $_ } keys %atoms;
    my $code = $self->walk(
        sub {
            my ( $op, $arg ) = @_;
            if ( $op == LE_NOT ) {
                return "!$arg->[0]";
            } elsif ( $op == LE_AND ) {
                return "($arg->[0] and $arg->[1])";
            } elsif ( $op == LE_OR ) {
                return "($arg->[0] or $arg->[1])";
            } elsif ( $op == LE_COND ) {
                return "(!$arg->[0] or $arg->[1])";
            } elsif ( $op == LE_BICOND ) {
                return "!($arg->[0] xor $arg->[1])";
            } else {
                die "unknown op $op";
            }
        },
        sub { q($p{) . $atom2symbol{ refaddr($_[0]) } . q(}) },
    );
    eval "sub { my \%p = \@_; $code ? TRUE : FALSE }";
}

sub new
{
    my ( $class, %param ) = @_;
    my $self = { expr => $param{expr} };
    bless $self, $class;
    return $self;
}

sub reset { %atoms = @bools = (); }

# brute force all possible boolean states for an expression
sub solutions
{
    my ($self, $noprefix) = @_;
    my (@orig, $ret, @solutions);
    for my $x (@bools) {
        push @orig, $x;
        $x = TRUE;
    }
    $ret = _solve( $self->{expr} ) ? TRUE : FALSE;
    push @solutions, $noprefix ? $ret : [ [@bools], $ret ];
    # the reverse index ordering is to match that of the logic book,
    # backwards binary counting
    my $i = $#bools;
    while ( $i >= 0 ) {
        if ( $bools[$i] ) {
            $bools[$i] = FALSE;
            $ret = _solve( $self->{expr} ) ? TRUE : FALSE;
            push @solutions, $noprefix ? $ret : [ [@bools], $ret ];
            $i = $#bools;
        } else {
            $bools[ $i-- ] = TRUE;
        }
    }
    for my $x (@bools) { $x = shift @orig }
    return \@solutions;
}

# solve the expression using the current state in bools
sub solve { _solve( $_[0]->{expr} ) ? TRUE : FALSE }

sub _solve
{
    my ($ptr) = @_;
    my $rt = ref $ptr;
    return $$ptr if $rt eq 'SCALAR';    # lookup from bools
    if ( $rt eq 'ARRAY' ) {
        if ( $ptr->[0] == LE_NOT ) {
            return !_solve( $ptr->[1] );
        } elsif ( $ptr->[0] == LE_AND ) {
            return _solve( $ptr->[1] ) && _solve( $ptr->[2] );
        } elsif ( $ptr->[0] == LE_OR ) {
            return _solve( $ptr->[1] ) || _solve( $ptr->[2] );
        } elsif ( $ptr->[0] == LE_COND ) {
            return !_solve( $ptr->[1] ) || _solve( $ptr->[2] );
        } elsif ( $ptr->[0] == LE_BICOND ) {
            return !( _solve( $ptr->[1] ) ^ _solve( $ptr->[2] ) );
        }
        die "unknown op $ptr->[0]";
    }
    die "unexpected reference type '$rt'";
}

sub walk
{
    my ( $self, $opfn, $atomfn ) = @_;
    _walk( $self->{expr}, $opfn, $atomfn );
}

sub _walk
{
    my ( $ptr, $opfn, $atomfn ) = @_;
    my $rt = ref $ptr;
    if ( $rt eq 'SCALAR' ) {
        return $atomfn->($ptr);
    } elsif ( $rt eq 'ARRAY' ) {
        return $opfn->(
            $ptr->[0],
            [   map {
                    my $type = ref $ptr->[$_];
                    if ( $type eq 'SCALAR' ) {
                        $atomfn->( $ptr->[$_] );
                    } elsif ( $type eq 'ARRAY' ) {
                        _walk( $ptr->[$_], $opfn, $atomfn );
                    } else {
                        ()    # unary negation, probably
                    }
                } 1 .. 2
            ]
        );
    } else {
        die "unexpected reference type '$rt'";
    }
}

1;
__END__

=head1 NAME

Logic::Expr - logical expression parsing and related routines

=head1 SYNOPSIS

  use Logic::Expr::Parser;
  my $expr = Logic::Expr::Parser->new->from_string('Xv~Y');

  use Data::Dumper; 
  print Dumper $expr->solutions;

  $Logic::Expr::bools[1] = 0;    # fiddle with Y
  print $expr->solve;
  # (hopefully it is Y, better to find it through atoms)

  # build, invoke a solver function
  my $fn = $expr->codex;
     $fn->( X => 0, Y => 0 );

  # complicated, see the code
  $expr->walk( sub { ... }, sub { ... } );

  # clean out the atoms and booleans
  Logic::Expr::reset;

=head1 DESCRIPTION

L<Logic::Expr::Parser> parses logic expressions of a particular syntax
and returns a C<Logic::Expr> object. This module in turn has various
methods for solving all possible solutions, etc.

=head2 But What Is It Good For?

Good question! Let's say you walk into a bar on Vulcan, live on planet
Earth, and cannot be on Vulcan and Earth. (I know, bear with me here,
it's just an example.) So,

  V      walk into a bar on Vulcan
  E      live on planet Earth
  !(V&E) cannot be something-about Vulcan and living on Earth

This module can help solve logical problems such as the one presented,
and also the harder ones that involve a Rabbi, etc. There's a link to a
book, too, somewhere down below from here (or up, if you're on one of
them newfangled devices that scroll in the wrong direction).

C<eg/solver> may also be of interest under this module's distribution.

=head1 METHODS

Since module version 0.02 the B<atoms> and B<bools> methods have been
removed; instead use B<%atoms> or B<@bools> in the module if need be.

=over 4

=item B<codex>

Returns a function reference built with B<walk> (and a string
C<eval>!) that when called with suitable parameters calculates the
logic of the B<expr>.

  my $e  = Logic::Expr::Parser->new->from_string('Xv~Y');
  my $fn = $e->codex;
     $fn->( X => 0, Y => 0 );

=item B<expr>

Returns parse tree, which could be a scalar reference, something more
complicated involving array references and more, or C<undef> if the
object was not setup right.

=item B<new>

Constructor. Probably should supply the I<expr> parameter, as shown in
the code for L<Logic::Expr::Parser>.

=item B<solutions> I<noprefix>

Solves all possible B<@bools> states returning an array reference of the
results. The optional I<noprefix> argument, if true, prevents each
solution from having the state of B<@bools> prefixed to each result.

The prior state of B<@bools> is restored after this call.

=item B<solve>

Solves the B<expr> using the current state of B<@bools>. B<@bools> atoms
are all set to true by default though could be changed manually.

=item B<walk> I<opfn> I<atomfn>

Walks through the B<expr>, calling the I<atomfn> for each atom and
I<opfn> for each operator found. B<codex> uses this to generate a string
to C<eval> into a subroutine reference.

=back

=head1 FUNCTIONS

Most of these are available for export, mostly to the parser module,
probably via the C<:all> tag.

=over 4

=item B<TRUE>

=item B<FALSE>

=item B<LE_NOT>

=item B<LE_AND>

=item B<LE_OR>

=item B<LE_COND>

=item B<LE_BICOND>

Exportable constant functions, the lot of them.

=item B<reset>

Clears out the atoms and bools structures. These are as of module
version 0.02 class-based so that a set of logic expressions (e.g.
C<~(A&B)>, C<~A>, and C<~B>) can all share the same memory addresses for
C<A> and C<B> without having to rewire each expression. The downside is
that B<Logic::Expr::reset> will likely need to be called prior to
parsing a new, unrelated set of expressions.

=back

=head1 BUGS

None known.

=head1 SEE ALSO

There are various other logic modules on CPAN. In particular
L<Math::Logic::Predicate> appears to contain section 2 material while
this module only has section 1 material from

"A Modern Formal Logic Primer". Paul Teller. 1989.

https://tellerprimer.ucdavis.edu/

=head1 COPYRIGHT AND LICENSE

Copyright 2022 Jeremy Mates

This program is distributed under the (Revised) BSD License:
L<https://opensource.org/licenses/BSD-3-Clause>

=cut
