File Coverage

blib/lib/AI/FuzzyEngine/Set.pm
Criterion Covered Total %
statement 224 226 99.1
branch 51 60 85.0
condition 4 9 44.4
subroutine 30 30 100.0
pod 0 15 0.0
total 309 340 90.8


line stmt bran cond sub pod time code
1             package AI::FuzzyEngine::Set;
2            
3 3     3   230968 use 5.008009;
  3         13  
  3         123  
4 3     3   1648 use version 0.77; our $VERSION = version->declare('v0.2.2');
  3         6973  
  3         21  
5            
6 3     3   298 use strict;
  3         6  
  3         76  
7 3     3   16 use warnings;
  3         5  
  3         84  
8 3     3   17 use Carp;
  3         6  
  3         232  
9 3     3   17 use Scalar::Util qw(blessed weaken);
  3         5  
  3         159  
10 3     3   18 use List::MoreUtils;
  3         4  
  3         7667  
11            
12             sub new {
13 144     144 0 9595 my ($class, @pars) = @_;
14 144         598 my $self = bless {}, $class;
15            
16 144         398 $self->_init(@pars);
17            
18 143         563 return $self;
19             }
20            
21 1     1 0 598 sub name { shift->{name} }
22 1     1 0 5 sub variable { shift->{variable} }
23 43     43 0 180 sub fuzzyEngine { shift->{fuzzyEngine} }
24 184     184 0 1535 sub memb_fun { shift->{memb_fun} }
25            
26             sub degree {
27 74     74 0 111 my ($self, @vals) = @_;
28            
29 74 100       152 if (@vals) {
30             # Multiple input degrees are conjuncted:
31 21         54 my $and_degree = $self->fuzzyEngine->and( @vals );
32            
33             # Result counts against (up to now) best hit
34 21         74 my $last_degree = $self->{degree};
35 21         43 $self->{degree} = $self->fuzzyEngine->or( $last_degree, $and_degree );
36             };
37            
38 74         325 return $self->{degree};
39             }
40            
41             # internal helpers, return @x and @y from the membership functions
42 372     372   556 sub _x_of ($) { return @{shift->[0]} };
  372         1128  
43 237     237   433 sub _y_of ($) { return @{shift->[1]} };
  237         636  
