view release on metacpan or  search on metacpan

FuzzyInference.pm  view on Meta::CPAN

# A module to implement a fuzzy inference system.
#
# Copyright Ala Qumsieh (aqumsieh@cpan.org) 2002.
# This program is distributed under the same terms as Perl itself.

package AI::FuzzyInference;
use strict;

use vars qw/$VERSION/;
$VERSION = 0.05;

use AI::FuzzyInference::Set;

############################################
#
# First some global vars.
#
############################################

# this hash defines the possible interpretations of the
# standard fuzzy logic operations.
my %_operations = (
		   '&' => {
		       min     => sub { (sort {$a <=> $b} @_)[0] },
		       product => sub { my $p = 1; $p *= $_ for @_; $p },
		       default => 'min',
		   },
		   '|'  => {
		       max     => sub { (sort {$a <=> $b} @_)[-1] },
		       sum     => sub { my $s = 0; $s += $_ for @_; $s > 1 ? 1 : $s },
		       default => 'max',
		   },
		   '!' => {
		       complement => sub { 1 - $_[0] },
		       custom  => sub {},
		       default    => 'complement',
		   },
		   );

# this hash defines the currently implemented implication methods.
my %_implication     = qw(
			  clip    1
			  scale   1
			  default clip
			  );

# this hash defines the currently implemented aggregation methods.
my %_aggregation     = qw(
			  max     1
			  default max
			  );

# this hash defines the currently implemented defuzzification methods.
my %_defuzzification = qw(
			  centroid 1
			  default  centroid
			  );

# sub new() - constructor.
# 
# doesn't take any arguments. Returns an initialized AI::FuzzyInference object.

sub new {
    my $self  = shift;
    my $class = ref($self) || $self;

    my $obj = bless {} => $class;

    $obj->_init;

    return $obj;
}

# sub _init() - private method.
#
# no arguments. Initializes the data structures we will need.
# It also defines the default logic operations we might need.

sub _init {
    my $self = shift;

    $self->{SET}     = new AI::FuzzyInference::Set;
    $self->{INVARS}  = {};
    $self->{OUTVARS} = {};
    $self->{RULES}   = [];
    $self->{RESULTS} = {};

    $self->{IMPLICATION}     = $_implication{default};
    $self->{AGGREGATION}     = $_aggregation{default};
    $self->{DEFUZZIFICATION} = $_defuzzification{default};

    for my $op (qw/& | !/) {
	$self->{OPERATIONS}{$op} = $_operations{$op}{default};
    }
}

# sub implication() - public method.
#
# one optional argument: has to match one of the keys of the %_implication hash.
# used to query/set the implication method.

sub implication {
    my ($self,
	$new,
	) = @_;

    if (defined $new and exists $_implication{$new}) {
	$self->{IMPLICATION} = $new;
    }

    return $self->{IMPLICATION};
}

# sub aggregation() - public method.
#
# one optional argument: has to match one of the keys of the %_aggregation hash.
# used to query/set the aggregation method.

sub aggregation {
    my ($self,
	$new,
	) = @_;

    if (defined $new and exists $_aggregation{$new}) {
	$self->{AGGREGATION} = $new;
    }

    return $self->{AGGREGATION};
}

# sub defuzzification() - public method.
#
# one optional argument: has to match one of the keys of the %_defuzzification hash.
# used to query/set the defuzzification method.

sub defuzzification {
    my ($self,
	$new,
	) = @_;

    if (defined $new and exists $_defuzzification{$new}) {
	$self->{DEFUZZIFICATION} = $new;
    }

    return $self->{DEFUZZIFICATION};
}

# sub operation() - public method.
#
# two arguments: first one mandatory and specifies the logic operation
# in question. Second one is optional and has to match one of the keys
# of the %{$_operations{$first_arg}} hash.
# Used to query/set the logic operations method.

sub operation {
    my ($self,
	$op,
	$new,
	) = @_;

    return unless defined $op && exists $_operations{$op};

    if (defined $new and exists $_operations{$op}{$new}) {
	$self->{OPERATIONS}{$op} = $new;
    }

    return $self->{OPERATIONS}{$op};
}

