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 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 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);
}
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 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 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);
}
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;
}
/* 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);
}
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_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_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 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 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 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);
}
/* 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);
}
LVAL xssample(V)
{
LVAL x, result, temp, elem;
int n, N, replace, i, j;
x = xlgaseq();
n = getfixnum(xlgafixnum());
N = seqlen(x);
replace = (moreargs()) ? (xlgetarg() != NIL) : FALSE;
xllastarg();
if (! replace && n > N) n = N;
xlstkcheck(4);
xlprotect(x);
xlsave(result);
xlsave(elem);
xlsave(temp);
x = (listp(x)) ? coerce_to_tvec(x, s_true) : copyvector(x);
result = NIL;
if (N > 0 && n > 0) {
for (i = 0; i < n; i++) {
j = (replace) ? osrand(N) : i + osrand(N - i);
elem = gettvecelement(x, j);
result = cons(elem, result);
if (! replace) { /* swap elements i and j */
temp = gettvecelement(x, i);
settvecelement(x, i, elem);
settvecelement(x, j, temp);
}
}
}
xlpopn(4);
return(result);
}
/* xintchar - convert a character to an integer */
LVAL xintchar(void)
{
LVAL arg;
arg = xlgafixnum();
xllastarg();
return (cvchar((int)getfixnum(arg)));
}
LVAL xsmenu_popup(V)
{
LVAL menu, window;
int left, top, item;
menu = xsgetmenu();
left = getfixnum(xlgafixnum());
top = getfixnum(xlgafixnum());
window = (moreargs()) ? xlgaobject() : NIL;
xllastarg();
send_message(menu, sk_update);
item = StMObPopup(menu, left, top, window);
if (item > 0) send_message1(menu, sk_select, item);
return(cvfixnum((FIXTYPE) item));
}
/* Built in BASE-MAKE-SWEEP-MATRIX function */
LVAL xsbasemkswpmat(V)
{
int n, p;
double *x, *y, *w, *sm, *xmean;
n = getfixnum(xlgafixnum());
p = getfixnum(xlgafixnum());
getsweepdata(n * p, &x);
getsweepdata(n, &y);
getsweepdata(n, &w);
getsweepdata((p + 2) * (p + 2), &sm);
getsweepdata(p, &xmean);
xllastarg();
mkswpmat(n, p, x, y, w, sm, xmean);
return NIL;
}
LVAL xlc_block_watch(void)
{
long arg1 = getfixnum(xlgafixnum());
xllastarg();
block_watch(arg1);
return NIL;
}
/* xdigitchar - built-in function 'digit-char' */
LVAL xdigitchar(void)
{
LVAL arg;
int n;
arg = xlgafixnum(); n = getfixnum(arg);
xllastarg();
return (n >= 0 && n <= 9 ? cvchar(n + '0') : NIL);
}
/* xcodechar - built-in function 'code-char' */
LVAL xcodechar(void)
{
LVAL arg;
int ch;
arg = xlgafixnum(); ch = getfixnum(arg);
xllastarg();
return (ch >= 0 && ch <= 127 ? cvchar(ch) : NIL);
}
LVAL iview_std_adjust_points_in_rect(V)
{
IVIEW_WINDOW w;
int left, top, width, height;
PointState state;
w = (IVIEW_WINDOW) get_iview_address(xlgaobject());
left = getfixnum(xlgafixnum());
top = getfixnum(xlgafixnum());
width = getfixnum(xlgafixnum());
height = getfixnum(xlgafixnum());
state = decode_point_state(xlgetarg());
xllastarg();
IViewStdAdjustPointsInRect(w, left, top, width, height, state);
return(NIL);
}
LVAL xlc_snd_print(void)
{
LVAL arg1 = xlgetarg();
long arg2 = getfixnum(xlgafixnum());
xllastarg();
sound_print(arg1, arg2);
return NIL;
}
