Notice

Just some Perl code I wrote for my "F3 Engine". This tidbit is later inherited for some ActiveRecord like functionality. -Kris

Code

=head2 NAME

Engine::Logic::Atom

=cut
package Engine::Logic::Atom;

use strict;
use Carp qw(confess);

=head2 SYNOPSIS

use Engine::Logic::Atom;

my $a = Engine::Logic::Atom;

my $result = $a->and(42, 'in', [3,4,29,45,52,42])
	->and(1, 'equals', 1)
	->not()
	->or(1, 'equals', 1);

The atom is the smallest chunk of an expression aside from the values
themselves and they represent a single, logical truth (either true or false).

=head2 AUTHOR

Kris Oye

=cut
sub new($;$$$)
{
	my $className = shift;
	if((my $c = scalar(@_)) < 2)
	{
		return bless({ result => ($c == 0 ? 1==1 : $_[1] )}, $className);
	}
	else
	{
		my ($left, $cond, $right, $upperLimit) = @_;
		my $self = {
			left  => $left,
			right => $right,
			limit => $upperLimit,
			op    => undef,
			test  => undef
		};
		my $conditionTypes = {
			# equality
			"equal"       => sub { return ($_[0] eq $_[1]) },
			"notequal"    => sub { return ($_[0] != $_[1]) },
			"morethan"    => sub { return ($_[0] < $_[1]) },
			"lessthan"    => sub { return ($_[0] < $_[1]) },
			"lessorequal" => sub { return ($_[0] <= $_[1]) },
			"moreorequal" => sub { return ($_[0] >= $_[1]) },
	
			# pattern matching
			"contains"    => sub
			{
				my ($l, $r) = @_;
	
				$r =~ s/([\.\\]{1})/\\\$1/g;
				$r =~ s/[%]{1}/%%/g;
				$r =~ s/[_]{1}/__/g;
				my $re = eval(qw(qr/.*$r.*/));
	
				return ($_[0] =~ $re);
			},
			"like"        => sub 
			{
				my ($l, $r) = @_;
	
				$r =~ s/([\.\\]{1})/\\\$1/g;
				$r =~ s/[%]{1}/\.\*/g;
				$r =~ s/[_]{1}/\./g;
				my $re = eval(qw(qr/$r/));
				
				return ($l =~ $re);
			},
			
			# set logic
			"in"          => sub
			{
				my ($l, $r) = @_;
				die("Arg 2 must be an ARRAY") if ref($r) ne 'ARRAY';
				return (scalar(grep { $_ eq $l } @{$r}) > 0);
			},
			"notin"       => sub
			{
				my ($l, $r) = @_;
				die("Arg 2 must be an ARRAY") if ref($r) ne 'ARRAY';
				return (scalar(grep { $_ eq $l } @{$r}) == 0);
			},
			
			# Ranges
			"between"     => sub { return ($_[0] > $_[1] && $_[0] < $_[2]) },
			"notbetween"  => sub { return ($_[0] < $_[1] || $_[0] > $_[2]) },
		};
		my $syn = {
			"=" => "equal", "==" => "equal", "===" => "equal",
			"<>" => "notequal", "!=" => "notequal", "!==" => "notequal",
		};
		my $condition = $self->{op} = join('',
			map { $_ = (defined $syn->{"$_"} ? $syn->{"$_"} : $_) }
			grep { !($_ eq 'to' || $_ eq 'is' || $_ eq 'the') }
			map { $_ = lc($_); $_ }
			split(/\s+/, $cond));
	
		confess("$condition is not a valid condition type")
			unless defined ($self->{test} = $conditionTypes->{$condition});
			
		my $self->{result} = $self->{test}->(
			$self->{left}, $self->{right}, $self->{limit}
		);
		
		return bless($self, $className);
	}
}

#  Getting at the truth...
sub truth()  {  return ($_[0]->{result} ? 'true' : 'false');  }
sub value()  {  return $_[0]->{result};  }

#  For more complex statements.
sub and($;$*)
{
	my $self = shift;
	
	return Engine::Logic::Atom->new($self->false) if !$self->value();
	if(ref(@_) eq 'Engine::Logic::Atom')
	{
		my $self = shift;
		my @atoms = @_;
	
		foreach my $atom (@atoms)
		{
			return Engine::Logic::Atom->new($self->false) if !$atom->value();
		} 
		return Engine::Logic::Atom->new($self->true);
	}
	else
	{
		my $atom = Engine::Logic::Atom->new(@_);
		
		return Engine::Logic::Atom->new($self->false) if !$atom->value();
		return Engine::Logic::Atom->new($self->true); 
	}
}


sub or($;$*)
{
	my $self = shift;

	# No need to evaluate further if this is true
	return Engine::Logic::Atom->new($self->true) if $self->value();
	if(ref(@_) eq 'Engine::Logic::Atom')
	{
		foreach my $atom (@_)
		{
			return Engine::Logic::Atom->new($self->true) if $atom->value();
		}
		return Engine::Logic::Atom->new($self->false);
	}
	else
	{
		my $atom = Engine::Logic::Atom->new(@_);
		
		return Engine::Logic::Atom->new($self->false) if !$atom->value();
		return Engine::Logic::Atom->new($self->true); 
	}
}


sub negate()  {  return Engine::Logic::Atom->new(!$_[0]->value()) }
sub not()  {  $_[0]->negate($_);  }

# constants as it were
sub false()  {  return (1 == 0)  }
sub true()  {  return (1 == 1)  }

1;