# sub inVar() - public method.
#
# 4 arguments or more : First is a name of a new input variable.
# Second and third are the min and max values of that variable.
# These define the universe of discourse for that variable.
# Additional argumets constitute a hash. The keys of the hash
# are term set names defined for the given variable. The values
# are the coordinates of the vertices of the term sets.
#
# ex. $obj->inVar('height',
#                 5, 8,   # xmin, xmax (in feet, say)
#                 'tall' => [0, 0,
#                            5, 1,
#                            10,0],
#                  ....);

sub inVar {
    my ($self,
	$var,
	$xmin,
	$xmax,
	@sets,
	) = @_;

    $self->{INVARS}{$var} = [$xmin, $xmax];

    while (@sets) {
	my $s = shift @sets;
	my $c = shift @sets;

	$self->{SET}->add("$var:$s", $xmin, $xmax, @$c);
    }
}

# sub outVar() - public method.
#
# 4 arguments or more : First is a name of a new output variable.
# Second and third are the min and max values of that variable.
# These define the universe of discourse for that variable.
# Additional argumets constitute a hash. The keys of the hash
# are term set names defined for the given variable. The values
# are the coordinates of the vertices of the term sets.

sub outVar {
    my ($self,
	$var,
	$xmin,
	$xmax,
	@sets,
	) = @_;

    $self->{OUTVARS}{$var} = [$xmin, $xmax];

    while (@sets) {
	my $s = shift @sets;
	my $c = shift @sets;

	$self->{SET}->add("$var:$s", $xmin, $xmax, @$c);
    }
}

# sub addRule() - public method.
#
# Adds fuzzy if-then inference rules.
#
# $obj->addRule('x=medium'         => 'z = slow',
#               'x=low  & y=small' => 'z = fast',
#               'x=high & y=tiny'  => 'z=veryfast');
# spaces are optional. The characters [&=|] are special.

sub addRule {
    my ($self, %rules) = @_;

    for my $k (keys %rules) {
	my $v = $rules{$k};
	s/\s+//g for $v, $k;

	push @{$self->{RULES}} => [$k, $v];
    }

    return 1;
}

# sub show() - public method.
#
# This method displays the computed values of all
# output variables.
# It is ugly, and will be removed. Here for debugging.

sub show {
    my $self = shift;

    for my $var (keys %{$self->{RESULTS}}) {
	print "Var $var = $self->{RESULTS}{$var}.\n";
    }
}

# sub value() - public method.
#
# one argument: the name of an output variable.
# This method returns the computed value of a given output var.

sub value {
    my ($self,
	$var,
	) = @_;

    return undef unless exists $self->{RESULTS}{$var};
    return $self->{RESULTS}{$var};
}

# sub reset() - public method
# 
# cleans the data structures used.

sub reset {
    my $self = shift;

    my @list   =  $self->{SET}->listMatching(q|:implicated$|);
    push @list => $self->{SET}->listMatching(q|:aggregated$|);

    $self->{SET}->delete($_) for @list;

    $self->{RESULTS} = {};
}

# sub compute() - public method
#
# This method takes as input crisp values for each
# of the input vars, and produces a crisp output value
# based on the application of the fuzzy if-then rules.
# ex.
# $z = $obj->compute(x => 5,
#                    y => 24);

sub compute {
    my ($self,
	%vars,
	) = @_;

    $self->reset();

    # First thing we do is to fuzzify the inputs.
    $self->_fuzzify(%vars);

    # Now, apply the rules to see which ones fire.
    $self->_infer;

    # implicate
    $self->_implicate;

    # aggregate
    $self->_aggregate;

    # defuzzify .. final step.
    $self->_defuzzify;

    return 1;
}

# sub _defuzzify() - private method.
#
# no arguments. This method applies the defuzzification technique
# to get a crisp value out of the aggregated set of each output
# var.

sub _defuzzify {
    my $self = shift;

    my $_defuzzification = $self->{DEFUZZIFICATION};

    # iterate through all output vars.
    for my $var (keys %{$self->{OUTVARS}}) {

	my $result = 0;
	if ($self->{SET}->exists("$var:aggregated")) {
	    $result = $self->{SET}->$_defuzzification("$var:aggregated");
	}

	$self->{RESULTS}{$var} = $result;
    }
}

# sub _aggregate() - private method.
#
# no arguments. This method applies the aggregation technique to get
# one fuzzy set out of the implicated sets of each output var.