44            
45             sub _init {
46 144     144   728 my ($self, %pars) = @_;
47 144         788 my %defaults = ( name => '',
48             value => 0,
49             memb_fun => [[]=>[]], # \@x => \@y
50             variable => undef,
51             fuzzyEngine => undef,
52             );
53            
54 144         837 my %attrs = ( %defaults, %pars );
55            
56 144         267 my $class = 'AI::FuzzyEngine';
57 144 50 33     1191 croak "fuzzyEngine is not a $class"
58             unless blessed $attrs{fuzzyEngine} && $attrs{fuzzyEngine}->isa($class);
59            
60 144         220 $class = 'AI::FuzzyEngine::Variable';
61 144 50 33     1002 croak "variable is not a $class"
62             unless blessed $attrs{variable} && $attrs{variable}->isa($class);
63            
64 144 50       404 croak 'Membership function is not an array ref'
65             unless ref $attrs{memb_fun} eq 'ARRAY';
66            
67 144         1021 $self->{$_} = $attrs{$_} for qw( variable fuzzyEngine name memb_fun);
68 144         794 weaken $self->{$_} for qw( variable fuzzyEngine );
69            
70 144         256 $self->{degree} = 0;
71            
72 144         320 my @x = _x_of $self->memb_fun;
73 144 100       920 croak 'No double interpolation points allowed'
74             if List::MoreUtils::uniq( @x ) < @x;
75            
76 143         769 $self;
77             }
78            
79             sub _copy_fun {
80 37     37   2070 my ($class, $fun) = @_;
81 37         43 my @x = @{$fun->[0]}; # my @x = _x_of $fun;, improve speed
  37         98  
82 37         43 my @y = @{$fun->[1]};
  37         86  
83 37         130 return [ \@x => \@y ];
84             }
85            
86             sub _interpol {
87 67     67   119 my ($class, $fun, $val_x) = @_;
88            
89 67         74 my @x = @{$fun->[0]}; # speed
  67         158  
90 67         80 my @y = @{$fun->[1]};
  67         141  
91            
92 67 50       161 if (not ref $val_x eq 'PDL') {
93            
94 67 100       173 return $y[ 0] if $val_x <= $x[ 0];
95 57 100       131 return $y[-1] if $val_x >= $x[-1];
96            
97             # find block
98 49         70 my $ix = 0;
99 49   66     404 $ix++ while $val_x > $x[$ix] && $ix < $#x;
100             # firstidx takes longer (156ms vs. 125ms with 50_000 calls)
101             # my $ix = List::MoreUtils::firstidx { $val_x <= $_ } @x;
102            
103             # interpolate
104 49         117 my $fract = ($val_x - $x[$ix-1]) / ($x[$ix] - $x[$ix-1]);
105 49         110 my $val_y = $y[$ix-1] + $fract * ($y[$ix] - $y[$ix-1]);
106            
107 49         202 return $val_y;
108             };
109            
110 0         0 my ($val_y) = $val_x->interpolate( PDL->pdl(@x), PDL->pdl(@y) );
111 0         0 return $val_y;
112             }
113            
114             # Some functions are not marked private (using leading '_')
115             # but should be used by AI::FuzzyEngine::Variable only:
116            
117             sub set_x_limits {
118 143     143 0 6551 my ($class, $fun, $from, $to) = @_;
119            
120 143         295 my @x = _x_of $fun;
121 143         290 my @y = _y_of $fun;
122            
123 143 50       343 return $fun unless @x;
124            
125 143 100       343 if (@x == 1) {
126             # Explicitly deal with this case to allow recursive removing of points
127 109         275 $fun->[0] = [$from => $to];
128 109         305 $fun->[1] = [ @y[0, 0] ];
129 109         448 return $fun;
130             }
131            
132 34 100       101 if ($x[0] > $from) {
    100          
133 11         23 unshift @x, $from;
134 11         19 unshift @y, $y[0];
135             }
136             elsif ($x[0] < $from) {
137            
138             # Check for @x > 1 allows to use $x[1]
139 8 100       22 if ($x[1] <= $from) {
140             # Recursive call with removed left border
141 2         2 shift @{$fun->[0]};
  2         4  
142 2         4 shift @{$fun->[1]};
  2         4  
143 2         18 $class->set_x_limits( $fun, $from => $to );
144            
145             # update @x and @y for further calculation
146 2         4 @x = _x_of $fun;
147 2         4 @y = _y_of $fun;
148             }
149             else {
150 6         11 $x[0] = $from;
151 6         21 $y[0] = $class->_interpol( $fun => $from );
152             };
153            
154             };
155            
156 34 100       123 if ($x[-1] < $to) {
    100          
157 11         22 push @x, $to;
158 11         20 push @y, $y[-1];
159             }
160             elsif ($x[-1] > $to) {
161            
162             # Check for @x > 1 allows to use $x[-2]
163 7 100       15 if ($x[-2] >= $to) {
164             # Recursive call with removed right border
165 2         3 pop @{$fun->[0]};
  2         5  
166 2         3 pop @{$fun->[1]};
  2         3  
167 2         18 $class->set_x_limits( $fun, $from => $to );
168            
169             # update @x and @y for further calculation
170 2         5 @x = _x_of $fun;
171 2         6 @y = _y_of $fun;
172             }
173             else {
174 5         9 $x[-1] = $to;
175 5         14 $y[-1] = $class->_interpol( $fun => $to );
176             };
177            
178             };
179            
180 34         76 $fun->[0] = \@x;
181 34         65 $fun->[1] = \@y;
182 34         112 return $fun;
183             }
184            
185             sub synchronize_funs {
186 22     22 0 7814 my ($class, $funA, $funB) = @_;
187             # change $funA, $funB directly, use their references
188             # \@x and \@y as part of $fun will be replaced nevertheless
189            
190 22         45 my @xA = _x_of $funA;
191 22         49 my @yA = _y_of $funA;
192 22         46 my @xB = _x_of $funB;
193 22         47 my @yB = _y_of $funB;
194            
195 22 100       84 croak '$funA is empty' unless @xA;
196 21 50       42 croak '$funB is empty' unless @xB;
197            
198             # Find and add missing points
199 21         26 my (%yA_of, %yB_of);
200 21         61 @yA_of{@xA} = @yA;
201 21         56 @yB_of{@xB} = @yB;
202            
203 21         25 my (%xA, %xB);
204 21         51 @xA{@xA} = 1;
205 21         39 @xB{@xB} = 1;
206            
207             MISSING_IN_A:
208 21         37 for my $x (@xB) {
209 76 100       176 next MISSING_IN_A if exists $xA{$x};
210 11         37 $yA_of{$x} = $class->_interpol( $funA => $x );
211             };
212            
213             MISSING_IN_B:
214 21         42 for my $x (@xA) {
215 78 100       179 next MISSING_IN_B if exists $xB{$x};
216 13         33 $yB_of{$x} = $class->_interpol( $funB => $x );
217             };
218            
219             # Sort them and put them back to the references of $funA and $funB
220             # (Sort is necessary even if no crossings exist)
221 21         86 my @x = sort {$a<=>$b} keys %yA_of;
  115         247  
222 21         67 @yA = @yA_of{@x};
223 21         54 @yB = @yB_of{@x};
224            
225             # Assign to fun references (needed within CHECK_CROSSING)
226 21         41 $funA->[0] = \@x;
227 21         54 $funA->[1] = \@yA;
228 21         39 $funB->[0] = \@x;
229 21         39 $funB->[1] = \@yB;
230            
231             # Any crossing between interpolation points
232 21         80 my $found;
233             CHECK_CROSSING:
234 21         44 for my $ix (1..$#xA) {
235 57         92 my $dy1 = $yB[$ix-1] - $yA[$ix-1];
236 57         78 my $dy2 = $yB[$ix] - $yA[$ix];
237 57 100       162 next CHECK_CROSSING if $dy1 * $dy2 >= 0;
238            
239 10         14 $found++;
240 10         31 my $dx = $xA[$ix] - $xA[$ix-1];
241 10         29 my $x = $xA[$ix-1] + $dx * $dy1 / ($dy1-$dy2);
242 10         31 my $y = $class->_interpol( $funA => $x );
243 10         65 $yA_of{$x} = $y;
244 10         33 $yB_of{$x} = $y;
245             };
246            
247 21 100       52 if ($found) {
248             # Rest of procedure is known (and necessary)
249 8         29 @x = sort {$a<=>$b} keys %yA_of;
  72         122  
250 8         29 @yA = @yA_of{@x};
251 8         23 @yB = @yB_of{@x};
252            
253 8         14 $funA->[0] = \@x;
254 8         15 $funA->[1] = \@yA;
255 8         13 $funB->[0] = \@x;
256 8         12 $funB->[1] = \@yB;
257             };
258            
259 21         122 return;
260             };
261            
262             sub _max_of {
263 19     19   29 my ($factor, $ar, $br) = @_;
264 19         20 my @y;
265 19         49 for my $ix ( reverse 0..$#$ar ) {
266 92 100       206 my $max = $ar->[$ix] * $factor > $br->[$ix] * $factor ?
267             $ar->[$ix] : $br->[$ix];
268 92         152 $y[$ix] = $max;
269             };
270 19         79 return @y;
271             }
272            
273             sub _minmax_of_pair_of_funs {
274 19     19   35 my ($class, $factor, $funA, $funB) = @_;
275             # $factor > 0: 'max' operation
276             # $factor < 0: 'min' operation
277            
278             # synchronize interpolation points (original functions are changed)
279 19         45 $class->synchronize_funs( $funA, $funB );
280            
281 19         37 my @x = _x_of $funA;
282 19         50 my @yA = _y_of $funA;
283 19         47 my @yB = _y_of $funB;
284             # my @y = List::MoreUtils::pairwise { $a*$factor > $b*$factor ?
285             # $a : $b
286             # } @yA, @yB;
287            
288 19         70 my @y = _max_of( $factor, \@yA, \@yB ); # faster than pairwise
289            
290 19         78 return [ \@x, \@y ];
291             }
292            
293             sub _minmax_of_funs {
294 36     36   70 my ($class, $factor, $funA, @moreFuns) = @_;
295 36 100       232 return $funA unless @moreFuns;
296            
297 19         26 my $funB = shift @moreFuns;
298 19         53 my $fun = $class->_minmax_of_pair_of_funs( $factor, $funA, $funB );
299            
300             # solve recursively
301 19         57 return $class->_minmax_of_funs( $factor, $fun, @moreFuns );
302             }
303            
304             sub min_of_funs {
305 12     12 0 2646 my ($class, @funs) = @_;
306             # Copy can not moved to _minmax_of_funs (is recursively called)
307 12         24 my @copied_funs = map { $class->_copy_fun($_) } @funs;
  25         58  
308 12         38 return $class->_minmax_of_funs( -1, @copied_funs );
309             }
310            
311             sub max_of_funs {
312 5     5 0 13 my ($class, @funs) = @_;
313             # Copy can not moved to _minmax_of_funs (is recursively called)
314 5         11 my @copied_funs = map { $class->_copy_fun($_) } @funs;
  11         25  
315 5         18 return $class->_minmax_of_funs( 1, @copied_funs );
316             }
317            
318             sub clip_fun {
319 10     10 0 2777 my ($class, $fun, $max_y) = @_;
320            
321             # clip by min operation on function $fun
322 10         19 my @x = _x_of $fun;
323 10         36 my @y = ( $max_y ) x @x;
324 10         24 my $fun_limit = [ \@x => \@y ];
325 10         31 return $class->min_of_funs( $fun, $fun_limit );
326             }
327            
328             sub centroid {
329 8     8 0 2793 my ($class, $fun) = @_;
330            
331             # x and y values, check
332 8         16 my @x = _x_of $fun;
333 8         18 my @y = _y_of $fun;
334 8 50       29 croak "At least two points needed" if @x < 2;
335            
336             # using code fragments from Ala Qumsieh (AI::FuzzyInference::Set)
337            
338             # Left
339 8         14 my $x0 = shift @x;
340 8         14 my $y0 = shift @y;
341            
342 8         11 my (@areas, $x1, $y1);
343            
344             AREA:
345 8         22 while (@x) {
346             # Right egde of area
347 24         30 $x1 = shift @x;
348 24         35 $y1 = shift @y;
349            
350             # Each area is build of a rectangle and a top placed triangle
351             # Each of them might have a height of zero
352            
353             # Area and local centroid of base rectangle
354 24 100       61 my $a1 = abs(($x1 - $x0) * ($y0 < $y1 ? $y0 : $y1));
355 24         38 my $c1 = $x0 + 0.5 * ($x1 - $x0);
356            
357             # Area and local centroid of triangle on top of rectangle
358 24         99 my $a2 = abs(0.5 * ($x1 - $x0) * ($y1 - $y0));
359 24 100       53 my $c2 = (1/3) * ($x0 + $x1 + ($y1 > $y0 ? $x1 : $x0));
360            
361             # Total area of block
362 24         32 my $ta = $a1 + $a2;
363 24 100       53 next AREA if $ta == 0;
364            
365             # Total centroid of block
366 20         34 my $c = ( $c1*$a1 + $c2*$a2 ) / $ta;
367            
368             # Store them for final calculation of average
369 20         50 push @areas, [$c, $ta];
370             }
371             continue {
372             # Left edge of next area
373 24         65 ($x0, $y0) = ($x1, $y1);
374             };
375            
376             # Sum of area
377 8         10 my $ta = 0;
378 8         36 $ta += $_->[1] for @areas;
379            
380 8 50       18 croak "Function has no height --> no centroid" unless $ta;
381            
382             # Final Centroid in x direction
383 8         12 my $c = 0;
384 8         31 $c += $_->[0] * $_->[1] for @areas;
385 8         41 return $c / $ta;
386             }
387            
388             sub fuzzify {
389 22     22 0 886 my ($self, $val) = @_;
390            
391 22         46 my $fun = $self->memb_fun;
392 22         55 croak "No valid membership function"
393 22 50       26 unless @{$fun->[0]}; # at least one x
394            
395 22         51 return $self->{degree} = $self->_interpol( $fun => $val );
396             }
397            
398             sub reset {
399 29     29 0 35 my ($self) = @_;
400 29         39 $self->{degree} = 0;
401 29         84 $self;
402             }
403            
404             # Replace a membership function
405             # To be called by variable->change_set( 'setname' => $new_fun );
406             sub replace_memb_fun {
407 3     3 0 9 my ($self, $new_fun) = @_;
408 3         8 $self->{memb_fun} = $new_fun;
409 3         11 return;
410             }
411            
412             1;
413            
414             =pod
415            
416             =head1 NAME
417            
418             AI::FuzzyEngine::Set - Class used by AI::FuzzyEngine.
419            
420             =head1 DESCRIPTION
421            
422             Please see L for a description.
423            
424             =head1 SUPPORT
425            
426             You can find documentation for this module with the perldoc command.
427            
428             perldoc AI::FuzzyEngine
429            
430             =head1 AUTHOR
431            
432             Juergen Mueck, jmueck@cpan.org
433            
434             =head1 COPYRIGHT
435            
436             Copyright (c) Juergen Mueck 2013. All rights reserved.
437            
438             This library is free software; you can redistribute it and/or
439             modify it under the same terms as Perl itself.
440            
441             =cut