LVAL xsbaselowess(V)
{
LVAL x, y, ys, rw, res;
double *dx, *dy, *dys, *drw, *dres;
int n, nsteps, error;
double f, delta;
x = xlgetarg();
y = xlgetarg();
n = getfixnum(xlgafixnum());
f = makefloat(xlgetarg());
nsteps = getfixnum(xlgafixnum());
delta = makefloat(xlgetarg());
ys = xlgetarg();
rw = xlgetarg();
res = xlgetarg();
xllastarg();
dx = getlinalgdvec(0, n, x);
dy = getlinalgdvec(0, n, y);
dys = getlinalgdvec(0, n, ys);
drw = getlinalgdvec(0, n, rw);
dres = getlinalgdvec(0, n, res);
error = lowess(dx, dy, n, f, nsteps, delta, dys, drw, dres);
return error ? s_true : NIL;
}
LVAL iview_hist_mark_points_in_rect(V)
{
int i, n, in_rect;
PointState point_state;
IVIEW_WINDOW w;
int left, top, width, height;
LVAL object, hdata;
gethistargs(&w, &object, &hdata);
left = getfixnum(xlgafixnum());
top = getfixnum(xlgafixnum());
width = getfixnum(xlgafixnum());
height = getfixnum(xlgafixnum());
if (IVIEW_WINDOW_NULL(w)) return(NIL);
n = IViewNumPoints(w);
for (i = 0; i < n; i++) {
point_state = IViewPointState(w, i);
if (! IViewPointMasked(w, i) && point_state != pointInvisible) {
in_rect = sect_point_rect(hdata, i, left, top, width, height);
IViewSetPointMark(w, i, in_rect);
}
}
return(NIL);
}
LVAL xsbasespline(V)
{
LVAL x, y, xs, ys, work;
double *dx, *dy, *dxs, *dys, *dwork;
int n, ns, error;
n = getfixnum(xlgafixnum());
x = xlgetarg();
y = xlgetarg();
ns = getfixnum(xlgafixnum());
xs = xlgetarg();
ys = xlgetarg();
work = xlgetarg();
xllastarg();
dx = getlinalgdvec(0, n, x);
dy = getlinalgdvec(0, n, y);
dxs = getlinalgdvec(0, ns, xs);
dys = getlinalgdvec(0, ns, ys);
dwork = getlinalgdvec(0, 2 * n, work);
error = fit_spline(n, dx, dy, ns, dxs, dys, dwork);
return error ? s_true : NIL;
}
/* find length of a compound item's data sequence */
int compounddatalen P1C(LVAL, x)
{
switch (ntype(x)) {
case OBJECT:
{
LVAL n = send_message(x, sk_data_length);
if (! fixp(n) || getfixnum(n) < 0) xlerror("bad length", n);
return((int) getfixnum(n));
}
case CONS:
return(llength(x));
case DARRAY:
x = getdarraydata(x);
if (stringp(x))
xlbadtype(x);
/* fall through */
case VECTOR:
case TVEC:
return(gettvecsize(x));
case SYMBOL:
if (null(x)) return(0);
default:
xlbadtype(x);
return(0);
}
}
VOID initialize_graph_window P1C(LVAL, object)
{
LVAL internals, value;
int v, width, height, size;
StGWWinInfo *gwinfo;
ColorCode bc,dc; /* added JKL */
internals = newadata(StGWWinInfoSize(), 1, FALSE);
set_slot_value(object, s_internals, consa(internals));
StGWInitWinInfo(object);
gwinfo = StGWObWinInfo(object);
if (gwinfo == NULL) return;
StGWSetObject(gwinfo, object);
if (slot_value(object, s_black_on_white) == NIL) {
bc = StGWBackColor(gwinfo); /* this seems better for color */
dc = StGWDrawColor(gwinfo); /* machines - 0 and 1 are not */
StGWSetDrawColor(gwinfo, bc); /* the default draw and back */
StGWSetBackColor(gwinfo, dc); /* colors on the Amiga JKL */
}
StGetScreenSize(&width, &height);
size = (width > height) ? width : height;
if ((value = slot_value(object, s_has_h_scroll)) != NIL) {
v = (fixp(value)) ? getfixnum(value) : size;
StGWSetHasHscroll(gwinfo, TRUE, v);
}
if ((value = slot_value(object, s_has_v_scroll)) != NIL) {
v = (fixp(value)) ? getfixnum(value) : size;
StGWSetHasVscroll(gwinfo, TRUE, v);
}
}
/* eql - internal eql function */
int eql P2C(LVAL, arg1, LVAL, arg2)
{
/* compare the arguments */
if (arg1 == arg2)
return (TRUE);
else if (arg1 != NIL) {
switch (ntype(arg1)) {
case FIXNUM:
return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
#ifdef BIGNUMS
case RATIO:
return (ratiop(arg2) ? compareratio(arg1, arg2) : FALSE);
case BIGNUM:
return (bignump(arg2) ? comparebignum(arg1, arg2) == 0 : FALSE);
#endif
case FLONUM:
return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
case COMPLEX:
return (complexp(arg2) ? comparecomplex(arg1,arg2) : FALSE);
default:
return (FALSE);
}
}
else
return (FALSE);
}
LVAL xseispackrs(V)
{
int nm, n, matz, ierr;
LVAL a, w, z, fv1, fv2;
double *da, *dw, *dz, *dfv1, *dfv2;
nm = getfixnum(xlgafixnum());
n = getfixnum(xlgafixnum());
a = xlgetarg();
w = xlgetarg();
matz = getfixnum(xlgafixnum());
z = xlgetarg();
fv1 = xlgetarg();
fv2 = xlgetarg();
xllastarg();
checkldim(nm, n);
da = getlinalgdvec(0, nm * n, a);
dw = getlinalgdvec(0, n, w);
dz = (matz != 0) ? getlinalgdvec(0, nm * n, z) : NULL;
dfv1 = getlinalgdvec(0, n, fv1);
dfv2 = getlinalgdvec(0, n, fv2);
eispack_rs(nm, n, da, dw, matz, dz, dfv1, dfv2, &ierr);
return (ierr == 0) ? NIL : cvfixnum((FIXTYPE) ierr);
}
/* getbounds - get the start and end bounds of a string */
LOCAL void getbounds(LVAL str, LVAL skey, LVAL ekey, int *pstart, int *pend)
{
LVAL arg;
int len;
/* get the length of the string */
len = getslength(str) - 1;
/* get the starting index */
if (xlgkfixnum(skey,&arg)) {
*pstart = (int)getfixnum(arg);
if (*pstart < 0 || *pstart > len)
xlerror("string index out of bounds",arg);
}
else
*pstart = 0;
/* get the ending index */
if (xlgkfixnum(ekey,&arg)) {
*pend = (int)getfixnum(arg);
if (*pend < 0 || *pend > len)
xlerror("string index out of bounds",arg);
}
else
*pend = len;
/* make sure the start is less than or equal to the end */
if (*pstart > *pend)
xlerror("starting index error",cvfixnum((FIXTYPE)*pstart));
}
LVAL xseispackch(V)
{
int nm, n, matz, ierr;
LVAL ar, ai, w, zr, zi, fv1, fv2, fm1;
double *dar, *dai, *dw, *dzr, *dzi, *dfv1, *dfv2, *dfm1;
nm = getfixnum(xlgafixnum());
n = getfixnum(xlgafixnum());
ar = xlgetarg();
ai = xlgetarg();
w = xlgetarg();
matz = getfixnum(xlgafixnum());
zr = xlgetarg();
zi = xlgetarg();
fv1 = xlgetarg();
fv2 = xlgetarg();
fm1 = xlgetarg();
xllastarg();
checkldim(nm, n);
dar = getlinalgdvec(0, nm * n, ar);
dai = getlinalgdvec(0, nm * n, ai);
dw = getlinalgdvec(0, n, w);
dzr = (matz != 0) ? getlinalgdvec(0, nm * n, zr) : NULL;
dzi = (matz != 0) ? getlinalgdvec(0, nm * n, zi) : NULL;
dfv1 = getlinalgdvec(0, n, fv1);
dfv2 = getlinalgdvec(0, n, fv2);
dfm1 = getlinalgdvec(0, 2 * n, fm1);
eispack_ch(nm, n, dar, dai, dw, matz, dzr, dzi, dfv1, dfv2, dfm1, &ierr);
return (ierr == 0) ? NIL : cvfixnum((FIXTYPE) ierr);
}
LVAL xslpzgesl(V)
{
LVAL a, ipvt, b;
dcomplex *da, *db;
int lda, offa, n, *dipvt, job, i, ilda;
a = xlgetarg();
offa = getfixnum(xlgafixnum());
lda = getfixnum(xlgafixnum());
n = getfixnum(xlgafixnum());
ipvt = xlgetarg();
b = xlgetarg();
job = getfixnum(xlgafixnum());
xllastarg();
checkldim(lda, n);
da = getlinalgzvec(offa, lda * n, a);
dipvt = getlinalgivec(0, n, ipvt);
db = getlinalgzvec(0, n, b);
for (i = 0, ilda = 0; i < n; i++, ilda += lda)
if (da[ilda + i].r == 0.0 && da[ilda + i].i == 0.0)
xlfail("matrix is (numerically) singular");
linpack_zgesl(da, lda, n, dipvt, db, job);
return NIL;
}
LVAL xslpzgedi(V)
{
LVAL a, ipvt, det, work;
dcomplex *da, *ddet, *dwork;
int lda, offa, n, *dipvt, job, i, ilda;
a = xlgetarg();
offa = getfixnum(xlgafixnum());
lda = getfixnum(xlgafixnum());
n = getfixnum(xlgafixnum());
ipvt = xlgetarg();
det = xlgetarg();
work = xlgetarg();
job = getfixnum(xlgafixnum());
xllastarg();
checkldim(lda, n);
da = getlinalgzvec(offa, lda * n, a);
dipvt = getlinalgivec(0, n, ipvt);
ddet = (job / 10 != 0) ? getlinalgzvec(0, 2, det) : NULL;
dwork = getlinalgzvec(0, n, work);
if (job % 10 != 0)
for (i = 0, ilda = 0; i < n; i++, ilda += lda)
if (da[ilda + i].r == 0.0 && da[ilda + i].i == 0.0)
xlfail("matrix is (numerically) singular");
linpack_zgedi(da, lda, n, dipvt, ddet, dwork, job);
return NIL;
}
LVAL xsbasekernelsmooth(V)
{
LVAL x, y, xs, ys, targ;
int n, ns, error, ktype;
double *dx, *dy, *dxs, *dys, width;
n = getfixnum(xlgafixnum());
x = xlgetarg();
y = xlgetarg();
ns = getfixnum(xlgafixnum());
xs = xlgetarg();
ys = xlgetarg();
width = makefloat(xlgetarg());
targ = xlgasymbol();
xllastarg();
dx = getlinalgdvec(0, n, x);
dy = null(y) ? NULL : getlinalgdvec(0, n, y);
dxs = getlinalgdvec(0, ns, xs);
dys = getlinalgdvec(0, ns, ys);
switch (getstring(getpname(targ))[0]) {
case 'U': ktype = 'U'; break;
case 'T': ktype = 'T'; break;
case 'G': ktype = 'G'; break;
default: ktype = 'B'; break;
}
error = kernel_smooth(dx, dy, n, width, NULL, NULL, dxs, dys, ns, ktype);
return error ? s_true : NIL;
}
LVAL xlc_snd_save(void)
{
LVAL arg1 = xlgetarg();
long arg2 = getfixnum(xlgafixnum());
unsigned char * arg3 = getstring(xlgastring());
long arg4 = getfixnum(xlgafixnum());
long arg5 = getfixnum(xlgafixnum());
long arg6 = getfixnum(xlgafixnum());
long arg7 = getfixnum(xlgafixnum());
double arg8 = 0.0;
long arg9 = 0;
double arg10 = 0.0;
LVAL arg11 = xlgetarg();
double result;
xllastarg();
result = sound_save(arg1, arg2, arg3, arg4, arg5, arg6, arg7, &arg8, &arg9, &arg10, arg11);
{ LVAL *next = &getvalue(RSLT_sym);
*next = cons(NIL, NIL);
car(*next) = cvflonum(arg8); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg9); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvflonum(arg10);
}
return cvflonum(result);
}
/* tiebreaker routine */
LOCAL int tiebreak P2C(LVAL *, px, LVAL *, py)
{
int ix = getfixnum(px[1]);
int iy = getfixnum(py[1]);
if (ix < iy) return(-1);
else return(1);
}
/* SHLIB-INIT funtab &optional (version -1) (oldest version) */
LVAL xshlibinit()
{
LVAL subr, val, sym;
xlshlib_modinfo_t *info = getnpaddr(xlganatptr());
FUNDEF *p = info->funs;
FIXCONSTDEF *pfix = info->fixconsts;
FLOCONSTDEF *pflo = info->floconsts;
STRCONSTDEF *pstr = info->strconsts;
struct version_info defversion;
defversion.current = moreargs()?getfixnum(xlgafixnum()):-1;
defversion.oldest = moreargs()?getfixnum(xlgafixnum()):defversion.current;
xllastarg();
if (! check_version(&defsysversion, &(info->sysversion)))
xlfail("shared library not compatible with current system");
if (defversion.current >= 0 &&
! check_version(&defversion, &(info->modversion)))
xlfail("module not compatible with requested version");
xlsave1(val);
val = NIL;
if (p != NULL)
for (val = NIL; (p->fd_subr) != (LVAL(*)(void)) NULL; p++) {
subr = cvsubr(p->fd_subr, p->fd_type & TYPEFIELD, 0);
setmulvalp(subr, (p->fd_type & (TYPEFIELD + 1)) ? TRUE : FALSE);
val = cons(subr, val);
if (p->fd_name != NULL) {
sym = xlenter(p->fd_name);
setfunction(sym, subr);
}
}
if (pfix != NULL)
for (; pfix->name != NULL; pfix++) {
sym = xlenter(pfix->name);
defconstant(sym, cvfixnum(pfix->val));
}
if (pflo != NULL)
for (; pflo->name != NULL; pflo++) {
sym = xlenter(pflo->name);
defconstant(sym, cvflonum(pflo->val));
}
if (pstr != NULL)
for (; pstr->name != NULL; pstr++) {
sym = xlenter(pstr->name);
defconstant(sym, cvstring(pstr->val));
}
if (info->sysversion.current >= MAKEVERSION(0,1)) {
ULONGCONSTDEF *pulong = info->ulongconsts;
if (pulong != NULL)
for (; pulong->name != NULL; pulong++) {
sym = xlenter(pulong->name);
defconstant(sym, ulong2lisp(pulong->val));
}
}
xlpop();
return xlnreverse(val);
}
LVAL xlc_snd_fetch_array(void)
{
sound_type arg1 = getsound(xlgasound());
long arg2 = getfixnum(xlgafixnum());
long arg3 = getfixnum(xlgafixnum());
LVAL result;
xllastarg();
result = snd_fetch_array(arg1, arg2, arg3);
return (result);
}
void nyx_get_label(unsigned int index,
double *start_time,
double *end_time,
const char **label)
{
LVAL s = nyx_result;
LVAL label_expr;
LVAL t0_expr;
LVAL t1_expr;
LVAL str_expr;
if (nyx_get_type(nyx_result) != nyx_labels) {
return;
}
while (index) {
index--;
s = cdr(s);
if (s == NULL) {
// index was larger than number of labels
return;
}
}
/* We either have (t0 "label") or (t0 t1 "label") */
label_expr = car(s);
t0_expr = car(label_expr);
t1_expr = car(cdr(label_expr));
if (stringp(t1_expr)) {
str_expr = t1_expr;
t1_expr = t0_expr;
}
else {
str_expr = car(cdr(cdr(label_expr)));
}
if (floatp(t0_expr)) {
*start_time = getflonum(t0_expr);
}
else if (fixp(t0_expr)) {
*start_time = (double)getfixnum(t0_expr);
}
if (floatp(t1_expr)) {
*end_time = getflonum(t1_expr);
}
else if (fixp(t1_expr)) {
*end_time = (double)getfixnum(t1_expr);
}
*label = (const char *)getstring(str_expr);
}
LVAL xlc_snd_fft(void)
{
sound_type arg1 = getsound(xlgasound());
long arg2 = getfixnum(xlgafixnum());
long arg3 = getfixnum(xlgafixnum());
LVAL arg4 = xlgetarg();
LVAL result;
xllastarg();
result = snd_fft(arg1, arg2, arg3, arg4);
return (result);
}
LVAL xlc_snd_avg(void)
{
sound_type arg1 = getsound(xlgasound());
long arg2 = getfixnum(xlgafixnum());
long arg3 = getfixnum(xlgafixnum());
long arg4 = getfixnum(xlgafixnum());
sound_type result;
xllastarg();
result = snd_avg(arg1, arg2, arg3, arg4);
return cvsound(result);
}
LVAL xlc_seq_insert_macctrl(void)
{
seq_type arg1 = getseq(xlgaseq());
long arg2 = getfixnum(xlgafixnum());
long arg3 = getfixnum(xlgafixnum());
long arg4 = getfixnum(xlgafixnum());
long arg5 = getfixnum(xlgafixnum());
long arg6 = getfixnum(xlgafixnum());
xllastarg();
insert_macctrl(arg1, arg2, arg3, arg4, arg5, arg6);
return NIL;
}
LVAL xlc_snd_phasevocoder(void)
{
sound_type arg1 = getsound(xlgasound());
sound_type arg2 = getsound(xlgasound());
long arg3 = getfixnum(xlgafixnum());
long arg4 = getfixnum(xlgafixnum());
long arg5 = getfixnum(xlgafixnum());
sound_type result;
xllastarg();
result = snd_phasevocoder(arg1, arg2, arg3, arg4, arg5);
return cvsound(result);
}
LVAL xssweepinplace(V)
{
int rows, cols, k;
double *a, tol;
rows = getfixnum(xlgafixnum());
cols = getfixnum(xlgafixnum());
getsweepdata(rows * cols, &a);
k = getfixnum(xlgafixnum());
tol = makefloat(xlgetarg());
return sweepinplace(rows, cols, a, k, tol) ? s_true : NIL;
}
LVAL xsgen2linalg(V)
{
LVAL x, type;
int m, n, trans;
x = xlgetarg();
m = getfixnum(xlgafixnum());
n = getfixnum(xlgafixnum());
type = xlgetarg();
trans = moreargs() ? ! null(xlgetarg()) : FALSE;
xllastarg();
return gen2linalg(x, m, n, type, trans);
}
LVAL iview_std_mark_points_in_rect(V)
{
IVIEW_WINDOW w;
int left, top, width, height;
w = (IVIEW_WINDOW) get_iview_address(xlgaobject());
left = getfixnum(xlgafixnum());
top = getfixnum(xlgafixnum());
width = getfixnum(xlgafixnum());
height = getfixnum(xlgafixnum());
xllastarg();
IViewStdMarkPointsInRect(w, left, top, width, height);
return(NIL);
}
LVAL xstransposeinto(V)
{
LVAL x, y;
int m, n;
x = xlgetarg();
m = getfixnum(xlgafixnum());
n = getfixnum(xlgafixnum());
y = xlgetarg();
xllastarg();
transposeinto(x, m, n, y);
return y;
}
/* xmkstrinput - make a string input stream */
LVAL xmkstrinput(void)
{
int start,end,len,i;
unsigned char *str;
LVAL string,val;
/* protect the return value */
xlsave1(val);
/* get the string and length */
string = xlgastring();
str = getstring(string);
len = getslength(string) - 1;
/* get the starting offset */
if (moreargs()) {
val = xlgafixnum();
start = (int)getfixnum(val);
}
else start = 0;
/* get the ending offset */
if (moreargs()) {
val = xlgafixnum();
end = (int)getfixnum(val);
}
else end = len;
xllastarg();
/* check the bounds */
if (start < 0 || start > len)
xlerror("string index out of bounds",cvfixnum((FIXTYPE)start));
if (end < 0 || end > len)
xlerror("string index out of bounds",cvfixnum((FIXTYPE)end));
/* make the stream */
val = newustream();
/* copy the substring into the stream */
for (i = start; i < end; ++i)
xlputc(val,str[i]);
/* restore the stack */
xlpop();
/* return the new stream */
return (val);
}
/* xintchar - convert a character to an integer */
LVAL xintchar(void)
{
LVAL arg;
arg = xlgafixnum();
xllastarg();
return (cvchar((int)getfixnum(arg)));
}
int nyx_get_int()
{
if (nyx_get_type(nyx_result) != nyx_int)
return -1;
return getfixnum(nyx_result);
}
/* getivcnt - get the number of instance variables for a class */
LOCAL int getivcnt(LVAL cls, int ivar)
{
LVAL cnt;
if ((cnt = getivar(cls,ivar)) == NIL || !fixp(cnt))
xlfail("bad value for instance variable count");
return ((int)getfixnum(cnt));
}
/* xpoke - poke a value into memory */
LVAL xpoke(void)
{
LVAL val;
int *adr;
/* get the address and the new value */
val = xlgafixnum(); adr = (int *)getfixnum(val);
val = xlgafixnum();
xllastarg();
/* store the new value */
*adr = (int)getfixnum(val);
/* return the new value */
return (val);
}
