# This tests the new PDL constructor with a string argument.
# There are three goals from the new functionality: (1) to allow
# MATLAB to use familiar syntax to create arrays, (2) to allow
# cut-n-paste of PDL print output as input for scripts and programs,
# and (3) to allow easy ways to construct nan and inf values in ndarrays.
# (4) to allow complex numbers to be round-tripped in native
# complex (i.e. Math::Complex) format

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

isa_ok( pdl("[1,2]"), "PDL", qq{pdl("[1,2]") returns an ndarray} );

# Basic Tests #
ok( all(pdl([1,2])==pdl("[1,2]")), qq{pdl(ARRAY REF) equals pdl("ARRAY REF")});
my $compare = pdl([
	[1, 0, 8],
	[6, 3, 5],
	[3, 0, 5],
	[2, 4, 2]
]);
my $test_string = <<EOPDL;
   [
     [1, 0, 8],
     [6, 3, 5],
     [3, 0, 5],
     [2, 4, 2],
   ]
EOPDL
my $t1 = pdl $test_string;
ok(all(approx($t1, $compare)), "properly interprets good PDL input string");
# See what happens when we remove the end commas
$test_string =~ s/\],/]/g;
my $t2 = pdl $test_string;
ok(all(approx($t2, $compare)), "properly interprets good PDL input string sans ending commas");
my $t3 = pdl '[1, 0, 8; 6, 3, 5; 3, 0, 5; 2, 4, 2]';
ok(all(approx($t3, $compare)), "properly handles semicolons");
my $t4 = pdl "$compare";
ok(all(approx($t4, $compare)), "properly interprets good PDL output string");
my $expected = pdl(1.2e3);
my $got = pdl q[1.2e3];
is($got, $expected, "Correctly interprets [1.2e3]");
$expected = pdl(1.2e3, 4, 5.6e-7);
$got = pdl q[1.2e3 4 5.6e-7];
ok(all($got == $expected), "Correctly interprets [1.2e3 4 5.6e-7]");
$expected = pdl(1.2e3, 4, 5.e-7);
$got = pdl q[1.2e3 4 5.e-7];
ok(all($got == $expected), "Correctly interprets [1.2e3 4 5.e-7]");

for (
  '[i 1-i]',
  ['[-i 1 -i]', qr/(-0)?-i 1 (-0)?-i/],
  ['[-i 1 -i 1]', qr/(-0)?-i 1 (-0)?-i 1/],
  ['[-i 1-i 1]', qr/(-0)?-i 1-i 1/],
  '[i 1+i]',
  ['[i 1 +i]', '[i 1 i]'],
  ['[i 2e+2+i]', '[i 200+i]'],
  ['[i 2e2+i]', '[i 200+i]'],
  '[2i 1-2i]',
  '[2i 1+2i]',
  '[0.5-2i 1.5-2i]',
  '[0.5 0.5-2i 2i 1.5 1.5-2i]',
) {
  my ($input, $expected) = ref($_) ? @$_ : ($_, $_);
  my $got = eval { pdl($input).'' };
  is $@, '', "parsed '$input' with no exception";
  $expected = qr/\A\Q$expected\E\z/ if !ref $expected;
  like $got, $expected, "complex number round-tripped '$input'";
}

# Signs and operators #
# Now some more interesting tests
my $t5 = pdl "[1 -4]";
$compare = pdl [1, -4];
ok(all(approx($t5, $compare)), "properly identifies negative numbers with white-space separation");

my $t6 = pdl "[1 - 4]";
$compare = pdl [1,-4];
ok(all(approx($t6, $compare)), "properly affixes negation operator to right operand");

ok(all(approx(pdl("[1 - .4]"), pdl([1,-0.4]))), "properly handles decimals");

my $t8 = pdl <<EOPDL;
[
	[1,2,3; 4,-5,6]
	[7 +8, 8 + 9; 10, - .11, 12e3]
]
EOPDL

$compare = pdl([[[1,2,3], [4,-5,6]],[[7,8,8,9],[10,-.11,12e3]]]);
ok(all(approx($t8, $compare)), "properly handles all sorts of stuff!");