sub _aggregate {
    my $self = shift;

    my $_aggregation = $self->{AGGREGATION};

    # iterate through all output vars.
    for my $var (keys %{$self->{OUTVARS}}) {

	# get implicated sets.
	my @list = $self->{SET}->listMatching("\Q$var\E:.*:implicated\$");

	next unless @list;

	my $i = 0;
	my $current = shift @list;

	# aggregate everything together.
	while (@list) {
	    my $new  = shift @list;
	    my $name = "temp" . $i++;

	    my @c = $self->{SET}->$_aggregation($current, $new);
	    $self->{SET}->add($name, @{$self->{OUTVARS}{$var}}, @c);
	    $current = $name;
	}

	# rename the final aggregated set.
	my @c = $self->{SET}->coords($current);
	$self->{SET}->add("$var:aggregated", @{$self->{OUTVARS}{$var}}, @c);

	# delete the temporary sets.
	for my $j (0 .. $i - 1) {
	    $self->{SET}->delete("temp$j");
	}
    }
}

# sub _implicate() - private method.
#
# no arguments. This method applies the implication technique
# to all the fired rules to find a support value for each
# output variable.

sub _implicate {
  my $self = shift;

  my $_implication = $self->{IMPLICATION};

  my %ind;

  for my $ref (@{$self->{FIRED}}) {
    my ($i, $val) = @$ref;
    my ($var, $ts) = split /=/, $self->{RULES}[$i][1];

    if ($val > 0) {
      $ind{$var}{$ts}++;
      my @c = $self->{SET}->$_implication("$var:$ts", $val);
      my @u = @{$self->{OUTVARS}{$var}}; # the universe
      $self->{SET}->add("$var:$ts:$ind{$var}{$ts}:implicated", @u, @c);
    }
  }
}

# sub _fuzzify() - private method.
#
# one argument: a hash. The keys are input variables. The
# values are the crisp values of the input variables (same arguments
# as compute()). It finds the degree of membership of each input
# variable in each of its term sets.

sub _fuzzify {
    my ($self, %vars) = @_;

    my %terms;

    for my $var (keys %vars) {
	my $val = $vars{$var};

	for my $ts ($self->{SET}->listMatching("\Q$var\E")) {
	    my $deg = $self->{SET}->membership($ts, $val);

	    $terms{$var}{$ts} = $deg;
	}
    }

    $self->{FUZZIFY} = \%terms;
}

# sub _infer() - private method.
#
# no arguments. This method applies the logic operations to combine
# multiple parts of the antecedent of a rule to get one crisp value 
# that is the degree of support of that rule.
# Rules with positive support "fire".

sub _infer {
    my $self = shift;

    my @fired; # keep list of fired rules.

    for my $i (0 .. $#{$self->{RULES}}) {
	my $r = $self->{RULES}[$i][0];   # precedent

	my $val = 0;
	while ($r =~ /([&|]?)([^&|]+)/g) {
	    my ($op, $ant) = ($1, $2);
	    my ($var, $ts) = split /=/ => $ant;

	    $ts = "$var:$ts";

	    if ($op) {
		#$val = $self->{LOGIC}{$op}{SUB}->($val, $self->{FUZZIFY}{$var}{$ts});
		$val = $_operations{$op}{$self->{OPERATIONS}{$op}}->($val, $self->{FUZZIFY}{$var}{$ts});
	    } else {
		$val = $self->{FUZZIFY}{$var}{$ts};
	    }
	}

	# We only care about positive values.
	push @fired => [$i, $val];
    }

    $self->{FIRED} = \@fired;
}

__END__

=pod

=head1 NAME

AI::FuzzyInference - A module to implement a Fuzzy Inference System.

=head1 SYNOPSYS

    use AI::FuzzyInference;

    my $s = new AI::FuzzyInference;

    $s->inVar('service', 0, 10,
	  poor      => [0, 0,
			2, 1,
			4, 0],
	  good      => [2, 0,
			4, 1,
			6, 0],
	  excellent => [4, 0,
			6, 1,
			8, 0],
	  amazing   => [6, 0,
			8, 1,
			10, 0],
	  );

    $s->inVar('food', 0, 10,
	  poor      => [0, 0,