AI-FuzzyEngine
view release on metacpan - search on metacpan
view release on metacpan or search on metacpan
use 5.006;
use strict;
use warnings;
use Module::Build;
my $builder = Module::Build->new(
module_name => 'AI::FuzzyEngine',
license => 'perl',
dist_author => q{Juergen Mueck <jmueck@cpan.org>},
dist_version_from => 'lib/AI/FuzzyEngine.pm',
build_requires => {
'Test::More' => 0,
'Test::Most' => 0,
'List::Util' => 0,
'List::MoreUtils' => 0,
'Scalar::Util' => 0,
'Carp' => 0,
},
requires => {
'perl' => 5.008009,
},
add_to_cleanup => [ 'AI-FuzzyEngine-*' ],
create_makefile_pl => 'traditional',
);
# <img src="Changes" alt="Changes, 119B" class="" title="Changes" height="0" width="0" />
# <img src="MANIFEST" alt="MANIFEST, 194B" class="" title="MANIFEST" height="0" width="0" />
# <img src="README" alt="README, 1.6kB" class="" title="README" height="0" width="0" />
$builder->create_build_script();
Revision history for AI-FuzzyEngine
0.1.0 2013-02-08
First version, released on an unsuspecting world.
0.1.1 2013-02-08
README costumized. POD small improvement.
0.2.0 2013-02-13
PDL awareness
Tests re-factored
requires perl 5.8.9
POD improved, PDL sections added
0.2.1 2013-02-14
Bug in test fixed (use PDL removed)
versioning of Set and Variable adapted
0.2.2 2013-02-27
Declaring a version with version->declare() instead of qw()
A variable can change its sets' membership functions
(e.g. within optimisation routines)
Providing $fe->true() and $fe->false()
Build.PL
Changes
lib/AI/FuzzyEngine.pm
lib/AI/FuzzyEngine/Set.pm
lib/AI/FuzzyEngine/Variable.pm
MANIFEST This list of files
README
ignore.txt
t/00-load.t
t/01-fuzzyEngine.t
t/02-fuzzyEngine-pdl_aware.t
Makefile.PL
META.yml
META.json
{
"abstract" : "A Fuzzy Engine, PDL aware",
"author" : [
"Juergen Mueck <jmueck@cpan.org>"
],
"dynamic_config" : 1,
"generated_by" : "Module::Build version 0.38, CPAN::Meta::Converter version 2.112150",
"license" : [
"perl_5"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
"version" : "2"
},
"name" : "AI-FuzzyEngine",
"prereqs" : {
"build" : {
"requires" : {
"Carp" : 0,
"List::MoreUtils" : 0,
"List::Util" : 0,
"Scalar::Util" : 0,
"Test::More" : 0,
"Test::Most" : 0
}
},
"configure" : {
"requires" : {
"Module::Build" : "0.38"
}
},
"runtime" : {
"requires" : {
"perl" : "5.008009"
}
}
},
"provides" : {
"AI::FuzzyEngine" : {
"file" : "lib/AI/FuzzyEngine.pm",
"version" : "v0.2.2"
},
"AI::FuzzyEngine::Set" : {
"file" : "lib/AI/FuzzyEngine/Set.pm",
"version" : "v0.2.2"
},
"AI::FuzzyEngine::Variable" : {
"file" : "lib/AI/FuzzyEngine/Variable.pm",
"version" : "v0.2.2"
}
},
"release_status" : "stable",
"resources" : {
"license" : [
"http://dev.perl.org/licenses/"
]
},
"version" : "v0.2.2"
}
---
abstract: 'A Fuzzy Engine, PDL aware'
author:
- 'Juergen Mueck <jmueck@cpan.org>'
build_requires:
Carp: 0
List::MoreUtils: 0
List::Util: 0
Scalar::Util: 0
Test::More: 0
Test::Most: 0
configure_requires:
Module::Build: 0.38
dynamic_config: 1
generated_by: 'Module::Build version 0.38, CPAN::Meta::Converter version 2.112150'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
name: AI-FuzzyEngine
provides:
AI::FuzzyEngine:
file: lib/AI/FuzzyEngine.pm
version: v0.2.2
AI::FuzzyEngine::Set:
file: lib/AI/FuzzyEngine/Set.pm
version: v0.2.2
AI::FuzzyEngine::Variable:
file: lib/AI/FuzzyEngine/Variable.pm
version: v0.2.2
requires:
perl: 5.008009
resources:
license: http://dev.perl.org/licenses/
version: v0.2.2
Makefile.PL view on Meta::CPAN
# Note: this file was auto-generated by Module::Build::Compat version 0.3800
require 5.008009;
use ExtUtils::MakeMaker;
WriteMakefile
(
'PL_FILES' => {},
'INSTALLDIRS' => 'site',
'NAME' => 'AI::FuzzyEngine',
'EXE_FILES' => [],
'VERSION_FROM' => 'lib/AI/FuzzyEngine.pm',
'PREREQ_PM' => {
'Test::More' => 0,
'Scalar::Util' => 0,
'List::Util' => 0,
'Test::Most' => 0,
'List::MoreUtils' => 0,
'Carp' => 0
}
)
;
AI-FuzzyEngine v0.2.2
This module is yet another implementation of a fuzzy inference system.
The aim was to be able to code rules (no string parsing),
but avoid operator overloading,
and make it possible to split calculation into multiple steps.
All intermediate results (memberships of sets of variables)
should be available.
Beginning with v0.2.0 it is PDL aware,
meaning that it can handle piddles (PDL objects)
when running the fuzzy operations.
More information on PDL can be found at L<http://pdl.perl.org/>.
Credits to Ala Qumsieh and his L<AI::FuzzyInference>,
that showed me that fuzzy is no magic.
I learned a lot by analyzing his code,
and he provides good information and links to learn more about Fuzzy Logics.
INSTALLATION
To install this module, run the following commands:
perl Build.PL
./Build
./Build test
./Build install
SUPPORT AND DOCUMENTATION
After installing, you can find documentation for this module with the
perldoc command.
perldoc AI::FuzzyEngine
LICENSE AND COPYRIGHT
Copyright (C) 2013 Juergen Mueck
This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.
See http://dev.perl.org/licenses/ for more information.
blib*
Makefile
Makefile.old
Build
Build.bat
_build*
pm_to_blib*
*.tar.gz
.lwpcookies
cover_db
pod2htm*.tmp
AI-FuzzyEngine-*
lib/AI/FuzzyEngine.pm view on Meta::CPAN
package AI::FuzzyEngine;
use 5.008009;
use version 0.77; our $VERSION = version->declare('v0.2.2');
use strict;
use warnings;
use Carp;
use Scalar::Util;
use List::Util;
use List::MoreUtils;
use AI::FuzzyEngine::Variable;
sub new {
my ($class) = @_;
my $self = bless {}, $class;
$self->{_variables} = [];
return $self;
}
sub variables { @{ shift->{_variables} } };
sub and {
my ($self, @vals) = @_;
# PDL awareness: any element is a piddle?
return List::Util::min(@vals) if _non_is_a_piddle(@vals);
_check_for_PDL();
my $vals = $self->_cat_array_of_piddles(@vals);
return $vals->mv(-1, 0)->minimum;
}
sub or {
my ($self, @vals) = @_;
# PDL awareness: any element is a piddle?
return List::Util::max(@vals) if _non_is_a_piddle(@vals);
_check_for_PDL();
my $vals = $self->_cat_array_of_piddles(@vals);
return $vals->mv(-1, 0)->maximum;
}
sub not {
my ($self, $val) = @_;
return 1-$val;
}
sub true { return 1 }
sub false { return 0 }
sub new_variable {
my ($self, @pars) = @_;
my $variable_class = $self->_class_of_variable();
my $var = $variable_class->new($self, @pars);
push @{$self->{_variables}}, $var;
Scalar::Util::weaken $self->{_variables}->[-1];
return $var;
}
sub reset {
my ($self) = @_;
$_->reset() for $self->variables();
return $self;
}
sub _class_of_variable { 'AI::FuzzyEngine::Variable' }
sub _non_is_a_piddle {
return List::MoreUtils::none {ref $_ eq 'PDL'} @_;
}
my $_PDL_is_imported;
sub _check_for_PDL {
return if $_PDL_is_imported;
die "PDL not loaded" unless $INC{'PDL.pm'};
die "PDL::Core not loaded" unless $INC{'PDL/Core.pm'};
$_PDL_is_imported = 1;
}
sub _cat_array_of_piddles {
my ($class, @vals) = @_;
# TODO: Rapid return if @_ == 1 (isa piddle)
# TODO: join "-", ndims -> Schnellcheck auf gleiche Dim.
# All elements must get piddles
my @pdls = map { PDL::Core::topdl($_) } @vals;
# Get size of wrapping piddle (using a trick)
# applying valid expansion rules for element wise operations
my $zeros = PDL->pdl(0);
# v-- does not work due to threading mechanisms :-((
# $zeros += $_ for @pdls;
# Avoid threading!
for my $p (@pdls) {
croak "Empty piddles are not allowed" if $p->isempty();
eval { $zeros = $zeros + $p->zeros(); 1
} or croak q{Can't expand piddles to same size};
}
# Now, cat 'em by expanding them on the fly
my $vals = PDL::cat( map {$_ + $zeros} @pdls );
return $vals;
};
1;
=pod
=head1 NAME
AI::FuzzyEngine - A Fuzzy Engine, PDL aware
=head1 SYNOPSIS
=head2 Regular Perl - without PDL
use AI::FuzzyEngine;
# Engine (or factory) provides fuzzy logical arithmetic
my $fe = AI::FuzzyEngine->new();
# Disjunction:
my $a = $fe->or ( 0.2, 0.5, 0.8, 0.7 ); # 0.8
# Conjunction:
my $b = $fe->and( 0.2, 0.5, 0.8, 0.7 ); # 0.2
# Negation:
my $c = $fe->not( 0.4 ); # 0.6
# Always true:
my $t = $fe->true(); # 1.0
# Always false:
my $f = $fe->false(); # 0.0
# These functions are constitutive for the operations
# on the fuzzy sets of the fuzzy variables:
# VARIABLES (AI::FuzzyEngine::Variable)
# input variables need definition of membership functions of their sets
my $flow = $fe->new_variable( 0 => 2000,
small => [0, 1, 500, 1, 1000, 0 ],
med => [ 400, 0, 1000, 1, 1500, 0 ],
huge => [ 1000, 0, 1500, 1, 2000, 1],
);
my $cap = $fe->new_variable( 0 => 1800,
avg => [0, 1, 1500, 1, 1700, 0 ],
high => [ 1500, 0, 1700, 1, 1800, 1],
);
# internal variables need sets, but no membership functions
my $saturation = $fe->new_variable( # from => to may be ommitted
low => [],
crit => [],
over => [],
);
# But output variables need membership functions for their sets:
my $green = $fe->new_variable( -5 => 5,
decrease => [-5, 1, -2, 1, 0, 0 ],
ok => [ -2, 0 0, 1, 2, 0 ],
increase => [ 0, 0, 2, 1, 5, 1],
);
# Reset FuzzyEngine (resets all variables)
$fe->reset();
# Reset a fuzzy variable directly
$flow->reset;
# Membership functions can be changed via the set's variable.
# This might be useful during parameter identification algorithms
# Changing a function resets the respective variable.
$flow->change_set( med => [500, 0, 1000, 1, 1500, 0] );
# Fuzzification of input variables
$flow->fuzzify( 600 );
$cap->fuzzify( 1000 );
# Membership degrees of the respective sets are now available:
my $flow_is_small = $flow->small(); # 0.8
my $flow_is_med = $flow->med(); # 0.2
my $flow_is_huge = $flow->huge(); # 0.0
# RULES and their application
# a) If necessary, calculate some internal variables first.
# They will not be defuzzified (in fact, $saturation can't)
# Implicit application of 'and'
# Multiple calls to a membership function
# are similar to 'or' operations:
$saturation->low( $flow->small(), $cap->avg() );
$saturation->low( $flow->small(), $cap->high() );
$saturation->low( $flow->med(), $cap->high() );
# Explicite 'or', 'and' or 'not' possible:
$saturation->crit( $fe->or( $fe->and( $flow->med(), $cap->avg() ),
$fe->and( $flow->huge(), $cap->high() ),
),
);
$saturation->over( $fe->not( $flow->small() ),
$fe->not( $flow->med() ),
$flow->huge(),
$cap->high(),
);
$saturation->over( $flow->huge(), $fe->not( $cap->high() ) );
# b) deduce output variable(s) (here: from internal variable $saturation)
$green->decrease( $saturation->low() );
$green->ok( $saturation->crit() );
$green->increase( $saturation->over() );
# All sets provide their respective membership degrees:
my $saturation_is_over = $saturation->over(); # This is no defuzzification!
my $green_is_ok = $green->ok();
# Defuzzification ( is a matter of the fuzzy variable )
my $delta_green = $green->defuzzify(); # -5 ... 5
=head2 Using PDL and its threading capability
use PDL;
use AI::FuzzyEngine;
# (Probably a stupide example)
my $fe = AI::FuzzyEngine->new();
# Declare variables as usual
my $severity = $fe->new_variable( 0 => 10,
low => [0, 1, 3, 1, 5, 0 ],
high => [ 3, 0, 5, 1, 10, 1],
);
my $threshold = $fe->new_variable( 0 => 1,
low => [0, 1, 0.2, 1, 0.8, 0, ],
high => [ 0.2, 0, 0.8, 1, 1, 1],
);
my $problem = $fe->new_variable( -0.5 => 2,
no => [-0.5, 0, 0, 1, 0.5, 0, 1, 0],
yes => [ 0, 0, 0.5, 1, 1, 1, 1.5, 1, 2, 0],
);
# Input data is a pdl of arbitrary dimension
my $data = pdl( [0, 4, 6, 10] );
$severity->fuzzify( $data );
# Membership degrees are piddles now:
print 'Severity is high: ', $severity->high, "\n";
# [0 0.5 1 1]
# Other variables might be piddles of other dimensions,
# but all variables must be expandible to a common 'wrapping' piddle
# ( in this case a 4x2 matrix with 4 colums and 2 rows)
my $level = pdl( [0.6],
[0.2],
);
$threshold->fuzzify( $level );
print 'Threshold is low: ', $threshold->low(), "\n";
# [
# [0.33333333]
# [ 1]
# ]
# Apply some rules
$problem->yes( $severity->high, $threshold->low );
$problem->no( $fe->not( $problem->yes ) );
# Fuzzy results are represented by the membership degrees of sets
print 'Problem yes: ', $problem->yes, "\n";
# [
# [ 0 0.33333333 0.33333333 0.33333333]
# [ 0 0.5 1 1]
# ]
# Defuzzify the output variables
# Caveat: This includes some non-threadable operations up to now
my $problem_ratings = $problem->defuzzify();
print 'Problems rated: ', $problem_ratings;
# [
# [ 0 0.60952381 0.60952381 0.60952381]
# [ 0 0.75 1 1]
# ]
=head1 EXPORT
Nothing is exported or exportable.
=head1 DESCRIPTION
This module is yet another implementation of a fuzzy inference system.
The aim was to be able to code rules (no string parsing),
but avoid operator overloading,
and make it possible to split calculation into multiple steps.
All intermediate results (memberships of sets of variables)
should be available.
Beginning with v0.2.0 it is PDL aware,
meaning that it can handle piddles (PDL objects)
when running the fuzzy operations.
More information on PDL can be found at L<http://pdl.perl.org/>.
Credits to Ala Qumsieh and his L<AI::FuzzyInference>,
that showed me that fuzzy is no magic.
I learned a lot by analyzing his code,
and he provides good information and links to learn more about Fuzzy Logics.
=head2 Fuzzy stuff
The L<AI::FuzzyEngine> object defines and provides
the elementary operations for fuzzy sets.
All membership degrees of sets are values from 0 to 1.
Up to now there is no choice with regard to how to operate on sets:
=over 2
=item C<< $fe->or( ... ) >> (Disjunction)
is I<Maximum> of membership degrees
=item C<< $fe->and( ... ) >> (Conjunction)
is I<Minimum> of membership degrees
=item C<< $fe->not( $var->$set ) >> (Negation)
is I<1-degree> of membership degree
=item Aggregation of rules (Disjunction)
is I<Maximum>
=item True C<< $fe->true() >> and false C<< $fe->false() >>
are provided for convenience.
=back
Defuzzification is based on
=over 2
=item Implication
I<Clip> membership function of a set according to membership degree,
before the implicated memberships of all sets of a variable are taken for defuzzification:
=item Defuzzification
I<Centroid> of aggregated (and clipped) membership functions
=back
=head2 Public functions
Creation of an C<AI::FuzzyEngine> object by
my $fe = AI::FuzzyEngine->new();
This function has no parameters. It provides the fuzzy methods
C<or>, C<and> and C<not>, as listed above.
If needed, I will introduce alternative fuzzy operations,
they will be configured as arguments to C<new>.
Once built, the engine can create fuzzy variables by C<new_variable>:
my $var = $fe->new_variable( $from => $to,
$name_of_set1 => [$x11, $y11, $x12, $y12, ... ],
$name_of_set2 => [$x21, $y21, $x22, $y22, ... ],
...
);
Result is an L<AI::FuzzyEngine::Variable>.
The name_of_set strings are taken to assign corresponding methods
for the respective fuzzy variables.
They must be valid function identifiers.
Same name_of_set can used for different variables without conflict.
Take care:
There is no check for conflicts with predefined class methods.
Fuzzy variables provide a method to fuzzify input values:
$var->fuzzify( $val );
according to the defined sets and their membership functions.
The memberships of the sets of C<$var> are accessible
by the respective functions:
my $membership_degree = $var->$name_of_set();
Membership degrees can be assigned directly (within rules for example):
$var->$name_of_set( $membership_degree );
If multiple membership_degrees are given, they are "anded":
$var->$name_of_set( $degree1, $degree2, ... ); # "and"
By this, simple rules can be coded directly:
my $var_3->zzz( $var_1->xxx, $var_2->yyy, ... ); # "and"
this implements the fuzzy implication
if $var_1->xxx and $var_2->yyy and ... then $var_3->zzz
The membership degrees of a variable's sets can be reset to undef:
$var->reset(); # resets a variable
$fe->reset(); # resets all variables
The fuzzy engine C<$fe> has all variables registered
that have been created by its C<new_variable> method.
A variable can be defuzzified:
my $out_value = $var->defuzzify();
Membership functions can be replaced via a set's variable:
$var->change_set( $name_of_set => [$x11n, $y11n, $x12n, $y12n, ... ] );
The variable will be reset when replacing a membership function
of any of its sets.
Interdependencies with other variables are not checked
(it might happen that the results of any rules are no longer valid,
so it needs some recalculations).
Sometimes internal variables are used that need neither fuzzification
nor defuzzification.
They can be created by a simplified call to C<new_variable>:
my $var_int = $fe->new_variable( $name_of_set1 => [],
$name_of_set2 => [],
...
);
Hence, they can not use the methods C<fuzzify> or C<defuzzify>.
Fuzzy operations are simple operations on floating values between 0 and 1:
my $conjunction = $fe->and( $var1->xxx, $var2->yyy, ... );
my $disjunction = $fe->or( $var1->xxx, $var2->yyy, ... );
my $negated = $fe->not( $var1->zzz );
There is no magic.
A sequence of rules for the same set can be implemented as follows:
$var_3->zzz( $var_1->xxx, $var_2->yyy, ... );
$var_3->zzz( $var_4->aaa, $var_5->bbb, ... );
The subsequent application of C<< $var_3->zzz(...) >>
corresponds to "or" operations (aggregation of rules).
Only a reset can reset C<$var_3>.
=head2 PDL awareness
Membership degrees of sets might be either scalars or piddles now.
$var_a->memb_fun_a( 5 ); # degree of memb_fun_a is a scalar
$var_a->memb_fun_b( pdl(7, 8) ); # degree of memb_fun_b is a piddle
Empty piddles are not allowed, behaviour with bad values is not tested.
Fuzzification (hence calculating degrees) accepts piddles:
$var_b->fuzzify( pdl([1, 2], [3, 4]) );
Defuzzification returns a piddle if any of the membership
degrees of the function's sets is a piddle:
my $val = $var_a->defuzzify(); # $var_a returns a 1dim piddle with two elements
So do the fuzzy operations as provided by the fuzzy engine C<$fe> itself.
Any operation on more then one piddle expands those to common
dimensions, if possible, or throws a PDL error otherwise.
The way expansion is done is best explained by code
(see C<< AI::FuzzyEngine->_cat_array_of_piddles(@pdls) >>).
Assuming all piddles are in C<@pdls>,
calculation goes as follows:
# Get the common dimensions
my $zeros = PDL->pdl(0);
# Note: $zeros += $_->zeros() for @pdls does not work here
$zeros = $zeros + $_->zeros() for @pdls;
# Expand all piddles
@pdls = map {$_ + $zeros} @pdls;
Defuzzification uses some heavy non-threading code,
so there might be a performance penalty for big piddles.
=head2 Todos
=over 2
=item Add optional alternative implementations of fuzzy operations
=item More checks on input arguments and allowed method calls
=item PDL awareness: Use threading in C<< $variable->defuzzify >>
=item Divide tests into API tests and test of internal functions
=back
=head1 CAVEATS / BUGS
This is my first module.
I'm happy about feedback that helps me to learn
and improve my contributions to the Perl ecosystem.
Please report any bugs or feature requests to
C<bug-ai-fuzzyengine at rt.cpan.org>, or through
the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=AI-FuzzyEngine>.
I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc AI::FuzzyEngine
=head1 AUTHOR
Juergen Mueck, jmueck@cpan.org
=head1 COPYRIGHT
Copyright (c) Juergen Mueck 2013. All rights reserved.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
lib/AI/FuzzyEngine/Set.pm view on Meta::CPAN
package AI::FuzzyEngine::Set;
use 5.008009;
use version 0.77; our $VERSION = version->declare('v0.2.2');
use strict;
use warnings;
use Carp;
use Scalar::Util qw(blessed weaken);
use List::MoreUtils;
sub new {
my ($class, @pars) = @_;
my $self = bless {}, $class;
$self->_init(@pars);
return $self;
}
sub name { shift->{name} }
sub variable { shift->{variable} }
sub fuzzyEngine { shift->{fuzzyEngine} }
sub memb_fun { shift->{memb_fun} }
sub degree {
my ($self, @vals) = @_;
if (@vals) {
# Multiple input degrees are conjuncted:
my $and_degree = $self->fuzzyEngine->and( @vals );
# Result counts against (up to now) best hit
my $last_degree = $self->{degree};
$self->{degree} = $self->fuzzyEngine->or( $last_degree, $and_degree );
};
return $self->{degree};
}
# internal helpers, return @x and @y from the membership functions
sub _x_of ($) { return @{shift->[0]} };
sub _y_of ($) { return @{shift->[1]} };
sub _init {
my ($self, %pars) = @_;
my %defaults = ( name => '',
value => 0,
memb_fun => [[]=>[]], # \@x => \@y
variable => undef,
fuzzyEngine => undef,
);
my %attrs = ( %defaults, %pars );
my $class = 'AI::FuzzyEngine';
croak "fuzzyEngine is not a $class"
unless blessed $attrs{fuzzyEngine} && $attrs{fuzzyEngine}->isa($class);
$class = 'AI::FuzzyEngine::Variable';
croak "variable is not a $class"
unless blessed $attrs{variable} && $attrs{variable}->isa($class);
croak 'Membership function is not an array ref'
unless ref $attrs{memb_fun} eq 'ARRAY';
$self->{$_} = $attrs{$_} for qw( variable fuzzyEngine name memb_fun);
weaken $self->{$_} for qw( variable fuzzyEngine );
$self->{degree} = 0;
my @x = _x_of $self->memb_fun;
croak 'No double interpolation points allowed'
if List::MoreUtils::uniq( @x ) < @x;
$self;
}
sub _copy_fun {
my ($class, $fun) = @_;
my @x = @{$fun->[0]}; # my @x = _x_of $fun;, improve speed
my @y = @{$fun->[1]};
return [ \@x => \@y ];
}
sub _interpol {
my ($class, $fun, $val_x) = @_;
my @x = @{$fun->[0]}; # speed
my @y = @{$fun->[1]};
if (not ref $val_x eq 'PDL') {
return $y[ 0] if $val_x <= $x[ 0];
return $y[-1] if $val_x >= $x[-1];
# find block
my $ix = 0;
$ix++ while $val_x > $x[$ix] && $ix < $#x;
# firstidx takes longer (156ms vs. 125ms with 50_000 calls)
# my $ix = List::MoreUtils::firstidx { $val_x <= $_ } @x;
# interpolate
my $fract = ($val_x - $x[$ix-1]) / ($x[$ix] - $x[$ix-1]);
my $val_y = $y[$ix-1] + $fract * ($y[$ix] - $y[$ix-1]);
return $val_y;
};
my ($val_y) = $val_x->interpolate( PDL->pdl(@x), PDL->pdl(@y) );
return $val_y;
}
# Some functions are not marked private (using leading '_')
# but should be used by AI::FuzzyEngine::Variable only:
sub set_x_limits {
my ($class, $fun, $from, $to) = @_;
my @x = _x_of $fun;
my @y = _y_of $fun;
return $fun unless @x;
if (@x == 1) {
# Explicitly deal with this case to allow recursive removing of points
$fun->[0] = [$from => $to];
$fun->[1] = [ @y[0, 0] ];
return $fun;
}
if ($x[0] > $from) {
unshift @x, $from;
unshift @y, $y[0];
}
elsif ($x[0] < $from) {
# Check for @x > 1 allows to use $x[1]
if ($x[1] <= $from) {
# Recursive call with removed left border
shift @{$fun->[0]};
shift @{$fun->[1]};
$class->set_x_limits( $fun, $from => $to );
# update @x and @y for further calculation
@x = _x_of $fun;
@y = _y_of $fun;
}
else {
$x[0] = $from;
$y[0] = $class->_interpol( $fun => $from );
};
};
if ($x[-1] < $to) {
push @x, $to;
push @y, $y[-1];
}
elsif ($x[-1] > $to) {
# Check for @x > 1 allows to use $x[-2]
if ($x[-2] >= $to) {
# Recursive call with removed right border
pop @{$fun->[0]};
pop @{$fun->[1]};
$class->set_x_limits( $fun, $from => $to );
# update @x and @y for further calculation
@x = _x_of $fun;
@y = _y_of $fun;
}
else {
$x[-1] = $to;
$y[-1] = $class->_interpol( $fun => $to );
};
};
$fun->[0] = \@x;
$fun->[1] = \@y;
return $fun;
}
sub synchronize_funs {
my ($class, $funA, $funB) = @_;
# change $funA, $funB directly, use their references
# \@x and \@y as part of $fun will be replaced nevertheless
my @xA = _x_of $funA;
my @yA = _y_of $funA;
my @xB = _x_of $funB;
my @yB = _y_of $funB;
croak '$funA is empty' unless @xA;
croak '$funB is empty' unless @xB;
# Find and add missing points
my (%yA_of, %yB_of);
@yA_of{@xA} = @yA;
@yB_of{@xB} = @yB;
my (%xA, %xB);
@xA{@xA} = 1;
@xB{@xB} = 1;
MISSING_IN_A:
for my $x (@xB) {
next MISSING_IN_A if exists $xA{$x};
$yA_of{$x} = $class->_interpol( $funA => $x );
};
MISSING_IN_B:
for my $x (@xA) {
next MISSING_IN_B if exists $xB{$x};
$yB_of{$x} = $class->_interpol( $funB => $x );
};
# Sort them and put them back to the references of $funA and $funB
# (Sort is necessary even if no crossings exist)
my @x = sort {$a<=>$b} keys %yA_of;
@yA = @yA_of{@x};
@yB = @yB_of{@x};
# Assign to fun references (needed within CHECK_CROSSING)
$funA->[0] = \@x;
$funA->[1] = \@yA;
$funB->[0] = \@x;
$funB->[1] = \@yB;
# Any crossing between interpolation points
my $found;
CHECK_CROSSING:
for my $ix (1..$#xA) {
my $dy1 = $yB[$ix-1] - $yA[$ix-1];
my $dy2 = $yB[$ix] - $yA[$ix];
next CHECK_CROSSING if $dy1 * $dy2 >= 0;
$found++;
my $dx = $xA[$ix] - $xA[$ix-1];
my $x = $xA[$ix-1] + $dx * $dy1 / ($dy1-$dy2);
my $y = $class->_interpol( $funA => $x );
$yA_of{$x} = $y;
$yB_of{$x} = $y;
};
if ($found) {
# Rest of procedure is known (and necessary)
@x = sort {$a<=>$b} keys %yA_of;
@yA = @yA_of{@x};
@yB = @yB_of{@x};
$funA->[0] = \@x;
$funA->[1] = \@yA;
$funB->[0] = \@x;
$funB->[1] = \@yB;
};
return;
};
sub _max_of {
my ($factor, $ar, $br) = @_;
my @y;
for my $ix ( reverse 0..$#$ar ) {
my $max = $ar->[$ix] * $factor > $br->[$ix] * $factor ?
$ar->[$ix] : $br->[$ix];
$y[$ix] = $max;
};
return @y;
}
sub _minmax_of_pair_of_funs {
my ($class, $factor, $funA, $funB) = @_;
# $factor > 0: 'max' operation
# $factor < 0: 'min' operation
# synchronize interpolation points (original functions are changed)
$class->synchronize_funs( $funA, $funB );
my @x = _x_of $funA;
my @yA = _y_of $funA;
my @yB = _y_of $funB;
# my @y = List::MoreUtils::pairwise { $a*$factor > $b*$factor ?
# $a : $b
# } @yA, @yB;
my @y = _max_of( $factor, \@yA, \@yB ); # faster than pairwise
return [ \@x, \@y ];
}
sub _minmax_of_funs {
my ($class, $factor, $funA, @moreFuns) = @_;
return $funA unless @moreFuns;
my $funB = shift @moreFuns;
my $fun = $class->_minmax_of_pair_of_funs( $factor, $funA, $funB );
# solve recursively
return $class->_minmax_of_funs( $factor, $fun, @moreFuns );
}
sub min_of_funs {
my ($class, @funs) = @_;
# Copy can not moved to _minmax_of_funs (is recursively called)
my @copied_funs = map { $class->_copy_fun($_) } @funs;
return $class->_minmax_of_funs( -1, @copied_funs );
}
sub max_of_funs {
my ($class, @funs) = @_;
# Copy can not moved to _minmax_of_funs (is recursively called)
my @copied_funs = map { $class->_copy_fun($_) } @funs;
return $class->_minmax_of_funs( 1, @copied_funs );
}
sub clip_fun {
my ($class, $fun, $max_y) = @_;
# clip by min operation on function $fun
my @x = _x_of $fun;
my @y = ( $max_y ) x @x;
my $fun_limit = [ \@x => \@y ];
return $class->min_of_funs( $fun, $fun_limit );
}
sub centroid {
my ($class, $fun) = @_;
# x and y values, check
my @x = _x_of $fun;
my @y = _y_of $fun;
croak "At least two points needed" if @x < 2;
# using code fragments from Ala Qumsieh (AI::FuzzyInference::Set)
# Left
my $x0 = shift @x;
my $y0 = shift @y;
my (@areas, $x1, $y1);
AREA:
while (@x) {
# Right egde of area
$x1 = shift @x;
$y1 = shift @y;
# Each area is build of a rectangle and a top placed triangle
# Each of them might have a height of zero
# Area and local centroid of base rectangle
my $a1 = abs(($x1 - $x0) * ($y0 < $y1 ? $y0 : $y1));
my $c1 = $x0 + 0.5 * ($x1 - $x0);
# Area and local centroid of triangle on top of rectangle
my $a2 = abs(0.5 * ($x1 - $x0) * ($y1 - $y0));
my $c2 = (1/3) * ($x0 + $x1 + ($y1 > $y0 ? $x1 : $x0));
# Total area of block
my $ta = $a1 + $a2;
next AREA if $ta == 0;
# Total centroid of block
my $c = ( $c1*$a1 + $c2*$a2 ) / $ta;
# Store them for final calculation of average
push @areas, [$c, $ta];
}
continue {
# Left edge of next area
($x0, $y0) = ($x1, $y1);
};
# Sum of area
my $ta = 0;
$ta += $_->[1] for @areas;
croak "Function has no height --> no centroid" unless $ta;
# Final Centroid in x direction
my $c = 0;
$c += $_->[0] * $_->[1] for @areas;
return $c / $ta;
}
sub fuzzify {
my ($self, $val) = @_;
my $fun = $self->memb_fun;
croak "No valid membership function"
unless @{$fun->[0]}; # at least one x
return $self->{degree} = $self->_interpol( $fun => $val );
}
sub reset {
my ($self) = @_;
$self->{degree} = 0;
$self;
}
# Replace a membership function
# To be called by variable->change_set( 'setname' => $new_fun );
sub replace_memb_fun {
my ($self, $new_fun) = @_;
$self->{memb_fun} = $new_fun;
return;
}
1;
=pod
=head1 NAME
AI::FuzzyEngine::Set - Class used by AI::FuzzyEngine.
=head1 DESCRIPTION
Please see L<AI::FuzzyEngine> for a description.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc AI::FuzzyEngine
=head1 AUTHOR
Juergen Mueck, jmueck@cpan.org
=head1 COPYRIGHT
Copyright (c) Juergen Mueck 2013. All rights reserved.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
lib/AI/FuzzyEngine/Variable.pm view on Meta::CPAN
package AI::FuzzyEngine::Variable;
use 5.008009;
use version 0.77; our $VERSION = version->declare('v0.2.2');
use strict;
use warnings;
use Scalar::Util qw( blessed looks_like_number );
use List::MoreUtils;
use Carp;
use AI::FuzzyEngine::Set;
my $set_class = _class_of_set();
sub new {
my ($class, $fuzzyEngine, @pars) = @_;
my $self = bless {}, $class;
# check and store the assigned fuzzyEngine
my $fe_class = 'AI::FuzzyEngine';
croak "fuzzyEngine is not a $fe_class"
unless blessed $fuzzyEngine && $fuzzyEngine->isa($fe_class);
$self->{fuzzyEngine} = $fuzzyEngine;
# load pars, create sets etc.
$self->_init(@pars);
return $self;
};
sub is_internal { shift->{is_internal} }
sub from { shift->{from} };
sub to { shift->{to} };
sub sets { shift->{sets} };
sub set_names { @{shift->{set_names}} };
sub set {
my ($self, $set_name) = @_;
return $self->{sets}{$set_name};
};
sub fuzzyEngine { shift->{fuzzyEngine} };
sub is_valid_set {
my ($self, $set_name) = @_;
# Should be simplified to exists $self->{sets}{$set_name}
return List::MoreUtils::any { $_ eq $set_name } keys %{ $self->sets };
}
sub fuzzify {
my ($self, $val) = @_;
croak "Fuzzification not allowed for internal variables"
if $self->is_internal;
for my $set (values %{ $self->sets } ) {
$set->fuzzify( $val );
};
return;
}
sub defuzzify {
my ($self) = @_;
croak "Defuzzification not allowed for internal variables"
if $self->is_internal;
my @sets = values %{$self->sets};
my @funs = map { $_->memb_fun } @sets;
my @degrees = map { $_->degree } @sets;
# If all degrees are real scalars a shortcut is possible
if (_non_is_a_piddle(@degrees)) {
my $funs = _clipped_funs( \@funs, \@degrees);
my $fun_agg = $set_class->max_of_funs( @$funs );
my $c = $set_class->centroid( $fun_agg );
return $c;
};
# Need a function of my FuzzyEngine
my $fe = $self->fuzzyEngine;
die 'Internal: fuzzy_engine is lost' unless $fe;
# Unify dimensions of all @degrees (at least one is a pdl)
my @synched_degrees = $fe->_cat_array_of_piddles(@degrees)->dog;
my @dims_to_reshape = $synched_degrees[0]->dims;
# Make degrees flat to proceed them as lists
my @flat_degrees = map {$_->flat} @synched_degrees;
my $flat_degrees = PDL::cat( @flat_degrees );
# Proceed degrees of @sets as synchronized lists
my @degrees_per_el = $flat_degrees->transpose->dog;
my @defuzzified;
for my $ix (reverse 0..$#degrees_per_el) {
my $el_degrees = $degrees_per_el[$ix];
# The next two lines cost much (75% of defuzzify)
my $funs = _clipped_funs( \@funs, [$el_degrees->list] );
my $fun_agg = $set_class->max_of_funs( @$funs );
my $c = $set_class->centroid( $fun_agg );
$defuzzified[$ix] = $c;
};
# Build result in shape of unified membership degrees
my $flat_defuzzified = PDL->pdl( @defuzzified );
my $defuzzified = $flat_defuzzified->reshape(@dims_to_reshape);
return $defuzzified;
}
sub _clipped_funs {
# Clip all membership functions of a variable
# according to the respective membership degree (array of scalar)
my ($funs, $degrees) = @_;
my @funs = @$funs; # Dereferencing here saves some time
my @degrees = @$degrees;
my @clipped = List::MoreUtils::pairwise {
$set_class->clip_fun($a => $b)
} @funs, @degrees;
return \@clipped;
}
sub reset {
my ($self) = @_;
$_->reset() for values %{$self->sets};
return $self;
}
sub change_set {
my ($self, $setname, $new_memb_fun) = @_;
my $set = $self->set( $setname );
# Some checks
croak "Set $setname does not exist" unless defined $set;
croak 'Variable is internal' if $self->is_internal;
# Convert to internal representation
my $fun = $self->_curve_to_fun( $new_memb_fun );
# clip membership function to borders
$set->set_x_limits( $fun, $self->from => $self->to );
# Hand the new function over to the set
$set->replace_memb_fun( $fun );
# and reset the variable
$self->reset;
return;
}
sub _init {
my ($self, @pars) = @_;
croak "Too few arguments" unless @pars >= 2;
# Test for internal variable
my ($from, $to, @sets);
if (looks_like_number $pars[0]) {
# $from => $to is given
$self->{is_internal} = '';
($from, $to, @sets) = @pars;
}
else {
$self->{is_internal} = 1;
($from, $to, @sets) = (undef, undef, @pars);
};
# Store $from, $to ( undef if is_internal)
$self->{from} = $from;
$self->{to } = $to;
# Provide names of sets in correct order by attribute set_names
my $ix = 1;
$self->{set_names} = [ grep {$ix++ % 2} @sets ];
# Build sets of the variable
my %sets = @sets;
SET_TO_BUILD:
for my $set_name (keys %sets) {
my $fun = [ [] => [] ]; # default membership function
if (not $self->is_internal) {
# Convert from set of points to [ \@x, \@y ] format
my $curve = $sets{$set_name};
$fun = $self->_curve_to_fun( $curve );
# clip membership function to borders
$set_class->set_x_limits( $fun, $self->from => $self->to );
};
# create a set and store it
my $set_class = $self->_class_of_set();
my $set = $set_class
->new( fuzzyEngine => $self->fuzzyEngine,
variable => $self,
name => $set_name,
memb_fun => $fun, # [ [] => [] ] if is_internal
);
$self->{sets}{$set_name} = $set;
# build membership function if necessary
next SET_TO_BUILD if $self->can( $set_name );
my $method = sub {
my ($variable, @vals) = @_; # Variable, fuzzy values
my $set = $variable->{sets}{$set_name};
return $set->degree( @vals );
};
# register the new method to $self (the fuzzy variable)
no strict 'refs';
*{ $set_name } = $method;
};
}
sub _non_is_a_piddle {
return List::MoreUtils::none {ref $_ eq 'PDL'} @_;
}
# Might change for Variables inherited from AI::FuzzyEngine::Variable:
sub _class_of_set { 'AI::FuzzyEngine::Set' }
sub _curve_to_fun {
# Convert input format for membership functions
# to internal representation:
# [$x11, $y11, $x12, $y12, ... ]
# --> [ $x11, $x12, ... ] => [$y11, $y12, ... ] ]
my ($class, $curve) = @_;
my %points = @$curve;
my @x = sort {$a<=>$b} keys %points;
my @y = @points{ @x };
return [ \@x, \@y ];
}
1;
=pod
=head1 NAME
AI::FuzzyEngine::Variable - Class used by AI::FuzzyEngine.
=head1 DESCRIPTION
Please see L<AI::FuzzyEngine> for a description.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc AI::FuzzyEngine
=head1 AUTHOR
Juergen Mueck, jmueck@cpan.org
=head1 COPYRIGHT
Copyright (c) Juergen Mueck 2013. All rights reserved.
This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
=cut
t/00-load.t view on Meta::CPAN
use Test::More tests => 3;
BEGIN {
use_ok( 'AI::FuzzyEngine' ) || print "Bail out!\n";
use_ok( 'AI::FuzzyEngine::Variable' ) || print "Bail out!\n";
use_ok( 'AI::FuzzyEngine::Set' ) || print "Bail out!\n";
}
# diag( "Testing AI::FuzzyEngine $AI::FuzzyEngine::VERSION, Perl $], $^X" );
t/01-fuzzyEngine.t view on Meta::CPAN
use Test::Most;
use List::MoreUtils;
# check (not-) loading of PDL
BEGIN { use_ok 'AI::FuzzyEngine::Set' };
BEGIN { use_ok 'AI::FuzzyEngine::Variable' };
BEGIN { use_ok 'AI::FuzzyEngine' };
sub class { 'AI::FuzzyEngine' };
sub set_class { 'AI::FuzzyEngine::Set' };
sub var_class { 'AI::FuzzyEngine::Variable' };
my $class = class();
my $engine_class = class();
my $set_class = set_class();
my $var_class = var_class();
my $PDL_is_loaded = exists $INC{PDL};
subtest "$class constructor" => sub {
can_ok $class, 'new';
ok my $fe = $class->new, $class . '->new succeeds';
isa_ok $fe, $class, 'What it returns';
};
subtest "$class operations" => sub {
my $fe = $class->new();
# Disjunction:
my $a = $fe->or( 0.2, 0.5, 0.8, 0.7 );
is( $a, 0.8, '"or"' );
# Conjunction:
my $b = $fe->and( 0.2, 0.5, 0.8, 0.7 );
is( $b, 0.2, '"and"' );
# Negation:
my $c = $fe->not( 0.4 );
is( $c, 0.6, '"not"' );
# True:
my $t = $fe->true();
is( $t, 1.0, '"true"' );
# False:
my $f = $fe->false();
is( $f, 0.0, '"false"' );
};
subtest "Class $set_class _copy_fun" => sub {
my $fun_in = [[1=>2] => [-1=>1]];
my $fun_out = $set_class->_copy_fun( $fun_in );
ok( ( $fun_out ne $fun_in )
&& ($fun_out->[0] ne $fun_in->[0])
&& ($fun_out->[1] ne $fun_in->[1]),
'_copy_fun copies all references',
);
my $fun = [ [10] => [0.5] ];
$set_class->set_x_limits( $fun, 0 => 1 );
is_deeply( $fun,
[ [0, 1] => [0.5, 0.5] ],
'set_x_limits, single point',
);
$fun = [ [1, 2] => [1, 1] ];
$set_class->set_x_limits( $fun, 0 => 3 );
is_deeply( $fun,
[ [0, 1, 2, 3] => [1, 1, 1, 1] ],
'set_x_limits, enlarge',
);
};
subtest "Class $set_class set_x_limits" => sub {
my $fun = [ [-1, 4] => [1, 1] ];
$set_class->set_x_limits( $fun, 0 => 3 );
is_deeply( $fun,
[ [0, 3] => [1, 1] ],
'set_x_limits, reduce',
);
$fun = [ [-0.4, -0.2, 1.2, 1.4] => [0, 1, 1, 0] ];
$set_class->set_x_limits( $fun, -0.2 => 1.2 );
is_deeply( $fun,
[ [-0.2, 1.2] => [1, 1] ],
'set_x_limits, meet inner points',
);
$fun = [ [-1.2, -1.0, 1.2, 1.4] => [0, 1, 1, 0] ];
$set_class->set_x_limits( $fun, -0.2 => 0.2 );
is_deeply( $fun,
[ [-0.2, 0.2] => [1, 1] ],
'set_x_limits skip inner points',
);
};
subtest "Class $set_class synchronize_funs" => sub {
my $funA = [ [1, 2] => [-1, -2] ];
my $funB = [ [0, 4] => [-2, -3] ];
$set_class->synchronize_funs( $funA, $funB );
is_deeply( $funA->[0], [0, 1, 2, 4], 'synchronize_funs $funA->x' );
is_deeply( $funB->[0], [0, 1, 2, 4], 'synchronize_funs $funB->x' );
# y: borders not clipped, so interpol uses border values directly
is_deeply( $funA->[1], [-1, -1, -2, -2],
'synchronize_funs $funA->y',
);
is_deeply( $funB->[1], [-2, -2.25, -2.5, -3],
'synchronize_funs $funB->y',
);
# crossing
$funA = [ [0, 1] => [0.5, 2] ];
$funB = [ [0, 1] => [ 2, 1.5] ];
$set_class->synchronize_funs( $funA, $funB );
is_deeply( $funA,
[ [0, 0.75, 1] => [0.5, 1.625, 2] ],
'synchronize_funs $funA with crossing curves',
);
is_deeply( $funB,
[ [0, 0.75, 1] => [2, 1.625, 1.5] ],
'synchronize_funs $funB with crossing curves',
);
$funA = [ [] => [] ];
$funB = [ [] => [] ];
throws_ok { $set_class->synchronize_funs( $funA, $funB )
} qr/is empty/, 'Checks for empty functions';
};
subtest "Class $set_class min & max" => sub {
my $funA = [ [1, 2] => [-1, -2] ];
my $funB = [ [0, 4] => [-2, -3] ];
is_deeply( $set_class->min_of_funs( $funA, $funB ),
[ [0, 1, 2, 4] => [-2, -2.25, -2.5, -3] ],
'min_of_funs',
);
is_deeply( $set_class->max_of_funs( $funA, $funB ),
[ [0, 1, 2, 4] => [-1, -1, -2, -2] ],
'max_of_funs',
);
my $funC = [ [0, 4] => [-2.75, -2.75] ];
is_deeply( $set_class->min_of_funs( $funA, $funB, $funC ),
[ [0, 1, 2, 3, 4] => [-2.75, -2.75, -2.75, -2.75, -3] ],
'min_of_funs recursively',
);
};
subtest "Class $set_class clip_fun, centroid" => sub {
my $funA = [ [0, 1, 2] => [0, 1, 0] ];
my $funA_clipped = $set_class->clip_fun( $funA => 0.5 );
is_deeply( $funA_clipped,
[ [0, 0.5, 1, 1.5, 2] => [0, 0.5, 0.5, 0.5, 0] ],
'clip_fun',
);
my $fun = [ [1, 2] => [1, 1] ];
my $c = $set_class->centroid( $fun );
is( $c, 1.5, 'centroid box' );
$fun = [ [1, 4] => [0, 1] ];
$c = $set_class->centroid( $fun );
is( $c, 3, 'centroid triangle positive slope' );
$fun = [ [1, 4] => [1, 0] ];
$c = $set_class->centroid( $fun );
is( $c, 2, 'centroid triangle positive slope' );
$fun = [ [-2, 0, 0, 3] => [0.75, 0.75, 1, 0] ];
$c = $set_class->centroid( $fun );
is( $c, 0, 'centroid combination, checking area calculation' );
};
my $fe = a_fuzzyEngine();
my %set_pars = ( fuzzyEngine => $fe,
variable => a_variable( $fe ),
name => 'few',
memb_fun => [[7, 8] => [0, 1]],
);
subtest "$set_class constructor" => sub {
my $s = $set_class->new(%set_pars);
isa_ok( $s, $set_class, 'What the constructor returns' );
is_deeply( [ $s->name, $s->memb_fun, $s->variable, $s->fuzzyEngine],
[@set_pars{qw(name memb_fun variable)}, $fe],
'Attributes given in the constructor',
);
};
subtest "$set_class methods" => sub {
my $s = $set_class->new(%set_pars);
is( $s->degree, 0, 'Initial (internal) membership degree is 0' );
$s->degree( 0.2 );
is( $s->degree, 0.2, 'degree can be set by assignment' );
$s->degree( 0.1 );
is( $s->degree, 0.2, 'Disjunction of last and new degree' );
$s->degree( 0.3, 0.5 );
is( $s->degree, 0.3, 'Conjunction of multiple inputs ("and" operation)' );
local $set_pars{memb_fun} = [ [0.2, 0.3, 0.8, 1.0], # x
[0.1, 0.5, 0.5, 0.0], # y
];
$s = $set_class->new(%set_pars);
# fuzzify some values
my @vals = ( 0, 0.2, 0.25, 0.3, 0.5, 0.8, 0.90, 1);
my @expected = (0.1, 0.1, 0.30, 0.5, 0.5, 0.5, 0.25, 0 );
my @got = map { $s->fuzzify($_) } @vals;
is_deeply( \@got, \@expected,
'fuzzify incl. corner cases and reset of degree',
);
my $degree = $s->fuzzify( 0.2 );
is( $degree, 0.1, 'fuzzify returns degree' );
$set_pars{memb_fun} = [ [0, 1, 1, 2] => [1, 2, 3, 4] ];
throws_ok {$s = AI::FuzzyEngine::Set->new(%set_pars)
} qr/no double/i, 'Checks double interpolation coordinates';
};
subtest "$set_class special memb_fun methods" => sub {
# Replace a membership function
my $s = $set_class->new(%set_pars);
is_deeply( $s->memb_fun, [[7, 8] => [0, 1]],
'(preconditions)',
) or diag 'Test broken, check precondition';
my $new_fun = [ [5, 6] => [0.5, 0.7] ];
$s->replace_memb_fun( $new_fun );
is_deeply( $s->memb_fun, $new_fun, 'replace_memb_fun' );
1;
};
subtest "$var_class functions" => sub {
my $memb_fun = $var_class->_curve_to_fun( [8=>1, 7=>0] );
is_deeply( $memb_fun, [[7, 8] => [0, 1]], '_curve_to_fun' );
$memb_fun = $var_class->_curve_to_fun( [] );
is_deeply( $memb_fun, [[]=>[]], '_curve_to_fun( [] )' );
};
my @var_pars = ( 0 => 10, # order is relevant!
'low' => [0, 1, 10, 0],
'high' => [0, 0, 10, 1],
);
subtest "$var_class constructor" => sub {
my $v = $var_class->new( $fe, @var_pars );
isa_ok( $v, $var_class, '$v' );
is( $v->fuzzyEngine, $fe, 'fuzzyEngine is stored' );
ok( ! $v->is_internal, 'Variable is not internal' );
is_deeply( [$v->from, $v->to, [ sort keys %{ $v->sets } ] ],
[ 0, 10, [ sort qw(low high) ] ],
'Variable attributes and set names',
);
};
subtest "$var_class methods" => sub {
my $v = $var_class->new( $fe, @var_pars );
ok( $v->is_valid_set('high' ), 'is_valid_set (true) ' );
ok( ! $v->is_valid_set('wrong_set'), 'is_valid_set (false)' );
};
subtest "$var_class generated sets" => sub {
my $v = $var_class->new( $fe, @var_pars );
my $low_set = $v->sets->{low};
isa_ok( $low_set, $set_class, 'What variable generates' );
is_deeply( $low_set->memb_fun,
[ [0, 10] => [1, 0] ],
'and receives converted membership functions',
);
can_ok( $v, 'low' ); # can_ok needs no description!
my $degree = $v->low;
is( $degree, 0, 'initial value for degree of low' );
$degree = $v->low(0.2, 0.1);
is( $degree, 0.1, 'and / or for degree of low work' );
my $w = $var_class->new( $fe,
0 => 2,
'low' => [0, 1],
'med' => [0, 0],
);
# $v and $w have a 'low' function.
# Are they independent with regard to degree?
is( $v->low, 0.1, 'degree for low unchanged from other variables' );
is( $w->low, 0, 'degree for low of the new variable is independent');
};
subtest "$var_class order of sets" => sub {
my @range = 0..99;
my @list_of_sets = map { ("s_$_" => [$_,1]) } @range;
my $x = $var_class->new( $fe, 0 => 1, @list_of_sets );
my @indexes = map {/(\d+)/} $x->set_names;
no warnings qw(once);
my @is_same = List::MoreUtils::pairwise {$a==$b} @range, @indexes;
ok( ( List::MoreUtils::all {$_} @is_same ),
q{set_names returns the set's names in correct range},
);
};
subtest "$var_class completing membership functions in x" => sub {
my $v = $var_class->new( $fe,
0 => 10,
'low' => [ 3, 1, 6, 0],
'med' => [ 5, 0.5],
'high' => [ -5, 0, 15, 1],
);
is_deeply( $v->sets->{low}->memb_fun(),
[ [0, 3, 6, 10] => [1, 1, 0, 0] ],
'borders of membership funs are adapted to from=>to',
);
is_deeply( $v->sets->{med}->memb_fun(),
[ [0, 10] => [0.5, 0.5] ],
'even if constant',
);
is_deeply( $v->sets->{high}->memb_fun(),
[ [0, 10] => [0.25, 0.75] ],
'... limits even when crossing edges',
);
};
subtest "$var_class change_set" => sub {
my $v = $var_class->new( $fe,
0 => 10,
'low' => [ 3, 1, 6, 0],
# becomes [ [0, 3, 6, 10] => [1, 1, 0, 0] ],
'high' => [ -5, 0, 15, 1],
);
$v->fuzzify( 5 ); # $v->low > 0 && $v->high > 0
my $new_memb_fun = [2, 1, 8, 0];
$v->change_set( low => $new_memb_fun );
is_deeply( $v->sets->{low}->memb_fun(),
[ [0, 2, 8, 10] => [1, 1, 0, 0] ],
'change_set works and adapts borders in x',
);
is_deeply( [$v->low, $v->high], [0, 0], 'change_set resets the variable' );
throws_ok { $v->change_set( 'wrong_set' )
} qr/set/i, 'change_set checks correct set name';
1;
};
subtest "$var_class fuzzification and defuzzification" => sub {
my $v = $var_class->new( $fe,
0 => 10,
'low' => [ 3, 1, 6, 0],
'med' => [ 5, 0.5],
'high' => [ -5, 0, 15, 1],
);
$v->fuzzify( 0 );
is_deeply( [$v->low, $v->med, $v->high],
[ 1, 0.5, 0.25],
'fuzzify fuzzifies all sets',
);
$v->fuzzify( 10 );
is_deeply( [$v->low, $v->med, $v->high],
[ 0, 0.5, 0.75],
'fuzzify resets and fuzzifies all sets',
);
# Defuzzification
$v = AI::FuzzyEngine::Variable
->new( $fe,
0 => 2,
low => [0 => 1, 1 => 1, 1.00001 => 0, 2 => 0],
high => [0 => 0, 1 => 0, 1.00001 => 1, 2 => 1],
);
$v->low( 1 ); # explicit control for next tests
$v->high( 0 );
my $val = sprintf "%.2f", $v->defuzzify();
is( $val*1, 0.5, 'defuzzy low' );
$v->reset;
$v->low( 0 );
$v->high( 0.5 );
$val = sprintf "%.2f", $v->defuzzify();
is( $val*1, 1.5, 'defuzzy high' );
$v->low( 1 );
$val = $v->defuzzify();
ok( ($val > 0.5 && $val < 1), 'defuzzy low + 0.5*high' );
};
my @int_var_pars = ( # $from => $to MISSING --> internal
'low' => [0, 1, 10, 0],
'high' => [0, 0, 10, 1],
);
subtest "$var_class (internal) constructor" => sub {
my $v = $var_class->new( $fe, @int_var_pars );
isa_ok( $v, $var_class, '$v' );
is( $v->fuzzyEngine, $fe, 'fuzzyEngine is stored' );
ok( $v->is_internal, 'Variable is internal' );
is( ref( $v->sets), 'HASH', 'sets is a HashRef' );
is_deeply( [$v->from, $v->to, [ sort keys %{ $v->sets } ] ],
[ undef, undef, [ sort qw(low high) ] ],
'Variable attributes and set names',
);
};
subtest "$var_class (internal) methods" => sub {
my $v = $var_class->new( $fe, @int_var_pars );
ok( $v->is_valid_set('high' ), 'is_valid_set (true) ' );
ok( ! $v->is_valid_set('wrong_set'), 'is_valid_set (false)' );
my $low_set = $v->set('low');
isa_ok( $low_set, $set_class, 'What variable->set returns' );
is_deeply( $low_set->memb_fun,
[[]=>[]],
'Membership function is empty',
);
can_ok( $v, 'low' );
my $degree = $v->low;
is( $degree, 0, 'initial value for degree of low' );
$degree = $v->low(0.2, 0.1);
is( $degree, 0.1, 'and / or for degree of low work' );
$v->reset;
is( $v->low, 0, 'reset works' );
# Throw errors!
throws_ok { $v->fuzzify(0)
} qr/internal/, 'Checks illegal fuzzify call';
throws_ok { $v->defuzzify
} qr/internal/, 'Checks illegal defuzzify call';
throws_ok { $v->change_set( low => [[]=>[]] )
} qr/internal/i, 'Blocks change_set';
};
$fe = $class->new();
subtest "$class as factory" => sub {
my $v = $fe->new_variable( 0 => 10,
'low' => [0, 1, 10, 0],
'high' => [0, 0, 10, 1],
);
isa_ok( $v, $var_class, 'What $fe->new_variable returns' );
is_deeply( [$v->from, $v->to, [ sort keys %{ $v->sets } ] ],
[ 0, 10, [ sort qw(low high) ] ],
'Variable attributes and set names by new_variable',
);
my $w = $fe->new_variable( 0 => 1,
'low' => [0, 1],
'high' => [1, 0],
);
is_deeply( [ $fe->variables() ],
[$v, $w],
'Engine stores variables (should be weakened)',
);
$v->low( 0.1 );
$w->low( 0.2 );
my $v_resetted = $v->reset;
isa_ok( $v_resetted,
$var_class,
'What variable->reset returns',
) or exit;
is( $v->low, 0.0, 'Variable can be resetted' );
is( $w->low, 0.2, 'Other variables stay unchanged' );
my $fe_resetted = $fe->reset();
isa_ok( $fe_resetted,
$class,
'What fuzzyEngine->reset returns',
);
is( $w->low, 0.0, 'FuzzyEngine resets all variables' );
};
subtest 'synopsis' => sub {
# Engine (or factory) provides fuzzy logical arithmetic
my $fe = $class->new();
# Disjunction:
my $a = $fe->or ( 0.2, 0.5, 0.8, 0.7 ); # 0.8
# Conjunction:
my $b = $fe->and( 0.2, 0.5, 0.8, 0.7 ); # 0.2
# Negation:
my $c = $fe->not( 0.4 ); # 0.6
# Always true:
my $t = $fe->true(); # 1.0
# Always false:
my $f = $fe->false(); # 0.0
# These functions are constitutive for the operations
# on the fuzzy sets of the fuzzy variables:
# VARIABLES (AI::FuzzyEngine::Variable)
# input variables need definition of membership functions of their sets
my $flow = $fe->new_variable( 0 => 2000,
small => [0, 1, 500, 1, 1000, 0 ],
med => [ 400, 0, 1000, 1, 1500, 0 ],
huge => [ 1000, 0, 1500, 1, 2000, 1],
);
my $cap = $fe->new_variable( 0 => 1800,
avg => [0, 1, 1500, 1, 1700, 0 ],
high => [ 1500, 0, 1700, 1, 1800, 1],
);
# internal variables need sets, but no membership functions
my $saturation = $fe->new_variable( # from => to may be ommitted
low => [],
crit => [],
over => [],
);
# But output variables need membership functions for their sets:
my $green = $fe->new_variable( -5 => 5,
decrease => [-5, 1, -2, 1, 0, 0 ],
ok => [ -2, 0, 0, 1, 2, 0 ],
increase => [ 0, 0, 2, 1, 5, 1],
);
# Reset FuzzyEngine (resets all variables)
$fe->reset();
# Reset a fuzzy variable directly
$flow->reset;
# Membership functions can be changed via the set's variable.
# This might be useful during parameter identification algorithms
# Changing a function resets the respective variable.
$flow->change_set( med => [500, 0, 1000, 1, 1500, 0] );
# Fuzzification of input variables
$flow->fuzzify( 600 );
$cap->fuzzify( 1000 );
# Membership degrees of the respective sets are now available:
my $flow_is_small = $flow->small(); # 0.8
my $flow_is_med = $flow->med(); # 0.2
my $flow_is_huge = $flow->huge(); # 0.0
# RULES and their application
# a) first step, result is $saturation, an intermediate set
# implicit application of 'and'
# Multiple calls to a membership function
# are similar to 'or' operations:
$saturation->low( $flow->small(), $cap->avg() );
$saturation->low( $flow->small(), $cap->high() );
$saturation->low( $flow->med(), $cap->high() );
# Explicite 'or', 'and' or 'not' possible:
$saturation->crit( $fe->or( $fe->and( $flow->med(), $cap->avg() ),
$fe->and( $flow->huge(), $cap->high() ),
),
);
$saturation->over( $fe->not( $flow->small() ),
$fe->not( $flow->med() ),
$flow->huge(),
$cap->high(),
);
$saturation->over( $flow->huge(), $fe->not( $cap->high() ) );
# b) second step, deduce output variable from internal state of saturation
$green->decrease( $saturation->low() );
$green->ok( $saturation->crit() );
$green->increase( $saturation->over() );
# All sets provide the respective membership degrees of their variables:
my $saturation_is_over = $saturation->over(); # no defuzzification!
my $green_is_ok = $green->ok();
# Defuzzification ( is a matter of the fuzzy set )
my $delta_green = $green->defuzzify(); # -5 ... 5
ok( 1, 'POD synopsis' );
};
subtest 'PDL may not be loaded' => sub {
if ($PDL_is_loaded) {
diag "PDL was loaded at start of test - check not possible";
}
else {
ok( (not exists $INC{PDL}), 'Module does not load PDL' );
};
};
done_testing();
sub a_variable {
# Careful!
# a_variable does not register its result into $fuzzyEngine.
# ==> is missing in $fe->variables;
#
my ($fuzzyEngine, @pars) = @_;
my $v = var_class()->new( $fuzzyEngine,
0 => 1,
'low' => [0, 0],
'high' => [1, 1],
@pars,
);
return $v;
}
sub a_fuzzyEngine { return class()->new() }
1;
t/02-fuzzyEngine-pdl_aware.t view on Meta::CPAN
use Test::Most;
use List::MoreUtils;
use AI::FuzzyEngine::Set;
use AI::FuzzyEngine::Variable;
use AI::FuzzyEngine;
sub class { 'AI::FuzzyEngine' };
sub set_class { 'AI::FuzzyEngine::Set' };
sub var_class { 'AI::FuzzyEngine::Variable' };
my $class = class();
my $set_class = set_class();
my $var_class = var_class();
# Can PDL be loaded? skip_all if not.
my $module = 'PDL';
my $msg = qq{Cannot find $module. }
. qq{$class is not $module aware on your computer};
if (not eval "use $module; 1") { plan skip_all => $msg };
subtest "$class internal functions" => sub {
# _cat_array_of_piddles
my @vals = (0..2);
my $vals = $class->_cat_array_of_piddles(@vals);
is( $vals->ndims, 1, 'ndims of cat topdl with scalars');
ok_all( $vals == pdl( [ 0, 1, 2 ] ),
'cat topdl with scalars',
);
@vals = map {pdl([$_])} (0..2);
$vals = $class->_cat_array_of_piddles(@vals);
is( $vals->ndims, 2, 'ndims of cat topdl with pdl([scalar])' );
ok_all( $vals == pdl( [ [0], [1], [2], ] ),
'cat topdl with scalars',
);
@vals = map {pdl([[$_, 1], [7]])} (0..2);
$vals = $class->_cat_array_of_piddles(@vals);
is( $vals->ndims, 3, 'cat of 2dim' );
@vals =( 6, pdl( [[5, 7], [1, 2]] ) );
$vals = $class->_cat_array_of_piddles(@vals);
ok_all( $vals == pdl( [[6, 6], [6, 6]],
[[5, 7], [1, 2]],
),
'cat topdl scalar, 2dim 4elem pdl',
) or diag $vals;
@vals = ( pdl([[11],[21]]), pdl([[11, 12]]));
$vals = $class->_cat_array_of_piddles(@vals);
ok_all( $vals == pdl( [[11, 11], [21, 21]],
[[11, 12], [11, 12]],
),
'cat topdl two 2dim 4elem pdls',
) or diag $vals;
@vals = ( pdl([1]), pdl([]) );
throws_ok { $class->_cat_array_of_piddles(@vals)
} qr/empty/i,
'_cat_array_of_piddles checks for empty piddles';
};
subtest "$class PDL operations" => sub {
my $fe = $class->new();
# Negation:
my $c = $fe->not( 0.4 );
ok( ref $c eq '', 'not scalar: scalar' );
ok( $c == 0.6, 'not scalar: result' );
$c = $fe->not( pdl( 0.4 ) );
isa_ok( $c, 'PDL', 'not(PDL scalar)' );
ok( $c == 0.6, 'not(PDL scalar): result' );
$c = $fe->not( pdl([0.4, 0.5], [0, 1]) );
isa_ok( $c, 'PDL', 'not(PDL 2elem)' );
ok_all( $c == pdl([0.6, 0.5], [1, 0]), 'not(PDL 2elem): result' );
# And and or use _cat_array_of_piddles
# to bring input to the same dimensions
# And
$c = $fe->and( 0.4, pdl( [0.5] ) );
isa_ok( $c, 'PDL', 'and(scalar, PDL)' );
ok_all( $c == 0.4, 'and(scalar, PDL): result' );
$c = $fe->and( 0.6, pdl( [0.5, 0.7] ) );
isa_ok( $c, 'PDL', 'and(scalar, 2elem PDL)' );
ok_all( $c == pdl([0.5, 0.6]), 'and(scalar, 2elem PDL): result' );
# Or
$c = $fe->or( 0.4, pdl( [0.5] ) );
isa_ok( $c, 'PDL', 'or(scalar, PDL)' );
ok_all( $c == 0.5, 'or(scalar, PDL): result' );
$c = $fe->or( 0.6, pdl( [0.5, 0.7] ) );
isa_ok( $c, 'PDL', 'or(scalar, 2elem PDL)' );
ok_all( $c == pdl([0.6, 0.7]), 'or(scalar, 2elem PDL): result' );
};
my $fe = a_fuzzyEngine();
my %set_pars = ( fuzzyEngine => $fe,
variable => a_variable( $fe ),
name => 'few',
memb_fun => [[7, 8] => [0, 1]],
);
subtest "$set_class PDL degree" => sub {
my $s = $set_class->new(%set_pars);
is( $s->degree, 0, 'Initial (internal) membership degree is 0' );
$s->degree( pdl(0.2) );
is( $s->degree, 0.2, 'degree can be set by assignment of a piddle' );
isa_ok( $s->degree, 'PDL', '$s->degree' );
$s->degree( 0.1 );
is( $s->degree, 0.2, 'Disjunction of last and new degree (1)' );
$s->degree( 0.3 );
is( $s->degree, 0.3, 'Disjunction of last and new degree (2)' );
isa_ok( $s->degree, 'PDL', '$s->degree after recalculation' );
$s->reset();
is( ref $s->degree, '', 'reset makes degree a scalar again' );
$s->degree( 0.3, pdl([0.5, 0.2]) );
ok_all( $s->degree == pdl([0.3, 0.2] ),
'Conjunction of multiple inputs ("and" operation)',
);
local $set_pars{memb_fun} = pdl( [[7, 8] => [0, 1]] );
throws_ok{ $set_class->new(%set_pars)
} qr/array ref/, 'Checks pureness of membership function';
};
subtest "$set_class PDL _interpol & fuzzify" => sub {
local $set_pars{memb_fun} = [ [0.2, 0.3, 0.8, 1.0], # x
[0.1, 0.5, 0.5, 0.0], # y
];
my $s = $set_class->new(%set_pars);
# fuzzify some values
# (no extrapolation in this test case)
my $x = pdl(0.2, 0.25, 0.3, 0.5, 0.8, 0.90, 1);
my $expected = pdl(0.1, 0.30, 0.5, 0.5, 0.5, 0.25, 0 );
my $got = $s->fuzzify( $x );
isa_ok( $got, 'PDL', 'What fuzzify (_interpol) returns' );
ok_all( $got == $expected, 'fuzzify' ) or diag $got;
};
subtest "$var_class fuzzification with piddles" => sub {
my $v = $var_class->new( $fe,
0 => 10,
'low' => [ 3, 1, 6, 0],
'med' => [ 5, 0.5],
'high' => [ -5, 0, 15, 1],
);
my $vals = pdl( [10, 5]);
$v->fuzzify( $vals );
isa_ok( $v->low, 'PDL', 'What $v->low returns' );
ok_all( $v->low == pdl([ 0, 1/3]), '$v->low' ); # :-))
ok_all( $v->med == pdl([0.5, 0.5]), '$v->med' );
ok_all( $v->high == pdl([3/4, 1/2]), '$v->high' );
};
subtest "$var_class defuzzification with piddles" => sub {
my $v = AI::FuzzyEngine::Variable
->new( $fe,
0 => 2,
low => [0 => 1, 1 => 1, 1.00001 => 0, 2 => 0],
high => [0 => 0, 1 => 0, 1.00001 => 1, 2 => 1],
);
$v->low( pdl(1, 0, 1) );
$v->high( 0.5 ); # non pdl
my $val = $v->defuzzify;
isa_ok( $val, 'PDL', 'What $v->defuzzify returns from scalar+pdl' );
my @size = $val->dims;
is_deeply( \@size, [3], 'dimensions' );
$v->reset;
$v->low( pdl(1, 0, 1) );
$v->high( pdl(0, 0.5, 0.5) );
my $val_got = $v->defuzzify;
my $val_exp = pdl( 0.5, 1.5, 0.83 );
ok_all( abs($val_got-$val_exp) < 0.1, 'defuzzify a piddle' );
# Performance: Run testfile by nytprofiler
$v->reset;
my $n =100;
$v->low( random($n) );
$v->high( 1-$v->low );
lives_ok { $val_got = $v->defuzzify; } "Defuzzifying $n elements";
};
subtest 'PDL synopsis' => sub {
# use PDL;
# use AI::FuzzyEngine;
# (Probably a stupide example)
my $fe = AI::FuzzyEngine->new();
# Declare variables as usual
my $severity = $fe->new_variable( 0 => 10,
low => [0, 1, 3, 1, 5, 0 ],
high => [ 3, 0, 5, 1, 10, 1],
);
my $threshold = $fe->new_variable( 0 => 1,
low => [0, 1, 0.2, 1, 0.8, 0, ],
high => [ 0.2, 0, 0.8, 1, 1, 1],
);
my $problem = $fe->new_variable( -0.5 => 2,
no => [-0.5, 0, 0, 1, 0.5, 0, 1, 0],
yes => [ 0, 0, 0.5, 1, 1, 1, 1.5, 1, 2, 0],
);
# Input data is a pdl of arbitrary dimension
my $data = pdl( [0, 4, 6, 10] );
$severity->fuzzify( $data );
# Membership degrees are piddles now:
# print 'Severity is high: ', $severity->high, "\n";
# [0 0.5 1 1]
# Other variables might be a piddle of other dimensions,
# but variables must be extensible to a common 'wrapping' piddle
# ( in this case a 4x2 matrix with 4 colums and 2 rows)
my $level = pdl( [0.6],
[0.2],
);
$threshold->fuzzify( $level );
# print 'Threshold is low: ', $threshold->low(), "\n";
# [
# [0.33333333]
# [ 1]
# ]
# Apply the rule base
# --> no for loops, no explicit expansion, ...
$problem->yes( $severity->high, $threshold->low );
$problem->no( $fe->not( $problem->yes ) );
# print 'Problem yes: ', $problem->yes, "\n";
# [
# [ 0 0.33333333 0.33333333 0.33333333]
# [ 0 0.5 1 1]
# ]
# Defuzzify the output variables
# Caveat: This includes some non-threadable operations up to now
my $problem_ratings = $problem->defuzzify();
# print 'Problems rated: ', $problem_ratings;
# [
# [ 0 0.60952381 0.60952381 0.60952381]
# [ 0 0.75 1 1]
# ]
ok( 1, 'POD synopsis' );
};
done_testing();
sub ok_all {
my ($p, $descr) = @_;
die 'First arg must be a piddle' unless ref $p eq 'PDL';
ok( $p->all() , $descr || '' );
}
sub a_variable {
# Careful!
# a_variable does not register its result into $fuzzyEngine.
# ==> is missing in $fe->variables;
#
my ($fuzzyEngine, @pars) = @_;
my $v = var_class()->new( $fuzzyEngine,
0 => 1,
'low' => [0, 0],
'high' => [1, 1],
@pars,
);
return $v;
}
sub a_fuzzyEngine { return $class->new() }
1;
view release on metacpan - search on metacpan
( run in 2.168 seconds using v1.00-cache-2.02-grep-82fe00e-cpan-72ae3ad1e6da )