$compare = pdl [1,2,-5];
my $t9 = pdl '[1  + 2 - 5]';
ok(all(approx($t9, $compare)), "Another operator check for pdl_from_string");

$compare = pdl [1, 2, -5];
my $t10 = pdl '[1  +2 -5]';
ok(all(approx($t10, $compare)), "Yet another operator check for pdl_from_string");

#######################################
# Semicolons as column seperators - 2 #
#######################################

$compare = pdl [[1], [2], [3]];
my $t11 = pdl '[1;2;3]';
ok(all(approx($t11, $compare)), "column check");

$compare = pdl([[1,2,3],[4,5,6]]);
my $t12 = pdl q[1 2 3; 4 5 6];
ok(all(approx($t12, $compare)), "implicit bracketing check");

##################################
# Implicit bracketing checks - 9 #
##################################

$compare = pdl([1,2,3,4]);
my $t13 = pdl q[1 2 3 4];
my $t14 = pdl q[1,2,3,4];
my $t15 = pdl '[1 2 3 4]';
my $t16 = pdl '[1,2,3,4]';

ok(all(approx($t13, $compare)), "Double-check implicit bracketing - no brackets");
ok(all(approx($t14, $compare)), "Double-check implicit bracketing - no brackets and commas");
ok(all(approx($t15, $compare)), "Double-check implicit bracketing - brackets");
ok(all(approx($t16, $compare)), "Double-check implicit bracketing - brackets and commas");

# check dimensions of tests
ok($t13->ndims == 1, "Implicit bracketing gets proper number of dimensions - no brackets, no commas");
ok($t14->ndims == 1, "Implicit bracketing gets proper number of dimensions - no brackets, commas");
ok($t15->ndims == 1, "Implicit bracketing gets proper number of dimensions - brackets, no commas");
ok($t16->ndims == 1, "Implicit bracketing gets proper number of dimensions - brackets and commas");

$expected = pdl [];
$got = pdl q[];
ok(all($got == $expected), 'Blank strings are interpreted as empty arrays');
# This generates an annoying warning, and the ndarray should be Empty anyway
#$expected = pdl [];
$got = pdl q[[]];
ok(all($got == $expected), 'Empty bracket is correctly interpreted');

# Bad, inf, nan checks #
my $bad_values = pdl q[nan inf -inf bad];

# Bad value testing depends on whether nan and inf are represented as bad
# values

TODO: {
	# conditional TODO
	local $TODO = 'ActivePerl and/or perls built using MS compilers might fail this test'
		if($ActivePerl::VERSION || $Config{cc} eq 'cl');
	SKIP: {
		skip "broken for PDL_Index", 1;
		ok($bad_values->at(0) != $bad_values->at(0), 'properly handles nan')
			or diag("Zeroeth bad value should be nan but it describes itself as "
			. $bad_values->at(0));
	}
}

# inf test: inf == inf but inf * 0 != 0
ok((	$bad_values->at(1) == $bad_values->at(1)
		and $bad_values->at(1) * 0.0 != 0.0), 'properly handles inf')
	or diag("First bad value should be inf but it describes itself as " . $bad_values->at(1));
# inf test: -inf == -1 * inf
ok((	$bad_values->at(2) == $bad_values->at(2)
		and $bad_values->at(2) * 0.0 != 0.0), 'properly handles -inf')
	or diag("Second bad value should be -inf but it describes itself as " . $bad_values->at(2));
ok($bad_values->at(2) == -$bad_values->at(1), "negative inf is numerically equal to -inf");
ok($bad_values->isbad->at(3), 'properly handles bad values')
	or diag("Third bad value should be BAD but it describes itself as " . $bad_values->slice(3));

my $infty = inf();
my $min_inf = -inf();
my $nan = nan();

my $nan2 = $^O =~ /MSWin32/i && !$ActivePerl::VERSION && $Config{cc} ne 'cl' ? pdl (-((-1) ** 0.5))
                             : pdl '-nan';
my $bad = pdl 'bad';

