mirror of
https://github.com/perlbot/perlbuut
synced 2025-06-08 11:25:40 -04:00
458 lines
14 KiB
Perl
458 lines
14 KiB
Perl
package Math::Farnsworth::Functions::Standard;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use Math::Farnsworth::Value;
|
|
use Math::Farnsworth::Error;
|
|
use utf8;
|
|
|
|
use Data::Dumper;
|
|
|
|
use Math::Pari;
|
|
|
|
sub init
|
|
{
|
|
my $env = shift;
|
|
|
|
#i should really make some stuff to make this easier
|
|
#maybe some subs in Math::Farnsworth::Value that get exported
|
|
#my $array = new Math::Farnsworth::Value::Array([]);
|
|
#my $string = new Math::Farnsworth::Value::String("");
|
|
#my $lambda = new Math::Farnsworth::Value::Lambda();
|
|
#my $number = new Math::Farnsworth::Value::Pari(0);
|
|
#my $date = new Math::Farnsworth::Value::Date("today"); #create a date type for use
|
|
|
|
$env->eval("push{arr byref isa [], x isa ...} := {arr = arr + x};");
|
|
$env->eval("unshift{arr byref isa [], x isa ...} := {arr =x+arr};");
|
|
|
|
#$env->{funcs}->addfunc("push", [["arr", undef, $array, 0], ["in", undef, "VarArg", 0]],\&push); #actually i might rewrite this in farnsworth now that it can do it
|
|
$env->{funcs}->addfunc("pop", [["arr", undef, TYPE_ARRAY, 0]],\&pop); #eventually this maybe too
|
|
$env->{funcs}->addfunc("shift", [["arr", undef, TYPE_ARRAY, 1]], \&shift);
|
|
#$env->{funcs}->addfunc("unshift", [["arr", undef, $array, 0], ["in", undef, "VarArg", 0]], \&unshift);
|
|
$env->{funcs}->addfunc("sort", [["sortsub", undef, TYPE_LAMBDA, 0],["arr", undef, TYPE_ARRAY, 0]],\&sort);
|
|
|
|
$env->{funcs}->addfunc("length", [["in", undef, undef, 0]],\&length);
|
|
|
|
$env->{funcs}->addfunc("ord", [["in", undef, TYPE_STRING, 0]],\&ord);
|
|
$env->{funcs}->addfunc("chr", [["in", undef, TYPE_PLAIN, 0]],\&chr);
|
|
$env->{funcs}->addfunc("index", [["str", undef, TYPE_STRING, 0],["substr", undef, TYPE_STRING, 0],["pos", TYPE_PLAIN, TYPE_PLAIN, 0]],\&index);
|
|
$env->{funcs}->addfunc("eval", [["str", undef, TYPE_STRING, 0]],\&eval);
|
|
|
|
$env->eval('dbgprint{x isa ...} := {var z; var n = 0; var p; while(n != length[x]) {p = shift[x]; if (p conforms "") {z = p} else {z = "$p"}; _dbgprint[z]}}');
|
|
$env->{funcs}->addfunc("_dbgprint", [["str", undef, TYPE_STRING, 0]], \&dbgprint);
|
|
$env->{funcs}->addfunc("__dbgbranches", [[undef, undef, undef, 0]], \&dbgbranch);
|
|
|
|
$env->eval('map{sub isa {`x`}, x isa ...} := {var xx=[]+x; if (length[xx] == 1 && xx@0$ conforms []) {xx = x@0$}; if (length[xx] == 1 && !(xx conforms [])) {xx = [xx]}; var z=[]+xx; var e; var out=[]; while(length[z]) {e = shift[z]; dbgprint[e]; push[out,e => sub]}; dbgprint[out]; out}');
|
|
|
|
$env->{funcs}->addfunc("substrLen", [["str", undef, TYPE_STRING, 0],["left", undef, TYPE_PLAIN, 0],["length", undef, TYPE_PLAIN, 0]],\&substrlen); #this one works like perls
|
|
$env->eval("substr{str,left,right}:={substrLen[str,left,right-left]}");
|
|
$env->eval("left{str,pos}:={substrLen[str,0,pos]}");
|
|
$env->eval("right{str,pos}:={substrLen[str,length[str]-pos,pos]}");
|
|
|
|
$env->{funcs}->addfunc("reverse", [["in", undef, undef, 0]],\&reverse);
|
|
|
|
$env->eval("now{x = \"UTC\" isa \"\"} := {setzone[#today#, x]}");
|
|
$env->{funcs}->addfunc("setzone", [["date", undef, TYPE_DATE, 0],["zone", undef, TYPE_STRING, 0]], \&setzone);
|
|
|
|
$env->{funcs}->addfunc("unit", [["in", undef, undef, 0]], \&unit);
|
|
$env->{funcs}->addfunc("units", [["in", undef, undef, 0]], \&units);
|
|
$env->{funcs}->addfunc("error", [["in", undef, TYPE_STRING, 0]], \&doerror);
|
|
$env->{funcs}->addfunc("match", [["regex", undef, TYPE_STRING, 0], ["input", undef, TYPE_STRING, 0], ["options",TYPE_STRING,TYPE_STRING, 0]], \&match);
|
|
|
|
$env->eval('max{x isa ...} := {if (length[x] == 1 && x@0$ conforms []) {x = x@0$}; var z=[x]; var m = pop[z]; var n = length[z]; var q; while((n=n-1)>=0){q=pop[z]; q>m?m=q:0}; m}');
|
|
$env->eval('min{x isa ...} := {if (length[x] == 1 && x@0$ conforms []) {x = x@0$}; var z=[x]; var m = pop[z]; var n = length[z]; var q; while((n=n-1)>=0){q=pop[z]; q<m?m=q:0}; m}');
|
|
}
|
|
|
|
open(my $log, ">>", "/var/www/farnsworth/htdocs/test/debuglog.log");
|
|
$log->autoflush(1);
|
|
|
|
sub dbgprint
|
|
{
|
|
#with an array we give the number of elements, with a string we give the length of the string
|
|
my ($args, $eval, $branches)= @_;
|
|
|
|
my $input = $eval->{vars}->getvar("str"); #i should clean this up more too
|
|
my $string = $input->getstring();
|
|
|
|
print "DEBUGLOG: $string\n";
|
|
print $log "$string\n";
|
|
|
|
return Math::Farnsworth::Value::Pari->new(1);
|
|
}
|
|
|
|
sub dbgbranch
|
|
{
|
|
#with an array we give the number of elements, with a string we give the length of the string
|
|
my ($args, $eval, $branches)= @_;
|
|
|
|
$eval->{dumpbranches} = 1- $eval->{dumpbranches};
|
|
|
|
return Math::Farnsworth::Value::Pari->new($eval->{dumpbranches});
|
|
}
|
|
|
|
sub doerror
|
|
{
|
|
#with an array we give the number of elements, with a string we give the length of the string
|
|
my ($args, $eval, $branches)= @_;
|
|
|
|
my $input = $eval->{vars}->getvar("in"); #i should clean this up more too
|
|
|
|
error $input->getstring();
|
|
}
|
|
|
|
sub match
|
|
{
|
|
my ($args, $eval, $branches)= @_;
|
|
|
|
my $input = $eval->{vars}->getvar("input");
|
|
my $regex = $eval->{vars}->getvar("regex");
|
|
my $options = $eval->{vars}->getvar("options");
|
|
|
|
error $@ if $@;
|
|
}
|
|
|
|
sub units
|
|
{
|
|
#with an array we give the number of elements, with a string we give the length of the string
|
|
my ($args, $eval, $branches)= @_;
|
|
|
|
my $input = $eval->{vars}->getvar("in"); #i should clean this up more too
|
|
|
|
error "Need number with units for units[]" unless $input->istype("Pari");
|
|
|
|
my $units = $input->getdimen();
|
|
|
|
return Math::Farnsworth::Value::Pari->new(1.0, $units);
|
|
}
|
|
|
|
sub setzone
|
|
{
|
|
#with an array we give the number of elements, with a string we give the length of the string
|
|
my ($args, $eval, $branches)= @_;
|
|
|
|
my $date = $eval->{vars}->getvar("date"); #i should clean this up more too
|
|
my $zone = $eval->{vars}->getvar("zone"); #i should clean this up more too
|
|
|
|
$date->getdate()->set_time_zone($zone->getstring());
|
|
|
|
return $date;
|
|
}
|
|
|
|
sub unit
|
|
{
|
|
#args is... a Math::Farnsworth::Value array
|
|
my ($args, $eval, $branches)= @_;
|
|
|
|
#print Dumper($branches);
|
|
|
|
if ((ref($branches->[1][0]) ne "Fetch") || (!$eval->{units}->isunit($branches->[1][0][0])))
|
|
{
|
|
die "First argument to unit[] must be a unit name";
|
|
}
|
|
|
|
my $unitvar = $eval->{units}->getunit($branches->[1][0][0]);
|
|
|
|
return $unitvar; #if its undef, its undef! i should really make some kind of error checking here
|
|
}
|
|
|
|
sub sort
|
|
{
|
|
#args is... a Math::Farnsworth::Value array
|
|
my ($args, $eval, $branches)= @_;
|
|
|
|
my $argcount = $args->getarray();
|
|
|
|
my $sortlambda;
|
|
|
|
if (ref($args->getarrayref()->[0]) eq "Math::Farnsworth::Value::Lambda")
|
|
{
|
|
$sortlambda = shift(@{$args->getarrayref});
|
|
}
|
|
else
|
|
{
|
|
#i should really do this outside the sub ONCE, but i'm lazy for now
|
|
$sortlambda = $eval->eval("{|a,b| a <=> b}");
|
|
}
|
|
|
|
my $sortsub = sub
|
|
{
|
|
my $val = $eval->evalbranch(bless [(bless [$a, $b], 'Array'), $sortlambda], 'LambdaCall');
|
|
|
|
0+$val->toperl(); #return this, just to make sure the value is right
|
|
};
|
|
|
|
my @sorts;
|
|
|
|
if ($args->getarray() > 1)
|
|
{
|
|
#we've been given a bunch of things, assume we need to sort them like that
|
|
push @sorts, $args->getarray();
|
|
}
|
|
elsif (($args->getarray() == 1) && (ref($args->getarrayref()->[0]) eq "Math::Farnsworth::Value::Array"))
|
|
{
|
|
#given an array as a second value, dereference it since its the only thing we've got
|
|
push @sorts, $args->getarrayref()->[0]->getarray();
|
|
}
|
|
else
|
|
{
|
|
#ok you want me to sort ONE thing? i'll sort that one thing, in O(1) time!
|
|
return $args->getarrayref()->[0];
|
|
}
|
|
|
|
my @rets = CORE::sort $sortsub @sorts;
|
|
|
|
#print "SORT RETURNING!\n";
|
|
#print Dumper(\@rets);
|
|
|
|
return new Math::Farnsworth::Value::Array([@rets]);
|
|
}
|
|
|
|
sub push
|
|
{
|
|
#args is... a Math::Farnsworth::Value array
|
|
my ($args, $eval, $branches)= @_;
|
|
|
|
if ((ref($branches->[1][0]) ne "Fetch") || (!$eval->{vars}->isvar($branches->[1][0][0])))
|
|
{
|
|
die "First argument to push must be a variable";
|
|
}
|
|
|
|
my $arrayvar = $eval->{vars}->getvar($branches->[1][0][0]);
|
|
|
|
unless (ref($arrayvar) eq "Math::Farnsworth::Value::Array")
|
|
{
|
|
die "First argument to push must be an array";
|
|
}
|
|
|
|
#ok type checking is done, do the push!
|
|
|
|
my @input = $args->getarray();
|
|
shift @input; #remove the original array value
|
|
|
|
#i should probably flatten arrays here so that; a=[1,2,3]; push[a,a]; will result in a = [1,2,3,1,2,3]; instead of a = [1,2,3,[1,2,3]];
|
|
|
|
CORE::push @{$arrayvar->getarrayref()}, @input;
|
|
|
|
return new Math::Farnsworth::Value::Pari(0+@input); #returns number of items pushed
|
|
}
|
|
|
|
sub unshift
|
|
{
|
|
#args is... a Math::Farnsworth::Value array
|
|
my ($args, $eval, $branches)= @_;
|
|
|
|
if ((ref($branches->[1][0]) ne "Fetch") || (!$eval->{vars}->isvar($branches->[1][0][0])))
|
|
{
|
|
die "First argument to push must be a variable";
|
|
}
|
|
|
|
my $arrayvar = $eval->{vars}->getvar($branches->[1][0][0]);
|
|
|
|
unless (ref($arrayvar) eq "Math::Farnsworth::Value::Array")
|
|
{
|
|
die "First argument to push must be an array";
|
|
}
|
|
|
|
#ok type checking is done, do the push!
|
|
|
|
my @input = $args->getarray();
|
|
shift @input; #remove the original array value
|
|
|
|
#i should probably flatten arrays here so that; a=[1,2,3]; push[a,a]; will result in a = [1,2,3,1,2,3]; instead of a = [1,2,3,[1,2,3]];
|
|
|
|
CORE::unshift @{$arrayvar->getarrayref()}, @input;
|
|
|
|
return new Math::Farnsworth::Value::Pari(0+@input);
|
|
}
|
|
|
|
sub pop
|
|
{
|
|
#args is... a Math::Farnsworth::Value array
|
|
my ($args, $eval, $branches)= @_;
|
|
|
|
if ((ref($branches->[1][0]) ne "Fetch") || (!$eval->{vars}->isvar($branches->[1][0][0])))
|
|
{
|
|
die "Argument to pop must be a variable";
|
|
}
|
|
|
|
my $arrayvar = $eval->{vars}->getvar($branches->[1][0][0]);
|
|
|
|
unless (ref($arrayvar) eq "Math::Farnsworth::Value::Array")
|
|
{
|
|
die "Argument to pop must be an array";
|
|
}
|
|
|
|
#ok type checking is done, do the pop
|
|
|
|
my $retval = CORE::pop @{$arrayvar->getarrayref()};
|
|
|
|
return $retval; #pop returns the value of the element removed
|
|
}
|
|
|
|
sub shift
|
|
{
|
|
#args is... a Math::Farnsworth::Value array
|
|
my ($args, $eval, $branches)= @_;
|
|
|
|
my $var = $eval->{vars}->getvar("arr");
|
|
my $varref = $var->getref();
|
|
|
|
error "Need lvalue for input to shift[]" unless defined $varref;
|
|
|
|
#if ((ref($branches->[1][0]) ne "Fetch") || (!$eval->{vars}->isvar($branches->[1][0][0])))
|
|
#{
|
|
# die "Argument to shift must be a variable";
|
|
#}
|
|
|
|
#my $arrayvar = $eval->{vars}->getvar($branches->[1][0][0]);
|
|
|
|
unless (ref($var) eq "Math::Farnsworth::Value::Array")
|
|
{
|
|
die "Argument to shift must be an array";
|
|
}
|
|
|
|
#ok type checking is done, do the pop
|
|
|
|
my $retval = CORE::shift @{${$varref}->getarrayref()};
|
|
|
|
return $retval; #pop returns the value of the element removed
|
|
}
|
|
|
|
sub length
|
|
{
|
|
#with an array we give the number of elements, with a string we give the length of the string
|
|
my ($args, $eval, $branches)= @_;
|
|
my @argsarry = $args->getarray();
|
|
|
|
my @rets;
|
|
|
|
for my $arg (@argsarry)
|
|
{
|
|
if (ref($arg) eq "Math::Farnsworth::Value::Array")
|
|
{
|
|
CORE::push @rets, Math::Farnsworth::Value::Pari->new(scalar $arg->getarray());
|
|
}
|
|
elsif (ref($arg) eq "Math::Farnsworth::Value::String")
|
|
{
|
|
CORE::push @rets, Math::Farnsworth::Value::Pari->new(length $arg->getstring());
|
|
}
|
|
else
|
|
{
|
|
#until i decide how this should work on regular numbers, just do this
|
|
CORE::push @rets, Math::Farnsworth::Value::Pari->new(0);
|
|
}
|
|
}
|
|
|
|
if (@rets > 1)
|
|
{
|
|
return Math::Farnsworth::Value::Array->new(\@rets);
|
|
}
|
|
else
|
|
{
|
|
return $rets[0];
|
|
}
|
|
}
|
|
|
|
sub reverse
|
|
{
|
|
#with an array we give the number of elements, with a string we give the length of the string
|
|
my ($args, $eval, $branches)= @_;
|
|
my @argsarry = $args->getarray();
|
|
|
|
my @rets;
|
|
|
|
for my $arg (reverse @argsarry) #this will make reverse[1,2,3,4] return [4,3,2,1]
|
|
{
|
|
if (ref($arg) eq "Math::Farnsworth::Value::Array")
|
|
{
|
|
CORE::push @rets, Math::Farnsworth::Value::Array->new([reverse $arg->getarray()]);
|
|
}
|
|
elsif (ref($arg) eq "Math::Farnsworth::Value::String")
|
|
{
|
|
CORE::push @rets, Math::Farnsworth::Value::String->new("".reverse($arg->getstring()));
|
|
}
|
|
else
|
|
{
|
|
CORE::push @rets, $arg; #should i make it print the reverse of all its arguments? yes, lets fix that
|
|
}
|
|
}
|
|
|
|
if (@rets > 1)
|
|
{
|
|
return Math::Farnsworth::Value::Array->new(\@rets);
|
|
}
|
|
else
|
|
{
|
|
return $rets[0];
|
|
}
|
|
}
|
|
|
|
sub substrlen
|
|
{
|
|
#with an array we give the number of elements, with a string we give the length of the string
|
|
my ($args, $eval, $branches)= @_;
|
|
my @arg = $args->getarray();
|
|
|
|
if (ref $arg[0] eq "Math::Farnsworth::Value::String")
|
|
{
|
|
#do i need to do something to convert these to work? (the 1,2 anyway?)
|
|
my $ns = substr($arg[0]->getstring(), $arg[1]->toperl(), $arg[2]->toperl());
|
|
#print "SUBSTR :: $ns\n";
|
|
return Math::Farnsworth::Value::String->new($ns);
|
|
}
|
|
else
|
|
{
|
|
die "substr and friends only works on strings";
|
|
}
|
|
}
|
|
|
|
sub ord
|
|
{
|
|
#with an array we give the number of elements, with a string we give the length of the string
|
|
my ($args, $eval, $branches)= @_;
|
|
|
|
my $input = $eval->{vars}->getvar("in"); #i should clean this up more too
|
|
|
|
my $ns = ord($input->getstring());
|
|
return Math::Farnsworth::Value::Pari->new($ns);
|
|
}
|
|
|
|
sub chr
|
|
{
|
|
#with an array we give the number of elements, with a string we give the length of the string
|
|
my ($args, $eval, $branches)= @_;
|
|
|
|
my $input = $eval->{vars}->getvar("in"); #i should clean this up more too
|
|
|
|
my $ns = chr($input->toperl());
|
|
return Math::Farnsworth::Value::String->new($ns);
|
|
}
|
|
|
|
sub index
|
|
{
|
|
#with an array we give the number of elements, with a string we give the length of the string
|
|
my ($args, $eval, $branches)= @_;
|
|
|
|
my $string = $eval->{vars}->getvar("str")->getstring();
|
|
my $substr = $eval->{vars}->getvar("substr")->getstring();
|
|
my $pos = $eval->{vars}->getvar("pos")->toperl();
|
|
|
|
my $ns = index $string, $substr, $pos; #substr($arg[0]{pari}, "".$arg[1]{pari}, "".$arg[2]{pari});
|
|
return Math::Farnsworth::Value::Pari->new($ns); #give string flag of 1, since we don't know what language is intended
|
|
}
|
|
|
|
sub eval
|
|
{
|
|
#with an array we give the number of elements, with a string we give the length of the string
|
|
my ($args, $eval, $branches, $reval)= @_;
|
|
my $evalstr = $eval->{vars}->getvar("str")->getstring();
|
|
|
|
# my $nvars = new Math::Farnsworth::Variables($eval->{vars});
|
|
# my %nopts = (vars => $nvars, funcs => $eval->{funcs}, units => $eval->{units}, parser => $eval->{parser});
|
|
# my $neval = $eval->new(%nopts);
|
|
|
|
return $reval->eval($evalstr);
|
|
}
|
|
|
|
1;
|