package MpmasQLFunctionLanguage;
use strict;
use warnings FATAL => qw(all);
use Exporter;
use Storable qw(dclone);
use Data::Dumper;
use Carp qw(croak); #qw(croak verbose);
use CtUtilities qw(queryhash extqueryhash is_in_list);
use IndexedTable;
use Scalar::Util qw(looks_like_number);
use List::Util qw(max min);
use EmbeddedArray;
use POSIX qw (ceil);
#use Math::CDF qw(:all);
our @ISA = qw(Exporter);
our @EXPORT_OK = qw();

#$SIG{__DIE__} = \&Carp::confess;

use constant {
 PI => 4 * atan2(1, 1),
};
my $singlemode;
my $dbh;
my $setup;
my $tableregistry;
my $verbose;
my $ciTempArrays;
my $TempArrays;
my $mapregistry;
my $fast = 0;
#my $forvalues = [];
my $locloudeb1 = 0;
my $locals_hash = {};

### Subroutines to set symbols
sub set_globals {
	shift;
	$singlemode = shift;
	$dbh = shift;
	$setup = shift;
	$tableregistry = shift;	
	$verbose = shift||0;
}
sub set_globvar {
	croak  "Error: Variable $_[1] is not defined\n " unless (exists $setup->{$_[1]});
	$setup->{$_[1]} = $_[2];
}
sub set_mapregistry {
	shift;
	$mapregistry = shift;
}
sub set_this {
    $locals_hash = shift;
}
sub unset_this {
    $locals_hash = undef;
}
sub register_table {
	$tableregistry->add_or_replace_objects($_[1]);
}
sub table_link {
	return $tableregistry->get_object_by_id($_[1]);
}
###Function wrappers for translating and interpreting of MPMASQL Function Language Code
sub convert {
	shift;
	my $coded = shift;
	my $locvarhash = shift;
	my $is_translated = shift || 0;
	my $be_verbose = shift || 0;
	my ($rt, $rtfor);
	
	if ($is_translated) {
	      eval { 	($rt, $rtfor) = MpmasQLFunctionLanguage->interprete($coded,$locvarhash); };
	      croak "$@" if $@;
	}
	else {
		eval { 	($rt, $rtfor) = MpmasQLFunctionLanguage->translate_and_interprete($coded,$locvarhash, $be_verbose)};
		croak "$@" if $@;
	}
	if ($#{$rt} > 0 or defined $rtfor->[0][1] ) {
		return wantarray ? @$rt : $rt;
	}
	else {
		 return wantarray ? ($rt->[0]) : $rt->[0] ;
	}
}
sub convert_to_arrayrefs {
	shift;
	my $coded = shift;
	my $locvarhash = shift;
	my $is_translated = shift || 0;
	my $be_verbose = shift || 0;
	my ($rt, $rtfor);
	
	if ($is_translated) {
	      eval { 	($rt, $rtfor) = MpmasQLFunctionLanguage->interprete($coded,$locvarhash); };
	      croak "$@" if $@;
	}
	else {
		eval { 	($rt, $rtfor) = MpmasQLFunctionLanguage->translate_and_interprete($coded,$locvarhash, $be_verbose)};
		croak "$@" if $@;
	}
	return ($rt, $rtfor);
}



###Function for translating and interpreting of MPMASQL Function Language Code

