drygdryg/calc
1
0
Fork 0
mirror of https://github.com/lcn2/calc.git synced 2025-08-16 01:03:29 +03:00
Code Issues Packages Projects Releases Wiki Activity

Release calc version 2.12.4.10

Browse Source
This commit is contained in:
Landon Curt Noll
2013-08-11 02:13:25 -07:00
parent 7f125396c1
commit 17e3535595
70 changed files with 6874 additions and 628 deletions
Download Patch File Download Diff File Expand all files Collapse all files

34
cal/Makefile
View File

@@ -18,8 +18,8 @@
# received a copy with calc; if not, write to Free Software Foundation, Inc.
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
#
# @(#) $Revision: 30.5 $
# @(#) $Id: Makefile,v 30.5 2011/05/23 22:50:18 chongo Exp $
# @(#) $Revision: 30.7 $
# @(#) $Id: Makefile,v 30.7 2013/08/11 09:07:26 chongo Exp $
# @(#) $Source: /usr/local/src/bin/calc/cal/RCS/Makefile,v $
#
# Under source code control: 1991/07/21 05:00:54
@@ -182,19 +182,21 @@ TOUCH= touch
# The calc files to install
#
CALC_FILES= README bigprime.cal deg.cal ellip.cal lucas.cal lucas_chk.cal \
lucas_tbl.cal mersenne.cal mod.cal pell.cal pi.cal pix.cal \
pollard.cal poly.cal psqrt.cal quat.cal regress.cal solve.cal \
sumsq.cal surd.cal unitfrac.cal varargs.cal chrem.cal mfactor.cal \
bindings randmprime.cal test1700.cal randrun.cal linear.cal \
randbitrun.cal bernoulli.cal test2300.cal test2600.cal \
test2700.cal test3100.cal test3300.cal test3400.cal prompt.cal \
test3500.cal seedrandom.cal test4000.cal test4100.cal test4600.cal \
beer.cal hello.cal test5100.cal test5200.cal randombitrun.cal \
randomrun.cal repeat.cal xx_print.cal natnumset.cal qtime.cal \
test8400.cal test8500.cal test8600.cal chi.cal intfile.cal screen.cal \
dotest.cal set8700.cal set8700.line alg_config.cal sumtimes.cal \
dms.cal hms.cal gvec.cal
CALC_FILES= alg_config.cal beer.cal bernoulli.cal bernpoly.cal \
bigprime.cal bindings brentsolve.cal chi.cal chrem.cal constants.cal \
deg.cal dms.cal dotest.cal ellip.cal factorial2.cal factorial.cal \
gvec.cal hello.cal hms.cal intfile.cal lambertw.cal linear.cal \
lnseries.cal lucas.cal lucas_chk.cal lucas_tbl.cal mersenne.cal \
mfactor.cal mod.cal natnumset.cal pell.cal pi.cal pix.cal pollard.cal \
poly.cal prompt.cal psqrt.cal qtime.cal quat.cal randbitrun.cal \
randmprime.cal randombitrun.cal randomrun.cal randrun.cal README \
regress.cal repeat.cal screen.cal seedrandom.cal set8700.cal \
set8700.line solve.cal specialfunctions.cal statistics.cal sumsq.cal \
sumtimes.cal surd.cal test1700.cal test2300.cal test2600.cal \
test2700.cal test3100.cal test3300.cal test3400.cal test3500.cal \
test4000.cal test4100.cal test4600.cal test5100.cal test5200.cal \
test8400.cal test8500.cal test8600.cal test8900.cal toomcook.cal \
unitfrac.cal varargs.cal xx_print.cal zeta2.cal
# These files are found (but not built) in the distribution
#
@@ -293,7 +295,7 @@ install: all
${RM} -f ${T}${CALC_SHAREDIR}/$$i.new; \
${CP} -f $$i ${T}${CALC_SHAREDIR}/$$i.new; \
${CHMOD} 0444 ${T}${CALC_SHAREDIR}/$$i.new; \
${MV} -f ${T}${CALC_SHAREDIR}/$$i.new ${T}${CALC_SHAREDIR}/$$i; \
${MV} -f ${T}${CALC_SHAREDIR}/$$i.new ${T}${CALC_SHAREDIR}/$$i;\
echo "installed ${T}${CALC_SHAREDIR}/$$i"; \
fi; \
done

26
cal/alg_config.cal
View File

