view release on metacpan or  search on metacpan

lib/AI/FuzzyEngine/Set.pm  view on Meta::CPAN

    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;