AI-FuzzyEngine
view release on metacpan or search on metacpan
lib/AI/FuzzyEngine.pm view on Meta::CPAN
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
lib/AI/FuzzyEngine/Set.pm view on Meta::CPAN
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 );
lib/AI/FuzzyEngine/Set.pm view on Meta::CPAN
$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];
lib/AI/FuzzyEngine/Set.pm view on Meta::CPAN
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];
lib/AI/FuzzyEngine/Set.pm view on Meta::CPAN
$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;
lib/AI/FuzzyEngine/Set.pm view on Meta::CPAN
$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
lib/AI/FuzzyEngine/Set.pm view on Meta::CPAN
$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
lib/AI/FuzzyEngine/Variable.pm view on Meta::CPAN
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)) {
lib/AI/FuzzyEngine/Variable.pm view on Meta::CPAN
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 );
lib/AI/FuzzyEngine/Variable.pm view on Meta::CPAN
$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;
lib/AI/FuzzyEngine/Variable.pm view on Meta::CPAN
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 ];
}
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"' );
t/01-fuzzyEngine.t view on Meta::CPAN
# 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] ];
t/01-fuzzyEngine.t view on Meta::CPAN
);
$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 );
t/01-fuzzyEngine.t view on Meta::CPAN
);
$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',
);
t/01-fuzzyEngine.t view on Meta::CPAN
[ [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 );
t/01-fuzzyEngine.t view on Meta::CPAN
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' );
t/01-fuzzyEngine.t view on Meta::CPAN
);
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!
t/01-fuzzyEngine.t view on Meta::CPAN
'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] ],
t/01-fuzzyEngine.t view on Meta::CPAN
[ [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];
t/01-fuzzyEngine.t view on Meta::CPAN
);
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],
t/01-fuzzyEngine.t view on Meta::CPAN
$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',
t/01-fuzzyEngine.t view on Meta::CPAN
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',
);
t/01-fuzzyEngine.t view on Meta::CPAN
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
t/01-fuzzyEngine.t view on Meta::CPAN
# 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',
);
t/02-fuzzyEngine-pdl_aware.t view on Meta::CPAN
'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' );
t/02-fuzzyEngine-pdl_aware.t view on Meta::CPAN
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)' );
t/02-fuzzyEngine-pdl_aware.t view on Meta::CPAN
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
t/02-fuzzyEngine-pdl_aware.t view on Meta::CPAN
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],
t/02-fuzzyEngine-pdl_aware.t view on Meta::CPAN
# [
# [ 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;
( run in 0.285 second using v1.01-cache-2.11-cpan-4d50c553e7e )