lib/MGH_Biostat/TravEpi/SimpleRulesBase/Rules.pm


package MGH_Biostat::TravEpi::SimpleRulesBase::Rules;
use Modern::Perl;
use experimental 'switch';
use Carp;

use Set::Tiny qw(set);
use List::MoreUtils qw(all any);
use Module::Load;

use MGH_Biostat::TravEpi::SimpleRulesBase::DynamicText;

my $test_combiners = {
    'any' => \&any,
    'all' => \&all,
};

sub new {
    my $class = shift;
    my ($rules_module) = @_;

    load $rules_module;
    no strict 'refs';
    if ( defined( *{ $rules_module . '::' . 'get_rules' }{CODE} ) ) {
        my $self = ( $rules_module . '::' . 'get_rules' )->();
        _fix_rules($self);
        return bless $self, $class;
    }
    else {
        croak("package $rules_module does not define the 'get_rules' function");
    }
}

sub _fix_rules {
    my $rules = shift;

    foreach my $rule ( keys %$rules ) {
        if ( !defined( $rules->{'key'} ) ) {
            $rules->{$rule}{'key'} = $rule;
        }
        if ( !defined( $rules->{$rule}{'test-combiner'} ) ) {
            $rules->{$rule}{'test-combiner'} = 'any';
        }
        if ( defined( $rules->{'subrules'} ) ) {
            foreach my $subrule ( @{ $rules->{'subrules'} } ) {
                if ( !defined( $rules->{$subrule} ) ) {
                    die("Rule $subrule missing (referenced in $rule)\n");
                }
            }
        }
    }

}

sub get_rule_names {
    my $self = shift;
    return keys %{$self};
}

sub get_rule {
    my $self = shift;
    my ($name) = @_;
    no autovivification;
    if ( exists( $self->{$name} ) ) {
        return $self->{$name};
    }
    else {
        croak("undefined rule $name requested");
    }
}

# Rule handling

sub process_rule {
    my $self = shift;
    my ( $rulename, $params, $datatree ) = @_;

    # make sure the parameters are valid
    croak("incorrect number of parameters to process_rule") unless ( @_ == 3 );
    croak('no rule provided to process')           if ( !defined($rulename) or ( $rulename !~ m/\S/ ) );
    croak('params should be a hash')               if ( defined($params) and ( ref($params) ne 'HASH' ) );
    croak('no data tree provided for rule output') if ( ref($datatree) ne 'HASH' );

    # missing $params should just be treated as an empty hash
    $params //= {};

    # retrieve the rule
    my $rule = $self->get_rule($rulename);

    # run the various tests
    my $passed_tests = [];
    if ( defined( $rule->{'tests'} ) ) {
        $passed_tests = [ map { $self->_run_test( $_, $params ); } @{ $rule->{'tests'} } ];
    }
    else {
        # emulate a test that always passes
        $passed_tests = [ 1 ];
    }

    # @TODO this is ugly. can it be made better?
    my $combiner = $rule->{'test-combiner'} // 'any';

    # combine (if needed) the tests to get a final pass/fail,
    # gather any results from the tests into a subtree,
    # then recurse for child rules if needed.
    if ( $test_combiners->{$combiner}->( sub { $_ }, @$passed_tests ) ) {
        my $subtree = {};
        foreach my $imports ( grep { ref($_) eq 'HASH' } @$passed_tests ) {
            $subtree = { %$subtree, %$imports };
        }

        if ( defined( $rule->{'subrules'} ) ) {
            foreach my $subrule ( @{ $rule->{'subrules'} } ) {
                $self->process_rule( $subrule, $params, $subtree );
            }
        }

        $datatree->{ $rule->{'key'} } = $subtree;
    }
    else {
        # if no tests passed, we put an empty string in, because that's how Template::Simple works
        $datatree->{ $rule->{'key'} } = '';
    }

    # handle child precedence
    if ( $rule->{'child-precedence'} ) {
        my $subtree = $datatree->{ $rule->{'key'} };
        my $found   = 0;
        foreach my $c ( @{ $rule->{'child-precedence'} } ) {
            if ( !$found and exists( $subtree->{$c} ) and ( ref( $subtree->{$c} ) eq 'HASH' ) ) {
                $found = 1;
            }
            elsif ( $found and exists( $subtree->{$c} ) ) {
                $subtree->{$c} = '';
            }
        }
    }

    # remove the rule if we are supposed to
    if ( $rule->{'remove-if'} ) {
        my $subtree = $datatree->{ $rule->{'key'} };
        if ( ref($subtree) eq 'HASH' ) {
            if ( $rule->{'remove-if'}{'no-children'} ) {
                my $children = grep { ref( $subtree->{$_} ) eq 'HASH' } keys %$subtree;
                if ( !$children ) {
                    $datatree->{ $rule->{'key'} } = '';
                }
            }
            if ( $rule->{'remove-if'}{'missing-children'} ) {
                my $children = grep { ref( $subtree->{$_} ) eq 'HASH' } @{ $rule->{'remove-if'}{'missing-children'} };
                if ( !$children ) {
                    $datatree->{ $rule->{'key'} } = '';
                }
            }
        }
    }
}

