/* Copyright (c) 1991 Regents of the University of California */

#ifndef lint
static char SCCSid[] = "@(#)calfunc.c 2.5 10/2/92 LBL";
#endif

/*
 *  calfunc.c - routines for calcomp using functions.
 *
 *	The define BIGLIB pulls in a large number of the
 *  available math routines.
 *
 *      If VARIABLE is not defined, only library functions
 *  can be accessed.
 *
 *     4/2/86
 */

#include  <stdio.h>

#include  <errno.h>

#include  <math.h>

#include  "calcomp.h"

				/* bits in argument flag (better be right!) */
#define  AFLAGSIZ	(8*sizeof(unsigned long))
#define  ALISTSIZ	6	/* maximum saved argument list */

typedef struct activation {
    char  *name;		/* function name */
    struct activation  *prev;	/* previous activation */
    double  *ap;		/* argument list */
    unsigned long  an;		/* computed argument flags */
    EPNODE  *fun;		/* argument function */
}  ACTIVATION;		/* an activation record */

static ACTIVATION  *curact = NULL;

static double  libfunc();

#define  MAXLIB		64	/* maximum number of library functions */

static double  l_if(), l_select(), l_rand();
static double  l_floor(), l_ceil();
#ifdef  BIGLIB
static double  l_sqrt();
static double  l_sin(), l_cos(), l_tan();
static double  l_asin(), l_acos(), l_atan(), l_atan2();
static double  l_exp(), l_log(), l_log10();
#endif

#ifdef  BIGLIB
			/* functions must be listed alphabetically */
static LIBR  library[MAXLIB] = {
    { "acos", 1, ':', l_acos },
    { "asin", 1, ':', l_asin },
    { "atan", 1, ':', l_atan },
    { "atan2", 2, ':', l_atan2 },
    { "ceil", 1, ':', l_ceil },
    { "cos", 1, ':', l_cos },
    { "exp", 1, ':', l_exp },
    { "floor", 1, ':', l_floor },
    { "if", 3, ':', l_if },
    { "log", 1, ':', l_log },
    { "log10", 1, ':', l_log10 },
    { "rand", 1, ':', l_rand },
    { "select", 1, ':', l_select },
    { "sin", 1, ':', l_sin },
    { "sqrt", 1, ':', l_sqrt },
    { "tan", 1, ':', l_tan },
};

static int  libsize = 16;

#else
			/* functions must be listed alphabetically */
static LIBR  library[MAXLIB] = {
    { "ceil", 1, ':', l_ceil },
    { "floor", 1, ':', l_floor },
    { "if", 3, ':', l_if },
    { "rand", 1, ':', l_rand },
    { "select", 1, ':', l_select },
};

static int  libsize = 5;

#endif

extern char  *savestr(), *emalloc();

extern VARDEF  *argf();

#ifdef  VARIABLE
#define  resolve(ep)	((ep)->type==VAR?(ep)->v.ln:argf((ep)->v.chan))
#else
#define  resolve(ep)	((ep)->v.ln)
#define varlookup(name)	NULL
#endif


int
fundefined(fname)		/* return # of arguments for function */
char  *fname;
{
    LIBR  *lp;
    register VARDEF  *vp;

    if ((vp = varlookup(fname)) == NULL || vp->def == NULL
		|| vp->def->v.kid->type != FUNC)
	if ((lp = liblookup(fname)) == NULL)
	    return(0);
	else
	    return(lp->nargs);
    else
	return(nekids(vp->def->v.kid) - 1);
}


double
funvalue(fname, n, a)		/* return a function value to the user */
char  *fname;
int  n;
double  *a;
{
    ACTIVATION  act;
    register VARDEF  *vp;
    double  rval;
					/* push environment */
    act.name = fname;
    act.prev = curact;
    act.ap = a;
    if (n >= AFLAGSIZ)
	act.an = ~0;
    else
	act.an = (1L<<n)-1;
    act.fun = NULL;
    curact = &act;

    if ((vp = varlookup(fname)) == NULL || vp->def == NULL
		|| vp->def->v.kid->type != FUNC)
	rval = libfunc(fname, vp);
    else
	rval = evalue(vp->def->v.kid->sibling);

    curact = act.prev;			/* pop environment */
    return(rval);
}


