sub\s results from the CPAN

sub\s

AI-FuzzyInference

view release on metacpan or search on metacpan

############################################
#
# 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
			  );

FuzzyInference.pm view on Meta::CPAN

			  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.

FuzzyInference.pm view on Meta::CPAN


    # 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\$");

FuzzyInference.pm view on Meta::CPAN

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

FuzzyInference/Set.pm view on Meta::CPAN


package AI::FuzzyInference::Set;
use strict;

#our $VERSION = 0.02;
use vars qw/$VERSION/;  # a bit more backward compatibility.
$VERSION = 0.04;

1;

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

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

    $obj->_init;

    return $obj;
}

sub _init {
    my $self = shift;

    $self->{TS}   = {};
    $self->{AREA} = {};
}

sub add {
    my ($self,
	$name,
	$xmin,
	$xmax,
	@coords,
	) = @_;

    # make sure coords span the whole universe.
    if ($coords[0] > $xmin) {
	unshift @coords => ($xmin, $coords[1]);
    }

    if ($coords[-2] < $xmax) {
	push @coords => ($xmax, $coords[-1]);
    }

    $self->{TS}{$name} = \@coords;
}

sub delete {
    my ($self,
	$name,
	) = @_;

    delete $self->{$_}{$name} for qw/TS AREA/;
}

sub membership {
    my ($self,
	$name,
	$val,
	) = @_;

    return undef unless $self->exists($name);

    my $deg = 0;
    my @c   = $self->coords($name);

FuzzyInference/Set.pm view on Meta::CPAN

	    $y1 = $y2;
	    next;
	}
	$deg = $y2 - ($y2 - $y1) * ($x2 - $val) / ($x2 - $x1);
	last;
    }

    return $deg;
}

sub listAll {
    my $self = shift;

    return keys %{$self->{TS}};
}

sub listMatching {
    my ($self, $rgx) = @_;

    return grep /$rgx/, keys %{$self->{TS}};
}

sub max {    # max of two sets.
    my ($self,
	$set1,
	$set2,
	) = @_;

    my @coords1 = $self->coords($set1);
    my @coords2 = $self->coords($set2);

    my @newCoords;
    my ($x, $y, $other);

FuzzyInference/Set.pm view on Meta::CPAN

	$val = $y if $y > $val;
	push @newCoords => $x, $val;
    }

    push @newCoords => @coords1 if @coords1;
    push @newCoords => @coords2 if @coords2;

    return @newCoords;
}

sub min {    # min of two sets.
    my ($self,
	$set1,
	$set2,
	) = @_;

    my @coords1 = $self->coords($set1);
    my @coords2 = $self->coords($set2);

    my @newCoords;
    my ($x, $y, $other);

FuzzyInference/Set.pm view on Meta::CPAN

	$val = $y if $y < $val;
	push @newCoords => $x, $val;
    }

    push @newCoords => @coords1 if @coords1;
    push @newCoords => @coords2 if @coords2;

    return @newCoords;
}

sub complement {
    my ($self, $name) = @_;

    my @coords = $self->coords($name);
    my $i = 0;
    return map {++$i % 2 ? $_ : 1 - $_} @coords;
}

sub coords {
    my ($self,
	$name,
	) = @_;

    return undef unless $self->exists($name);

    return @{$self->{TS}{$name}};
}

sub scale {  # product implication
    my ($self,
	$name,
	$scale,
	) = @_;

    my $i = 0;
    my @c = map { $_ * ++$i % 2 ? 1 : $scale } $self->coords($name);

    return @c;
}

sub clip {   # min implication
    my ($self,
	$name,
	$val,
	) = @_;

    my $i = 0;
    my @c = map {
	++$i % 2 ? $_ : $_ > $val ? $val : $_
	}$self->coords($name);

    return @c;
}

# had to roll my own centroid algorithm.
# not sure why standard algorithms didn't work
# correctly!
sub centroid {   # center of mass.
    my ($self,
	$name,
	) = @_;

    return undef unless $self->exists($name);

    my @coords = $self->coords($name);
    my @ar;

    my $x0 = shift @coords;

FuzzyInference/Set.pm view on Meta::CPAN


    my $ta = 0;
    $ta += $_->[1] for @ar;

    my $c = 0;
    $c += $_->[0] * ($_->[1] / $ta) for @ar;

    return $c;
}

sub median {
    my ($self,
	$name,
	) = @_;

    my @coords = $self->coords($name);

    # hmmm .. how do I do *this*?
    return 0;
}

sub exists {
    my ($self,
	$name,
	) = @_;

    return exists $self->{TS}{$name};
}

sub uniquify {
    my $self = shift;

    my @new;
    my %seen;

    while (@_) {
	my $x = shift;
	my $y = shift;

	next if $seen{$x};

	push @new => ($x, $y);
	$seen{$x} = 1;
    }

    return @new;
}

sub area {
    my ($self, $name) = @_;

    return $self->{AREA}{$name} if exists $self->{AREA}{$name};

    my @coords = $self->coords($name);

    my $x0   = shift @coords;
    my $y0   = shift @coords;
    my $area = 0;

( run in 1.094 second using v1.01-cache-2.11-cpan-a5abf4f5562 )