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
|