sub translate_and_interprete {
	my ($class, $coded, $locvarhash) = @_;
	my ($string, $be_verbose, $rt, $rtfor);
	eval  {
	    ($string, $be_verbose) = MpmasQLFunctionLanguage->translate_to_perl($coded);	    
	    ($rt, $rtfor) = MpmasQLFunctionLanguage->interprete($string, $locvarhash, $be_verbose);   
	};
	croak "Error trace:\nLocal variables:\n". Dumper($locvarhash)."\nError: $@\n" if $@;
	return wantarray ? ($rt, $rtfor) : $rt;
}
sub interprete {
	my ($class, $string, $locvarhash, $be_verbose) = @_;
	croak "First argument to $class ->interprete should be string, not a reference!"  if (ref $string);
	croak "Second argument to $class ->interprete should be a hash reference!"  unless (ref $locvarhash eq "HASH");
	$locloudeb1 = $verbose ||$be_verbose || 0;

	return ([("")]) unless (defined $string);

	unset_this();
	set_this($locvarhash);
	print $string ."\n" if $locloudeb1;
	
	my $result = eval $string;
	croak $@."$string\n" if $@;
	unset_this();
	#print Dumper($result);
	my @rt; #declare return array
	my @rtfor; #declare return forelement array
	if (not defined $result ) {
	    print "Result: Undefined\n" if $locloudeb1;
	    return wantarray ?  (undef, undef) : undef ;
	}
	elsif (ref($result) eq 'EmbeddedArray') {
	    foreach my $i (0..$result->mi) {
	      print "List entry $i: ".$result->i($i)."\t".join("|",@{ $result->forvalues($i) })."\n" if $locloudeb1;
	      push @rt, $result->i($i);
	      push @rtfor , [($result->i($i), @{ $result->forvalues($i) })];#
	      
	    }
	    return wantarray ? (\@rt, \@rtfor): \@rt  ; 
	}
	else {
	    print "Result: ". $result . "\n" if $locloudeb1;
	    $rt[0] = $result;
	    return wantarray ?  (\@rt, undef): \@rt ; 
	}
	
	
}
sub translate_to_perl {
	my $class = shift;
	my $string = shift;
	my $verbose_switch;
	my $verbose_for_what;

	$string =~ s/^\s*//;
	$string =~ s/\s*$//;

	#resolve ^ \\ ~ "" undef arrays
	#translation into perl code
	my @quot;
	my $cc= 0;
	
	while ($string =~ /"(?>(?:[^"]+|\\")*)"/) {
	  my $cf = sprintf("%02d", $cc);
	  $string =~ s/"((?:[^"]+|\\")*)"/\$quot[$cf]/;
	  push @quot, $1;
	  $cc++;
	}
	
	while ($string =~ /@/) {
		$string =~ s/@(\{\s*\w+\s*\})?//g;
		$verbose_for_what = $1;
		 if (defined $verbose_for_what) {
			$verbose_for_what =~ s/{\s*//;
			$verbose_for_what =~ s/\s*\}//;
		}
		$verbose_switch = 1;	
	}
	
	$string =~ s/(?<!\$quot)\[/&embed([/g;
	$string =~ s/(?<!\$quot\[\d\d)\]/\])/g;
	$string =~ s/\^/**/g;
	$string =~ s/#/&/g;
	while ($string =~ s/(^|\s|\(|\[|,|\)|\]|~|\})(\w|\w[\w\s.\$:]*\w)(\)|\s|$|,|\]|&|~)/$1'$2'$3/){};#\d+[_\pL]\w*|[_\pL]\w+
	$string =~  s/~/./g;
	while ($string =~ s/(\)|\]|'[^']*'|\})\s*('[^']*'|\(|&\w|\$)/$1.$2/){};
	foreach (@quot) {
	  #$_ =~ s/\\/\\\\/g; #???
	  $_ =~ s/\$/\\\$/g;
	  $_ =~ s/\@/\\\@/g;
	}
	while ($string =~ s/\$quot\['?(\d+)'?\]/\"$quot[$1]\"/){};
	return wantarray ? ($string, $verbose_switch, $verbose_for_what): $string;
}

###Auxiliary functions
sub embed {
  return EmbeddedArray->new($_[0]);
}