funset(fname, nargs, assign, fptr)	/* set a library function */
char  *fname;
int  nargs;
int  assign;
double  (*fptr)();
{
    register LIBR  *lp;

    if ((lp = liblookup(fname)) == NULL) {	/* insert */
	if (libsize >= MAXLIB) {
	    eputs("Too many library functons!\n");
	    quit(1);
	}
	for (lp = &library[libsize]; lp > library; lp--)
	    if (strcmp(lp[-1].fname, fname) > 0) {
		lp[0].fname = lp[-1].fname;
		lp[0].nargs = lp[-1].nargs;
		lp[0].atyp = lp[-1].atyp;
		lp[0].f = lp[-1].f;
	    } else
		break;
	libsize++;
    }
    if (fptr == NULL) {				/* delete */
	while (lp < &library[libsize-1]) {
	    lp[0].fname = lp[1].fname;
	    lp[0].nargs = lp[1].nargs;
	    lp[0].atyp = lp[1].atyp;
	    lp[0].f = lp[1].f;
	    lp++;
	}
	libsize--;
    } else {					/* or assign */
	lp[0].fname = fname;		/* string must be static! */
	lp[0].nargs = nargs;
	lp[0].atyp = assign;
	lp[0].f = fptr;
    }
    libupdate(fname);			/* relink library */
}


int
nargum()			/* return number of available arguments */
{
    register int  n;

    if (curact == NULL)
	return(0);
    if (curact->fun == NULL) {
	for (n = 0; (1L<<n) & curact->an; n++)
	    ;
	return(n);
    }
    return(nekids(curact->fun) - 1);
}


double
argument(n)			/* return nth argument for active function */
register int  n;
{
    register ACTIVATION  *actp = curact;
    register EPNODE  *ep;
    double  aval;

    if (actp == NULL || --n < 0) {
	eputs("Bad call to argument!\n");
	quit(1);
    }
						/* already computed? */
    if (n < AFLAGSIZ && 1L<<n & actp->an)
	return(actp->ap[n]);

    if (actp->fun == NULL || (ep = ekid(actp->fun, n+1)) == NULL) {
	eputs(actp->name);
	eputs(": too few arguments\n");
	quit(1);
    }
    curact = actp->prev;			/* pop environment */
    aval = evalue(ep);				/* compute argument */
    curact = actp;				/* push back environment */
    if (n < ALISTSIZ) {				/* save value */
	actp->ap[n] = aval;
	actp->an |= 1L<<n;
    }
    return(aval);
}


#ifdef  VARIABLE
VARDEF *
argf(n)				/* return function def for nth argument */
int  n;
{
    register ACTIVATION  *actp;
    register EPNODE  *ep;

    for (actp = curact; actp != NULL; actp = actp->prev) {

	if (n <= 0)
	    break;

	if (actp->fun == NULL)
	    goto badarg;

	if ((ep = ekid(actp->fun, n)) == NULL) {
	    eputs(actp->name);
	    eputs(": too few arguments\n");
	    quit(1);
	}
	if (ep->type == VAR)
	    return(ep->v.ln);			/* found it */

	if (ep->type != ARG)
	    goto badarg;

	n = ep->v.chan;				/* try previous context */
    }
    eputs("Bad call to argf!\n");
    quit(1);

badarg:
    eputs(actp->name);
    eputs(": argument not a function\n");
    quit(1);
}


char *
argfun(n)			/* return function name for nth argument */
int  n;
{
    return(argf(n)->name);
}
#endif


double
efunc(ep)				/* evaluate a function */
register EPNODE  *ep;
{
    ACTIVATION  act;
    double  alist[ALISTSIZ];
    double  rval;
    register VARDEF  *dp;
					/* push environment */
    dp = resolve(ep->v.kid);
    act.name = dp->name;
    act.prev = curact;
    act.ap = alist;
    act.an = 0;
    act.fun = ep;
    curact = &act;

    if (dp->def == NULL || dp->def->v.kid->type != FUNC)
	rval = libfunc(act.name, dp);
    else
	rval = evalue(dp->def->v.kid->sibling);
    
    curact = act.prev;			/* pop environment */
    return(rval);
}


