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; }