ufunc.t

use strict;
use warnings;
use Test::More;
use PDL::LiteF;
use PDL::Types;
use Test::PDL;

my $p = pdl([]); $p->setdims([1,0]); $p->qsortvec; # shouldn't segfault!
my $p2d  = pdl([[1,2],[3,4],[1,3],[1,2],[3,3]]);
is $p2d->dice_axis(1,$p2d->qsortveci).'', $p2d->qsortvec.'', "qsortveci";

my $ind_double = zeroes($p2d->dim(1));
$p2d->qsortveci($ind_double); # shouldn't segfault!
is $ind_double.'', '[3 0 2 4 1]';

eval { empty()->medover }; # shouldn't segfault
isnt $@, '', 'exception for percentile on empty ndarray';

eval { sequence(3, 3)->medover(my $o = null, my $t = null); };
isnt $@, '', 'a [t] Par cannot be passed';

my $med_dim = 5;
is_pdl sequence(10,$med_dim,$med_dim)->medover, sequence($med_dim,$med_dim)*10+4.5, 'medover';

my $x = pdl(0,0,6,3,5,0,7,14,94,5,5,8,7,7,1,6,7,13,10,2,101,19,7,7,5);  # sf.net bug #2019651
# Test a range of values
is_pdl $x->pctover(-0.5), pdl(0), "pct below 0 for 25-elem pdl";
is_pdl $x->pctover( 0.0), pdl(0), "pct equal 0 for 25-elem pdl";
is_pdl $x->pctover( 0.9), pdl(17), "pct equal 0.9 for 25-elem pdl [SF bug 2019651]";
is_pdl $x->pctover( 1.0), pdl(101), "pct equal 1 for 25-elem pdl";
is_pdl $x->pctover( 2.0), pdl(101), "pct above 1 for 25-elem pdl";

is_pdl sequence(10)->pctover(0.2 ), pdl(1.8), "20th percentile of 10-elem ndarray [SF bug 2753869]";
is_pdl sequence(10)->pctover(0.23), pdl(2.07), "23rd percentile of 10-elem ndarray [SF bug 2753869]";

ok( ( eval { pdl([])->qsorti }, $@ eq '' ), "qsorti coredump,[SF bug 2110074]");

for (
  [
    pdl(0,0,6,3,5,0,7,14,94,5,5,8,7,7,1,6,7,13,10,2,101,19,7,7,5),
    pdl('0 0 0 1 2 3 5 5 5 5 6 6 7 7 7 7 7 7 8 10 13 14 19 94 101'),
  ], # sf.net bug #2019651
  [ pdl([55]), pdl([55]) ],
  [ pdl(55,55), pdl(55,55) ],
  [ sequence(10)->rotate(1), sequence(10) ],
  [ pdl('0 1 2 BAD 4 5 6 7 8 9'), pdl('0 1 2 4 5 6 7 8 9 BAD') ],
  [ pdl('0 BAD 4'), pdl('0 4 BAD') ],
  [ pdl('BAD 4'), pdl('4 BAD') ],
  [ pdl('[BAD]'), pdl('[BAD]') ],
  [ pdl("0 -100 BAD 100"), pdl('-100 0 100 BAD') ], # test qsort moves values with BAD components to end
  [ pdl('1 2;0 500;2 3;4 2;3 4;3 5'), pdl('0 500;1 2;2 3;3 4;3 5;4 2') ],
  [ pdl('1 2;0 500;2 3;4 BAD;3 4;3 5'), pdl('0 500;1 2;2 3;3 4;3 5;4 BAD') ],
  [ pdl("0 0;-100 0;BAD 0;100 0"), pdl('-100 0; 0 0; 100 0; BAD 0') ], # test qsortvec moves vectors with BAD components to end - GH#252
) {
  my ($in, $exp) = @$_;
  my $meth = $in->ndims > 1 ? 'qsortvec' : 'qsort'; # assume broadcast works
  is_pdl $in->copy->$meth, $exp, "non-inplace qsort $in";
  my $in_copy = $in->copy;
  $in_copy->inplace->$meth;
  is_pdl $in_copy, $exp, "inplace qsort $in";
  $meth .= "i";
  my $inds = $in->$meth;
  is_pdl $in->dice_axis(-1, $inds), $exp, "$in $meth";
}