LIBR *
liblookup(fname)		/* look up a library function */
char  *fname;
{
    int  upper, lower;
    register int  cm, i;

    lower = 0;
    upper = cm = libsize;

    while ((i = (lower + upper) >> 1) != cm) {
	cm = strcmp(fname, library[i].fname);
	if (cm > 0)
	    lower = i;
	else if (cm < 0)
	    upper = i;
	else
	    return(&library[i]);
	cm = i;
    }
    return(NULL);
}


#ifndef  VARIABLE
static VARDEF  *varlist = NULL;		/* our list of dummy variables */


VARDEF *
varinsert(vname)		/* dummy variable insert */
char  *vname;
{
    register VARDEF  *vp;

    vp = (VARDEF *)emalloc(sizeof(VARDEF));
    vp->name = savestr(vname);
    vp->nlinks = 1;
    vp->def = NULL;
    vp->lib = liblookup(vname);
    vp->next = varlist;
    varlist = vp;
    return(vp);
}


varfree(vp)			/* free dummy variable */
register VARDEF  *vp;
{
    register VARDEF  *vp2;

    if (vp == varlist)
	varlist = vp->next;
    else {
	for (vp2 = varlist; vp2->next != vp; vp2 = vp2->next)
		;
	vp2->next = vp->next;
    }
    freestr(vp->name);
    efree((char *)vp);
}


libupdate(nm)			/* update library */
char  *nm;
{
    register VARDEF  *vp;

    for (vp = varlist; vp != NULL; vp = vp->next)
	vp->lib = liblookup(vp->name);
}
#endif



/*
 *  The following routines are for internal use:
 */


static double
libfunc(fname, vp)			/* execute library function */
char  *fname;
VARDEF  *vp;
{
    register LIBR  *lp;
    double  d;
    int  lasterrno;

    if (vp != NULL)
	lp = vp->lib;
    else
	lp = liblookup(fname);
    if (lp == NULL) {
	eputs(fname);
	eputs(": undefined function\n");
	quit(1);
    }
    lasterrno = errno;
    errno = 0;
    d = (*lp->f)(lp->fname);
#ifdef  IEEE
    if (errno == 0)
	if (isnan(d))
	    errno = EDOM;
	else if (isinf(d))
	    errno = ERANGE;
#endif
    if (errno) {
	wputs(fname);
	if (errno == EDOM)
		wputs(": domain error\n");
	else if (errno == ERANGE)
		wputs(": range error\n");
	else
		wputs(": error in call\n");
	return(0.0);
    }
    errno = lasterrno;
    return(d);
}


/*
 *  Library functions:
 */


static double
l_if()			/* if(cond, then, else) conditional expression */
			/* cond evaluates true if greater than zero */
{
    if (argument(1) > 0.0)
	return(argument(2));
    else
	return(argument(3));
}


static double
l_select()		/* return argument #(A1+1) */
{
	register int  n;

	n = argument(1) + .5;
	if (n == 0)
		return(nargum()-1);
	if (n < 1 || n > nargum()-1) {
		errno = EDOM;
		return(0.0);
	}
	return(argument(n+1));
}


static double
l_rand()		/* random function between 0 and 1 */
{
    double  x;

    x = argument(1);
    x *= 1.0/(1.0 + x*x) + 2.71828182845904;
    x += .785398163397447 - floor(x);
    x = 1e5 / x;
    return(x - floor(x));
}


static double
l_floor()		/* return largest integer not greater than arg1 */
{
    return(floor(argument(1)));
}


static double
l_ceil()		/* return smallest integer not less than arg1 */
{
    return(ceil(argument(1)));
}


#ifdef  BIGLIB
static double
l_sqrt()
{
    return(sqrt(argument(1)));
}


static double
l_sin()
{
    return(sin(argument(1)));
}


static double
l_cos()
{
    return(cos(argument(1)));
}


static double
l_tan()
{
    return(tan(argument(1)));
}


static double
l_asin()
{
    return(asin(argument(1)));
}


static double
l_acos()
{
    return(acos(argument(1)));
}


static double
l_atan()
{
    return(atan(argument(1)));
}


static double
l_atan2()
{
    return(atan2(argument(1), argument(2)));
}


static double
l_exp()
{
    return(exp(argument(1)));
}


static double
l_log()
{
    return(log(argument(1)));
}


static double
l_log10()
{
    return(log10(argument(1)));
}
#endif