slib_math.cc

/*  
 *                   COPYRIGHT (c) 1988-1994 BY                             *
 *        PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
 *        See the source file SLIB.C for more information.                  *

 * Reorganization of files (Mar 1999) by Alan W Black <awb@cstr.ed.ac.uk>

 * math functions

*/
#include <cstdio>
#include "siod.h"
#include "siodp.h"

LISP numberp(LISP x)
{if FLONUMP(x) return(truth); else return(NIL);}

static LISP lplus(LISP args)
{
    LISP l;
    double sum;
    for (sum=0.0,l=args; l != NIL; l=cdr(l))
    {
    if (NFLONUMP(car(l))) err("wrong type of argument to plus",car(l));
    sum += FLONM(car(l));
    }
    return flocons(sum);
}

static LISP ltimes(LISP args)
{
    LISP l;
    double product;
    for (product=1.0,l=args; l != NIL; l=cdr(l))
    {
    if (NFLONUMP(car(l))) err("wrong type of argument to times",car(l));
    product *= FLONM(car(l));
    }
    return flocons(product);
}

static LISP difference(LISP x,LISP y)
{if NFLONUMP(x) err("wrong type of argument(1st) to difference",x);
 if NFLONUMP(y) err("wrong type of argument(2nd) to difference",y);
 return(flocons(FLONM(x) - FLONM(y)));}

static LISP quotient(LISP x,LISP y)
{if NFLONUMP(x) err("wrong type of argument(1st) to quotient",x);
 if NFLONUMP(y) err("wrong type of argument(2nd) to quotient",y);
 return(flocons(FLONM(x)/FLONM(y)));}

static LISP greaterp(LISP x,LISP y)
{if NFLONUMP(x) err("wrong type of argument(1st) to greaterp",x);
 if NFLONUMP(y) err("wrong type of argument(2nd) to greaterp",y);
 if (FLONM(x)>FLONM(y)) return(truth);
 return(NIL);}

static LISP lessp(LISP x,LISP y)
{if NFLONUMP(x) err("wrong type of argument(1st) to lessp",x);
 if NFLONUMP(y) err("wrong type of argument(2nd) to lessp",y);
 if (FLONM(x)<FLONM(y)) return(truth);
 return(NIL);}

static LISP l_nint(LISP number)
{
    if (TYPEP(number,tc_flonum))
    {
    int iii = (int)(FLONM(number)+0.5);
    return flocons(iii);
    }
    else if (TYPEP(number,tc_symbol))
    {
    int iii = (int)(atof(get_c_string(number))+0.5);
    return flocons(iii);
    }
    else
    err("nint: argument not a number",number);

    return NIL;
}

static LISP l_log(LISP n)
{
    if (n && (TYPEP(n,tc_flonum)))
    return flocons(log(FLONM(n)));
    else
    err("log: not a number",n);

    return NIL;
}

static LISP l_rand()
{
    double r = (double)abs(rand())/(double)RAND_MAX;
    
    return flocons(r);
}

static LISP l_srand(LISP seed)
{
    if (seed && (TYPEP(seed,tc_flonum)))
    srand((int) FLONM(seed));
    else
    err("srand: not a number", seed);
    return NIL;
}

static LISP l_exp(LISP n)
{
    if (n && (TYPEP(n,tc_flonum)))
    return flocons(exp(FLONM(n)));
    else
    err("exp: not a number",n);
    return NIL;
}

static LISP l_sin(LISP n)
{
    if (n && (TYPEP(n,tc_flonum)))
    return flocons(sin(FLONM(n)));
    else
    err("sin: not a number",n);
    return NIL;
}

static LISP l_cos(LISP n)
{
    if (n && (TYPEP(n,tc_flonum)))
    return flocons(cos(FLONM(n)));
    else
    err("cos: not a number",n);
    return NIL;
}

static LISP l_tan(LISP n)
{
    if (n && (TYPEP(n,tc_flonum)))
    return flocons(tan(FLONM(n)));
    else
    err("tan: not a number",n);
    return NIL;
}

static LISP l_asin(LISP n)
{
    if (n && (TYPEP(n,tc_flonum)))
    return flocons(asin(FLONM(n)));
    else
    err("asin: not a number",n);
    return NIL;
}

