perlbuut/deps/Math/Farnsworth/.svn/text-base/FunctionDispatch.pm.svn-base

package Math::Farnsworth::FunctionDispatch;

use strict;
use warnings;

use Data::Dumper;

use Math::Farnsworth::Variables;
use Math::Farnsworth::Value::Array;
use Math::Farnsworth::Error;

use Carp;

sub new
{
	my $self = {};
	bless $self, (shift);
}

sub addfunc
{
	my $self = shift;
	my $name = shift;
	my $args = shift;
	my $value = shift;
	my $scope = shift;

	#i should really have some error checking here
	$self->{funcs}{$name} = {name=>$name, args=>$args, value=>$value, parentscope=>$scope};
}

sub getfunc
{
	my $self = shift;
	my $name = shift; #which one to get, we return the hashref
	return $self->{funcs}{$name};
}

sub isfunc
{
	my $self = shift;
	my $name = shift;

	return exists($self->{funcs}{$name});
}

sub setupargs
{
	my $self = shift;
	my $eval = shift;
	my $args = shift;
	my $argtypes = shift;
	my $name = shift; #name to display
	#my $branch = shift;

	my $vars = $eval->{vars}; #get the scope we need

ARG:for my $argc (0..$#$argtypes)
	{
		my $n = $argtypes->[$argc][0]; #the rest are defaults and constraints
		my $v = $args->getarrayref()->[$argc];

		my $const = $argtypes->[$argc][2];

		if (ref($const) eq "VarArg")
		{
		   warn "Working around bug in lambdas!";
		   $const = "VarArg";
		}

		if (!defined($v))# || ($v->{dimen}{dimen}{"undef"})) #uncomment for undef== default value
		{
			#i need a default value!
			if (!defined($argtypes->[$argc][1]) && defined($argtypes->[$argc][0])  && (defined($const) && ref($const) !~ /Math::Farnsworth::Value/ && $const ne "VarArg"))
			{
				die "Required argument $argc to function $name\[\] missing\n";
			}

			$v = $argtypes->[$argc][1];
		}

		if (defined($const) && ref($const) =~ /Math::Farnsworth::Value/)
		{
			#we have a constraint
			if (!$v->conforms($const))
			{
				die "Constraint not met on argument $argc to $name\[\]\n";
			}
		}
		elsif (defined($const) && $const eq "VarArg")
		{
			#we've got a variable argument, it needs to slurp all the rest of the arguments into an array!
			my $last = $#{$args->getarrayref()};
			my @vargs = @{$args->getarrayref()}[$argc..$last];
			my $v = new Math::Farnsworth::Value::Array(\@vargs);
			$vars->declare($n, $v); #set the variable
			last ARG; #don't parse ANY more arguments
		}

		if (defined $n)  #happens when no arguments! so we check if the name is defined
		{
			#print "SETVAR $n: ";
			#print Dumper($argtypes->[$argc]);
			#print Dumper($vars->{vars});
			if (!$argtypes->[$argc][3]) #make sure that it shouldn't be byref
			{ 
				$vars->declare($n, $v);
			}
			else
			{
				#it should be by ref
				if ($v->getref())
				{
				  $vars->setref($n, $v->getref());
			    }
				else
				{
					error "Can't get reference from expression for argument $argc";
				}
			}

			#print Dumper($vars->{vars});
		}
	}
}

#should i really have this here? or should i have it in evaluate.pm?
sub callfunc
{
	my $self = shift;
	my $eval = shift;
	my $name = shift;
	my $args = shift;
	my $branches = shift;

	my $argtypes = $self->{funcs}{$name}{args};

	my $fval = $self->{funcs}{$name}{value};

	#print "-------------ATTEMPTING TO CALL FUNCTION!-------------\n";
	#print "FUNCTION NAME : $name\n";
	#print "Dumper of func: ".Dumper($fval);
	#print "--------------------THAT IS ALL\n";

	die "Function $name is not defined\n" unless defined($fval);
	die "Number of arguments not correct to $name\[\]\n" unless $self->checkparams($args, $argtypes); #this should check....

#	print Dumper($args);

	my $neval;

	if (defined $self->{funcs}{$name}{parentscope})
	{
		$neval = $self->{funcs}{$name}{parentscope};
		
		my $nvars = new Math::Farnsworth::Variables($neval->{vars});

		my %nopts = (vars => $nvars, funcs => $self, units => $neval->{units}, parser => $neval->{parser});
		$neval = $neval->new(%nopts);
	}
	else
	{
		#this should get scrapped once i fix the other modules!
		carp "SETTING UP PARENT SCOPE OUT OF NO WHERE!";
		my $nvars = new Math::Farnsworth::Variables($eval->{vars});

		my %nopts = (vars => $nvars, funcs => $self, units => $eval->{units}, parser => $eval->{parser});
		$neval = $eval->new(%nopts);
#		$self->{funcs}{$name}{parentscope} = $neval; #store it for later!
	}

	#print "NEWSCOPE! ".$neval->{vars}."\n";

	#eval #just for fucks sake!
	#{
	#	my $facts = $neval->{vars}->getvar("facts");
	#	print "FACTS!\n";
	#	print Dumper($facts, "$facts");
	#};

	#carp "$@" if $@;

	$self->setupargs($neval, $args, $argtypes, $name, $branches); #setup the arguments

	if (ref($fval) ne "CODE")
	{
		return $self->callbranch($neval, $fval, $name);
	}
	else
	{
		#we have a code ref, so we need to call it
		return $fval->($args, $neval, $branches, $eval);
	}
}

sub calllambda
{
	my $self = shift;
	my $lambda = shift;
	my $args = shift;
#	my $refscope = shift;
#	my $branch = shift; #new for lambdas!

	my $argtypes = $lambda->getargs();
	my $fval = $lambda->getcode();
    my $eval = $lambda->getscope();

	#print "LAMBDA---------------\n";
	#print Dumper($argtypes, $args, $fval);

	my $nvars = new Math::Farnsworth::Variables($eval->{vars});

	my %nopts = (vars => $nvars, funcs => $self, units => $eval->{units}, parser => $eval->{parser});
	my $neval = $eval->new(%nopts);

	die "Number of arguments not correct to lambda\n" unless $self->checkparams($args, $argtypes); #this shoul

	$self->setupargs($neval, $args, $argtypes, "lambda");
	return $self->callbranch($neval, $fval);
}

sub callbranch
{
	my $self = shift;
	my $eval = shift;
	my $branches = shift;
	my $name = shift;


#	print "CALLBRANCHES :: ";
#	print $name if defined $name;
#	print " :: $eval\n";

	return $eval->evalbranch($branches);
}

#this was supposed to be the checks for types and such, but now its something else entirely, mostly
sub checkparams 
{
	my $self = shift;
	my $args = shift;
	my $argtypes = shift;

	my $vararg = 0;

	my $neededargs = 0;
	my $badargs = 0;

	for my $argt (@$argtypes)
	{
		$neededargs++ unless (defined($argt->[1]) || !defined($argt->[0]));
		$badargs++ if (!defined($argt->[0]));
	}

	#might want to change the !~ to something else?
	#warn "Strange bug here to investigate, lambdas produce blessed array refs for vararg... wtf";
	$vararg = 1 if (grep {defined($_->[2]) && ref($_->[2]) !~ /Math::Farnsworth::Value/ && (($_->[2] eq "VarArg") || (ref($_->[2]) eq "VarArg"))} @{$argtypes}); #find out if there is a vararg arg

	#print "NEEDED: $neededargs :: $vararg\n";
	#print Data::Dumper->Dump([$argtypes, $args->getarrayref()], [qw(argtypes args)]);

    return 1 if ($vararg || ($args->getarray() <= (@{$argtypes}-$badargs) && $args->getarray() >= $neededargs));

	#return 0 unless (ref($args) eq "Math::Farnsworth::Value") && ($args->{dimen}->compare({dimen=>{array=>1}}));

	return 0;
}

sub getref
{
	my $self = shift;
	my $argc = shift;
	my $branch = shift;
	my $name = shift;

	#print "\n\nGETREF\n";
	#print Dumper($branch);

	if (ref $branch->[1] ne "Array")
	{
		#this should add support for some other stuff
		error "Cannot get a reference if function/lambda is called without []";
	}

	my $argexpr = $branch->[1][$argc];
	
	#print Dumper($argbranches->[$argc]);
	
	if (ref $argexpr ne "Fetch")
	{
		error "Argument $argc to $name\[\] is not referencable";
	}

	my $ref = $self->{funcs}{$name}->{scope}{vars}->getref($argexpr->[0]);

	print Dumper($argexpr, $ref);

	return $ref;
}

1;