TODO: {
	# conditional TODO
	local $TODO = 'ActivePerl and/or perls built using MS compilers might fail this test'
		if($ActivePerl::VERSION || $Config{cc} eq 'cl');
	ok((	$infty == $infty and $infty * 0.0 != 0.0), "pdl 'inf' works by itself")
		or diag("pdl 'inf' gave me $infty");
	ok((	$min_inf == $min_inf and $min_inf * 0.0 != 0.0), "pdl '-inf' works by itself")
		or diag("pdl '-inf' gave me $min_inf");
}

ok($min_inf == -$infty, "pdl '-inf' == -pdl 'inf'");

TODO: {
	local $TODO = 'Sign of Nan depends on platform, still some loose ends';
	# conditional TODO for a different reason
	local $TODO = 'Cygwin perl and/or ActivePerl might fail these tests'
		if($ActivePerl::VERSION || $^O =~ /cygwin/i);
	ok((   $nan != $nan), "pdl 'nan' works by itself")
	       or diag("pdl 'nan' gave me $nan");
	ok((   $nan2 != $nan2), "pdl '-nan' works by itself")
	       or diag("pdl '-nan' gave me $nan2");
	# On MS Windows, nan is -1.#IND and -nan is 1.#QNAN. IOW, nan has
	# a leading minus sign, and -nan is not signed.
	if($^O =~ /MSWin32/i) {
		ok((   $nan =~ /-/), "pdl 'nan' has a negative sign (MS Windows only)")
		       or diag("pdl 'nan' gave me $nan");
		ok((   $nan2 !~ /-/), "pdl '-nan' doesn't have a negative sign (MS Windows only)")
		       or diag("pdl -'nan' gave me $nan2");
	}
	else {
		ok((   $nan !~ /-/), "pdl 'nan' has a positive sign")
		       or diag("pdl 'nan' gave me $nan");
		ok((   $nan2 =~ /-/), "pdl '-nan' has a negative sign")
		       or diag("pdl '-nan' gave me $nan2");
	}
}

ok($bad->isbad, "pdl 'bad' works by itself")
	or diag("pdl 'bad' gave me $bad");

