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\">≥</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 ('>') {
return "<span class=\"variable\">$test->{'variable'}</span> <span class=\"test\">></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 ('=') {
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;