view release on metacpan or  search on metacpan

t/01_backtrack.t  view on Meta::CPAN

use strict;
use Test::More 0.98;
use Data::Dumper;

use Algorithm::SAT::Backtracking;

my $agent = Algorithm::SAT::Backtracking->new;

#Testing resolve

subtest "resolve()" => sub {
    my $t_model = { blue => 1, red => 0 };
    is( $agent->resolve( "blue", $t_model ),
        1, "'blue' in the test model should be true" );
    is( $agent->resolve( "-red", $t_model ),
        1, "'-red' in the test model should be true" );
    is( $agent->resolve( "-blue", $t_model ),
        0, "'-blue' in the test model should be false" );
    is( $agent->resolve( "-yellow", $t_model ),
        undef, "'-yellow' in the test model should be undef" );

};

#Testing Satisfiable
subtest "satisfiable()" => sub {
    my $t2_model
        = { pink => 1, purple => 0, green => 0, yellow => 1, red => 0 };
    is( $agent->satisfiable( [ 'purple', '-pink' ], $t2_model ),
        0, "Clause 'purple -pink' unsatisfiable" );
    is( $agent->satisfiable( [ 'orange', '-blue' ], $t2_model ),
        undef, "Clause 'orange -blue' satisfiable = 'undef'" );
    is( $agent->satisfiable( [ 'yellow', '-blue' ], $t2_model ),
        1, "Clause 'yellow -blue' satisfiable = 'true' " );
    is( $agent->satisfiable( [ 'pink', 'orange', '-blue' ], $t2_model ),
        1, "Clause 'pink orange -blue' = '1" );
    is( $agent->satisfiable(
            [ 'chair', 'table', 'coffee', 'satan' ], $t2_model
        ),
        undef,
        "Clause 'chair table coffee satan' satisfiable = 'undef"
    );
};

# Testing Update

subtest "update()" => sub {
    my $t_model
        = { pink => 1, red => 0, purple => 0, green => 0, yellow => 1 };
    my $new_model = $agent->update( $t_model, 'foobar', 1 );
    is( $t_model->{foobar}, undef, "old model doesn't have 'foobar'" );
    $new_model->{test} = 0;
    is( $t_model->{test}, undef, "old model it's not affected by new one" );
    is( $new_model->{foobar}, 1, "new model was updated" );
};

# Testing solve
subtest "solve()" => sub {
    my $variables = [ 'blue', 'green', 'yellow', 'pink', 'purple' ];
    my $clauses = [
        [ 'blue',  'green',  '-yellow' ],
        [ '-blue', '-green', 'yellow' ],
        [ 'pink', 'purple', 'green', 'blue', '-yellow' ]
    ];