# Checks for windows strings:
$infty = pdl q[1.#INF];
$nan = pdl q[-1.#IND];

TODO: {
	# conditional TODO
	local $TODO = 'ActivePerl and/or perls built using MS compilers might fail this test'
		if($ActivePerl::VERSION || $Config{cc} eq 'cl');
	ok((	$infty == $infty and $infty * 0 != 0), "pdl '1.#INF' works")
		or diag("pdl '1.#INF' gave me $infty");
	ok((	$nan != $nan), "pdl '-1.#IND' works")
		or diag("pdl '-1.#IND' gave me $nan");
}

# Pi and e checks #
$expected = pdl(1)->exp;
# using approx() here since PDL only has support for double data
# so there will be differences in the least significant places for
# perls compiled with uselongdouble
#
$got = pdl q[e];
ok(approx($got, $expected, 1e-12), 'q[e] returns exp(1)')
	or diag("Got $got");
# using approx() here since PDL only has support for double data
# so there will be differences in the least significant places for
# perls compiled with uselongdouble
#
$got = pdl q[E];
ok(approx($got, $expected, 1e-12), 'q[E] returns exp(1)')
	or diag("Got $got");
$expected = pdl(1, exp(1));
$got = pdl q[1 e];
ok(all($got == $expected), 'q[1 e] returns [1 exp(1)]')
	or diag("Got $got");
$got = pdl q[1 E];
ok(all($got == $expected), 'q[1 E] returns [1 exp(1)]')
	or diag("Got $got");
$expected = pdl(exp(1), 1);
$got = pdl q[e 1];
ok(all($got == $expected), 'q[e 1] returns [exp(1) 1]')
	or diag("Got $got");
$got = pdl q[E 1];
ok(all($got == $expected), 'q[E 1] returns [exp(1) 1]')
	or diag("Got $got");
$expected = pdl(1, exp(1), 2);
$got = pdl q[1 e 2];
ok(all($got == $expected), 'q[1 e 2] returns [1 exp(1) 2]')
	or diag("Got $got");
$got = pdl q[1 E 2];
ok(all($got == $expected), 'q[1 E 2] returns [1 exp(1) 2]')
	or diag("Got $got");

# Already checked all the permutations of e, so just make sure that it
# properly substitutes pi
$expected = pdl(1, 4 * atan2(1,1));
$got = pdl q[1 pi];
ok(all($got == $expected), 'q[1 pi] returns [1 4*atan2(1,1)]')
	or diag("Got $got");
$got = pdl q[1 PI];
ok(all($got == $expected), 'q[1 PI] returns [1 4*atan2(1,1)]')
	or diag("Got $got");
$expected = pdl(4 * atan2(1,1), 1);
$got = pdl q[pi 1];
ok(all($got == $expected), 'q[pi 1] returns [4*atan2(1,1) 1]')
	or diag("Got $got");

# Security checks #
# Check croaking on arbitrary bare-words:
eval {pdl q[1 foobar 2]};
isnt($@, '', 'croaks on arbitrary string input');
eval {pdl q[$a $b $c]};
isnt($@, '', 'croaks with non-interpolated strings');

# Install a function that knows if it's been executed.
{
	my $e_was_run = 0;
	sub PDL::Core::e { $e_was_run++ }
	sub PDL::Core::e123 { $e_was_run++ }
	my $to_check = q[1 e 2];
	eval {pdl $to_check};
	is($e_was_run, 0, "Does not execute local function e in [$to_check]");
	$e_was_run = 0;
	$to_check = q[1 +e 2];
	eval {pdl $to_check};
	is($e_was_run, 0, "Does not execute local function e in [$to_check]");
	$e_was_run = 0;
	$to_check = q[1 e+ 2];
	eval {pdl $to_check};
	is($e_was_run, 0, "Does not execute local function e in [$to_check]");
	$e_was_run = 0;
	$to_check = q[1e 2];
	eval {pdl $to_check};
	is($e_was_run, 0, "Does not execute local function e in [$to_check]");
	$e_was_run = 0;
	$to_check = q[1e+ 2];
	eval {pdl $to_check};
	is($e_was_run, 0, "Does not execute local function e in [$to_check]");
	$e_was_run = 0;
	$to_check = q[1+e 2];
	eval {pdl $to_check};
	is($e_was_run, 0, "Does not execute local function e in [$to_check]");
	$e_was_run = 0;
	$to_check = q[1+e+ 2];
	eval {pdl $to_check};
	is($e_was_run, 0, "Does not execute local function e in [$to_check]");
	$e_was_run = 0;
	$to_check = q[1 e123 2];
	eval {pdl $to_check};
	is($e_was_run, 0, "Does not execute local function e123 in [$to_check]");
	$e_was_run = 0;
}

###############################
# Useful croaking output - 36 #
###############################

eval{ pdl q[1 l 3] };
isnt($@, '', 'Croaks when invalid character is specified');
like($@, qr/found disallowed character\(s\) 'l'/, 'Gives meaningful explanation of problem');
eval{ pdl q[1 po 3] };
isnt($@, '', 'Croaks when invalid characters are specified');
like($@, qr/found disallowed character\(s\) 'po'/, 'Gives meaningful explanation of problem');

# checks for croaking behavior for consecutive signs like +-2:
eval{ pdl q[1 +-2 3] };
isnt($@, '', 'Croaks when it finds consecutive signs');
like($@, qr/found a \w+ sign/, 'Gives meaningful explanation of problem');
eval{ pdl q[1 -+2 3] };
isnt($@, '', 'Croaks when it finds consecutive signs');
like($@, qr/found a \w+ sign/, 'Gives meaningful explanation of problem');

# 'larger word' croak checks (36)
foreach my $special (qw(bad inf pi)) {
	foreach my $append (qw(2 e l)) {
		eval "pdl q[1 $special$append 2]";
		isnt($@, '', "Croaks when it finds $special$append");
		like($@, qr/larger word/, 'Gives meaningful explanation of problem');
		eval "pdl q[1 $append$special 2]";
		isnt($@, '', "Croaks when it finds $append$special");
		like($@, qr/larger word/, 'Gives meaningful explanation of problem');
	}
}

# e croaks (6)
my $special = 'e';
foreach my $append (qw(2 e l)) {
		eval "pdl q[1 $special$append 2]";
		isnt($@, '', "Croaks when it finds $special$append");
		eval "pdl q[1 $append$special 2]";
		isnt($@, '', "Croaks when it finds $append$special");
}

## Issue information
##
## Name: BAD value parsing breakage
##
## Parsing of BAD values fails to set the correct BAD value when parsing from
## the string "[BAD]".
##
## <http://sourceforge.net/p/pdl/bugs/367/>
## <https://github.com/PDLPorters/pdl/issues/47>

# input string -> expected string
my $cases = {
	q|BAD|         => q|BAD|,
	q|BAD BAD|     => q|[BAD BAD]|,
	q|BAD BAD BAD| => q|[BAD BAD BAD]|,
	q|[BAD]|       => q|[BAD]|,
	q|[ BAD ]|     => q|[BAD]|,
	q|[BAD BAD]|   => q|[BAD BAD]|,
	q|[ BAD BAD ]| => q|[BAD BAD]|,
};

while( my ($case_string, $expected_string) = each %$cases ) {
	my $bad_pdl = pdl( $case_string );
	subtest "Testing case: $case_string" => sub {
		ok( $bad_pdl->badflag, 'has badflag enabled');
		ok( $bad_pdl->isbad->all, 'all values in PDL are BAD');

		is($bad_pdl->string, $expected_string, "PDL stringifies back to input string: @{[ $bad_pdl->string ]}");
	};
}

done_testing;

# Basic 2D array
# pdl> p $x = pdl q[ [ 1, 2, 3 ], [ 4, 5, 6 ] ];
# pdl> p $x = pdl q[ 1 2 3 ; 4 5 6 ]
# pdl> p $x = pdl '[ [ 1, 2, 3 ], [ 4, 5, 6 ] ]';
#
# [
#  [1 2 3]
#  [4 5 6]
# ]

# Basic 1D array
# pdl> p $y = pdl [ 1, 2, 3, 4, 5, 6 ]
# pdl> p $y = pdl q[ 1 2 3 4 5 6 ]
# pdl> p $y = pdl q[1,2,3,4,5,6]
# [1 2 3 4 5 6]

# 1D array with signs
# pdl> p $c = pdl [ 7, -2, +5 ]
# pdl> p $c = pdl q[ 7 -2 +5 ]
# pdl> p $c = pdl q[ 7, -2, +5 ]
# [7 -2 5]

# 1D array with mixed ops and signs
# pdl> p $d = pdl [ 7 - 2, +5 ]
# pdl> p $d = pdl q[ 7 - 2 +5 ]
# [5 5]

# ...another
# pdl> p $d = pdl [ 7, -2 + 5 ]
# pdl> p $d = pdl q[ 7 -2 + 5 ]
# [7 3]

# 1D array with ops, not signs
# pdl> p $d = pdl [ 7 - 2 + 5 ]
# pdl> p $d = pdl q[ 7 - 2 + 5 ]
# 10

# A [2,3,4] shape ndarray
# pdl> p $d = pdl [ [ [0, 1], [4, 0], [0, 3] ],
#                   [ [2, 0], [4, 0], [4, 1] ],
#                   [ [0, 1], [3, 2], [1, 4] ],
#                   [ [1, 2], [2, 2], [2, 1] ] ];
#
# [
#  [
#   [0 1]
#   [4 0]
#   [0 3]
#  ]
#  [
#   [2 0]
#   [4 0]
#   [4 1]
#  ]
#  [
#   [0 1]
#   [3 2]
#   [1 4]
#  ]
#  [
#   [1 2]
#   [2 2]
#   [2 1]
#  ]
# ]
#
# ...the same, just different formatting...
#
# [
#  [ [0 1] [4 0] [0 3] ]
#  [ [2 0] [4 0] [4 1] ]
#  [ [0 1] [3 2] [1 4] ]
#  [ [1 2] [2 2] [2 1] ]
# ]

# A 3x3 2D array
# pdl> p pdl [ [1, 2, 3], [2, 1, 0], [2, 2, 1] ];
# pdl> p $e = pdl q[ [ 1 2 3 ] ; [ 2 1 0 ] ; [ 2 2 1 ] ];
# pdl> p pdl q[  1 2 3 ; 2 1 0 ; 2 2 1 ]  # this should be the same
#
# [
#  [1 2 3]
#  [2 1 0]
#  [2 2 1]
# ]
