La séptima vida

...o el gato así lo espera/teme

Evaluating conditional expressions

In a previous article, I discussed a language that tests data coming from a PLC. The language allows for testing conditional expressions such as 'temperature > 30' or 'alarm triggered'. The article covers the definition of the grammar and produces a parser for the language.

The parser developed in that article takes a textual definition and returns a data structure. This article will cover the conversion of the data structure to executable code.

Directives

First of all, the data structure returned by the parser is always an array reference. Its first element is the name of the instruction that should be executed, followed by its arguments. Let's consider the simplest case: the always directive. The data structure is:

[ 'always' ]

The executable version is not much more complicated:

sub { return 1 }

So, I am after a function that takes the data structure as input and returns a reference to this subroutine as output. I called it build_condition. It can start like this:

sub build_condition {
    my ($condition) = @_;
    return sub { return 1 };
}

This routine will always return a code reference which, when evaluated, returns a true value. This is regardless of the received $condition. To accomodate for new conditions, let's use a hash of code references:

 my %builder_for = (
    always => sub { return 1 },
    never  => sub { return 0 },
 );

# Use builder functions from the hash above:
sub build_condition {
    my ($condition) = @_;
    return $builder_for{ $condition };
}

Comparison operators

Having a hash of builder functions provides a lot of flexibility, but the implementation so far does not handle arguments at all. So, it is not yet enough to handle test functions such as temperature > 25. The array reference in this case is a little more complicated:

['numeric', '>', 'temperature', '30']

As always, the first element of this array reference is the name of the function to apply while the rest are the arguments to that function. The actual operator to use is included among the arguments of the function. The builder for numeric comparisons could be called like this:

$builder_for{numeric}->('>', 'temperature', '30');

The builder should return another code reference, the one which will actually return true if the temperature was above 30 degrees. Note that this builder returns a code reference, but those for always and never return their result if evaluated. Because all the builder functions will be called in the same way, those for always and never must be changed:

my %builder_for = (
    always  => sub { sub { 1 } },
    never   => sub { sub { 0 } },
    numeric => \&build_numerical_comparison,
 );

To evaluate numerical comparisons, we need to convert the string 'temperature' to something that can hold a numerical value. My application includes a class called Fields. Field objects can hold a value and they even remember their previous value. Additionally, Field objects must be available to the routine build_condition. In fact, all the code in this article belongs to a class, 'Conditions'. Condition objects can hold an array of Fields. Let's rewrite build_condition as follows:

sub build_condition {
    my ($self, $p) = @_;

    # $p is the array reference that came from the parser,
    # and its first element is the condition name:
    my ($fname, @args) = @$p;
    my $builder = $builder_for{$fname};

    # Builders are called with the object which contains field objects
    # and the arguments returned by the parser
    return $builder->($self, @args);
}

Note that I am calling the $builder with the object $self as argument. $self contains the collection of Field objects.

On the other hand, the builder method, build_numerical_comparison, must handle the operators '>', '<', and '='. I used a new hash to hold the operators, which are themselves code references. This is the implementation of '>':

my $gt = sub {
    my ($a, $b) = @_;
    return 0 unless defined $a && defined $b;
    return $a > $b;
};
 
# And this is the dispatch table for comparisons
my %operation_for = (
    '=' => $eq,
    '>' => $gt,
    '<' => $lt,
);

Operators defined this way also work in the variable-to-variable case, because the only difference is that variable comparison is made with the values of two Field objects. The two builders are:

sub build_numerical_comparison {
    my ($self, $operator, $field_name, $arg) = @_;

    my $op    = $operation_for{$operator};
    my $field = $self->get_field($field_name);

    return sub { $op->($field->value, $arg) };
}

sub build_variable_comparison {
    my ($self, $operator, $field_name, $arg) = @_;
 
    my $op     = $operation_for{$operator};
    my $field  = $self->get_field($field_name);
    my $field2 = $self->get_field($arg);
 
    return sub { $op->($field->value, $field2->value) };
}

This completes the implementation of comparison operators.

Post-operators

The grammar defines operators that test the value of a variable, like alarm on and air_conditioner off. There are also operators that require to keep the previous value of each of the variables: alarm triggered, motor turned_off, and temperature changed. Because all these operators work on variables, they are actually methods of the Field class. The class includes also value and previous_value, needed to build the actual tests. Thus, I can say:

$variable->on;
$variable->off;
$variable->triggered;
$variable->turned_off;
$variable->changed;

The data structure corresponding to such conditions looks like this:

[ 'postop', 'operator', 'variable' ]

and the builder becomes:

sub build_postop {
    my ($self, $postop, $field_name) = @_;
    my $field = $self->get_field($field_name);
    return sub { $field->$postop() };
}

Logical operators

The last part of the puzzle is about logical operators. Their particularity is that their arguments are expressions which were already processed. In other words, logical operators work on code references. If their builder receives an array reference instead, it must be built first:

my %logic_op_for = (
    NOT => sub { return !shift->() },
    AND => sub { return shift->() && shift->() },
    OR  => sub { return shift->() || shift->() },
);

sub build_logic {
    my ($self, $operator, @args) = @_;
    my $op = $logic_op_for{$operator};
    my @built;
    foreach my $rule (@args) {
        if (ref $rule eq 'CODE') {
            push @built, $rule;
        }
        else {
            push @built, $self->build_condition($rule);
        }
    }   
    return sub { $op->(@built) };
}

Magically, this code will turn the data structures that result from parsing conditional expressions into executable code references.

Full module

The final module is below. It is implemented as a role, using Moo::Role. This role can be applied to Field containers, such as outgoing MQTT messages in my application. This module works with the parser defined in the previous post.

package Machine::Interface::Conditions;

use Machine::Interface::RuleParser;
use Carp;
use Moo::Role;
use strictures 1;
use v5.10;

requires qw(name fields);

# Code reference to evaluate conditions. Default is '@always'
has condition => (
    is      => 'rw',
    default => sub { return 1 },
);

sub add_condition {
    my ($self, $condition) = @_;
    my $p = $self->parse_condition($condition);
    my $s = $self->build_condition($p);
    $self->condition($s);
}

sub parse_condition {
    my ($self, $condition) = @_;
    my $p = Machine::Interface::RuleParser->parse_rule($condition)
        || croak "Could not parse '$condition'";
    return $p;
}

sub evaluate_condition {
    my $self = shift;
    return $self->condition->();
}

# Dispatch table for condition builders
my %builder_for = (
    always     => sub { return sub {1} },
    never      => sub { return sub {0} },
    any_change => \&build_any_change,
    numeric    => \&build_numerical_comparison,
    variable   => \&build_variable_comparison,
    postop     => \&build_postop,
    logicop    => \&build_logic,
);

sub build_condition {
    my ($self, $p) = @_;

    # $p is an array reference, where the first element is the rule
    # name.
    my ($fname, @args) = @$p;
    my $builder = $builder_for{$fname};

    # Builders are called with the object which contains field objects
    # and the arguments returned by the parser
    return $builder->($self, @args);
}

#### Builders for directives ####

sub build_any_change {
    my $self = shift;
    
    # Get the list of fields of this object and build a 'changed'
    # code reference for each
    my @field_conditions;
    foreach my $field (@{$self->fields}) {
        my $changed = sub { return $field->changed() };
        push @field_conditions, $changed;
    }

    # The returned code ref will evaluate all individual field conditions
    # until it finds one that changed
    return sub {
        foreach my $changed (@field_conditions) {
            return 1 if $changed->();
        }
        return 0;
    }    
}

#### Builders for comparison instructions ####

# These are the allowed comparison operators
my $eq = sub {
    my ($a, $b) = @_;
    return 0 unless defined $a && defined $b;
    return $a == $b;
};

my $gt = sub {
    my ($a, $b) = @_;
    return 0 unless defined $a && defined $b;
    return $a > $b;
};

my $lt = sub {
    my ($a, $b) = @_;
    return 0 unless defined $a && defined $b;
    return $a < $b;
};

# And this is the dispatch table for comparisons
my %operation_for = (
    '=' => $eq,
    '>' => $gt,
    '<' => $lt,
);

sub build_numerical_comparison {
    my ($self, $operator, $field_name, $arg) = @_;

    my $op    = $operation_for{$operator};
    my $field = $self->get_field($field_name)
        || croak "Could not find field <$field_name> in " . $self->name;

    return sub { $op->($field->value, $arg) };
}

sub build_variable_comparison {
    my ($self, $operator, $field_name, $arg) = @_;

    my $op    = $operation_for{$operator};
    my $field = $self->get_field($field_name)
        || croak "Could not find field <$field_name> in " . $self->name;

    my $field2 = $self->get_field($arg)
        || croak "Could not find field <$arg> in " . $self->name;

    return sub { $op->($field->value, $field2->value) };
}

# Post operators are in fact methods of field objects

sub build_postop {
    my ($self, $postop, $field_name) = @_;
    my $field = $self->get_field($field_name);
    return sub { $field->$postop() };
}

my %logic_op_for = (
    NOT => sub { return !shift->() },
    AND => sub { return shift->() && shift->() },
    OR  => sub { return shift->() || shift->() },
);

sub build_logic {
    my ($self, $operator, @args) = @_;
    my $op = $logic_op_for{$operator};
    my @built;
    foreach my $rule (@args) {
        if (ref $rule eq 'CODE') {
            push @built, $rule;
        }
        else {
            push @built, $self->build_condition($rule);
        }
    }   
    return sub { $op->(@built) };
}

#### Other methods ####

sub get_field {
    my ($self, $fname) = @_;
    foreach (@{$self->fields}) {
        return $_ if $_->name eq $fname;
    }
    return undef;
}

1;