sub any_undef_in {
#	foreach (@_)	{	
#		return 1 if (not defined $_ );
#	}
#	return 0;
	return grep ( !defined $_, @_); 
}
sub report {
  my ($report_id,$report_if) = ($_[0], $_[1]);
  my @args = @_[2..$#_];
  print "requested #report: $report_id = ".join(";" , map { ref ($_) ? Dumper($_) : $_ } @args)."\n" if $report_if;
  return wantarray ? (@args): $args[0];
}

###Funtions of the MPMASQL Function Language	

sub this {
    my ($var, $index) = @_;
    croak "Error: Local variable $var undefined."  unless (exists $locals_hash->{$var});
    return $locals_hash->{$var} unless (ref $locals_hash->{$var});
    
    if (ref $locals_hash->{$var} eq "ARRAY") {
	  $index = 0 unless (defined $index);
	  croak "Error: invalid index $index for local variable $var." unless ($index =~ /^\d+$/ and $index >= 0 and $index <= $#{$locals_hash->{$var}});
	  return $locals_hash->{$var}->[$index];
    }
    $index = "id" unless (defined $index);
    return $locals_hash->{$var}->{$index} if (exists $locals_hash->{$var}->{$index}) ;
    return 0;
}
sub protected_divide {
	my ($o2, $o1, $o3) = @_;
	return ( any_undef_in($o1, $o2)) ? undef : ($o1 == 0   ?  $o3 : ($o2 / $o1) );		
}

sub round_to {
	return sprintf("%.$_[1]f",$_[0]);
}	
sub floor {
	$_[0] =~ /^(\d+).?/;
	defined $1 ? $1 : 0;
}
sub steps {
    my ($start, $end, $step) = @_;
    croak "Error: invalid arguments for function #steps: $start, $end, $step\n" if ( $step == 0  );
    #or ($start <=> $end) != (0 <=> $step ) #Not a problem actually, will just never start
    my @array;
    my $i = $start;
    while ($i <= $end) {
      push @array, $i;
      $i += $step;
    }
    return EmbeddedArray->new(\@array);
}	
sub normlike {
      return  1 / ( sqrt(2 * PI ) * $_[2] ) * exp ( -1 * ( $_[1] - $_[0]  ) ** 2 /  (2 * $_[2] ** 2));
}
sub inverse_normal {
    require Math::CDF;
    return Math::CDF::qnorm($_[0]) * $_[2] + $_[1];
}	
sub sql {
  my $get1 = $_[0];
  my $query =[];
  eval{	#exception handling to avoid fatals because table column does not exist 
	  #!!CT: revise as for now it captures all warnings, better solutions after restructuring of database
	  local $SIG{__WARN__}=sub{}; #Temporarily suppress warnings
	  $query = $dbh->selectcol_arrayref($get1);
  };
  if ($@) {	
	 croak "Query error captured\n$@\nQuery string was : $get1\n\n";
	 return undef; 
  }
  elsif (not defined $query->[0]) {
	  #print "Query resulted in NULL\n" if $::loudcprep;
	  $query->[0] = undef;
	  # print "\t Result (NULL) pushed to operands\n"  if $locloudeb1;
	  return  EmbeddedArray->new([]);		
  }
  elsif ($#{$query} == 0) {
	  #print "\t Result ($query->[0]) pushed to operands\n"  if $locloudeb1;
	  return EmbeddedArray->new($query);		
  }
  else {
    return EmbeddedArray->new($query);
  }
 }
sub if {
  $_[0] ? $_[1] : $_[2];
}
sub ifthenelse {
  eval($_[0]) ? $_[1] : $_[2];
}	
sub if_elsif {
  while (@_) {
    my $condition = shift @_;
    my $value = shift @_;
    return $value if ($condition);
  }
  return 0;
}

sub replace_null {
   if (UNIVERSAL::isa( $_[0], "EmbeddedArray") ){
	$_[0] ? $_[0]:$_[1];
   } 
  else {
    defined ($_[0]) ? $_[0]:$_[1];
  }
}	
sub ifalone {
  $singlemode ? $_[0] : $_[1];
}
sub annuity {
    my ($anInterest, $anCapital, $anLifespan) = @_;
    return $anCapital * (( 1 + $anInterest)**$anLifespan *$anInterest) / ((1 +$anInterest)**$anLifespan -1);
}	
sub fvalue {
  my $i = $_[0]; #interest
  my $t = $_[1]; #lifetime
  my $q =  1.0 + $i;
  my $fvalue =   $q **$t / ($q ** $t - 1.0) - (1.0 / ($t * ($q - 1.0)));
  return $fvalue;
}


sub foreach {
    croak  "Error in foreach: list $_[0]  is not defined\n " unless (exists $setup->{$_[0]});
    print "Foreach: $_[0]\n" if $locloudeb1;
    return EmbeddedArray->new([])  if (not ref $setup->{$_[0]} or ref $setup->{$_[0]} eq "ARRAY" and scalar @{$setup->{$_[0]}} == 0 or not defined $setup->{$_[0]}->[0] );
    return EmbeddedArray->new([$setup->{$_[0]}]) if (not ref $setup->{$_[0]} eq "ARRAY");
    return EmbeddedArray->new( $setup->{$_[0]} );
}	
sub count {
	my @list;
	if (UNIVERSAL::isa( $_[0], "EmbeddedArray")) { 
	    @list = $_[0]->ealist;
	}
	else {
	    croak  "Error: List $_[0]  is not defined\n " unless (exists $setup->{$_[0]});
	    @list = @{$setup->{$_[0]}};
	}
      return scalar @list;
}	
sub random_number {
      croak  "Error: Argument ($_[0]) to random_number invalid\n " unless (looks_like_number($_[0]));
      return rand($_[0]);
}	
sub  listelement{
	if (UNIVERSAL::isa( $_[0], "EmbeddedArray")) { 
		croak  "Error: List is shorter than $_[1] \n " if ($_[1] -1 > $_[0]->mi) ;
	    return $_[0]->i($_[1] -1);
	}
	elsif ($setup->{$_[0]}) {
	    
	    return $setup->{$_[0]}->[$_[1] -1]    ;	
	}
    croak  "Error: List $_[0]  is not defined or empty\n ";
}
sub var {
	croak  "Error: Variable $_[0] is not defined\n " unless (exists $setup->{$_[0]});
	croak  "Error: Variable $_[0] is a list\nUse a list function like #foreach, #list, #qlist, #listelement, #list_concat, #count, ... instead of #var\n" if (ref($setup->{$_[0]}) );
	return	$setup->{$_[0]};
}
sub regexp {
	return $_[0] =~ $_[1];
}
sub list {
	my @list;
	if (UNIVERSAL::isa( $_[0], "EmbeddedArray")) { 
	    @list = $_[0]->ealist;
	}
	else {
	    @list = @{$setup->{$_[0]}};
	}
	my $qlist = join (", ", @list);
	return $qlist;	
}
sub qlist {
	my @list;
	if (UNIVERSAL::isa( $_[0], "EmbeddedArray")) { 
	    @list = $_[0]->ealist;
	}
	else {
	    croak  "Error: List $_[0] is  not defined or empty\n " unless (exists $setup->{$_[0]});
	    @list = @{$setup->{$_[0]}};
	}
	
	my $qlist = "'".join("', '", @list)  ."'"; 
	return $qlist;	
}
sub list_concat {
       my $first = shift @_;
       unless (UNIVERSAL::isa( $first, "EmbeddedArray")) {
	  $first = EmbeddedArray->new($setup->{$first} );
       }
       while (@_) {#
	  my $second = shift @_;
	  unless (UNIVERSAL::isa( $second, "EmbeddedArray")) {
			$second = EmbeddedArray->new($setup->{$second} );
	  }
	$first->merge($second);
	}
	return $first;
}
sub table {
	my ($tablename, $column, $keylist, $tabtouse) = @_;
	my @keyarray = @{$keylist->{array}};
	if (not defined $tabtouse) {
		if (any_undef_in($tablename, $column, @keyarray)) {
			return undef;
		}		
		#print "Table query : $tablename, $column, [".join(",", @keyarray)."]\n" if $locloudeb1;
		croak "Error: No tables (#table) defined in this environment!\n" unless (defined $tableregistry);
		$tabtouse = $tableregistry->get_object_by_id($tablename);
		croak "Table (#table) $tablename unknown" unless ( defined $tabtouse);
	}
	my $qresult = []; 
	if (not defined $column or $column =~ /^\s*\d+\s*$/) { 
		$qresult =  [ $tabtouse->query(\@keyarray,$column) ];
	}
	else {
		$qresult =  [ $tabtouse->query_by_columnname(\@keyarray,$column) ];
	}
	my $repl;
	
	if (not defined $qresult->[0]) {
		#using the array method because then the NA can be caught in the EXPANDARRAYS routine and the whole field value is set to 0, not creating a field even if there were pure string elements
		#print "Query resulted in NULL\n" if $locloudeb1;
		$repl = EmbeddedArray->new([]);
		#print scalar @keyarray."\t". $tabtouse->numkeys ."\t@keyarray\t@{$repl->{array}}" . "\n" if ($tablename eq "fieldtest" or $tablename eq "workforhire");
	}
	elsif ($#{$qresult} == 0 and scalar @keyarray == $tabtouse->numkeys) { #makes sure a scalar is only reported, when it was the intention to do so (otherwise 1 item results for list queries would not produce thisfor values
		$repl = $qresult->[0];
		#print scalar @keyarray."\t". $tabtouse->numkeys ."\t@keyarray\t$repl" . "\n" if ($tablename eq "fieldtest" or $tablename eq "workforhire");
	}
	else {
		$repl = EmbeddedArray->new($qresult);
		  #print scalar @keyarray."\t". $tabtouse->numkeys ."\t@keyarray\t@{$repl->{array}}" . "\n" if ($tablename eq "fieldtest" or $tablename eq "workforhire");	
	}
		
	#print "\t\tResult: $repl pushed to operands\n" if $locloudeb1;
	return $repl;
}
sub tablekeys {
	my ($tablename, $keylist) = @_;
	my @keyarray = @{$keylist->{array}};
	if (any_undef_in($tablename, @keyarray)) {
		return undef;
	}		
	croak "Error: No tables (#table) defined in this environment!\n" unless (defined $tableregistry);
	my $tabtouse = $tableregistry->get_object_by_id($tablename);
	croak "Table (#table) $tablename unknown" unless ( defined $tabtouse);
	if (scalar @keyarray >=  $tabtouse->numkeys) {
		croak "Error for #keys_of_table: Too many keys already given: ". join(" ", @keyarray) ."\n";
	}
	return table($tablename, 0,  $keylist, $tabtouse);	
}
sub tablevalue {
	my ($tablename, $column, $keylist) = @_;
	my @keyarray = @{$keylist->{array}};
	if (any_undef_in($tablename, $column, @keyarray)) {
		return undef;
	}		
	croak "Error: No tables (#table) defined in this environment!\n" unless (defined $tableregistry);
	my $tabtouse = $tableregistry->get_object_by_id($tablename);
	croak "Table (#table) $tablename unknown" unless ( defined $tabtouse);
	if (scalar @keyarray >  $tabtouse->numkeys) {
		croak "Error for #tablevalue: Too many keys given: ". join(" ", @keyarray) ."\n";
	}
	if (scalar @keyarray <  $tabtouse->numkeys) {
		croak "Error for #tablevalue: Not enough keys given: ". join(" ", @keyarray) ."\n";
	}
	return table($tablename, $column,  $keylist, $tabtouse);	
}
sub mapcell {
	my ($map, $x, $y) = @_;
	#print "Map query: $map, $x, $y:\n" if $locloudeb1;
	croak ("Error: No maps loaded\n") unless (defined $mapregistry);
	my $mo = $mapregistry->get_object_by_id($map);
	croak ("Error: Map $map unknown\n") unless (defined $mo);
	my $repl = $mo->get_cell($x,$y);
	#print "\t\tResult: $repl pushed to operands\n" if $locloudeb1;
	return $repl;
}
sub classify_to_multiple {
	my ($value, $base) = @_;
	return &ceil($value / $base)  * $base; 
	
}
sub isequal {
	return ($_[0] eq $_[1]);
}
sub e {
	exp($_[0]);
}
sub ln {
	log($_[0]);
}
sub finance_FRM_rate {
	my ($amount_financed, $irate,  $totalTime )= @_;
	return $amount_financed * annuity_factor($irate,  $totalTime); 
}
sub annuity_factor {
	my ($irate, $totalTime) = @_;
	return (((1 + $irate) ** $totalTime) * $irate) / (((1 + $irate) ** $totalTime) -1);
}
sub finance_FRM_principal_paid_at_age {
	my ($amount_financed, $irate, $age, $totalTime )= @_;
	return $amount_financed * ((1 + $irate)**$age) * (annuity_factor($irate, $totalTime ) - $irate);
}
sub finance_FRM_interest_paid_at_age {
	my ($amount_financed, $irate, $age, $totalTime )= @_;
	if ($age > 0) {
		return $irate * $amount_financed * zeitwert( $totalTime, $age, $irate);
	}
	else {
		return $irate * $amount_financed;
	}
}
sub zeitwert {
	my ( $totalTime, $age, $irate) = @_;
	return 1.0 - ((1.0 + $irate)** $age) * (annuity_factor($irate, $totalTime) - $irate) / annuity_factor($irate, $age);
}
sub time_value {
	my ( $totalTime, $age, $irate) = @_;
	return 1.0 - ((1.0 + $irate)** $age) * (annuity_factor($irate, $totalTime) - $irate) / annuity_factor($irate, $age);
}
1;
