File Coverage

blib/lib/Logic/Expr.pm

Criterion	Covered	Total	%
statement	43	43	100.0
branch	22	22	100.0
condition	9	9	100.0
subroutine	9	9	100.0
pod	6	6	100.0
total	89	89	100.0

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

package Logic::Expr;
our $VERSION = '0.01';
use parent qw(Exporter);

our ( @EXPORT_OK, %EXPORT_TAGS );

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

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 }    # ==

# '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, ... ]

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

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

# brute force all possible boolean states for an expression
sub solutions
{
    my ($self) = @_;
    my @orig;
    my $bools = $self->{bools};
    for my $x (@$bools) {
        push @orig, $x;
        $x = TRUE;
    }
    my @solutions = [ [@$bools], _solve( $self->{expr} ) ? TRUE : FALSE ];
    # 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;
            push @solutions, [ [ $bools->@* ], _solve( $self->{expr} ) ? TRUE : FALSE ];
            $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'";
}

1;
__END__