File Coverage

blib/lib/Logic/Expr.pm

Criterion	Covered	Total	%
statement	73	73	100.0
branch	44	44	100.0
condition	9	9	100.0
subroutine	14	14	100.0
pod	7	7	100.0
total	147	147	100.0

# -*- 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__