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 xsaxpy(V)
{
LVAL result, next, tx, a, x, y;
int i, j, m, n, start, end, lower;
double val;
a = getdarraydata(xlgamatrix());
x = xlgaseq();
y = xlgaseq();
lower = (moreargs() && xlgetarg() != NIL) ? TRUE : FALSE;
n = seqlen(x);
m = seqlen(y);
if (lower && m != n)
xlfail("dimensions do not match");
xlsave1(result);
result = mklist(m, NIL);
for (i = 0, start = 0, next = result;
i < m;
i++, start += n, next = cdr(next)) {
val = makefloat(getnextelement(&y, i));
end = (lower) ? i +1 : n;
for (j = 0, tx = x; j < end; j++) {
val += makefloat(getnextelement(&tx, j))
* makefloat(gettvecelement(a, start + j));
}
rplaca(next, cvflonum((FLOTYPE) val));
}
xlpop();
return(result);
}
static VOID make_number P2C(Number *, num, LVAL, x)
{
if (realp(x)) {
num->real = makefloat(x);
num->imag = 0.0;
num->complex = FALSE;
}
else if (complexp(x)) {
num->real = makefloat(getreal(x));
num->imag = makefloat(getimag(x));
num->complex = TRUE;
}
else xlerror("not a number", x);
}
LVAL xsmake_rotation(V)
{
LVAL x, y, dx, dy, val;
double alpha=0.0;
int n, use_alpha = FALSE;
x = xlgetarg();
y = xlgetarg();
if (moreargs()) {
use_alpha = TRUE;
alpha = makefloat(xlgetarg());
}
xllastarg();
xlstkcheck(3);
xlsave(dx);
xlsave(dy);
xlsave(val);
dx = coerce_to_tvec(x, s_c_double);
dy = coerce_to_tvec(y, s_c_double);
n = gettvecsize(dx);
if (gettvecsize(dy) != n)
xlfail("sequences not the same length");
val = mktvec(n * n, s_c_double);
make_rotation(n, REDAT(val), REDAT(dx), REDAT(dy), use_alpha, alpha);
val = linalg2genmat(val, n, n, FALSE);
xlpopn(3);
return val;
}
LVAL xschol_decomp(V)
{
LVAL a, da, val;
int n;
double maxoffl, maxadd;
a = xlgadarray();
maxoffl = moreargs() ? makefloat(xlgetarg()) : 0.0;
xllastarg();
checksquarematrix(a);
n = numrows(a);
xlstkcheck(2);
xlsave(da);
xlsave(val);
da = gen2linalg(a, n, n, s_c_double, FALSE);
choldecomp(REDAT(da), n, maxoffl, &maxadd);
val = consa(cvflonum((FLOTYPE) maxadd));
val = cons(linalg2genmat(da, n, n, FALSE), val);
xlpopn(2);
return val;
}
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 iview_spin_angle(V)
{
LVAL object;
object = xlgaobject();
if (moreargs()) set_angle(object, makefloat(xlgetarg()));
xllastarg();
return(slot_value(object, s_rotation_angle));
}
static LVAL base_range(V)
{
int var, set = FALSE;
double low, high;
var = getfixnum(xlgafixnum());
if (moreargs()) {
set = TRUE;
low = makefloat(xlgetarg());
high = makefloat(xlgetarg());
}
if (set) {
if (range_type != 'S') IViewSetRange(wind, var, low, high);
else IViewSetScaledRange(wind, var, low, high);
}
if (range_type != 'S') IViewGetRange(wind, var, &low, &high);
else IViewGetScaledRange(wind, var, &low, &high);
return(double_list_2(low, high));
}
LVAL iview_get_nice_range(V)
{
double low, high;
int ticks;
LVAL temp, result;
low = makefloat(xlgetarg());
high = makefloat(xlgetarg());
ticks = getfixnum(xlgafixnum());
xllastarg();
GetNiceRange(&low, &high, &ticks);
xlstkcheck(2);
xlsave(result);
xlsave(temp);
temp = cvfixnum((FIXTYPE) ticks); result = consa(temp);
temp = cvflonum((FLOTYPE) high); result = cons(temp, result);
temp = cvflonum((FLOTYPE) low); result = cons(temp, result);
xlpopn(2);
return(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;
}
static VOID set_internal_transformation P3C(int, vars, LVAL, m, LVAL, b)
{
int i, j, k, rows, cols;
LVAL data;
if (vars <= 0) return;
if (vars > maxvars) {
maxvars = 0;
StFree(transformdata);
StFree(transform);
StFree(inbasis);
transformdata = (double *) StCalloc(vars * vars, sizeof(double));
transform = (double **) StCalloc(vars, sizeof(double *));
for (i = 0; i < vars; i++) transform[i] = transformdata + vars * i;
inbasis = (int *) StCalloc(vars, sizeof(double));
maxvars = vars;
}
if (! matrixp(m)) xlerror("not a matrix", m);
rows = numrows(m);
cols = numcols(m);
if (rows > vars) rows = vars;
if (cols > vars) cols = vars;
if (rows != cols) xlerror("bad transformation matrix", m);
/* fill in upper left corner of transform from m; rest is identity */
data = getdarraydata(m);
for (i = 0, k = 0; i < rows; i++) {
for (j = 0; j < cols; j++, k++)
transform[i][j] = makefloat(gettvecelement(data, k));
for (j = cols; j < vars; j++)
transform[i][j] = (i == j) ? 1.0 : 0.0;
}
for (i = rows; i < vars; i++)
for (j = 0; j < vars; j++)
transform[i][j] = (i == j) ? 1.0 : 0.0;
/* figure out basis elements using b and size of m */
if (b != NIL) {
if (! seqp(b)) xlerror("not a sequence", b);
if (seqlen(b) != rows) xlerror("wrong length for basis", b);
for (i = 0; i < rows; i++)
inbasis[i] = (getnextelement(&b, i) != NIL) ? TRUE : FALSE;
}
else for (i = 0; i < rows; i++) inbasis[i] = TRUE;
for (i = rows; i < vars; i++) inbasis[i] = FALSE;
}
LVAL iview_rotate_2(V)
{
IVIEW_WINDOW w;
int var1, var2;
double alpha;
LVAL object;
object = xlgaobject();
w = (IVIEW_WINDOW) get_iview_address(object);
var1 = getfixnum(xlgafixnum());
var2 = getfixnum(xlgafixnum());
alpha = makefloat(xlgetarg());
IViewRotate2(w, var1, var2, alpha);
check_redraw(object, TRUE, TRUE);
return(NIL);
}
LVAL xssurface_contour(V)
{
LVAL s1, s2, mat, result;
LVAL x, y, z;
double *dx, *dy, *dz;
double v;
int i, j, n, m;
s1 = xlgaseq();
s2 = xlgaseq();
mat = xlgamatrix();
v = makefloat(xlgetarg());
xllastarg();
n = seqlen(s1);
m = seqlen(s2);
if (n != numrows(mat) || m != numcols(mat))
xlfail("dimensions do not match");
xlstkcheck(4);
xlsave(x);
xlsave(y);
xlsave(z);
xlsave(result);
x = gen2linalg(s1, n, 1, s_c_double, FALSE); dx = REDAT(x);
y = gen2linalg(s2, m, 1, s_c_double, FALSE); dy = REDAT(y);
z = gen2linalg(mat, n, m, s_c_double, FALSE); dz = REDAT(z);
result = NIL;
for (i = 0; i < n - 1; i++) {
for (j = 0; j < m - 1; j++) {
result = add_contour_point(m, i, j, i, j+1, dx, dy, dz, v, result);
result = add_contour_point(m, i, j+1, i+1, j+1, dx, dy, dz, v, result);
result = add_contour_point(m, i+1, j+1, i+1, j, dx, dy, dz, v, result);
result = add_contour_point(m, i+1, j, i, j, dx, dy, dz, v, result);
}
}
xlpopn(4);
return(result);
}
/*-----------------------------------------------------------------------------*/
int GetColumn()
{
struct Cursor *cur = (struct Cursor *)ptoc_int(2);
int ColCurNum = ptoc_int(3);
Cell op1;
Cell op = ptoc_tag(4);
UDWORD len;
if (ColCurNum < 0 || ColCurNum >= cur->NumCols) {
/* no more columns in the result row*/
ctop_int(5,1);
return TRUE;
}
ctop_int(5,0);
/* get the data*/
if (cur->OutLen[ColCurNum] == SQL_NULL_DATA) {
/* column value is NULL*/
return unify(op,nullStrAtom);
}
/* convert the string to either integer, float or string*/
/* according to the column type and pass it back to XSB*/
switch (ODBCToXSBType(cur->ColTypes[ColCurNum])) {
case SQL_C_CHAR:
/* convert the column string to a C string */
len = ((cur->ColLen[ColCurNum] < cur->OutLen[ColCurNum])?
cur->ColLen[ColCurNum]:cur->OutLen[ColCurNum]);
*(cur->Data[ColCurNum]+len) = '\0';
/* compare strings here, so don't intern strings unnecessarily*/
XSB_Deref(op);
if (isref(op))
return unify(op, makestring(string_find(cur->Data[ColCurNum],1)));
if (isconstr(op) && get_arity(get_str_psc(op)) == 1) {
STRFILE strfile;
op1 = cell(clref_val(op)+1);
XSB_Deref(op1);
strfile.strcnt = strlen(cur->Data[ColCurNum]);
strfile.strptr = strfile.strbase = cur->Data[ColCurNum];
read_canonical_term(NULL,&strfile,op1); /* terminating '.'? */
return TRUE;
}
if (!isstring(op)) return FALSE;
if (strcmp(string_val(op),cur->Data[ColCurNum])) return FALSE;
return TRUE;
case SQL_C_BINARY:
/* convert the column string to a C string */
len = ((cur->ColLen[ColCurNum] < cur->OutLen[ColCurNum])?
cur->ColLen[ColCurNum]:cur->OutLen[ColCurNum]);
*(cur->Data[ColCurNum]+len) = '\0';
/* compare strings here, so don't intern strings unnecessarily*/
XSB_Deref(op);
if (isref(op))
return unify(op, makestring(string_find(cur->Data[ColCurNum],1)));
if (isconstr(op) && get_arity(get_str_psc(op)) == 1) {
STRFILE strfile;
op1 = cell(clref_val(op)+1);
XSB_Deref(op1);
strfile.strcnt = strlen(cur->Data[ColCurNum]);
strfile.strptr = strfile.strbase = cur->Data[ColCurNum];
read_canonical_term(NULL,&strfile,op1); /* terminating '.'? */
return TRUE;
}
if (!isstring(op)) return FALSE;
if (strcmp(string_val(op),cur->Data[ColCurNum])) return FALSE;
return TRUE;
case SQL_C_SLONG:
return unify(op,makeint(*(long *)(cur->Data[ColCurNum])));
case SQL_C_FLOAT:
return unify(op,makefloat(*(float *)(cur->Data[ColCurNum])));
}
return FALSE;
}