sub _run_test {
    my $self = shift;
    my ( $test, $params ) = @_;

    # this needs to be here so that we don't falsely fail due to a missing "variable" key
    given ( $test->{'test'} ) {
        when ('true')  { return 1; }
        when ('false') { return 0; }
    }

    my $variable_value = $params->{ $test->{'variable'} };

    if ( !defined($variable_value) ) {
        return 0;
    }

    given ( $test->{'test'} ) {
        when ('>=') {
            return $variable_value >= $test->{'with'};
        }
        when ('<=') {
            return $variable_value <= $test->{'with'};
        }
        when ('>') {
            return $variable_value > $test->{'with'};
        }
        when ('<') {
            return $variable_value < $test->{'with'};
        }
        when ('=') {
            return $variable_value == $test->{'with'};
        }
        when ('eq') {
            return $variable_value eq $test->{'with'};
        }
        when ('intersects') {
            ## double !! is effectively a coercion to boolean
            my $intersection = $variable_value->intersection( $test->{'values'} );
            my $passed       = !!( $intersection->size() );

            if ( $passed and exists( $test->{'intersect-values-to'} ) ) {
                my $def     = $test->{'intersect-values-to'};
                my $type    = $def->{'type'} || $variable_value;
                my $context = $def->{'context'} || {};
                return { $def->{'token'} => newdt( $type, $intersection, $context ) };
            }
            else {
                return $passed;
            }
        }
        when ('excludes') {
            ## an excludes test checks if the person is going to any country
            ## not on the list provided; that is, it removes the provided list
            ## of countries from the destinations, and then checks to see if
            ## there are any remaining countries. If there are, the test "passes",
            ## and the remaining countries are considered to be the "intersect values".
            ## (nb, maybe the list is not of countries, but the same idea applies.)
            my $difference = $variable_value->difference( $test->{'values'} );
            my $passed     = !!( $difference->size() );

            if ( $passed and exists( $test->{'intersect-values-to'} ) ) {
                my $def     = $test->{'intersect-values-to'};
                my $type    = $def->{'type'} || $variable_value;
                my $context = $def->{'context'} || {};
                return { $def->{'token'} => newdt( $type, $difference, $context ) };
            }
            else {
                return $passed;
            }
        }
        when ('disjoints') {
            ## this is only true if the test set is completely disjoint from the
            ## parameter set.
            return $variable_value->is_disjoint( $test->{'values'} );
        }
        default {
            # @TODO should this throw an error?
            return 0;
        }
    }
}

