./TravEpi/SimpleRulesBase/Rules.pm


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

use JSON;
use File::Slurp qw(slurp read_dir);
use Try::Tiny;
use Set::Tiny qw(set);
use List::MoreUtils qw(all any);

use MGH_Biostat::TravEpi::SimpleRulesBase::DynamicText;
use Package::Alias 'M_B::Countries' => 'MGH_Biostat::TravEpi::SimpleRulesBase::Countries';

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

sub new {
    my $class = shift;
    my $self  = {};

    my $valid_test_combiners = set( 'any', 'all' );

    foreach my $f ( read_dir("rules") ) {
        next unless $f =~ m/(.+)\.rule/;
        my $rule_name = $1;
        try {
            $self->{$rule_name} = _convert_into_sets( decode_json( scalar( slurp("rules/$f") ) ) );
            $self->{$rule_name}{'key'} = $rule_name;
        }
        catch {
            # if it is a non-empty file, warn about the file being non-valid JSON
            if ( -s "rules/$f" ) {
                if ( $_ =~ m/malformed JSON string/ ) {
                    warn("$rule_name: could not parse file: $_");
                }
                else {
                    die "$f: " . $_;
                }
            }
        };

        if ( defined( $self->{$rule_name}{'test-combiner'} ) ) {
            if ( !$valid_test_combiners->element( $self->{$rule_name}{'test-combiner'} ) ) {
                die("$rule_name: test combiner '$self->{$rule_name}{'test-combiner'}' invalid\n");
            }
        }
        else {
            $self->{$rule_name}{'test-combiner'} = 'any';
        }
    }

    # verify that all rules are valid
    no autovivification;
    my @missing_rule_errors = ();
    foreach my $rule_name ( keys %$self ) {
        my $rule = $self->{$rule_name};
        if ( exists( $rule->{'subrules'} ) ) {
            foreach my $subrule_name ( @{ $rule->{'subrules'} } ) {
                if ( !exists( $self->{$subrule_name} ) ) {
                    push @missing_rule_errors, "Error in $rule_name: subrule $subrule_name doesn't exist";
                }
            }
        }
    }
    if (@missing_rule_errors) {
        die( "Errors:\n" . join( "\n" => @missing_rule_errors ) . "\n" );
    }

    # verify that all countries are valid, and remap them if they are
    no autovivification;
    my @country_errors = ();
    foreach my $rule_name ( keys %$self ) {
        my $rule = $self->{$rule_name};
        if ( exists( $rule->{'tests'} ) ) {
            foreach my $test ( @{ $rule->{'tests'} } ) {
                if ( exists( $test->{'variable'} ) and ( $test->{'variable'} eq 'dests' ) ) {
                    my $invalid = $test->{'values'}->difference( M_B::Countries::valid_countries() );
                    if ( $invalid->is_empty() ) {
                        $test->{'values'} = M_B::Countries::mapped_countries( $test->{'values'} );
                    }
                    else {
                        push @country_errors, "Error in $rule_name: invalid country(s) " . join( ", " => sort $invalid->elements() );
                    }
                }
            }
        }
    }
    if (@country_errors) {
        die( "Errors:\n" . join( "\n" => @country_errors ) . "\n" );
    }

    return bless $self, $class;
}

sub _convert_into_sets {
    my ($rule) = @_;
    no autovivification;
    if ( exists( $rule->{'tests'} ) ) {
        foreach my $test ( @{ $rule->{'tests'} } ) {
            if ( exists( $test->{'values'} ) ) {
                $test->{'values'} = set( $test->{'values'} );
            }
        }
    }

    return $rule;
}

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 ) = @_;

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

    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';

    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 {
        $datatree->{ $rule->{'key'} } = '';
    }

    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} = '';
            }
        }
    }

    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') {
            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') {
            return $variable_value->is_disjoint( $test->{'values'} );
        }
        default {
            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) = @_;

    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 ( defined( $rule->{'subrules'} ) ) {
        foreach my $subrule ( @{ $rule->{'subrules'} } ) {
            $tree->{$subrule} = $self->describe_rule($subrule);
        }
    }

    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;