static LISP l_acos(LISP n)
{
    if (n && (TYPEP(n,tc_flonum)))
    return flocons(acos(FLONM(n)));
    else
    err("acos: not a number",n);
    return NIL;
}

static LISP l_atan(LISP n)
{
    if (n && (TYPEP(n,tc_flonum)))
    return flocons(atan(FLONM(n)));
    else
    err("atan: not a number",n);
    return NIL;
}

static LISP l_sqrt(LISP n)
{
    if (n && (TYPEP(n,tc_flonum)))
    return flocons(sqrt(FLONM(n)));
    else
    err("sqrt: not a number",n);
    return NIL;
}

static LISP l_pow(LISP x, LISP y)
{
    if (x && (TYPEP(x,tc_flonum)) &&
    y && (TYPEP(y,tc_flonum)))
    return flocons(pow(FLONM(x),FLONM(y)));
    else
    err("pow: x or y not a number",cons(x,cons(y,NIL)));
    return NIL;
}

static LISP l_mod(LISP x, LISP y)
{
    if (x && (TYPEP(x,tc_flonum)) &&
    y && (TYPEP(y,tc_flonum)))
    {
    int a,b;

    a = (int)FLONM(x);
    b = (int)FLONM(y);
    if (b == 0)
        err("mod: y cannot be 0",cons(x,cons(y,NIL)));

    return flocons((float)(a%b));
    }
    else
    err("mod: x or y not a number",cons(x,cons(y,NIL)));
    return NIL;
}

void init_subrs_math(void)
{
 init_subr_1("number?",numberp,
 "(number? DATA)\n\
  Returns t if DATA is a number, nil otherwise.");
 init_lsubr("+",lplus,
 "(+ NUM1 NUM2 ...)\n\
  Returns the sum of NUM1 and NUM2 ...  An error is given is any argument\n\
  is not a number.");
 init_subr_2("-",difference,
 "(- NUM1 NUM2)\n\
  Returns the difference between NUM1 and NUM2.  An error is given is any\n\
  argument is not a number.");
 init_lsubr("*",ltimes,
 "(* NUM1 NUM2 ...)\n\
  Returns the product of NUM1 and NUM2 ...  An error is given is any\n\
  argument is not a number.");
 init_subr_2("/",quotient,
 "(/ NUM1 NUM2)\n\
  Returns the quotient of NUM1 and NUM2.  An error is given is any\n\
  argument is not a number.");
 init_subr_2(">",greaterp,
 "(> NUM1 NUM2)\n\
  Returns t if NUM1 is greater than NUM2, nil otherwise.  An error is\n\
  given is either argument is not a number.");
 init_subr_2("<",lessp,
 "(< NUM1 NUM2)\n\
  Returns t if NUM1 is less than NUM2, nil otherwise.  An error is\n\
  given is either argument is not a number.");
 init_subr_1("nint",l_nint,
 "(nint NUMBER)\n\
  Returns nearest int to NUMBER.");
 init_subr_1("log",l_log,
 "(log NUM)\n\
 Return natural log of NUM.");
 init_subr_0("rand",l_rand,
 "(rand)\n\
 Returns a pseudo random number between 0 and 1 using the libc rand()\n\
 function.");
 init_subr_1("srand",l_srand,
 "(srand SEED)\n\
 Seeds the libc pseudo random number generator with the integer SEED.");
 init_subr_1("exp",l_exp,
 "(exp NUM)\n\
 Return e**NUM.");
 init_subr_1("sin",l_sin,
 "(sin NUM)\n\
 Return sine of NUM.");
 init_subr_1("cos",l_cos,
 "(cos NUM)\n\
 Return cosine of NUM.");
 init_subr_1("tan",l_tan,
 "(tan NUM)\n\
 Return tangent of NUM.");
 init_subr_1("asin",l_asin,
 "(asin NUM)\n\
 Return arcsine of NUM.");
 init_subr_1("acos",l_acos,
 "(acos NUM)\n\
 Return arccosine of NUM.");
 init_subr_1("atan",l_atan,
 "(atan NUM)\n\
 Return arctangent of NUM.");
 init_subr_1("sqrt",l_sqrt,
 "(sqrt NUM)\n\
 Return square root of NUM.");
 init_subr_2("pow",l_pow,
 "(pow X Y)\n\
 Return X**Y.");
 init_subr_2("%",l_mod,
 "(% X Y)\n\
 Return X%Y.");

}