# process the rules, generating a description instead of running tests
# note that this returns a tree with HTML embedded!
sub describe_rule {
    no autovivification;
    my $self = shift;
    my ( $rulename, $hidedesc ) = @_;

    my $rule = $self->get_rule($rulename);
    my $tree = { '_rule' => '' };

    $tree->{'_rule'} .= '<div class="rule-explanation" id="rule-' . $rulename . '">';

    $tree->{'_rule'} .= '<p class="rule-name">' . $rulename . '</p>';

    if ( defined( $rule->{'tests'} ) ) {

        $tree->{'_rule'} .= '<p class="tests-title">Tests (' . $rule->{'test-combiner'} . '):</p><ol class="tests">';
        foreach my $test ( @{ $rule->{'tests'} } ) {
            $tree->{'_rule'} .= '<li>' . $self->_describe_test($test) . '</li>';
            if ( defined( $test->{'intersect-values-to'} ) ) {
                $tree->{ $test->{'intersect-values-to'}{'token'} } = '[intersecting or disjoint elements]';
            }
        }
        $tree->{'_rule'} .= '</ol>';
    }

    if ( defined( $rule->{'child-precedence'} ) ) {
        $tree->{'_rule'} .= '<p class="child-precedence">Only the first of these rules to be true will be displayed: '
          . '<span class="subrule-list">' . join( ", " => @{ $rule->{'child-precedence'} } ) . '</span>'
          . '</p>';
    }

    if ( defined( $rule->{'remove-if'} ) ) {
        $tree->{'_rule'} .= '<p class="remove-if">'
          . 'This rule will be removed if'
          . ( defined( $rule->{'remove-if'}{'no-children'} )      ? ' no subrules pass'                                                                                                                             : '' )
          . ( defined( $rule->{'remove-if'}{'missing-children'} ) ? ' none of the following subrules are present: ' . join( ", " => map { '<kbd>' . $_ . '</kbd>' } @{ $rule->{'remove-if'}{'missing-children'} } ) : '' )
          . '</p>';
    }

    $tree->{'_rule'} .= '</div>';

    if ($hidedesc) {
        $tree->{'_rule'} = '';
    }

    if ( defined( $rule->{'subrules'} ) ) {
        foreach my $subrule ( @{ $rule->{'subrules'} } ) {
            $tree->{$subrule} = $self->describe_rule( $subrule, $hidedesc );
        }
    }

    return $tree;
}

sub _describe_test {
    my $self = shift;
    my ($test) = @_;

    given ( $test->{'test'} ) {
        when ('true') {
            return "This test is always true";
        }
        when ('false') {
            return "This test is always false";
        }
        when ('>=') {
            return "<span class=\"variable\">$test->{'variable'}</span> <span class=\"test\">&ge;</span> <span class=\"value\">$test->{'with'}</span>";
        }
        when ('<=') {
            return "<span class=\"variable\">$test->{'variable'}</span> <span class=\"test\">&le;</span> <span class=\"value\">$test->{'with'}</span>";
        }
        when ('>') {
            return "<span class=\"variable\">$test->{'variable'}</span> <span class=\"test\">&gt;</span> <span class=\"value\">$test->{'with'}</span>";
        }
        when ('<') {
            return "<span class=\"variable\">$test->{'variable'}</span> <span class=\"test\">&lt;</span> <span class=\"value\">$test->{'with'}</span>";
        }
        when ('=') {
            return "<span class=\"variable\">$test->{'variable'}</span> <span class=\"test\">=</span> <span class=\"value\">$test->{'with'}</span>";
        }
        when ('eq') {
            return "<span class=\"variable\">$test->{'variable'}</span> <span class=\"test\">matches as a string with</span> <span class=\"value\">$test->{'with'}</span>";
        }
        when ('intersects') {
            return "<span class=\"variable\">$test->{'variable'}</span> <span class=\"test intersect\">intersects the set</span> <span class=\"value set intersection\">" . join( ", " => sort $test->{'values'}->elements() ) . '</span>';
        }
        when ('excludes') {
            return "<span class=\"variable\">$test->{'variable'}</span> <span class=\"test exclude\">has elements not in the set</span> <span class=\"value set exclusion\">" . join( ", " => sort $test->{'values'}->elements() ) . '</span>';
        }
        when ('disjoints') {
            return "<span class=\"variable\">$test->{'variable'}</span> <span class=\"test disjoint\">is disjoint from the set</span> <span class=\"value set disjunction\">" . join( ", " => sort $test->{'values'}->elements() ) . '</span>';
        }
        default {
            return "There is no test here; move along (something weird is going on).";
        }
    }
}

1;