view release on metacpan or  search on metacpan

lib/Math/BSpline/Basis.pm  view on Meta::CPAN

package Math::BSpline::Basis;
$Math::BSpline::Basis::VERSION = '0.002';
use 5.014;
use warnings;

# ABSTRACT: B-spline basis functions

use Moo 2.002005;
use List::Util 1.26 ('min');
use Ref::Util 0.010 (
    'is_ref',
    'is_plain_hashref',
    'is_blessed_hashref',
    'is_plain_arrayref',
);


around BUILDARGS => sub {
    my ($orig, $class, @args) = @_;
    my $munged_args;

    if (@args == 1) {
        if (!is_ref($args[0])) {
            # We do not understand this and dispatch to Moo (if this
            # is what $orig does, the docu is very sparse).
            return $class->$orig(@args);
        }
        elsif (
            is_plain_hashref($args[0])
            or
            is_blessed_hashref($args[0])
        ) {
            # I am trying to stay as close to Moo's default behavior
            # as I can, this is the only reason why I am supporing
            # hashrefs at all. And since Moo apparently accepts
            # blessed references, I do the same. However, I make a
            # copy, blessed or not.
            #
            # The ugly test is due to an announced change in the
            # behavior of Ref::Util. is_hashref is going to behave
            # like is_plain_hashref does now.  However, the planned
            # replacement called is_any_hashref is not there. So the
            # only future-safe implementation seems to be to use
            # both explicit functions.
            $munged_args = {%{$args[0]}};
        }
        else {
            # We do not understand this and dispatch to Moo (if this
            # is what $orig does, the docu is very sparse).
            return $class->$orig(@args);
        }
    }
    elsif (@args % 2 == 1) {
        # We do not understand this and dispatch to Moo (if this
        # is what $orig does, the docu is very sparse).
        return $class->$orig(@args);
    }
    else {
        $munged_args = {@args};
    }

    if (exists($munged_args->{knot_vector})) {
        # degree is mandatory, so we only deal with the case when it
        # is there. Otherwise we just let Moo do its job.
        if (exists($munged_args->{degree})) {
            # We do not perform any type validation etc, if the
            # attributes are there, we use them assuming that they
            # are valid.
            my $p           = $munged_args->{degree};
            my $U           = $munged_args->{knot_vector};
            my $is_modified = 0;

            # deal with empty array
            if (!defined($U) or !is_plain_arrayref($U) or @$U == 0) {
                $U = [
                    (map { 0 } (0..$p)),
                    (map { 1 } (0..$p)),
                ];
                $is_modified = 1;
            }

            # deal with unsorted
            for (my $i=1;$i<@$U;$i++) {
                if ($U->[$i] < $U->[$i-1]) {
                    $U           = [sort { $a <=> $b } @$U];
                    $is_modified = 1;
                    last;
                }
            }

            # deal with first breakpoint
            for (my $i=1;$i<=$p;$i++) {
                if ($i == @$U or $U->[$i] != $U->[$i-1]) {
                    $U = [@$U] if (!$is_modified);
                    unshift(@$U, $U->[0]);
                    $is_modified = 1;
                }
            }

            # deal with last breakpoint