# Test sf.net bug 379 "Passing qsort an extra argument causes a segfault"
# (also qsorti, qsortvec, qsortveci)
eval { random(15)->qsort(5); };
isnt($@, '', "qsort extra argument");
eval { random(15)->qsorti(5); };
isnt($@, '', "qsorti extra argument");
eval {random(10,4)->qsortvec(5); };
isnt($@, '', "qsortvec extra argument");
eval {random(10,4)->qsortveci(2); };
isnt($@, '', "qsortveci extra argument");
#but the dimension size checks for those cases shouldn't derail trivial qsorts:
is_pdl pdl(5)->qsort, pdl([5]),'trivial qsort';
is_pdl pdl(8)->qsorti, indx([0]),'trivial qsorti';
is_pdl pdl(42,41)->qsortvec, pdl(42,41)->dummy(1),'trivial qsortvec';
is_pdl pdl(53,35)->qsortveci,indx([0]),'trivial qsortveci';

# test for sf.net bug report 3234141 "max() fails on nan"
#   NaN values are handled inconsistently by min, minimum, max, maximum...
#
{
 my $nan = nan();
 my $x = pdl($nan, 0, 1, 2);
 my $y = pdl(0, 1, 2, $nan);

 is "".$x->min, '0', 'min leading nan';
 is "".$y->min, '0', 'min trailing nan';
 is "".$x->max, '2', 'max leading nan';
 is "".$y->max, '2', 'max trailing nan';
 is join(" ", $x->minmax), '0 2', 'minmax leading nan';
 is join(" ", $y->minmax), '0 2', 'minmax trailing nan';
}
my $empty = empty();
is_pdl $empty->maximum, sbyte('BAD'), "max of empty nonbad float gives BAD";
# test bad value handling with max
$empty->badflag(1);
is_pdl $empty->maximum, sbyte('BAD'), "bad flag gets set on max over an empty dim";
is_pdl $empty->magnover, float('BAD'), "bad flag gets set on empty magnover";

is_pdl zeroes(4)->magnover, pdl(0), 'magnover correct for real zeroes';
is_pdl sequence(4)->magnover, pdl(3.741657), 'magnover correct for real sequence';
is_pdl +(sequence(4)+i())->magnover, cdouble(4.242640), 'magnover correct for complex';

#Test subroutines directly.

#set up ndarrays
my $f=pdl(1,2,3,4,5);
my $g=pdl (0,1);
my $h=pdl(1, 0,-1);
my $i=pdl (1,0);
my $j=pdl(-3, 3, -5, 10);

#Test percentile routines
is_pdl $f->pct(.5), pdl(3), 'PDL::pct 50th percentile';
is_pdl $g->pct(.76), pdl(0.76), 'PDL::pct interpolation test';
is_pdl $i->pct(.76), pdl(0.76), 'PDL::pct interpolation not in order test';

is_pdl $f->oddpct(.5), pdl(3), 'PDL::oddpct 50th percentile';
is_pdl $f->oddpct(.79), pdl(4), 'PDL::oddpct intermediate value test';
is_pdl $h->oddpct(.5), pdl(0), 'PDL::oddpct 3-member 50th percentile with negative value';
is_pdl $j->oddpct(.1), pdl(-5), 'PDL::oddpct negative values in-between test';

#Test oddmedian
is_pdl $g->oddmedian, pdl(0), 'Oddmedian 2-value ndarray test';
is_pdl $h->oddmedian, pdl(0), 'Oddmedian 3-value not in order test';
is_pdl $j->oddmedian, pdl(-3), 'Oddmedian negative values even cardinality';

#Test mode and modeover
$x = pdl([1,2,3,3,4,3,2],1);
is_pdl $x->mode, longlong(0), "mode";
is_pdl $x->modeover, longlong(3,0), "modeover";

#the next 4 tests address GitHub issue #248.

#   .... 0000 1010
#   .... 1111 1100
#OR:.... 1111 1110 = -2
is longlong([10,0,-4])->borover(), -2, "borover with no BAD values";

#     .... 1111 1111
#     .... 1111 1010
#     .... 1111 1100
#AND: .... 1111 1000 = -8

is( longlong([-6,~0,-4])->bandover(), -8, "bandover with no BAD values");

