File Coverage

blib/lib/Algorithm/SAT/Expression.pm

Criterion	Covered	Total	%
statement	48	49	97.9
branch	4	6	66.6
condition			n/a
subroutine	12	12	100.0
pod	5	7	71.4
total	69	74	93.2

package Algorithm::SAT::Expression;
use 5.008001;
use strict;
use warnings;
require Algorithm::SAT::Backtracking;
use Carp qw(croak);
our $VERSION = "0.13";

# Boolean expression builder.  Note that the connector for clauses is `OR`;
# so, when calling the instance methods `xor`, `and`, and `or`, the clauses
# you're generating are `AND`ed with the existing clauses in the expression.
sub new {
    return bless {
        _literals       => {},
        _expr           => [],
        _implementation => "Algorithm::SAT::Backtracking"
        },
        shift;
}

sub with {
    my $self = shift;
    if ( eval "require $_[0];1;" ) {
        $self->{_implementation} = shift;
        $self->{_implementation}->import();
    }
    else {
        croak "The '$_[0]' could not be loaded";
    }
    return $self;
}

# ### or
# Add a clause consisting of the provided literals or'ed together.
sub or {
    my $self = shift;
    $self->_ensure(@_);
    push( @{ $self->{_expr} }, [@_] );
    return $self;
}

# ### xor
# Add clauses causing each of the provided arguments to be xored.2
sub xor {

    # This first clause is the 'or' portion. "One of them must be true."
    my $self     = shift;
    my @literals = @_;
    push( @{ $self->{_expr} }, \@_ );
    $self->_ensure(@literals);

    # Then, we generate clauses such that "only one of them is true".
    for ( my $i = 0; $i <= $#literals; $i++ ) {
        for ( my $j = $i + 1; $j <= $#literals; $j++ ) {
            push(
                @{ $self->{_expr} },
                [   $self->negate_literal( $literals[$i] ),
                    $self->negate_literal( $literals[$j] )
                ]
            );
        }
    }
    return $self;
}

# ### and
# Add each of the provided literals into their own clause in the expression.
sub and {
    my $self = shift;
    $self->_ensure(@_);
    push( @{ $self->{_expr} }, [$_] ) for @_;
    return $self;
}

# ### solve
# Solve this expression with the backtrack solver. Lazy-loads the solver.
sub solve {
    return $_[0]->{_implementation}
        ->new->solve( $_[0]->{_variables}, $_[0]->{_expr} );
}

# ### _ensure
# Private method that ensures that a particular literal is marked as being in
# the expression.
sub _ensure {
    my $self = shift;
    do {
        $self->{_literals}->{$_} = 1;
        push( @{ $self->{_variables} }, $_ );
        }
        for grep { !$self->{_literals}->{$_} }
        map { substr( $_, 0, 1 ) eq "-" ? substr( $_, 1 ) : $_ } @_;
}

sub negate_literal {
    my ( undef, $var ) = @_;

    return ( substr( $var, 0, 1 ) eq "-" )
        ? substr( $var, 1 )
        : '-' . $var;
}

1;
__END__