@@ -17,8 +17,8 @@
* received a copy with calc; if not, write to Free Software Foundation, Inc.
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*
* @(#) $Revision: 30.1 $
* @(#) $Id: alg_config.cal,v 30.1 2007/03/16 11:09:54 chongo Exp $
* @(#) $Revision: 30.2 $
* @(#) $Id: alg_config.cal,v 30.2 2013/08/11 08:41:38 chongo Exp $
* @(#) $Source: /usr/local/src/bin/calc/cal/RCS/alg_config.cal,v $
*
* Under source code control: 2006/06/07 14:10:11
@@ -80,7 +80,8 @@ define mul_loop(repeat, x)
len = sizeof((*x)[0]) / baseb_bytes;
for (i=1; i < 4; ++i) {
if ((sizeof((*x)[i]) / baseb_bytes) != len) {
quit "mul_loop: 2nd arg matrix elements are not of equal BASEB-bit word length";
quit "mul_loop: 2nd arg matrix elements are not of "
"equal BASEB-bit word length";
}
}
@@ -378,7 +379,8 @@ define best_mul2()
}
} while (ratio >= 1.0);
if (config("user_debug") > 0) {
printf("alg1/alg2 ratio now < 1.0, starting binary search between %d and %d\n",
printf("alg1/alg2 ratio now < 1.0, starting binary search "
"between %d and %d\n",
low, high);
}
@@ -472,7 +474,8 @@ define sq_loop(repeat, x)
len = sizeof((*x)[0]) / baseb_bytes;
for (i=1; i < 4; ++i) {
if ((sizeof((*x)[i]) / baseb_bytes) != len) {
quit "sq_loop: 2nd arg matrix elements are not of equal BASEB-bit word length";
quit "sq_loop: 2nd arg matrix elements are not of equal "
"BASEB-bit word length";
}
}
@@ -769,7 +772,8 @@ define best_sq2()
}
} while (ratio >= 1.0);
if (config("user_debug") > 0) {
printf("alg1/alg2 ratio now < 1.0, starting binary search between %d and %d\n",
printf("alg1/alg2 ratio now < 1.0, starting binary search "
"between %d and %d\n",
low, high);
}
@@ -866,7 +870,8 @@ define pow_loop(repeat, x, ex)
len = sizeof((*x)[0]) / baseb_bytes;
for (i=1; i < 4; ++i) {
if ((sizeof((*x)[i]) / baseb_bytes) != len) {
quit "pow_loop: 2nd arg matrix elements are not of equal BASEB-bit word length";
quit "pow_loop: 2nd arg matrix elements are not of "
"equal BASEB-bit word length";
}
}
if (!isint(ex) || ex < 3) {
@@ -1151,7 +1156,8 @@ define best_pow2()
if (config("user_debug") > 1) {
printf(" pmod alg1/alg2 ratio = %.3f\n", ratio);
if (ratio > 1.0 && ratio <= 1.02) {
printf(" while alg1 is slightly better than alg2, it is not clearly better\n");
printf(" while alg1 is slightly better than alg2, "
"it is not clearly better\n");
}
}
} while (ratio <= 1.02);
@@ -1205,8 +1211,8 @@ define best_pow2()
looped = 1;
} while (ratio >= 1.0);
if (config("user_debug") > 0) {
printf("alg1/alg2 ratio now < 1.0, starting binary search between %d and %d\n",
low, high);
printf("alg1/alg2 ratio now < 1.0, starting binary search "
"between %d and %d\n", low, high);
}
/*

59
cal/bernpoly.cal Normal file
View File

@@ -0,0 +1,59 @@
/*
* bernpoly- Bernoully polynomials B_n(z) for arbitrary n,z..
*
* Copyright (C) 2013 Christoph Zurnieden
*
* bernpoly is open software; you can redistribute it and/or modify it under
* the terms of the version 2.1 of the GNU Lesser General Public License
* as published by the Free Software Foundation.
*
* bernpoly is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General
* Public License for more details.
*
* A copy of version 2.1 of the GNU Lesser General Public License is
* distributed with calc under the filename COPYING-LGPL. You should have
* received a copy with calc; if not, write to Free Software Foundation, Inc.
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*
* @(#) $Revision: 30.3 $
* @(#) $Id: bernpoly.cal,v 30.3 2013/08/11 08:41:38 chongo Exp $
* @(#) $Source: /usr/local/src/bin/calc/cal/RCS/bernpoly.cal,v $
*
* Under source code control: 2013/08/11 01:31:28
* File existed as early as: 2013
*/
static resource_debug_level;
resource_debug_level = config("resource_debug", 0);
read -once zeta2
/* Idea by Don Zagier */
define bernpoly(n,z){
local h s c k;
if(isint(n) && n>=0){
h=0;s=0;c=-1;
for(k=1;k<=n+1;k++){
c*=1-(n+2)/k;
s+=z^n;
z++;
h+=c*s/k;
}
return h;
}
else return -n*hurwitzzeta(1-n,z);
}
/*
* restore internal function from resource debugging
*/
config("resource_debug", resource_debug_level),;
if (config("resource_debug") & 3) {
print "bernpoly(n,z)";
}

257
cal/brentsolve.cal Normal file
View File

@@ -0,0 +1,257 @@
/*
* brentsolve- Root finding with the Brent-Dekker trick.
*
* Copyright (C) 2013 Christoph Zurnieden
*
* brentsolve is open software; you can redistribute it and/or modify it under
* the terms of the version 2.1 of the GNU Lesser General Public License
* as published by the Free Software Foundation.
*
* brentsolve is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General
* Public License for more details.
*
* A copy of version 2.1 of the GNU Lesser General Public License is
* distributed with calc under the filename COPYING-LGPL. You should have
* received a copy with calc; if not, write to Free Software Foundation, Inc.
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*
* @(#) $Revision: 30.3 $
* @(#) $Id: brentsolve.cal,v 30.3 2013/08/11 08:41:38 chongo Exp $
* @(#) $Source: /usr/local/src/bin/calc/cal/RCS/brentsolve.cal,v $
*
* Under source code control: 2013/08/11 01:31:28
* File existed as early as: 2013
*/
static resource_debug_level;
resource_debug_level = config("resource_debug", 0);
/*
A short explanation is at http://en.wikipedia.org/wiki/Brent%27s_method
I tried to follow the description at wikipedia as much as possible to make
the slight changes I did more visible.
You may give http://people.sc.fsu.edu/~jburkardt/cpp_src/brent/brent.html a
short glimpse (Brent's originl Fortran77 versions and some translations of
it).
*/
static true = 1;
static false = 0;
define brentsolve(low, high,eps){
local a b c d fa fb fc fa2 fb2 fc2 s fs tmp tmp2 mflag i places;
a = low;
b = high;
c = 0;
if(isnull(eps))
eps = epsilon(epsilon()*1e-3);
places = highbit(1 + int( 1/epsilon() ) ) + 1;
d = 1/eps;
fa = f(a);
fb = f(b);
fc = 0;
s = 0;
fs = 0;
if(fa * fb >= 0){
if(fa < fb){
epsilon(eps);
return a;
}
else{
epsilon(eps);
return b;
}
}
if(abs(fa) < abs(fb)){
tmp = a; a = b; b = tmp;
tmp = fa; fa = fb; fb = tmp;
}
c = a;
fc = fa;
mflag = 1;
i = 0;
while(!(fb==0) && (abs(a-b) > eps)){
if((fa != fc) && (fb != fc)){
/* Inverse quadratic interpolation*/
fc2 = fc^2;
fa2 = fa^2;
s = bround(((fb^2*((fc*a)-(c*fa)))+(fb*((c*fa2)-(fc2*a)))+(b*((fc2*fa)
-(fc*fa2))))/((fc - fb)*(fa - fb)*(fc - fa)),places++);
}
else{
/* Secant Rule*/
s =bround( b - fb * (b - a) / (fb - fa),places++);
}
tmp2 = (3 * a + b) / 4;
if( (!( ((s > tmp2) && (s < b))||((s < tmp2) && (s > b))))
|| (mflag && (abs(s - b) >= (abs(b - c) / 2)))
|| (!mflag && (abs(s - b) >= (abs(c - d) / 2)))) {
s = (a + b) / 2;
mflag = true;
}
else{
if( (mflag && (abs(b - c) < eps))
|| (!mflag && (abs(c - d) < eps))) {
s = (a + b) / 2;
mflag = true;
}
else
mflag = false;
}
fs = f(s);
c = b;
fc = fb;
if (fa * fs < 0){
b = s;
fb = fs;
}
else {
a = s;
fa = fs;
}
if (abs(fa) < abs(fb)){
tmp = a; a = b; b = tmp;
tmp = fa; fa = fb; fb = tmp;
}
i++;
if (i > 1000){
epsilon(eps);
return newerror("brentsolve: does not converge");
}
}
epsilon(eps);
return b;
}
/*
A variation of the solver to accept functions named differently from "f". The
code should explain it.
*/
define brentsolve2(low, high,which,eps){
local a b c d fa fb fc fa2 fb2 fc2 s fs tmp tmp2 mflag i places;
a = low;
b = high;
c = 0;
switch(param(0)){
case 0:
case 1: return newerror("brentsolve2: not enough argments");
case 2: eps = epsilon(epsilon()*1e-2);
which = 0;break;
case 3: eps = epsilon(epsilon()*1e-2);break;
default: break;
};
places = highbit(1 + int(1/epsilon())) + 1;
d = 1/eps;
switch(which){
case 1: fa = __CZ__invbeta(a);
fb = __CZ__invbeta(b); break;
case 2: fa = __CZ__invincgamma(a);
fb = __CZ__invincgamma(b); break;
default: fa = f(a);fb = f(b); break;
};
fc = 0;
s = 0;
fs = 0;
if(fa * fb >= 0){
if(fa < fb)
return a;
else
return b;
}
if(abs(fa) < abs(fb)){
tmp = a; a = b; b = tmp;
tmp = fa; fa = fb; fb = tmp;
}
c = a;
fc = fa;
mflag = 1;
i = 0;
while(!(fb==0) && (abs(a-b) > eps)){
if((fa != fc) && (fb != fc)){
/* Inverse quadratic interpolation*/
fc2 = fc^2;
fa2 = fa^2;
s = bround(((fb^2*((fc*a)-(c*fa)))+(fb*((c*fa2)-(fc2*a)))+(b*((fc2*fa)
-(fc*fa2))))/((fc - fb)*(fa - fb)*(fc - fa)),places);
places++;
}
else{
/* Secant Rule*/
s =bround( b - fb * (b - a) / (fb - fa),places);
places++;
}
tmp2 = (3 * a + b) / 4;
if( (!( ((s > tmp2) && (s < b))||((s < tmp2) && (s > b))))
|| (mflag && (abs(s - b) >= (abs(b - c) / 2)))
|| (!mflag && (abs(s - b) >= (abs(c - d) / 2)))) {
s = (a + b) / 2;
mflag = true;
}
else{
if( (mflag && (abs(b - c) < eps))
|| (!mflag && (abs(c - d) < eps))) {
s = (a + b) / 2;
mflag = true;
}
else
mflag = false;
}
switch(which){
case 1: fs = __CZ__invbeta(s); break;
case 2: fs = __CZ__invincgamma(s); break;
default: fs = f(s); break;
};
c = b;
fc = fb;
if (fa * fs < 0){
b = s;
fb = fs;
}
else {
a = s;
fa = fs;
}
if (abs(fa) < abs(fb)){
tmp = a; a = b; b = tmp;
tmp = fa; fa = fb; fb = tmp;
}
i++;
if (i > 1000){
return newerror("brentsolve2: does not converge");
}
}
return b;
}
/*
* restore internal function from resource debugging
*/
config("resource_debug", resource_debug_level),;
if (config("resource_debug") & 3) {
print "brentsolve(low, high,eps)";
print "brentsolve2(low, high,which,eps)";
}

104
cal/constants.cal Normal file
View File

@@ -0,0 +1,104 @@
/*
* constants - implementation of different constants to arbitrary precision
*
* Copyright (C) 2013 Christoph Zurnieden
*
* constants is open software; you can redistribute it and/or modify it under
* the terms of the version 2.1 of the GNU Lesser General Public License
* as published by the Free Software Foundation.
*
* constants is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General
* Public License for more details.
*
* A copy of version 2.1 of the GNU Lesser General Public License is
* distributed with calc under the filename COPYING-LGPL. You should have
* received a copy with calc; if not, write to Free Software Foundation, Inc.
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*
* @(#) $Revision: 30.3 $
* @(#) $Id: constants.cal,v 30.3 2013/08/11 08:41:38 chongo Exp $
* @(#) $Source: /usr/local/src/bin/calc/cal/RCS/constants.cal,v $
*
* Under source code control: 2013/08/11 01:31:28
* File existed as early as: 2013
*/
static resource_debug_level;
resource_debug_level = config("resource_debug", 0);
static __CZ__euler_mascheroni = 0;
static __CZ__euler_mascheroni_prec = 0;
define e(){
local k temp1 temp2 ret eps factor upperlimit prec;
prec = digits(1/epsilon());
if(__CZ__euler_mascheroni != 0 && __CZ__euler_mascheroni_prec >= prec)
return __CZ__euler_mascheroni;
if(prec<=20) return 2.718281828459045235360287471;
if(prec<=1800){
__CZ__euler_mascheroni = exp(1);
__CZ__euler_mascheroni_prec = prec;
}
eps=epsilon(1e-20);
factor = 1;
k = 0;
upperlimit = prec * ln(10);
while(k<upperlimit){
k += ln(factor);
factor++;
}
epsilon(eps);
temp1 = 0;
ret = 1;
for(k=3;k<=factor;k++){
temp2 = temp1;
temp1 = ret;
ret = (k-1) *(temp1 + temp2);
}
ret = inverse( ret * inverse(factorial(factor) ) ) ;
__CZ__euler_mascheroni = ret;
__CZ__euler_mascheroni_prec = prec;
return ret;
}
/* Lupas' series */
static __CZ__catalan = 0;
static __CZ__catalan_prec = 0;
define G(){
local eps a s t n;
eps = epsilon(epsilon()*1e-10);
if(__CZ__catalan != 0 && __CZ__catalan >= log(1/eps))
return __CZ__catalan;
a = 1;
s = 0;
t = 1;
n = 1;
while(abs(t)> eps){
a *= 32 * n^3 * (2*n-1);
a /=((3-16*n+16*n^2)^2);
t = a * (-1)^(n-1) * (40*n^2-24*n+3) / (n^3 * (2*n-1));
s += t;
n += 1;
}
s = s/64;
__CZ__catalan = s;
__CZ__catalan_prec = log(1/eps);
epsilon(eps);
return s;
}
config("resource_debug", resource_debug_level),;
if (config("resource_debug") & 3) {
print "e()";
print "G()";
}

204
cal/factorial.cal Normal file
View File

@@ -0,0 +1,204 @@
/*
* factorial - implementation of different algorithms for the factorial
*
* Copyright (C) 2013 Christoph Zurnieden
*
* factorial is open software; you can redistribute it and/or modify it under
* the terms of the version 2.1 of the GNU Lesser General Public License
* as published by the Free Software Foundation.
*
* factorial is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General
* Public License for more details.
*
* A copy of version 2.1 of the GNU Lesser General Public License is
* distributed with calc under the filename COPYING-LGPL. You should have
* received a copy with calc; if not, write to Free Software Foundation, Inc.
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*
* @(#) $Revision: 30.3 $
* @(#) $Id: factorial.cal,v 30.3 2013/08/11 08:41:38 chongo Exp $
* @(#) $Source: /usr/local/src/bin/calc/cal/RCS/factorial.cal,v $
*
* Under source code control: 2013/08/11 01:31:28
* File existed as early as: 2013
*/
/*
* hide internal function from resource debugging
*/
static resource_debug_level;
resource_debug_level = config("resource_debug", 0);
/*
get dependencies
*/
read -once toomcook;
/* A simple list to keep things...uhm...simple?*/
static __CZ__primelist = list();
/* Helper for primorial: fill list with primes in range a,b */
define __CZ__fill_prime_list(a,b)
{
local k;
k=a;
if(isprime(k))k--;
while(1){
k = nextprime(k);
if(k > b) break;
append(__CZ__primelist,k );
}
}
/* Helper for factorial: how often prime p divides the factorial of n */
define __CZ__prime_divisors(n,p)
{
local q,m;
q = n;
m = 0;
if (p > n) return 0;
if (p > n/2) return 1;
while (q >= p) {
q = q//p;
m += q;
}
return m;
}
/*
Wrapper. Please set cut-offs to own taste and hardware.
*/
define factorial(n){
local prime result shift prime_list k k1 k2 expo_list pix cut primorial;
result = 1;
prime = 2;
if(!isint(n)) {
return newerror("factorial(n): n is not an integer"); ## or gamma(n)?
}
if(n < 0) return newerror("factorial(n): n < 0");
if(n < 9000 && !isdefined("test8900")) {
## builtin is implemented with splitting but only with
## Toom-Cook 2 (by Karatsuba (the father))
return n!;
}
shift = __CZ__prime_divisors(n,prime);
prime = 3;
cut = n//2;
pix = pix(cut);
prime_list = mat[pix];
expo_list = mat[pix];
k = 0;
/*
Peter Borwein's algorithm
@Article{journals/jal/Borwein85,
author = {Borwein, Peter B.},
title = {On the Complexity of Calculating Factorials.},
journal = {J. Algorithms},
year = {1985},
number = {3},
url = {http://dblp.uni-trier.de/db/journals/jal/jal6.html#Borwein85}
*/
do {
prime_list[k] = prime;
expo_list[k++] = __CZ__prime_divisors(n,prime);
prime = nextprime(prime);
}while(prime <= cut);
/* size of the largest exponent in bits */
k1 = highbit(expo_list[0]);
k2 = size(prime_list)-1;
for(;k1>=0;k1--){
/*
the cut-off for T-C-4 ist still to low, using T-C-3 here
TODO: check cutoffs
*/
result = toomcook3square(result);
/*
almost all time is spend in this loop, so cutting of the
upper half of the primes makes sense
*/
for(k=0; k<=k2; k++) {
if((expo_list[k] & (1 << k1)) != 0) {
result *= prime_list[k];
}
}
}
primorial = primorial( cut, n);
result *= primorial;
result <<= shift;
return result;
}
/*
Helper for primorial: do the product with binary splitting
TODO: do it without the intermediate list
*/
define __CZ__primorial__lowlevel( a, b ,p)
{
local c;
if( b == a) return p ;
if( b-a > 1){
c= (b + a) >> 1;
return __CZ__primorial__lowlevel( a , c , __CZ__primelist[a] )
* __CZ__primorial__lowlevel( c+1 , b , __CZ__primelist[b] ) ;
}
return __CZ__primelist[a] * __CZ__primelist[b];
}
/*
Primorial, Product of consecutive primes in range a,b
Originally meant to do primorials with a start different from 2, but
found out that this is faster at about a=1,b>=10^5 than the builtin
function pfact(). With the moderately small list a=1,b=10^6 (78498
primes) it is 3 times faster. A quick look-up showed what was already
guessed: pfact() does it linearly. (BTW: what is the time complexity
of the primorial with the naive algorithm?)
*/
define primorial(a,b)
{
local C1 C2;
if(!isint(a)) return newerror("primorial(a,b): a is not an integer");
else if(!isint(b)) return newerror("primorial(a,b): b is not an integer");
else if(a < 0) return newerror("primorial(a,b): a < 0");
else if( b < 2 ) return newerror("primorial(a,b): b < 2");
else if( b < a) return newerror("primorial(a,b): b < a");
else{
/* last prime < 2^32 is also max. prime for nextprime()*/
if(b >= 4294967291) return newerror("primorial(a,b): max. prime exceeded");
if(b == 2) return 2;
/*
Can be extended by way of pfact(b)/pfact(floor(a-1/2)) for small a
*/
if(a<=2 && b < 10^5) return pfact(b);
/* TODO: use pix() and a simple array (mat[])instead*/
__CZ__primelist = list();
__CZ__fill_prime_list(a,b);
C1 = size(__CZ__primelist)-1;
return __CZ__primorial__lowlevel( 0, C1,1)
}
}
/*
* restore internal function from resource debugging
* report important interface functions
*/
config("resource_debug", resource_debug_level),;
if (config("resource_debug") & 3) {
print "factorial(n)";
print "primorial(a, b)";
}

723
cal/factorial2.cal Normal file
View File

@@ -0,0 +1,723 @@
/*
* factorial2 - implementation of different factorial related functions
*
* Copyright (C) 2013 Christoph Zurnieden
*
* factorial2 is open software; you can redistribute it and/or modify it under
* the terms of the version 2.1 of the GNU Lesser General Public License
* as published by the Free Software Foundation.
*
* factorial2 is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General
* Public License for more details.
*
* A copy of version 2.1 of the GNU Lesser General Public License is
* distributed with factorial2 under the filename COPYING-LGPL. You should have
* received a copy with calc; if not, write to Free Software Foundation, Inc.
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*
* @(#) $Revision: 30.3 $
* @(#) $Id: factorial2.cal,v 30.3 2013/08/11 08:41:38 chongo Exp $
* @(#) $Source: /usr/local/src/bin/calc/cal/RCS/factorial2.cal,v $
*
* Under source code control: 2013/08/11 01:31:28
* File existed as early as: 2013
*/
/*
* hide internal function from resource debugging
*/
static resource_debug_level;
resource_debug_level = config("resource_debug", 0);
/*
get dependencies
*/
read -once factorial toomcook specialfunctions;
/*
Factorize a factorial and put the result in a 2-column matrix with pi(n) rows
mat[ primes , exponent ]
Result can be restricted to start at a prime different from 2 with the second
argument "start". That arguments gets taken at face value if it prime and
smaller than n, otherwise the next larger prime is taken if that prime is
smaller than n.
*/
define __CZ__factor_factorial(n,start){
local prime prime_list k pix stop;
if(!isint(n)) return
newerror("__CZ__factor_factorial(n,start): n is not integer");
if(n < 0) return newerror("__CZ__factor_factorial(n,start): n < 0");
if(n == 1) return newerror("__CZ__factor_factorial(n,start): n == 1");
if(start){
if(!isint(start) && start < 0 && start > n)
return newerror("__CZ__factor_factorial(n,start): value of "
"parameter 'start' out of range");
if(start == n && isprime(n)){
prime_list = mat[1 , 2];
prime_list[0,0] = n;
prime_list[0,1] = 1;
}
else if(!isprime(start) && nextprime(start) >n)
return newerror("__CZ__factor_factorial(n,start): value of parameter "
"'start' out of range");
else{
if(!isprime(start)) prime = nextprime(start);
else prime = start;
}
}
else
prime = 2;
pix = pix(n);
if(start){
pix -= pix(prime) -1;
}
prime_list = mat[pix , 2];
k = 0;
do {
prime_list[k ,0] = prime;
prime_list[k++,1] = __CZ__prime_divisors(n,prime);
prime = nextprime(prime);
}while(prime <= n);
return prime_list;
}
/*
subtracts exponents of n_1! from exponents of n_2! with n_1<=n_2
Does not check for size or consecutiveness of the primes or a carry
*/
define __CZ__subtract_factored_factorials(matrix_2n,matrix_n){
local k ret len1,len2,tmp count p e;
len1 = size(matrix_n)/2;
len2 = size(matrix_2n)/2;
if(len2<len1){
swap(len1,len2);
tmp = matrix_n;
matrix_n = matrix_2n;
matrix_2n = tmp;
}
tmp = mat[len1,2];
k = 0;
for(;k<len1;k++){
p = matrix_2n[k,0];
e = matrix_2n[k,1] - matrix_n[k,1];
if(e!=0){
tmp[count ,0] = p;
tmp[count++,1] = e;
}
}
ret = mat[count + (len2-len1),2];
for(k=0;k<count;k++){
ret[k,0] = tmp[k,0];
ret[k,1] = tmp[k,1];
}
free(tmp);
for(k=len1;k<len2;k++){
ret[count,0] = matrix_2n[k,0];
ret[count++,1] = matrix_2n[k,1];
}
return ret;
}
/*
adds exponents of n_1! to exponents of n_2! with n_1<=n_2
Does not check for size or consecutiveness of the primes or a carry
*/
define __CZ__add_factored_factorials(matrix_2n,matrix_n){
local k ret len1,len2,tmp;
len1 = size(matrix_n)/2;
len2 = size(matrix_2n)/2;
if(len2<len1){
swap(len1,len2);
tmp = matrix_n;
matrix_n = matrix_2n;
matrix_2n = tmp;
}
ret = mat[len2,2];
k = 0;
for(;k<len1;k++){
ret[k,0] = matrix_2n[k,0];
ret[k,1] = matrix_2n[k,1] + matrix_n[k,1];
}
for(;k<len2;k++){
ret[k,0] = matrix_2n[k,0];
ret[k,1] = matrix_2n[k,1];
}
return ret;
}
/*
Does not check if all exponents are positive
timings
this comb comb-this rel. k/n
; benchmark_binomial(10,13)
n=2^13 k=2^10 0.064004 0.016001 + 0.76923076923076923077
n=2^13 k=2^11 0.064004 0.048003 + 0.84615384615384615385
n=2^13 k=2^12 0.068004 0.124008 - 0.92307692307692307692
; benchmark_binomial(10,15)
n=2^15 k=2^10 0.216014 0.024001 + 0.66666666666666666667
n=2^15 k=2^11 0.220014 0.064004 + 0.73333333333333333333
n=2^15 k=2^12 0.228014 0.212014 + 0.8
n=2^15 k=2^13 0.216013 0.664042 - 0.86666666666666666667
n=2^15 k=2^14 0.240015 1.868117 - 0.93333333333333333333
; benchmark_binomial(11,15)
n=2^15 k=2^11 0.216014 0.068004 + 0.73333333333333333333
n=2^15 k=2^12 0.236015 0.212013 + 0.8
n=2^15 k=2^13 0.216013 0.656041 - 0.86666666666666666667
n=2^15 k=2^14 0.244016 1.872117 - 0.93333333333333333333
; benchmark_binomial(11,18)
n=2^18 k=2^11 1.652103 0.100006 + 0.61111111111111111111
n=2^18 k=2^12 1.608101 0.336021 + 0.66666666666666666667
n=2^18 k=2^13 1.700106 1.140071 + 0.72222222222222222222
n=2^18 k=2^14 1.756109 3.924245 - 0.77777777777777777778
n=2^18 k=2^15 2.036127 13.156822 - 0.83333333333333333333
n=2^18 k=2^16 2.172135 41.974624 - 0.88888888888888888889
n=2^18 k=2^17 2.528158 121.523594 - 0.94444444444444444444
; benchmark_binomial(15,25)
n=2^25 k=2^15 303.790985 38.266392 + 0.6
; benchmark_binomial(17,25)
n=2^25 k=2^17 319.127944 529.025062 - 0.68
*/
define benchmark_binomial(s,limit){
local ret k A B T1 T2 start end N K;
N = 2^(limit);
for(k=s;k<limit;k++){
K = 2^k;
start=usertime();A=binomial(N,K);end=usertime();
T1 = end-start;
start=usertime();B=comb(N,K);end=usertime();
T2 = end-start;
print "n=2^"limit,"k=2^"k," ",T1," ",T2,T1<T2?"-":"+"," "k/limit;
if(A!=B){
print "false";
break;
}
}
}
define __CZ__multiply_factored_factorial(matrix,stop){
local prime result shift prime_list k k1 k2 expo_list pix count start;
local hb flag;
result = 1;
shift = 0;
if(!ismat(matrix))
return newerror("__CZ__multiply_factored_factorial(matrix): "
"argument matrix not a matrix ");
if(!matrix[0,0])
return
newerror("__CZ__multiply_factored_factorial(matrix): "
"matrix[0,0] is null/0");
if(!isnull(stop))
pix = stop;
else
pix = size(matrix)/2-1;
if(matrix[0,0] == 2 && matrix[0,1] > 0){
shift = matrix[0,1];
if(pix-1 == 0)
return 2^matrix[0,1];
}
/*
This is a more general way to do the multiplication, so any optimization
must have been done by the caller.
*/
k = 0;
/*
The size of the largest exponent in bits is calculated dynamically.
Can be done more elegantly and saves one run over the whole array if done
inside the main loop.
*/
hb =0;
for(k=0;k<pix;k++){
k1=highbit(matrix[k,1]);
if(hb < k1)hb=k1;
}
k2 = pix;
start = 0;
if(shift) start++;
for(k1=hb;k1>=0;k1--){
/*
the cut-off for T-C-4 ist still too low, using T-C-3 here
TODO: check cutoffs
*/
result = toomcook3square(result);
for(k=start; k<=k2; k++) {
if((matrix[k,1] & (1 << k1)) != 0) {
result *= matrix[k,0];
}
}
}
result <<= shift;
return result;
}
/*
Compute binomial coeficients n!/(k!(n-k)!)
One of the rare cases where a formula once meant to ease manual computation
is actually the (aymptotically) fastest way to do it (in July 2013) for
the extreme case binomial(2N,N) but for a high price, the memory
needed is pi(N)--theoretically.
*/
define binomial(n,k){
local ret factored_n factored_k factored_nk denom num quot K prime_list prime;
local pix diff;
if(!isint(n) || !isint(k))
return newerror("binomial(n,k): input is not integer");
if(n<0 || k<0)
return newerror("binomial(n,k): input is not >= 0"); ;
if(n<k ) return 0;
if(n==k) return 1;
if(k==0) return 1;
if(k==1) return n;
if(n-k==1) return n;
/*
cut-off depends on real size of n,k and size of n/k
The current cut-off is to small for large n, e.g.:
for 2n=2^23, k=n-n/2 the quotient is q=2n/k=0.25. Empirical tests showed
that 2n=2^23 and k=2^16 with q=0.0078125 are still faster than the
builtin function.
The symmetry (n,k) = (n,n-k) is of not much advantage here. One way
might be to get closer to k=n/2 if k<n-k but only if the difference
is small and n very large.
*/
if(n<2e4 && !isdefined("test8900")) return comb(n,k);
if(n<2e4 && k< n-n/2 && !isdefined("test8900")) return comb(n,k);
/*
This should be done in parallel to save some memory, e.g. no temporary
arrays are needed, all can be done inline.
The theoretical memory needed is pi(k).
Which is still a lot.
*/
prime = 2;
pix = pix(n);
prime_list = mat[pix , 2];
K = 0;
do {
prime_list[K ,0] = prime;
diff = __CZ__prime_divisors(n,prime)-
( __CZ__prime_divisors(n-k,prime)+__CZ__prime_divisors(k,prime));
if(diff != 0)
prime_list[K++,1] = diff;
prime = nextprime(prime);
}while(prime <= k);
do {
prime_list[K ,0] = prime;
diff = __CZ__prime_divisors(n,prime)-__CZ__prime_divisors(n-k,prime);
if(diff != 0)
prime_list[K++,1] = diff;
prime = nextprime(prime);
}while(prime <= n-k);
do {
prime_list[K ,0] = prime;
prime_list[K++,1] = __CZ__prime_divisors(n,prime);
prime = nextprime(prime);
}while(prime <= n);
##print K,pix(k),pix(n-k),pix(n);
##factored_k = __CZ__factor_factorial(k,1);
##factored_nk = __CZ__factor_factorial(n-k,1);
##denom = __CZ__add_factored_factorials(factored_k,factored_nk);
##free(factored_k,factored_nk);
##num = __CZ__factor_factorial(n,1);
##quot = __CZ__subtract_factored_factorials( num , denom );
##free(num,denom);
ret = __CZ__multiply_factored_factorial(`prime_list,K-1);
return ret;
}
/*
Compute large catalan numbers C(n) = binomial(2n,n)/(n+1) with
cut-off: (n>5e4)
Needs a lot of memory.
*/
define bigcatalan(n){
if(!isint(n) )return newerror("bigcatalan(n): n is not integer");
if( n<0) return newerror("bigcatalan(n): n < 0");
if( n<5e4 && !isdefined("test8900") ) return catalan(n);
return binomial(2*n,n)/(n+1);
}
/*
df(-111) = -1/3472059605858239446587523014902616804783337112829102414124928
7753332469144201839599609375
df(-3+1i) = 0.12532538977287649201-0.0502372106177184607i
df(2n + 1) = (2*n)!/(n!*2^n)
*/
define __CZ__double_factorial(n){
local n1 n2 diff prime pix K prime_list k;
prime = 3;
pix = pix(2*n)+1;
prime_list = mat[pix , 2];
K = 0;
do {
prime_list[K ,0] = prime;
diff = __CZ__prime_divisors(2*n,prime)-( __CZ__prime_divisors(n,prime));
if(diff != 0)
prime_list[K++,1] = diff;
prime = nextprime(prime);
}while(prime <= n);
do {
prime_list[K ,0] = prime;
prime_list[K++,1] = __CZ__prime_divisors(2*n,prime);
prime = nextprime(prime);
}while(prime <= 2*n);
return __CZ__multiply_factored_factorial(prime_list,K);
/*
n1=__CZ__factor_factorial(2*n,1);
n1[0,1] = n1[0,1]-n;
n2=__CZ__factor_factorial(n,1);
diff=__CZ__subtract_factored_factorials( n1 , n2 );
return __CZ__multiply_factored_factorial(diff);
*/
}
##1, 1, 3, 15, 105, 945, 10395, 135135, 2027025, 34459425, 654729075,
##13749310575, 316234143225, 7905853580625, 213458046676875,
##6190283353629375, 191898783962510625, 6332659870762850625,
##221643095476699771875, 8200794532637891559375
## 1, 2, 8, 48, 384, 3840, 46080, 645120, 10321920, 185794560,
##3715891200, 81749606400, 1961990553600, 51011754393600,
##1428329123020800, 42849873690624000, 1371195958099968000,
##46620662575398912000, 1678343852714360832000, 63777066403145711616000
define doublefactorial(n){
local n1 n2 diff eps ret;
if(!isint(n) ){
/*
Probably one of the not-so-good ideas. See result of
http://www.wolframalpha.com/input/?i=doublefactorial%28a%2Bbi%29
*/
eps=epsilon(epsilon()*1e-2);
ret = 2^(n/2-1/4 * cos(pi()* n)+1/4) * pi()^(1/4 *
cos(pi()* n)-1/4)* gamma(n/2+1);
epsilon(eps);
return ret;
}
if(n==2) return 2;
if(n==3) return 3;
switch(n){
case -1:
case 0 : return 1;break;
case 2 : return 2;break;
case 3 : return 3;break;
case 4 : return 8;break;
default: break;
}
if(isodd(n)){
/*
TODO: find reasonable cutoff
df(2n + 1) = (2*n)!/(n!*2^n)
*/
if(n>0){
n = (n+1)//2;
return __CZ__double_factorial(n);
}
else{
if(n == -3 ) return -1;
n = ((-n)-1)/2;
return ((-1)^-n)/__CZ__double_factorial(n);
}
}
else{
/*
I'm undecided here. The formula for complex n is valid for the negative
integers, too.
*/
n = n>>1;
if(n>0){
if(!isdefined("test8900"))
return factorial(n)<<n;
else
return n!<<n;
}
else
return newerror("doublefactorial(n): even(n) < 0");
}
}
/*
Algorithm 3.17,
Donald Kreher and Douglas Simpson,
Combinatorial Algorithms,
CRC Press, 1998, page 89.
*/
static __CZ__stirling1;
static __CZ__stirling1_n = -1;
static __CZ__stirling1_m = -1;
define stirling1(n,m){
local i j k;
if(n<0)return newerror("stirling1(n,m): n <= 0");
if(m<0)return newerror("stirling1(n,m): m < 0");
if(n<m) return 0;
if(n==m) return 1;
if(m==0 || n==0) return 0;
/* We always use the list */
/*
if(m=1){
if(iseven(n)) return -factorial(n-1);
else return factorial(n-1);
}
if(m == n-1){
if(iseven(n)) return -binomial(n,2);
else return -binomial(n,2);
}
*/
if(__CZ__stirling1_n >= n && __CZ__stirling1_m >= m){
return __CZ__stirling1[n,m];
}
else{
__CZ__stirling1 = mat[n+1,m+1];
__CZ__stirling1[0,0] = 1;
for(i=1;i<=n;i++)
__CZ__stirling1[i,0] = 0;
for(i=1;i<=n;i++){
for(j=1;j<=m;j++){
if(j<=i){
__CZ__stirling1[i, j] = __CZ__stirling1[i - 1, j - 1] - (i - 1)\
* __CZ__stirling1[i - 1, j];
}
else{
__CZ__stirling1[i, j] = 0;
}
}
}
__CZ__stirling1_n = n;
__CZ__stirling1_m = m;
return __CZ__stirling1[n,m];
}
}
define stirling2(n,m){
local k sum;
if(n<0)return newerror("stirling2(n,m): n < 0");
if(m<0)return newerror("stirling2(n,m): m < 0");
if(n<m) return 0;
if(n==0 && n!=m) return 0;
if(n==m) return 1;
if(m==0 )return 0;
if(m==1) return 1;
if(m==2) return 2^(n-1)-1;
/*
There are different methods to speed up alternating sums.
This one doesn't.
*/
if(isdefined("test8900")){
for(k=0;k<=m;k++){
sum += (-1)^(m-k)*comb(m,k)*k^n;
}
return sum/(m!);
}
else{
for(k=0;k<=m;k++){
sum += (-1)^(m-k)*binomial(m,k)*k^n;
}
return sum/factorial(m);
}
}
static __CZ__stirling2;
static __CZ__stirling2_n = -1;
static __CZ__stirling2_m = -1;
define stirling2caching(n,m){
local nm i j ;
if(n<0)return newerror("stirling2iter(n,m): n < 0");
if(m<0)return newerror("stirling2iter(n,m): m < 0");
/* no shortcuts here */
if(n<m) return 0;
if(n==0 && n!=m) return 0;
if(n==m) return 1;
if(m==0 )return 0;
if(m==1) return 1;
if(m==2) return 2^(n-1)-1;
nm = n-m;
if(__CZ__stirling2_n >= n && __CZ__stirling2_m >= m){
return __CZ__stirling2[n,m];
}
else{
__CZ__stirling2 = mat[n+1,m+1];
__CZ__stirling2[0,0] = 1;
for(i=1;i<=n;i++){
__CZ__stirling2[i,0] = 0;
for(j=1;j<=m;j++){
if(j<=i){
__CZ__stirling2[i, j] = __CZ__stirling2[i -1, j -1] + (j )\
* __CZ__stirling2[i - 1, j];
}
else{
__CZ__stirling2[i, j] = 0;
}
}
}
}
__CZ__stirling2_n = (n);
__CZ__stirling2_m = (m);
return __CZ__stirling2[n,m];
}
define bell(n){
local sum s2list k A;
if(!isint(n)) return newerror("bell(n): n is not integer");
if(n < 0) return newerror("bell(n): n is not positive");
/* place some more shortcuts here?*/
if(n<=15){
mat A[16] = {
1, 1, 2, 5, 15, 52, 203, 877, 4140, 21147, 115975, 678570,
4213597, 27644437, 190899322, 1382958545
};
return A[n];
}
/* Start by generating the list of stirling numbers of the second kind */
s2list = stirling2caching(n,n//2);
if(iserror(s2list))
return newerror("bell(n): could not build stirling num. list");
sum = 0;
for(k=1;k<=n;k++){
sum += stirling2caching(n,k);
}
return sum;
}
define subfactorialrecursive(n){
if(n==0) return 1;
if(n==1) return 0;
if(n==2) return 1;
return n * subfactorialrecursive(n-1) + (-1)^n;
}
/* This is, quite amusingely, faster than the very same algorithm in
PARI/GP + GMP*/
define subfactorialiterative(n){
local k temp1 temp2 ret;
if(n==0) return 1;
if(n==1) return 0;
if(n==2) return 1;
temp1 = 0;
ret = 1;
for(k=3;k<=n;k++){
temp2 = temp1;
temp1 = ret;
ret = (k-1) *(temp1 + temp2);
}
return ret;
}
define subfactorial(n){
local epsilon eps ret lnfact;
if(!isint(n))return newerror("subfactorial(n): n is not integer.");
if(n < 0)return newerror("subfactorial(n): n < 0");
return subfactorialiterative(n);
}
define risingfactorial(x,n){
local num denom quot ret;
if(n == 1) return x;
if(x==0) return newerror("risingfactorial(x,n): x == 0");
if(!isint(x) || !isint(n)){
return gamma(x+n)/gamma(x);
}
if(x<1)return newerror("risingfactorial(x,n): integer x and x < 1");
if(x+n < 1)return newerror("risingfactorial(x,n): integer x+n and x+n < 1");
if(x<9000&&n<9000){
return (x+n-1)!/(x-1)!;
}
else{
num = __CZ__factor_factorial(x+n-1,1);
denom = __CZ__factor_factorial(x-1,1);
quot = __CZ__subtract_factored_factorials( num , denom );
free(num,denom);
ret = __CZ__multiply_factored_factorial(quot);
return ret;
}
}
define fallingfactorial(x,n){
local num denom quot ret;
if(n == 0) return 1;
if(!isint(x) || !isint(n)){
if(x == n) return gamma(x+1);
return gamma(x+1)/gamma(x-n+1);
}
else{
if(x<0 || x-n < 0)
return newerror("fallingfactorial(x,n): integer x<0 or x-n < 0");
if(x == n) return factorial(x);
if(x<9000&&n<9000){
return (x)!/(x-n)!;
}
else{
num = __CZ__factor_factorial(x,1);
denom = __CZ__factor_factorial(x-n,1);
quot = __CZ__subtract_factored_factorials( num , denom );
free(num,denom);
ret = __CZ__multiply_factored_factorial(quot);
return ret;
}
}
}
/*
* restore internal function from resource debugging
* report important interface functions
*/
config("resource_debug", resource_debug_level),;
if (config("resource_debug") & 3) {
print "binomial(n,k)";
print "bigcatalan(n)";
print "doublefactorial(n)";
print "subfactorial(n)";
print "stirling1(n,m)";
print "stirling2(n,m)";
print "stirling2caching(n,m)";
print "bell(n)";
print "subfactorial(n)";
print "risingfactorial(x,n)";
print "fallingfactorial(x,n)";
}

288
cal/lambertw.cal Normal file
View File

@@ -0,0 +1,288 @@
/*
* lambertw- Lambert's W-function
*
* Copyright (C) 2013 Christoph Zurnieden
*
* lambertw is open software; you can redistribute it and/or modify it under
* the terms of the version 2.1 of the GNU Lesser General Public License
* as published by the Free Software Foundation.
*
* lambertw is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General
* Public License for more details.
*
* A copy of version 2.1 of the GNU Lesser General Public License is
* distributed with calc under the filename COPYING-LGPL. You should have
* received a copy with calc; if not, write to Free Software Foundation, Inc.
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*
* @(#) $Revision: 30.3 $
* @(#) $Id: lambertw.cal,v 30.3 2013/08/11 08:41:38 chongo Exp $
* @(#) $Source: /usr/local/src/bin/calc/cal/RCS/lambertw.cal,v $
*
* Under source code control: 2013/08/11 01:31:28
* File existed as early as: 2013
*/
static resource_debug_level;
resource_debug_level = config("resource_debug", 0);
/*
R. M. Corless and G. H. Gonnet and D. E. G. Hare and D. J. Jeffrey and
D. E. Knuth, "On the Lambert W Function", Advances n Computational
Mathematics, 329--359, (1996)
http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.112.6117
D. J. Jeffrey, D. E. G. Hare, R. M. Corless, "Unwinding the branches of the
Lambert W function", The Mathematical Scientist, 21, pp 1-7, (1996)
http://www.apmaths.uwo.ca/~djeffrey/Offprints/wbranch.pdf
Darko Verebic, "Having Fun with Lambert W(x) Function"
arXiv:1003.1628v1, March 2010, http://arxiv.org/abs/1003.1628
Winitzki, S. "Uniform Approximations for Transcendental Functions",
In Part 1 of Computational Science and its Applications - ICCSA 2003,
Lecture Notes in Computer Science, Vol. 2667, Springer-Verlag,
Berlin, 2003, 780-789. DOI 10.1007/3-540-44839-X_82
A copy may be found by Google.
*/
static true = 1;
static false = 0;
/* Branch 0, Winitzki (2003) , the well known Taylor series*/
define __CZ__lambertw_0(z,eps){
local a=2.344e0, b=0.8842e0, c=0.9294e0, d=0.5106e0, e=-1.213e0;
local y=sqrt(2*exp(1)*z+2);
return (2*ln(1+b*y)-ln(1+c*ln(1+d*y))+e)/(1+1/(2*ln(1+b*y)+2*a));
}
/* branch -1 */
define __CZ__lambertw_m1(z,eps){
local wn k;
/* Cut-off found in Maxima */
if(z < 0.3) return __CZ__lambertw_app(z,eps);
wn = z;
/* Verebic (2010) eqs. 16-18*/
for(k=0;k<10;k++){
wn = ln(-z)-ln(-wn);
}
return wn;
}
/*
generic approximation
series for 1+W((z-2)/(2 e))
Corless et al (1996) (4.22)
Verebic (2010) eqs. 35-37; more coefficients given at the end of sect. 3.1
or online
http://www.wolframalpha.com/input/?
i=taylor+%28+1%2Bproductlog%28+%28z-2%29%2F%282*e%29+%29+%29
or by using the function lambertw_series_print() after running
lambertw_series(z,eps,branch,terms) at least once with the wanted number of
terms and z = 1 (which might throw an error because the series will not
converge in anybodies lifetime for something that far from the branchpoint).
*/
define __CZ__lambertw_app(z,eps){
local b0=-1, b1=1, b2=-1/3, b3=11/72;
local y=sqrt(2*exp(1)*z+2);
return b0 + ( y * (b1 + (y * (b2 + (b3 * y)))));
}
static __CZ__Ws_a;
static __CZ__Ws_c;
static __CZ__Ws_len=0;
define lambertw_series_print(){
local k;
for(k=0;k<__CZ__Ws_len;k++){
print num(__CZ__Ws_c[k]):"/":den(__CZ__Ws_c[k]):"*p^":k;
}
}
/*
The series is fast but only if _very_ close to the branchpoint
The exact branch must be given explicitly, e.g.:
; lambertw(-exp(-1)+.001)-lambertw_series(-exp(-1)+.001,epsilon()*1e-10,0)
-0.14758879113205794065490184399030194122136720202792-
0.00000000000000000000000000000000000000000000000000i
; lambertw(-exp(-1)+.001)-lambertw_series(-exp(-1)+.001,epsilon()*1e-10,1)
0.00000000000000000000000000000000000000000000000000-
0.00000000000000000000000000000000000000000000000000i
*/
define lambertw_series(z,eps,branch,terms){
local k l limit tmp sum A C P PP epslocal;
if(!isnull(terms))
limit = terms;
else
limit = 100;
if(isnull(eps))
eps = epsilon(epsilon()*1e-10);
epslocal = epsilon(eps);
P = sqrt(2*(exp(1)*z+1));
if(branch != 0) P = -P;
tmp=0;sum=0;PP=P;
__CZ__Ws_a = mat[limit+1];
__CZ__Ws_c = mat[limit+1];
__CZ__Ws_len = limit;
/*
c0 = -1; c1 = 1
a0 = 2; a1 =-1
*/
__CZ__Ws_c[0] = -1; __CZ__Ws_c[1] = 1;
__CZ__Ws_a[0] = 2; __CZ__Ws_a[1] = -1;
sum += __CZ__Ws_c[0];
sum += __CZ__Ws_c[1] * P;
PP *= P;
for(k=2;k<limit;k++){
for(l=2;l<k;l++){
__CZ__Ws_a[k] += __CZ__Ws_c[l]*__CZ__Ws_c[k+1-l];
}
__CZ__Ws_c[k] = (k-1) * ( __CZ__Ws_c[k-2]/2
+__CZ__Ws_a[k-2]/4)/
(k+1)-__CZ__Ws_a[k]/2-__CZ__Ws_c[k-1]/(k+1);
tmp = __CZ__Ws_c[k] * PP;
sum += tmp;
if(abs(tmp) <= eps){
epsilon(epslocal);
return sum;
}
PP *= P;
}
epsilon(epslocal);
return
newerror(strcat("lambertw_series: does not converge in ",
str(limit)," terms" ));
}
/* */
define lambertw(z,branch){
local eps epslarge ret branchpoint bparea w we ew w1e wn k places m1e;
local closeness;
eps = epsilon();
if(branch == 0){
if(!im(z)){
if(abs(z) <= eps) return 0;
if(abs(z-exp(1)) <= eps) return 1;
if(abs(z - (-ln(2)/2)) <= eps ) return -ln(2);
if(abs(z - (-pi()/2)) <= eps ) return 1i*pi()/2;
}
}
branchpoint = -exp(-1);
bparea = .2;
if(branch == 0){
if(!im(z) && abs(z-branchpoint) == 0) return -1;
ret = __CZ__lambertw_0(z,eps);
/* Yeah, C&P, I know, sorry */
##ret = ln(z) + 2*pi()*1i*branch - ln(ln(z)+2*pi()*1i*branch);
}
else if(branch == 1){
if(im(z)<0 && abs(z-branchpoint) <= bparea)
ret = __CZ__lambertw_app(z,eps);
/* Does calc have a goto? Oh, it does! */
ret =ln(z) + 2*pi()*1i*branch - ln(ln(z)+2*pi()*1i*branch);
}
else if(branch == -1){##print "-1";
if(!im(z) && abs(z-branchpoint) == 0) return -1;
if(!im(z) && z>branchpoint && z < 0){##print "0";
ret = __CZ__lambertw_m1(z,eps);}
if(im(z)>=0 && abs(z-branchpoint) <= bparea){##print "1";
ret = __CZ__lambertw_app(z,eps);}
ret =ln(z) + 2*pi()*1i*branch - ln(ln(z)+2*pi()*1i*branch);
}
else
ret = ln(z) + 2*pi()*1i*branch - ln(ln(z)+2*pi()*1i*branch);
/*
Such a high precision is only needed _very_ close to the branchpoint
and might even be insufficient if z has not been computed with
sufficient precision itself (M below was calculated by Mathematica and also
with the series above with epsilon(1e-200)):
; epsilon(1e-50)
0.00000000000000000001
; display(50)
20
; M=-0.9999999999999999999999997668356018402875796636464119050387
; lambertw(-exp(-1)+1e-50,0)-M
-0.00000000000000000000000002678416515423276355643684
; epsilon(1e-60)
0.0000000000000000000000000000000000000000000000000
; A=-exp(-1)+1e-50
; epsilon(1e-50)
0.00000000000000000000000000000000000000000000000000
; lambertw(A,0)-M
-0.00000000000000000000000000000000000231185460220585
; lambertw_series(A,epsilon(),0)-M
-0.00000000000000000000000000000000000132145133161626
; epsilon(1e-100)
0.00000000000000000000000000000000000000000000000001
; A=-exp(-1)+1e-50
; epsilon(1e-65)
0.00000000000000000000000000000000000000000000000000
; lambertw_series(A,epsilon(),0)-M
0.00000000000000000000000000000000000000000000000000
; lambertw_series(-exp(-1)+1e-50,epsilon(),0)-M
-0.00000000000000000000000000000000000000002959444084
; epsilon(1e-74)
0.00000000000000000000000000000000000000000000000000
; lambertw_series(-exp(-1)+1e-50,epsilon(),0)-M
-0.00000000000000000000000000000000000000000000000006
*/
closeness = abs(z-branchpoint);
if( closeness< 1){
if(closeness != 0)
eps = epsilon(epsilon()*( closeness));
else
eps = epsilon(epsilon()^2);
}
else
eps = epsilon(epsilon()*1e-2);
epslarge =epsilon();
places = highbit(1 + int(1/epslarge)) + 1;
w = ret;
for(k=0;k<100;k++){
ew = exp(w);
we = w*ew;
if(abs(we-z)<= 4*epslarge*abs(z))break;
w1e = (1+w)*ew;
wn = bround(w- ((we - z) / ( w1e - ( (w+2)*(we-z) )/(2*w+2) ) ),places++) ;
if( abs(wn - w) <= epslarge*abs(wn)) break;
else w = wn;
}
if(k==100){
epsilon(eps);
return newerror("lambertw: Halley iteration does not converge");
}
/* The Maxima coders added a check if the iteration converged to the correct
branch. This coder deems it superfluous. */
epsilon(eps);
return wn;
}
config("resource_debug", resource_debug_level),;
if (config("resource_debug") & 3) {
print "lambertw(z,branch)";
print "lambertw_series(z,eps,branch,terms)";
print "lambertw_series_print()";
}

112
cal/lnseries.cal Normal file
View File

@@ -0,0 +1,112 @@
/*
* special_functions - special functions (e.g.: gamma, zeta, psi)
*
* Copyright (C) 2013 Christoph Zurnieden
*
* lnseries.cal is open software; you can redistribute it and/or modify it under
* the terms of the version 2.1 of the GNU Lesser General Public License
* as published by the Free Software Foundation.
*
* lnseries.cal is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General
* Public License for more details.
*
* A copy of version 2.1 of the GNU Lesser General Public License is
* distributed with calc under the filename COPYING-LGPL. You should have
* received a copy with calc; if not, write to Free Software Foundation, Inc.
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*
* @(#) $Revision: 30.3 $
* @(#) $Id: lnseries.cal,v 30.3 2013/08/11 08:41:38 chongo Exp $
* @(#) $Source: /usr/local/src/bin/calc/cal/RCS/lnseries.cal,v $
*
* Under source code control: 2013/08/11 01:31:28
* File existed as early as: 2013
*/
/*
* hide internal function from resource debugging
*/
static resource_debug_level;
resource_debug_level = config("resource_debug", 0);
static __CZ__int_logs;
static __CZ__int_logs_limit;
static __CZ__int_logs_prec;
define deletelnseries(){
free(__CZ__int_logs,__CZ__int_logs_limit,__CZ__int_logs_prec);
}
define lnfromseries(n){
if( isnull(__CZ__int_logs)
|| __CZ__int_logs_limit < n
|| __CZ__int_logs_prec < log(1/epsilon())){
lnseries(n+1);
}
return __CZ__int_logs[n,0];
}
define lnseries(limit){
local k j eps ;
if( isnull(__CZ__int_logs)
|| __CZ__int_logs_limit < limit
|| __CZ__int_logs_prec < log(1/epsilon())){
__CZ__int_logs = mat[limit+1,2];
__CZ__int_logs_limit = limit;
__CZ__int_logs_prec = log(1/epsilon());
/* probably still too much */
eps = epsilon(epsilon()*10^(-(5+log(limit))));
k =2;
while(1){
/* the prime itself, compute logarithm */
__CZ__int_logs[k,0] = ln(k);
__CZ__int_logs[k,1] = k;
for(j = 2*k;j<=limit;j+=k){
/* multiples of prime k, add logarithm of k computed earlier */
__CZ__int_logs[j,0] += __CZ__int_logs[k,0];
/* First hit, set counter to number */
if(__CZ__int_logs[j,1] ==0)
__CZ__int_logs[j,1]=j;
/* reduce counter by prime added */
__CZ__int_logs[j,1] //= __CZ__int_logs[k,1];
}
k++;
if(k>=limit) break;
/* Erastothenes-sieve: look for next prime. */
while(__CZ__int_logs[k,0]!=0){
k++;
if(k>=limit) break;
}
}
/* Second run to include the last factor */
for(k=1;k<=limit;k++){
if(__CZ__int_logs[k,1] != k){
__CZ__int_logs[k,0] +=__CZ__int_logs[ __CZ__int_logs[k,1],0];
__CZ__int_logs[k,1] = 0;
}
}
epsilon(eps);
}
return 1;
}
/*
* restore internal function from resource debugging
*/
config("resource_debug", resource_debug_level),;
if (config("resource_debug") & 3) {
print "lnseries(limit)";
print "lnfromseries(n)";
print "deletelnseries()";
}

7
cal/quat.cal
View File

@@ -17,8 +17,8 @@
* received a copy with calc; if not, write to Free Software Foundation, Inc.
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*
* @(#) $Revision: 30.1 $
* @(#) $Id: quat.cal,v 30.1 2007/03/16 11:09:54 chongo Exp $
* @(#) $Revision: 30.2 $
* @(#) $Id: quat.cal,v 30.2 2013/08/11 08:41:38 chongo Exp $
* @(#) $Source: /usr/local/src/bin/calc/cal/RCS/quat.cal,v $
*
* Under source code control: 1990/02/15 01:50:35
@@ -55,7 +55,8 @@ define quat(a,b,c,d)
define quat_print(a)
{
print "quat(" : a.s : ", " : a.v[0] : ", " : a.v[1] : ", " : a.v[2] : ")" :;
print "quat(" : a.s : ", " : a.v[0] : ", " :
a.v[1] : ", " : a.v[2] : ")" :;
}

23
cal/regress.cal
View File

@@ -17,8 +17,8 @@
* received a copy with calc; if not, write to Free Software Foundation, Inc.
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*
* @(#) $Revision: 30.7 $
* @(#) $Id: regress.cal,v 30.7 2013/08/11 02:57:22 chongo Exp $
* @(#) $Revision: 30.8 $
* @(#) $Id: regress.cal,v 30.8 2013/08/11 08:41:38 chongo Exp $
* @(#) $Source: /usr/local/src/bin/calc/cal/RCS/regress.cal,v $
*
* Under source code control: 1990/02/15 01:50:36
@@ -1397,7 +1397,8 @@ define test_functions()
vrfy(quomod(10,-3,a,b,12) == 1, '1193: vrfy(quomod(10,-3,a,b,12) == 1');
vrfy(a == -3, '1194: a == -3');
vrfy(b == 1, '1195: b == 1');
vrfy(quomod(-10,-3,a,b,13) == 1,'1196: vrfy(quomod(-10,-3,a,b,13) == 1');
vrfy(quomod(-10,-3,a,b,13) == 1,
'1196: vrfy(quomod(-10,-3,a,b,13) == 1');
vrfy(a == 4, '1197: a == 4');
vrfy(b == 2, '1198: b == 2');
vrfy(quomod(10,3,a,b,14) == 1, '1199: vrfy(quomod(10,3,a,b,14) == 1');
@@ -1509,8 +1510,10 @@ define test_assoc()
vrfy(isnull(search(a,16)), '1312: isnull(search(a,16))');
a["curds","whey"] = "spider";
print '1313: a["curds","whey"] = "spider"';
vrfy(a["curds","whey"] == "spider", '1314: a["curds","whey"] == "spider"');
vrfy(a[[rsearch(a,"spider")]] == "spider", '1315: a[[rsearch(a,"spider")]] == "spider"');
vrfy(a["curds","whey"] == "spider",
'1314: a["curds","whey"] == "spider"');
vrfy(a[[rsearch(a,"spider")]] == "spider",
'1315: a[[rsearch(a,"spider")]] == "spider"');
b = a;
print '1316: b = a';
vrfy(b[17] == 19, '1317: b[17] == 19');
@@ -4892,7 +4895,8 @@ define test_newsyn()
vrfy(s5500 == 55, '5510: s5500 == 45');
vrfy(i == 11, '5511: i == 11');
}
print "5512: { local i; for (s5500 = 0, i = 0; i < 10; i++) s5500 += i; ... }";
print "5512: { local i; for (s5500 = 0, i = 0; i < 10; i++) ":
"s5500 += i; ... }";
vrfy(s5500 == 55, '5513: s5500 == 55');
vrfy(i == 11, '5514: i == 11');
@@ -6506,7 +6510,8 @@ define test_blk()
/* A second named block */
B1 = blk("+++6700", 15, 10) = {1,2,3,4,5};
print '6746: B1 = blk("+++6700", 15 , 10) = {1,2,3,4,5};';
print
'6746: B1 = blk("+++6700", 15 , 10) = {1,2,3,4,5};';
vrfy(size(B1) == 15, '6747: size(B1) == 15');
vrfy(sizeof(B1) == 20, '6748: sizeof(B1) == 20');
vrfy(test(B1) == 1, '6749: test(B1) == 1');
@@ -6871,7 +6876,8 @@ define test_sha1()
z = sha1(list(1,2,3), "curds and whey", 2^21701-1, pi(1e-100));
print '7210: z = sha1(list(1,2,3), "curds and whey", 2^21701-1, pi(1e-100));';
print '7210: z = sha1(list(1,2,3), "curds and whey",',
'2^21701-1, pi(1e-100));';
vrfy(sha1(z) == 0x158cc87deeb9dd478ca14e3ab359205b0fb15b83,
'7211: sha1(z) == 0x158cc87deeb9dd478ca14e3ab359205b0fb15b83');
@@ -7923,7 +7929,6 @@ print '8901: read -once "test8900"';
read -once "test8900";
print '8902: about to run test8900(1,,8903)';
testnum = test8900(1,,8903);
print testnum: ": End of test of calc resource functions by Christoph Zurnieden";
/* 89xx: test calc resource functions by Christoph Zurnieden */

7
cal/solve.cal
View File

@@ -17,8 +17,8 @@
* received a copy with calc; if not, write to Free Software Foundation, Inc.
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*
* @(#) $Revision: 30.2 $
* @(#) $Id: solve.cal,v 30.2 2008/05/10 13:30:00 chongo Exp $
* @(#) $Revision: 30.3 $
* @(#) $Id: solve.cal,v 30.3 2013/08/11 08:41:38 chongo Exp $
* @(#) $Source: /usr/local/src/bin/calc/cal/RCS/solve.cal,v $
*
* Under source code control: 1990/02/15 01:50:37
@@ -52,7 +52,8 @@ define solve(low, high, epsilon)
if (sgn(flow) == sgn(fhigh))
quit "Non-opposite signs";
while (1) {
mid = bround(high - fhigh * (high - low) / (fhigh - flow), places);
mid = bround(high - fhigh * (high - low) / (fhigh - flow),
places);
if ((mid == low) || (mid == high))
places++;
fmid = f(mid);

1394
cal/specialfunctions.cal Normal file
View File

File diff suppressed because it is too large Load Diff

502
cal/statistics.cal Normal file
View File

@@ -0,0 +1,502 @@
/*
* statistics - Some assorted statistics functions.
*
* Copyright (C) 2013 Christoph Zurnieden
*
* statistics is open software; you can redistribute it and/or modify it under
* the terms of the version 2.1 of the GNU Lesser General Public License
* as published by the Free Software Foundation.
*
* statistics is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General
* Public License for more details.
*
* A copy of version 2.1 of the GNU Lesser General Public License is
* distributed with calc under the filename COPYING-LGPL. You should have
* received a copy with calc; if not, write to Free Software Foundation, Inc.
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*
* @(#) $Revision: 30.3 $
* @(#) $Id: statistics.cal,v 30.3 2013/08/11 08:41:38 chongo Exp $
* @(#) $Source: /usr/local/src/bin/calc/cal/RCS/statistics.cal,v $
*
* Under source code control: 2013/08/11 01:31:28
* File existed as early as: 2013
*/
static resource_debug_level;
resource_debug_level = config("resource_debug", 0);
/*
get dependencies
*/
read -once factorial2 brentsolve
/*******************************************************************************
*
*
* Continuous distributions
*
*
******************************************************************************/
/* regularized incomplete gamma function like in Octave, hence the name */
define gammaincoctave(z,a){
local tmp;
tmp = gamma(z);
return (tmp-gammainc(a,z))/tmp;
}
/* Inverse incomplete beta function. Old and slow. */
static __CZ__invbeta_a;
static __CZ__invbeta_b;
static __CZ__invbeta_x;
define __CZ__invbeta(x){
return __CZ__invbeta_x-__CZ__ibetaas63(x,__CZ__invbeta_a,__CZ__invbeta_b);
}
define invbetainc_slow(x,a,b){
local flag ret eps;
/* place checks and balances here */
eps = epsilon();
if(.5 < x){
__CZ__invbeta_x = 1 - x;
__CZ__invbeta_a = b;
__CZ__invbeta_b = a;
flag = 1;
}
else{
__CZ__invbeta_x = x;
__CZ__invbeta_a = a;
__CZ__invbeta_b = b;
flag = 0;
}
ret = brentsolve2(0,1,1);
if(flag == 1)
ret = 1-ret;
epsilon(eps);
return ret;
}
/* Inverse incomplete beta function. Still old but not as slow as the function
above. */
/*
Purpose:
invbetainc computes inverse of the incomplete Beta function.
Licensing:
This code is distributed under the GNU LGPL license.
Modified:
10 August 2013
Author:
Original FORTRAN77 version by GW Cran, KJ Martin, GE Thomas.
C version by John Burkardt.
Calc version by Christoph Zurnieden
Reference:
GW Cran, KJ Martin, GE Thomas,
Remark AS R19 and Algorithm AS 109:
A Remark on Algorithms AS 63: The Incomplete Beta Integral
and AS 64: Inverse of the Incomplete Beta Integeral,
Applied Statistics,
Volume 26, Number 1, 1977, pages 111-114.
Parameters:
Input, P, Q, the parameters of the incomplete
Beta function.
Input, BETA, the logarithm of the value of
the complete Beta function.
Input, ALPHA, the value of the incomplete Beta
function. 0 <= ALPHA <= 1.
Output, the argument of the incomplete
Beta function which produces the value ALPHA.
Local Parameters:
Local, SAE, the most negative decimal exponent
which does not cause an underflow.
*/
define invbetainc(x,a,b){
return __CZ__invbetainc(a,b,lnbeta(a,b),x);
}
define __CZ__invbetainc(p,q,beta,alpha){
local a acu adj fpu g h iex indx pp prev qq r s sae sq t tx value;
local w xin y yprev places eps;
/* Dirty trick, don't try at home */
eps= epsilon(epsilon()^2);
sae = -((log(1/epsilon())/log(2))//2);
fpu = 10.0^sae;
places = highbit(1 + int(1/epsilon())) + 1;
value = alpha;
if( p <= 0.0 ){
epsilon(eps);
return newerror("invbeta: argument p <= 0");
}
if( q <= 0.0 ){
epsilon(eps);
return newerror("invbeta: argument q <= 0");
}
if( alpha < 0.0 || 1.0 < alpha ){
epsilon(eps);
return newerror("invbeta: argument alpha out of domain");
}
if( alpha == 0.0 ){
epsilon(eps);
return 0;
}
if( alpha == 1.0 ){
epsilon(eps);
return 1;
}
if ( 0.5 < alpha ){
a = 1.0 - alpha;
pp = q;
qq = p;
indx = 1;
}
else{
a = alpha;
pp = p;
qq = q;
indx = 0;
}
r = sqrt ( - ln ( a * a ) );
y = r-(2.30753+0.27061*r)/(1.0+(0.99229+0.04481*r)*r);
if ( 1.0 < pp && 1.0 < qq ){
r = ( y * y - 3.0 ) / 6.0;
s = 1.0 / ( pp + pp - 1.0 );
t = 1.0 / ( qq + qq - 1.0 );
h = 2.0 / ( s + t );
w = y*sqrt(h+r)/h-(t-s)*(r+5.0/6.0-2.0/(3.0*h));
value = pp / ( pp + qq * exp ( w + w ) );
}
else{
r = qq + qq;
t = 1.0 / ( 9.0 * qq );
t = r * ( 1.0 - t + y * sqrt ( t )^ 3 );
if ( t <= 0.0 ){
value = 1.0 - exp ( ( ln ( ( 1.0 - a ) * qq ) + beta ) / qq );
}
else{
t = ( 4.0 * pp + r - 2.0 ) / t;
if ( t <= 1.0 ) {
value = exp ( ( ln ( a * pp ) + beta ) / pp );
}
else{
value = 1.0 - 2.0 / ( t + 1.0 );
}
}
}
r = 1.0 - pp;
t = 1.0 - qq;
yprev = 0.0;
sq = 1.0;
prev = 1.0;
if ( value < 0.0001 )
value = 0.0001;
if ( 0.9999 < value )
value = 0.9999;
acu = 10^sae;
for ( ; ; ){
y = bround(__CZ__ibetaas63( value, pp, qq, beta),places);
xin = value;
y = bround(exp(ln(y-a)+(beta+r*ln(xin)+t*ln(1.0- xin ) )),places);
if ( y * yprev <= 0.0 ) {
prev = max ( sq, fpu );
}
g = 1.0;
for ( ; ; ){
for ( ; ; ){
adj = g * y;
sq = adj * adj;
if ( sq < prev ){
tx = value - adj;
if ( 0.0 <= tx && tx <= 1.0 ) break;
}
g = g / 3.0;
}
if ( prev <= acu ){
if ( indx )
value = 1.0 - value;
epsilon(eps);
return value;
}
if ( y * y <= acu ){
if ( indx )
value = 1.0 - value;
epsilon(eps);
return value;
}
if ( tx != 0.0 && tx != 1.0 )
break;
g = g / 3.0;
}
if ( tx == value ) break;
value = tx;
yprev = y;
}
if ( indx )
value = 1.0 - value;
epsilon(eps);
return value;
}
/*******************************************************************************
*
*
* Beta distribution
*
*
******************************************************************************/
define betapdf(x,a,b){
if(x<0 || x>1) return newerror("betapdf: parameter x out of domain");
if(a<=0) return newerror("betapdf: parameter a out of domain");
if(b<=0) return newerror("betapdf: parameter b out of domain");
return 1/beta(a,b) *x^(a-1)*(1-x)^(b-1);
}
define betacdf(x,a,b){
if(x<0 || x>1) return newerror("betacdf: parameter x out of domain");
if(a<=0) return newerror("betacdf: parameter a out of domain");
if(b<=0) return newerror("betacdf: parameter b out of domain");
return betainc(x,a,b);
}
define betacdfinv(x,a,b){
return invbetainc(x,a,b);
}
define betamedian(a,b){
local t106 t104 t103 t105 approx ret;
if(a == b) return 1/2;
if(a == 1 && b > 0) return 1-(1/2)^(1/b);
if(a > 0 && b == 1) return (1/2)^(1/a);
if(a == 3 && b == 2){
/* Yes, the author is not ashamed to ask Maxima for the exact solution
of a quartic equation. */
t103 = ( (2^(3/2))/27 +4/27 )^(1/3);
t104 = sqrt( ( 9*t103^2 + 4*t103 + 2 )/(t103) )/3;
t105 = -t103-2/(9*t103) +8/9;
t106 = sqrt( (27*t104*t105+16)/(t104) )/(2*3^(3/2));
return -t106+t104/2+1/3;
}
if(a == 2 && b == 3){
t103 = ( (2^(3/2))/27 +4/27 )^(1/3);
t104 = sqrt( ( 9*t103^2 + 4*t103 + 2 )/(t103) )/3;
t105 = -t103-2/(9*t103) +8/9;
t106 = sqrt( (27*t104*t105+16)/(t104) )/(2*3^(3/2));
return 1-(-t106+t104/2+1/3);
}
return invbetainc(1/2,a,b);
}
define betamode(a,b){
if(a + b == 2) return newerror("betamod: a + b = 2 = division by zero");
return (a-1)/(a+b-2);
}
define betavariance(a,b){
return (a*b)/( (a+b)^2*(a+b+1) );
}
define betalnvariance(a,b){
return polygamma(1,a)-polygamma(a+b);
}
define betaskewness(a,b){
return (2*(b-a)*sqrt(a+b+1))/( (a+b+1)*sqrt(a*b) );
}
define betakurtosis(a,b){
local num denom;
num = 6*( (a-b)^2*(a+b+1)-a*b*(a+b+2));
denom = a*b*(a+b+2)*(a+b+3);
return num/denom;
}
define betaentropy(a,b){
return lnbeta(a,b)-(a-1)*psi(a)-(b-1)*psi(b)+(a+b+1)*psi(a+b);
}
/*******************************************************************************
*
*
* Normal (Gaussian) distribution
*
*
******************************************************************************/
define normalpdf(x,mu,sigma){
return 1/(sqrt(2*pi()*sigma^2))*exp( ( (x-mu)^2 )/( 2*sigma^2 ) );
}
define normalcdf(x,mu,sigma){
return 1/2*(1+erf( ( x-mu )/( sqrt(2*sigma^2) ) ) );
}
define probit(p){
if(p<0 || p > 1) return newerror("probit: p out of domain 0<=p<=1");
return sqrt(2)*ervinv(2*p-1);
}
define normalcdfinv(p,mu,sigma){
if(p<0 || p > 1) return newerror("normalcdfinv: p out of domain 0<=p<=1");
return mu+ sigma*probit(p);
}
define normalmean(mu,sigma){return mu;}
define normalmedian(mu,sigma){return mu;}
define normalmode(mu,sigma){return mu;}
define normalvariance(mu,sigma){return sigma^2;}
define normalskewness(mu,sigma){return 0;}
define normalkurtosis(mu,sigma){return 0;}
define normalentropy(mu,sigma){
return 1/3*ln( 2*pi()*exp(1)*sigma^2 );
}
/* moment generating f. */
define normalmgf(mu,sigma,t){
return exp(mu*t+1/2*sigma^2*t^2);
}
/* characteristic f. */
define normalcf(mu,sigma,t){
return exp(mu*t-1/2*sigma^2*t^2);
}
/*******************************************************************************
*
*
* Chi-squared distribution
*
*
******************************************************************************/
define chisquaredpdf(x,k){
if(!isint(k) || k<0) return newerror("chisquaredpdf: k not in N");
if(im(x) || x<0) return newerror("chisquaredpdf: x not in +R");
/* The gamma function does not check for half integers, do it here? */
return 1/(2^(k/2)*gamma(k/2))*x^((k/2)-1)*exp(-x/2);
}
define chisquaredpcdf(x,k){
if(!isint(k) || k<0) return newerror("chisquaredcdf: k not in N");
if(im(x) || x<0) return newerror("chisquaredcdf: x not in +R");
return 1/(gamma(k/2))*gammainc(k/2,x/2);
}
define chisquaredmean(x,k){return k;}
define chisquaredmedian(x,k){
/* TODO: implement a FAST inverse incomplete gamma-{q,p} function */
return k*(1-2/(9*k))^3;
}
define chisquaredmode(x,k){return max(k-2,0);}
define chisquaredvariance(x,k){return 2*k;}
define chisquaredskewness(x,k){return sqrt(8/k);}
define chisquaredkurtosis(x,k){return 12/k;}
define chisquaredentropy(x,k){
return k/2+ln(2*gamma(k/2)) + (1-k/2)*psi(k/2);
}
define chisquaredmfg(k,t){
if(t>=1/2)return newerror("chisquaredmfg: t >= 1/2");
return (1-2*t)^(k/2);
}
define chisquaredcf(k,t){
return (1-2*1i*t)^(k/2);
}
/*
* restore internal function from resource debugging
*/
config("resource_debug", resource_debug_level),;
if (config("resource_debug") & 3) {
print "gammaincoctave(z,a)";
print "invbetainc(x,a,b)";
print "betapdf(x,a,b)";
print "betacdf(x,a,b)";
print "betacdfinv(x,a,b)";
print "betamedian(a,b)";
print "betamode(a,b)";
print "betavariance(a,b)";
print "betalnvariance(a,b)";
print "betaskewness(a,b)";
print "betakurtosis(a,b)";
print "betaentropy(a,b)";
print "normalpdf(x,mu,sigma)";
print "normalcdf(x,mu,sigma)";
print "probit(p)";
print "normalcdfinv(p,mu,sigma)";
print "normalmean(mu,sigma)";
print "normalmedian(mu,sigma)";
print "normalmode(mu,sigma)";
print "normalvariance(mu,sigma)";
print "normalskewness(mu,sigma)";
print "normalkurtosis(mu,sigma)";
print "normalentropy(mu,sigma)";
print "normalmgf(mu,sigma,t)";
print "normalcf(mu,sigma,t)";
print "chisquaredpdf(x,k)";
print "chisquaredpcdf(x,k)";
print "chisquaredmean(x,k)";
print "chisquaredmedian(x,k)";
print "chisquaredmode(x,k)";
print "chisquaredvariance(x,k)";
print "chisquaredskewness(x,k)";
print "chisquaredkurtosis(x,k)";
print "chisquaredentropy(x,k)";
print "chisquaredmfg(k,t)";
print "chisquaredcf(k,t)";
}

16
cal/test2600.cal
View File

@@ -19,8 +19,8 @@
* received a copy with calc; if not, write to Free Software Foundation, Inc.
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*
* @(#) $Revision: 30.2 $
* @(#) $Id: test2600.cal,v 30.2 2007/07/11 22:57:23 chongo Exp $
* @(#) $Revision: 30.3 $
* @(#) $Id: test2600.cal,v 30.3 2013/08/11 08:41:38 chongo Exp $
* @(#) $Source: /usr/local/src/bin/calc/cal/RCS/test2600.cal,v $
*
* Under source code control: 1995/10/13 00:13:14
@@ -91,7 +91,8 @@ define testismult(str, n, verbose)
if (!ismult(c,a)) {
m++;
if (verbose > 1) {
printf("*** Failure with:\na = %d\nb = %d\n", a,b);
printf("*** Failure with:\na = %d\nb = %d\n",
a,b);
}
}
}
@@ -133,7 +134,8 @@ define testsqrt(str, n, eps, verbose)
if (abs(c) > 1) {
m++;
if (verbose > 1) {
printf("*** Failure with:\na = %d\neps = %d\n", a,eps);
printf("*** Failure with:\na = %d\neps = %d\n",
a,eps);
}
}
}
@@ -178,7 +180,8 @@ define testexp(str, n, eps, verbose)
if (abs(c) > 0.02) {
m++;
if (verbose > 1) {
printf("*** Failure with:\na = %d\neps = %d\n", a,eps);
printf("*** Failure with:\na = %d\neps = %d\n",
a,eps);
}
}
}
@@ -235,7 +238,8 @@ define testln(str, n, eps, verbose)
if (abs(c) > 0.5) {
m++;
if (verbose > 1) {
printf("*** Failure with:\na = %d\neps = %d\n", a,eps);
printf("*** Failure with:\na = %d\neps = %d\n",
a,eps);
}
}
}

7
cal/test2700.cal
View File

@@ -19,8 +19,8 @@
* received a copy with calc; if not, write to Free Software Foundation, Inc.
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*
* @(#) $Revision: 30.1 $
* @(#) $Id: test2700.cal,v 30.1 2007/03/16 11:09:54 chongo Exp $
* @(#) $Revision: 30.2 $
* @(#) $Id: test2700.cal,v 30.2 2013/08/11 08:41:38 chongo Exp $
* @(#) $Source: /usr/local/src/bin/calc/cal/RCS/test2700.cal,v $
*
* Under source code control: 1995/11/01 22:52:25
@@ -127,7 +127,8 @@ define testcsqrt(str, n, verbose)
if (p) {
if (verbose > 0)
printf(
"*** Type %d failure for x = %r, y = %r, z = %d\n",
"*** Type %d failure for x = %r, "
"y = %r, z = %d\n",
p, x, y, z);
m++;
}

10
cal/test4000.cal
View File

@@ -19,8 +19,8 @@
* received a copy with calc; if not, write to Free Software Foundation, Inc.
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*
* @(#) $Revision: 30.1 $
* @(#) $Id: test4000.cal,v 30.1 2007/03/16 11:09:54 chongo Exp $
* @(#) $Revision: 30.2 $
* @(#) $Id: test4000.cal,v 30.2 2013/08/11 08:41:38 chongo Exp $
* @(#) $Source: /usr/local/src/bin/calc/cal/RCS/test4000.cal,v $
*
* Under source code control: 1996/03/13 02:38:45
@@ -199,7 +199,8 @@ define ctimes(str, N, n, count, skip, verbose)
p = ptest(A[i], count, skip);
if (p) {
if (verbose > 0) {
printf("*** Error, what should be rare has occurred for x = %d \n", A[i]);
printf("*** Error, what should be rare "
"has occurred for x = %d \n", A[i]);
m++;
}
}
@@ -306,7 +307,8 @@ define ntimes(str, N, n, count, skip, residue, modulus, verbose)
}
tprev = round(usertime() - t, 4);
if (verbose > 0) {
printf("%d evaluations, nextcand: %d, prevcand: %d\n", n, tnext, tprev);
printf("%d evaluations, nextcand: %d, "
"prevcand: %d\n", n, tnext, tprev);
}
}

8
cal/test8500.cal
View File

@@ -19,8 +19,8 @@
* received a copy with calc; if not, write to Free Software Foundation, Inc.
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*
* @(#) $Revision: 30.1 $
* @(#) $Id: test8500.cal,v 30.1 2007/03/16 11:09:54 chongo Exp $
* @(#) $Revision: 30.2 $
* @(#) $Id: test8500.cal,v 30.2 2013/08/11 08:41:38 chongo Exp $
* @(#) $Source: /usr/local/src/bin/calc/cal/RCS/test8500.cal,v $
*
* Under source code control: 1999/11/12 20:59:59
@@ -134,8 +134,8 @@ define onetest_8500(a,b,rnd) {
* The rounding parameter is randomly chosen.
*
* After a run of divmod_8500 the a, b, rnd values which gave failure are
* stored in the list L_8500. L_8500[0], L_8500[1], L_8500[2] are a, b, rnd for the first
* test, etc.
* stored in the list L_8500. L_8500[0], L_8500[1], L_8500[2] are a, b,
* rnd for the first* test, etc.
*/
define divmod_8500(N = 10, M1 = 2^128, M2 = 2^64, testnum = 0)
{

1641
cal/test8900.cal Normal file
View File

File diff suppressed because it is too large Load Diff

362
cal/toomcook.cal Normal file
View File

@@ -0,0 +1,362 @@
/*
* Toom-Cook - implementation of Toom-Cook(3,4) multiplication algorithm
*
* Copyright (C) 2013 Christoph Zurnieden
*
* Toom-Cook is open software; you can redistribute it and/or modify it under
* the terms of the version 2.1 of the GNU Lesser General Public License
* as published by the Free Software Foundation.
*
* Toom-Cook is distributed in the hope that it will be useful, but WITHOUT
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General
* Public License for more details.
*
* A copy of version 2.1 of the GNU Lesser General Public License is
* distributed with calc under the filename COPYING-LGPL. You should have
* received a copy with calc; if not, write to Free Software Foundation, Inc.
* 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*
* @(#) $Revision: 30.3 $
* @(#) $Id: toomcook.cal,v 30.3 2013/08/11 08:41:38 chongo Exp $
* @(#) $Source: /usr/local/src/bin/calc/cal/RCS/toomcook.cal,v $
*
* Under source code control: 2013/08/11 01:31:28
* File existed as early as: 2013
*/
/*
* hide internal function from resource debugging
*/
static resource_debug_level;
resource_debug_level = config("resource_debug", 0);
/* */
define toomcook3(a,b){
local alen blen a0 a1 a2 b0 b1 b2 m ret sign mask;
local S0 S1 S2 S3 S4 T1 T2;
if(!isint(a) || !isint(b))
return newerror("toomcook3(a,b): a and/or b is not an integer");
alen = digits(a,2);
blen = digits(b,2);
sign = sgn(a) * sgn(b);
/* sgn(x) returns 0 if x = 0 */
if(sign == 0) return 0;
m = min(alen,blen)//3;
mask = ~-(1<<m);
/*
Cut-off at about 4,000 dec. digits
TODO: check
*/
if(isdefined("test8900")){
if(m < 20) return a*b;
}
else{
if(m < 4096 ) return a*b;
}
a = abs(a);
b = abs(b);
a0 = a & mask;
a1 = (a>>m) & mask;
a2 = (a>>(2*m));
b0 = b & mask;
b1 = (b>>m) & mask;
b2 = (b>>(2*m));
/*
Zimmermann
*/
S0 = toomcook3(a0 , b0);
S1 = toomcook3((a2+a1+a0) , (b2+b1+b0));
S2 = toomcook3(((a2<<2)+(a1<<1)+a0) , ((b2<<2)+(b1<<1)+b0));
S3 = toomcook3((a2-a1+a0) , (b2-b1+b0));
S4 = toomcook3(a2,b2);
T1 = (S3<<1) + S2;
T1 /= 3;
T1 += S0;
T1 >>= 1;
T1 -= S4<<1;
T2 = (S1 + S3)>>1;
S1 -= T1;
S2 = T2 - S0 - S4;
S3 = T1 - T2;
ret = (S4<<(4*m)) + (S3<<(3*m)) + (S2<<(2*m)) + (S1<<(1*m)) + S0;
ret = sign *ret;
return ret;
}
define toomcook3square(a){
local alen a0 a1 a2 m tmp tmp2 ret sign S0 S1 S2 S3 S4 T1 mask;
if(!isint(a))return newerror("toomcook3square(a): a is not integer");
alen = digits(a,2);
sign = sgn(a) * sgn(a);
if(sign == 0) return 0;
m = alen//3;
mask = ~-(1<<m);
/*
Cut-off at about 5,000 dec. digits
TODO: check
*/
if(isdefined("test8900")){
if(m < 20) return a^2;
}
else{
if(m < 5000 ) return a^2;
}
a = abs(a);
a0 = a & mask;
a1 = (a>>m) & mask;
a2 = (a>>(2*m));
/*
Bodrato/Zanoni
*/
S0 = toomcook3square(a0);
S1 = toomcook3square(a2+a1+a0);
S2 = toomcook3square(a2-a1+a0);
S3 = toomcook3(a1<<1,a2);
S4 = toomcook3square(a2);
T1 = (S1 + S2)>>1;
S1 = S1 - T1 - S3;
S2 = T1 - S4 -S0;
S1 = S1<<(1*m);
S2 = S2<<(2*m);
S3 = S3<<(3*m);
S4 = S4<<(4*m);
ret = S0 + S1 + S2 + S3 + S4;
ret = sign *ret;
return ret;
}
define toomcook4(a,b)
{
local a0 a1 a2 a3 b0 b1 b2 b3 b4 ret tmp tmp2 tmp3 sign;
local m alen blen mask;
local w1, w2, w3, w4, w5, w6, w7;
if(!isint(a) || !isint(b))
return newerror("toomcook4(a,b): a and/or b is not integer");
alen = digits(a,2);
blen = digits(b,2);
sign = sgn(a) * sgn(b);
if(sign == 0) return 0;
m = min(alen//4,blen//4);
mask = ~-(1<<m);
if(isdefined("test8900")){
if(m < 100) return toomcook3(a,b);
}
else{
if(m < 256*3072) return toomcook3(a,b);
}
a = abs(a);
b = abs(b);
a0 = a & mask;
a1 = (a>>m) & mask;
a2 = (a>>(2*m)) & mask;
a3 = (a>>(3*m));
b0 = b & mask;
b1 = (b>>m) & mask;
b2 = (b>>(2*m)) & mask;
b3 = (b>>(3*m));
/*
Bodrato / Zanoni
*/
w3 = a3 + (a1 + (a2 + a0));
w7 = b3 + (b1 + (b2 + b0));
w4 = -a3 + (-a1 + (a2 + a0));
w5 = -b3 + (-b1 + (b2 + b0));
w3 = toomcook4(w3, w7);
w4 = toomcook4(w4, w5);
w5 = a3 + ((a1<<2) + ((a2<<1) + (a0<<3)));
w2 = b3 + ((b1<<2) + ((b2<<1) + (b0<<3)));
w6 = -a3 + (-(a1<<2) + ((a2<<1) + (a0<<3)));
w7 = -b3 + (-(b1<<2) + ((b2<<1) + (b0<<3)));
w5 = toomcook4(w5, w2);
w6 = toomcook4(w6, w7);
w2 = (a3<<3) + ((a1<<1) + ((a2<<2) + a0));
w7 = (b3<<3) + ((b1<<1) + ((b2<<2) + b0));
w2 = toomcook4(w2, w7);
w1 = toomcook4(a3, b3);
w7 = toomcook4(a0, b0);
w2 = w2 + w5;
w6 = w5 - w6;
w4 = w3 - w4;
w5 = w5 - w1;
w5 -= w7 << 6;
w4 = w4>>1;
w3 = w3 - w4;
w5 = w5<<1;
w5 = w5 - w6;
w2 -= w3 * 65;
w3 = w3 - w7;
w3 = w3 - w1;
w2 += w3 * 45;
w5 -= w3<<3;
w5 = w5//24;
w6 = w6 - w2;
w2 -= w4<<4;
w2 = w2//18;
w3 = w3 - w5;
w4 = w4 - w2;
w6 += w2 * 30;
w6 = w6//60;
w2 = w2 - w6;
ret = w7 + (w6<<m) + (w5<<(2*m)) + (w4<<(3*m))+ (w3<<(4*m))+
(w2<<(5*m))+ (w1<<(6*m));
ret = sign *ret;
return ret;
}
define toomcook4square(a){
local a0 a1 a2 a3 ret S0 S1 S2 S3 S4 S5 S6 S7 tmp tmp2 tmp3;
local sign m alen mask;
local T0 T1 T2 T3 T4 T5 T6 T7 T8;
if(!isint(a) )return newerror("toomcook3square(a): a is not integer");
alen = digits(a,2);
sign = sgn(a) * sgn(a);
/* sgn(x) returns 0 if x = 0 */
if(sign == 0) return 0;
m = (alen)//4;
mask = ~-( 1 << m );
/*
cut-off at about 2 mio. dec. digits
TODO: check!
*/
if(isdefined("test8900")){
if(m < 100) return toomcook3square(a);
}
else{
if(m < 512*3072) return toomcook3square(a);
}
a = abs(a);
a0 = a & mask;
a1 = (a>>m) & mask;
a2 = (a>>(2*m)) & mask;
a3 = (a>>(3*m)) ;
/*
Bodrato / Zanoni
*/
S1 = toomcook4square(a0);
S2 = toomcook4(a0<<1,a1);
S3 = toomcook4((a0 + a1 - a2 - a3 ) , (a0 - a1 - a2 + a3 ));
S4 = toomcook4square(a0 + a1 + a2 + a3 );
S5 = toomcook4( (a0 - a2 )<<1 , (a1 - a3 ));
S6 = toomcook4(a3<<1 , a2);
S7 = toomcook4square(a3);
T1 = S3 + S4;
T2 = (T1 + S5 )>>1;
T3 = S2 + S6;
T4 = T2 - T3;
T5 = T3 - S5;
T6 = T4 - S3;
T7 = T4 - S1;
T8 = T6 - S7;
ret = (S7<<(6*m)) + (S6<<(5*m)) + (T7<<(4*m))
+ (T5<<(3*m)) + (T8<<(2*m)) + (S2<<(1*m)) + S1;
ret = sign *ret;
return ret;
}
/*
TODO: Implement the asymmetric variations
*/
/*
produce_long_random_number(n) returns large pseudorandom numbers. Really large
numbers, e.g.:
produce_long_random_number(16)
is ca 4,128,561 bits (ca 1,242,821 dec. digits) large. Exact length is not
predeterminable because of the chaotic output of the function random().
*/
define __CZ__produce_long_random_number(n)
{
local ret k;
ret = 1;
if(!isint(n) || n<1)
return newerror("__CZ__produce_long_random_number(n): "
"n is not an integer >=1");
for(k=0;k<n;k++){
ret += random();
ret = toomcook4square(ret);
}
return ret;
}
/*
* restore internal function from resource debugging
* report important interface functions
*/
config("resource_debug", resource_debug_level),;
if (config("resource_debug") & 3) {
print "toomcook3(a,b)";
print "toomcook3square(a)";
print "toomcook4(a,b)";
print "toomcook4square(a)";
}

114
cal/zeta2.cal Normal file
View File

@@ -0,0 +1,114 @@
/*
* zeta2 - Hurwitz Zeta function
* Copyright (C) 2013 Christoph Zurnieden
* Version: 0.0.1
* Licence: GPL
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* @(#) $Revision: 30.3 $
* @(#) $Id: zeta2.cal,v 30.3 2013/08/11 08:41:38 chongo Exp $
* @(#) $Source: /usr/local/src/bin/calc/cal/RCS/zeta2.cal,v $
*
* Under source code control: 2013/08/11 01:31:28
* File existed as early as: 2013
*/
/*
* hide internal function from resource debugging
*/
static resource_debug_level;
resource_debug_level = config("resource_debug", 0);
define hurwitzzeta(s,a){
local realpart_a imagpart_s tmp tmp1 tmp2 tmp3;
local sum1 sum2 sum3 i k n precision result limit;
local limit_function offset offset_squared rest_sum eps;
/*
According to Linas Vepstas' "An efficient algorithm for accelerating
the convergence of oscillatory series, useful for computing the
polylogarithm and Hurwitz zeta functions" the Euler-Maclaurin series
is the fastest in most cases.
With a lot of help of the PARI/GP implementation by Prof. Henri Cohen,
hence the different license.
*/
eps=epsilon( epsilon() * 1e-3);
realpart_a=re(a);
if(realpart_a>1.5){
tmp=floor(realpart_a-0.5);
sum1 = 0;
for( i = 1 ; i <= tmp ; i++){
sum1 += ( a - i )^( -s );
}
epsilon(eps);
return (hurwitzzeta(s,a-tmp)-sum1);
}
if(realpart_a<=0){
tmp=ceil(-realpart_a+0.5);
for( i = 0 ; i <= tmp-1 ; i++){
sum2 += ( a + i )^( -s );
}
epsilon(eps);
return (hurwitzzeta(s,a+tmp)+sum2);
}
precision=digits(1/epsilon());
realpart_a=re(s);
imagpart_s=im(s);
epsilon(1e-9);
result=s-1.;
if(abs(result)<0.1){
result=-1;
}
else
result=ln(result);
limit=(precision*ln(10)-re((s-.5)*result)+(1.*realpart_a)*ln(2.*pi()))/2;
limit=max(2,ceil(max(limit,abs(s*1.)/2)));
limit_function=ceil(sqrt((limit+realpart_a/2-.25)^2+(imagpart_s*1.)^2/4)/
pi());
if (config("user_debug") > 0) {
print "limit_function = " limit_function;
print "limit = " limit;
print "prec = " precision;
}
/* Full precison plus 5 digits angstzuschlag*/
epsilon( (10^(-precision)) * 1e-5);
tmp3=(a+limit_function+0.)^(-s);
sum3 = tmp3/2;
for(n=0;n<=limit_function-1;n++){
sum3 += (a+n)^(-s);
}
result=sum3;
offset=a+limit_function;
offset_squared=1./(offset*offset);
tmp1=2*s-1;
tmp2=s*(s-1);
rest_sum=bernoulli(2*limit);
for(k=2*limit-2;k>=2;k-=2){
rest_sum=bernoulli(k)+offset_squared*
(k*k+tmp1*k+tmp2)*rest_sum/((k+1)*(k+2));
}
rest_sum=offset*(1+offset_squared*tmp2*rest_sum/2);
result+=rest_sum*tmp3/(s-1);
epsilon(eps);
return result;
}
/*
* restore internal function from resource debugging
* report important interface functions
*/
config("resource_debug", resource_debug_level),;
if (config("resource_debug") & 3) {
print "hurwitzzeta(s,a)";
}