#   0000 1010
#   1111 1100
#OR:1111 1110 = 254 if the accumulator in BadCode is an unsigned char
is( pdl([10,0,-4])->setvaltobad(0)->borover(), -2, "borover with BAD values");
#     1111 1010
#     1111 1100
#AND: 1111 1000 = 248 if the accumulator in BadCode is an unsigned char
is( pdl([-6,~0,-4])->setvaltobad(~0)->bandover(), -8, "bandover with BAD values");

#     0000 0110
#     1111 1110
#XOR: 1111 1000 = -8
is( longlong([6, 0, -2])->bxorover(), -8, "bxorover with no BAD values");

is( longlong([6, 0, -2])->setvaltobad(0)->bxorover(), -8, "bxorover with BAD values");
is( longlong([6, 0, -2])->bxor(), -8, "bxor");

is( longlong([-1, 0, 2])->xorover(), 0, "xorover with no BAD values");
is( longlong([-1, 0, 2])->setvaltobad(0)->xorover(), 0, "xorover with BAD values");
is( longlong([-1, 0, 2])->xorall(), 0, "xorall");

{
  # all calls to functions that handle finding minimum and maximum should return
  # the same values (i.e., BAD).  NOTE: The problem is that perl scalar values
  # have no 'BAD' values while pdls do.  We need to sort out and document the
  # differences between routines that return perl scalars and those that return
  # pdls.
  my $bad_0dim = pdl(q|BAD|);
  is( "". $bad_0dim->min, 'BAD', "does min returns 'BAD'" );
  isnt( "". ($bad_0dim->minmax)[0], "". $bad_0dim->min, "does minmax return same as min" );
  is( "". ($bad_0dim->minmaximum)[0],  "". $bad_0dim->min, "does minmaximum return same as min" );
}

is ushort(65535)->max, 65535, 'max(highest ushort value) should not be BAD';

{
  is_pdl empty(indx)->long->avg, long(0), "avg of long Empty";
  is_pdl empty(indx)->double->average, nan(), "average double Empty";
}

# provide independent copies of test data.
sub X { PDL->pdl( [ [ 5, 4, 3 ], [ 2, 3, 1.5 ] ] ) }

is_pdl X->average(),  PDL->pdl( [ 4,  2.1666666 ] ), "average";
is_pdl X->sumover(),  PDL->pdl( [ 12, 6.5 ] ),     "sumover";
is_pdl X->prodover(), PDL->pdl( [ 60, 9 ] ),       "prodover";

# provide independent copies of test data.
sub IM {
    PDL->new(
        [
            [ 1,  2,  3,  3,  5 ],
            [ 2,  3,  4,  5,  6 ],
            [ 13, 13, 13, 13, 13 ],
            [ 1,  3,  1,  3,  1 ],
            [ 10, 10, 2,  2,  2, ]
        ]
    );
}

subtest 'minmax' => sub {
    my @minMax = IM->minmax;
    is $minMax[0], 1,  "minmax min";
    is $minMax[1], 13, "minmax max";
};

is_pdl ones(byte, 3000)->dsumover, pdl(3000);

subtest 'minimum_n_ind' => sub {

    subtest 'usage' => sub {
        my $p = pdl [ 1, 2, 3, 4, 7, 9, 1, 1, 6, 2, 5 ];
        my $q = zeroes 5;
        minimum_n_ind $p, $q;
        is_pdl $q, pdl(indx, 0, 6, 7, 1, 9), "usage 1";
        $q = minimum_n_ind( $p, 5 );
        is_pdl $q, pdl(indx, 0, 6, 7, 1, 9), "usage 2";
        minimum_n_ind( $p, $q = null, 5 );
        is_pdl $q, pdl(indx, 0, 6, 7, 1, 9), "usage 3";
    };

    subtest 'BAD' => sub {
        my $p = pdl '[1 BAD 3 4 7 9 1 1 6 2 5]';
        my $q = zeroes 5;
        minimum_n_ind $p, $q;
        is $q. '', '[0 6 7 9 2]', "BAD";
    };

    subtest 'insufficient good' => sub {
        my $p = pdl '[1 BAD 3 4 BAD BAD]';
        my $q = zeroes 5;
        minimum_n_ind $p, $q;
        is $q. '', '[0 2 3 BAD BAD]', "insufficient good";
    };

    subtest 'bad & good' => sub {
        my $p = pdl '[1 BAD 3 4 BAD BAD 3 1 5 8 9]';
        my $q = zeroes 5;
        minimum_n_ind $p, $q;
        is $q. '', '[0 7 2 6 3]', "some bad, sufficient good";
    }
};

subtest partial => sub {
  my $a = (sequence(4,4) + 2) ** 2;
  is_pdl $a->partial(0), pdl('-8 6 8 -6; -16 14 16 -14;
    -24 22 24 -22; -32 30 32 -30'), "partial(0)";
  is_pdl $a->partial(0,{d=>'f'}), pdl('4 5 7 9; 36 13 15 17;
    100 21 23 25; 196 29 31 33'), "partial(0,f)";
  is_pdl $a->partial(1), pdl('-80 -88 -96 -104; 48 56 64 72;
    80 88 96 104; -48 -56 -64 -72'), "partial(1)";
  is_pdl $a->partial(1,{d=>'f'}), pdl('4 9 16 25; 32 40 48 56;
    64 72 80 88; 96 104 112 120'), "partial(1,f)";
};

subtest numdiff => sub {
  my $a = sequence(5) + 2;
  is_pdl $a->numdiff, pdl(2, 1, 1, 1, 1), "numdiff";
  $a->inplace->numdiff;
  is_pdl $a, pdl(2, 1, 1, 1, 1), "numdiff inplace";
};

subtest diffcentred => sub {
  my $a = sequence(6) + 2;
  is_pdl $a->diffcentred, pdl(-2, 1, 1, 1, 1, -2), "diffcentred";
  is_pdl +($a**2)->diffcentred, pdl('-20 6 8 10 12 -16'), "diffcentred of x^2";
  $a->setbadat(2);
  is_pdl +($a**2)->diffcentred, pdl('-20 BAD 8 BAD 12 -16'), "diffcentred of x^2 with bad";
};

subtest diff2 => sub {
  my $got = pdl('[BAD 2 3 4]')->diff2;
  is "$got", "[2 1 1]", 'first bad';
  $got = pdl('[BAD BAD 3 4]')->diff2;
  is "$got", "[BAD 3 1]", 'first 2 bad';
  $got = pdl('[2 BAD 3 4]')->diff2;
  is "$got", "[BAD 1 1]", 'second bad';
  $got = pdl('[2 3 BAD 4]')->diff2;
  is "$got", "[1 BAD 1]", 'third bad';
  $got = pdl('[2 BAD BAD 4]')->diff2;
  is "$got", "[BAD BAD 2]", 'middle 2 bad';
  $got = pdl('[2 3 4 BAD]')->diff2;
  is "$got", "[1 1 BAD]", 'last bad';
  $got = pdl('[BAD BAD 4]')->diff2;
  is "$got", "[BAD 4]", 'only 1 good';
  $got = pdl('[BAD BAD]')->diff2;
  is "$got", "[BAD]", 'none good';
  eval {empty()->diff2};
  like $@, qr/diff2/, 'empty gives good error';
  $got = pdl(1)->diff2;
  is "$got", "Empty[0]", 'single-element gives empty';
};

subtest intover => sub {
  for ([1,0], [2,0.5], [3,2], [4,4.5], [5,8], [6,12.5], [7,18]) {
    my ($size, $exp) = @$_;
    is_pdl sequence($size)->intover, pdl($exp), "intover $size";
  }
};

subtest firstnonzeroover => sub {
  my $a = pdl '0 0 3 4; 0 5 0 1';
  is_pdl $a->firstnonzeroover, pdl(3, 5), "firstnonzeroover";
};

# Some (!) of these fail when exported:
subtest core_functions => sub {
  ok approx(sin(1), &CORE::sin(1)), 'sin 1';    # !
  ok approx(cos(1), &CORE::cos(1)), 'cos 1';    # !
  ok approx(sqrt(2), &CORE::sqrt(2)), 'sqrt 2'; # !
  ok approx(exp(1), &CORE::exp(1)), 'exp 1';
  ok approx(log(2), &CORE::log(2)), 'log 2';
  ok approx(atan2(1, 1), &CORE::atan2(1, 1)), 'atan2 1, 1';
};

done_testing;