static LVAL add_contour_point P10C(int, m,
int, i,
int, j,
int, k,
int, l,
double *, x,
double *, y,
double *, z,
double, v,
LVAL, result)
{
LVAL pt;
double p, q;
double zij = z[i * m + j];
double zkl = z[k * m + l];
if ((zij <= v && v < zkl) || (zkl <= v && v < zij)) {
xlsave(pt);
pt = mklist(2, NIL);
p = (v - zij) / (zkl - zij);
q = 1.0 - p;
rplaca(pt, cvflonum((FLOTYPE) (q * x[i] + p * x[k])));
rplaca(cdr(pt), cvflonum((FLOTYPE) (q * y[j] + p * y[l])));
result = cons(pt, result);
xlpop();
}
return(result);
}
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);
}
void nyx_set_audio_params(double rate, long len)
{
LVAL flo;
LVAL con;
xlstkcheck(2);
xlsave(flo);
xlsave(con);
/* Bind the sample rate to the "*sound-srate*" global */
flo = cvflonum(rate);
setvalue(xlenter("*SOUND-SRATE*"), flo);
/* Bind selection len to "len" global */
flo = cvflonum(len);
setvalue(xlenter("LEN"), flo);
/* Set the "*warp*" global based on the length of the audio */
con = cons(NULL, NULL);
flo = cvflonum(len > 0 ? (double) len / rate : 1.0);
con = cons(flo, con);
flo = cvflonum(0);
con = cons(flo, con);
setvalue(xlenter("*WARP*"), con);
xlpopn(2);
}
static NODE *binary(NODE *args, int fcn)
{
long ival,iarg;
float fval,farg;
NODE *arg;
int imode;
arg = xlarg(&args);
if (((arg) && (arg)->n_type == 5)) {
ival = ((arg)->n_info.n_xint.xi_int);
imode = 1;
}
else if (((arg) && (arg)->n_type == 9)) {
fval = ((arg)->n_info.n_xfloat.xf_float);
imode = 0;
}
else
xlerror("bad argument type",arg);
if (fcn == '-' && args == (NODE *)0)
if (imode)
ival = -ival;
else
fval = -fval;
while (args) {
arg = xlarg(&args);
if (((arg) && (arg)->n_type == 5))
if (imode) iarg = ((arg)->n_info.n_xint.xi_int);
else farg = (float)((arg)->n_info.n_xint.xi_int);
else if (((arg) && (arg)->n_type == 9))
if (imode) { fval = (float)ival; farg = ((arg)->n_info.n_xfloat.xf_float); imode = 0; }
else farg = ((arg)->n_info.n_xfloat.xf_float);
else
xlerror("bad argument type",arg);
if (imode)
switch (fcn) {
case '+': ival += iarg; break;
case '-': ival -= iarg; break;
case '*': ival *= iarg; break;
case '/': checkizero(iarg); ival /= iarg; break;
case '%': checkizero(iarg); ival %= iarg; break;
case 'M': if (iarg > ival) ival = iarg; break;
case 'm': if (iarg < ival) ival = iarg; break;
case '&': ival &= iarg; break;
case '|': ival |= iarg; break;
case '^': ival ^= iarg; break;
default: badiop();
}
else
switch (fcn) {
case '+': fval += farg; break;
case '-': fval -= farg; break;
case '*': fval *= farg; break;
case '/': checkfzero(farg); fval /= farg; break;
case 'M': if (farg > fval) fval = farg; break;
case 'm': if (farg < fval) fval = farg; break;
case 'E': fval = pow(fval,farg); break;
default: badfop();
}
}
return (imode ? cvfixnum(ival) : cvflonum(fval));
}
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);
}
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;
}
/* 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_maxsamp(void)
{
sound_type arg1 = getsound(xlgasound());
double result;
xllastarg();
result = snd_maxsamp(arg1);
return cvflonum(result);
}
LVAL xlc_hz_to_step(void)
{
double arg1 = testarg2(xlgaanynum());
double result;
xllastarg();
result = hz_to_step(arg1);
return cvflonum(result);
}
LVAL xlc_snd_set_latency(void)
{
double arg1 = getflonum(xlgaflonum());
double result;
xllastarg();
result = snd_set_latency(arg1);
return cvflonum(result);
}
LVAL xlc_log(void)
{
double arg1 = getflonum(xlgaflonum());
double result;
xllastarg();
result = xlog(arg1);
return cvflonum(result);
}
LVAL xlc_snd_max(void)
{
LVAL arg1 = xlgetarg();
long arg2 = getfixnum(xlgafixnum());
double result;
xllastarg();
result = sound_max(arg1, arg2);
return cvflonum(result);
}
LVAL xslider_read(void)
{
LVAL arg = xlgafixnum();
int index = getfixnum(arg);
xllastarg();
if (index >= 0 && index < SLIDERS_MAX) {
return cvflonum(slider_array[index]);
}
return NIL;
}
LVAL xlc_snd_sref(void)
{
sound_type arg1 = getsound(xlgasound());
double arg2 = testarg2(xlgaanynum());
double result;
xllastarg();
result = snd_sref(arg1, arg2);
return cvflonum(result);
}
LVAL xlc_snd_read(void)
{
unsigned char * arg1 = getstring(xlgastring());
double arg2 = testarg2(xlgaanynum());
double arg3 = testarg2(xlgaanynum());
long arg4 = getfixnum(xlgafixnum());
long arg5 = getfixnum(xlgafixnum());
long arg6 = getfixnum(xlgafixnum());
long arg7 = getfixnum(xlgafixnum());
long arg8 = getfixnum(xlgafixnum());
double arg9 = testarg2(xlgaanynum());
double arg10 = testarg2(xlgaanynum());
long arg11 = 0;
long arg12 = 0;
LVAL result;
xllastarg();
xlprot1(result);
result = snd_make_read(arg1, arg2, arg3, &arg4, &arg5, &arg6, &arg7, &arg8, &arg9, &arg10, &arg11, &arg12);
{ LVAL *next = &getvalue(RSLT_sym);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg4); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg5); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg6); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg7); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg8); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvflonum(arg9); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvflonum(arg10); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg11); next = &cdr(*next);
*next = cons(NIL, NIL);
car(*next) = cvfixnum(arg12);
}
xlpop();
return (result);
}
LVAL Native_MinTime()
{
TF2L fTrans;
/* guaranteed to be earlier than any system time */
fTrans.u.l = NANCY_MINTIME;
return(cvflonum(fTrans.u.f));
} /* Native_MinTime */
static NODE *unary(NODE *args, int fcn)
{
float fval;
long ival;
NODE *arg;
arg = xlarg(&args);
xllastarg(args);
if (((arg) && (arg)->n_type == 5)) {
ival = ((arg)->n_info.n_xint.xi_int);
switch (fcn) {
case '~': ival = ~ival; break;
case 'A': ival = ((ival) < 0 ? -(ival) : (ival)); break;
case '+': ival++; break;
case '-': ival--; break;
case 'I': break;
case 'F': return (cvflonum((float)ival));
case 'R': ival = (long)osrand((int)ival); break;
default: badiop();
}
return (cvfixnum(ival));
}
else if (((arg) && (arg)->n_type == 9)) {
fval = ((arg)->n_info.n_xfloat.xf_float);
switch (fcn) {
case 'A': fval = ((fval) < 0.0 ? -(fval) : (fval)); break;
case '+': fval += 1.0; break;
case '-': fval -= 1.0; break;
case 'S': fval = sin(fval); break;
case 'C': fval = cos(fval); break;
case 'T': fval = tan(fval); break;
case 'E': fval = exp(fval); break;
case 'R': checkfneg(fval); fval = sqrt(fval); break;
case 'I': return (cvfixnum((long)fval));
case 'F': break;
default: badfop();
}
return (cvflonum(fval));
}
else
xlerror("bad argument type",arg);
}
LVAL xlc_snd_overwrite(void)
{
LVAL arg1 = xlgetarg();
long arg2 = getfixnum(xlgafixnum());
unsigned char * arg3 = getstring(xlgastring());
double arg4 = testarg2(xlgaanynum());
long arg5 = getfixnum(xlgafixnum());
long arg6 = getfixnum(xlgafixnum());
long arg7 = getfixnum(xlgafixnum());
long arg8 = getfixnum(xlgafixnum());
double arg9 = 0.0;
double result;
xllastarg();
result = sound_overwrite(arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, &arg9);
{ LVAL *next = &getvalue(RSLT_sym);
*next = cons(NIL, NIL);
car(*next) = cvflonum(arg9);
}
return cvflonum(result);
}
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 xsmean(V)
{
Number mean;
int count;
LVAL x;
x = xlgetarg();
xllastarg();
mean.real = 0.0; mean.imag = 0.0; mean.complex = FALSE;
count = 0;
base_mean(&count, &mean, x);
if (mean.complex) return(newdcomplex(mean.real,mean.imag));
else return(cvflonum((FLOTYPE) mean.real));
}
/* isnumber - check if this string is a number */
int isnumber(char *str, LVAL *pval)
{
int dl,dr;
char *p;
/* initialize */
p = str; dl = dr = 0;
/* check for a sign */
if (*p == '+' || *p == '-')
p++;
/* check for a string of digits */
while (isdigit(*p))
p++, dl++;
/* check for a decimal point */
if (*p == '.') {
p++;
while (isdigit(*p))
p++, dr++;
}
/* check for an exponent */
if ((dl || dr) && *p == 'E') {
p++;
/* check for a sign */
if (*p == '+' || *p == '-')
p++;
/* check for a string of digits */
while (isdigit(*p))
p++, dr++;
}
/* make sure there was at least one digit and this is the end */
if ((dl == 0 && dr == 0) || *p)
return (FALSE);
/* convert the string to an integer and return successfully */
if (pval) {
if (*str == '+') ++str;
if (str[strlen(str)-1] == '.') str[strlen(str)-1] = 0;
*pval = (dr ? cvflonum(atof(str)) : cvfixnum(ICNV(str)));
}
return (TRUE);
}
static LVAL make_transformation P2C(double **, a, int, vars)
{
LVAL result, data;
int i, j, k;
if (a == NULL) return(NIL);
xlsave1(result);
result = newmatrix(vars, vars);
data = getdarraydata(result);
for (i = 0, k = 0; i < vars; i++)
for (j = 0; j < vars; j++, k++)
settvecelement(data, k, cvflonum((FLOTYPE) a[i][j]));
xlpop();
return(result);
}
/* xrdfloat - read a float from a file */
LVAL xrdfloat(void)
{
LVAL fptr;
union {
char b[8];
float f;
double d;
} rslt;
int n = 4;
int i;
int index = 3; /* where to start in array */
int incr = -1; /* how to step through array */
/* get file pointer */
fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
/* get byte count */
if (moreargs()) {
LVAL count = typearg(fixp);
n = getfixnum(count);
if (n < 0) {
n = -n;
index = 0;
incr = 1;
}
if (n != 4 && n != 8) {
xlerror("must be 4 or 8 bytes", count);
}
}
xllastarg();
#ifdef XL_BIG_ENDIAN
/* flip the bytes */
index = n - 1 - index;
incr = -incr;
#endif
for (i = 0; i < n; i++) {
int ch = xlgetc(fptr);
if (ch == EOF) return NIL;
rslt.b[index] = ch;
index += incr;
}
/* return result */
return cvflonum(n == 4 ? rslt.f : rslt.d);
}
/******************************************************************************
* (FSCANF-FLONUM <stream> <scanf-format>)
* This routine calls fscanf(3s) on a <stream> that was previously openend
* via open or popen. It will not work on an USTREAM.
* <scanf-format> is a format string containing a single conversion
* directive that will result in an FLONUM valued conversion.
* %e %f or %g are valid conversion specifiers for this routine.
*
* WARNING: specifying a <scanf-format> that will result in the conversion
* of a result larger than sizeof(float) will result in corrupted memory and
* core dumps.
*
* This routine will return a FLONUM if fscanf() returns 1 (i.e. if
* the one expected conversion has succeeded. It will return NIL if the
* conversion wasn't successful, or if EOF was reached.
******************************************************************************/
LVAL Prim_FSCANF_FLONUM()
{
LVAL lval_stream;
char* fmt;
FILE * fp;
float result;
lval_stream = xlgastream();
if (getfile(lval_stream) == NULL)
xlerror("File not opened.", lval_stream);
fmt = (char *) getstring(xlgastring());
xllastarg();
/* if scanf returns result <1 then an error or eof occured. */
if (fscanf(getfile(lval_stream), fmt, &result) < 1)
return (NIL);
else
return (cvflonum((FLOTYPE) result));
}
LVAL xslpdgeco(V)
{
LVAL a, ipvt, z;
double *da, rcond, *dz;
int lda, offa, n, *dipvt;
a = xlgetarg();
offa = getfixnum(xlgafixnum());
lda = getfixnum(xlgafixnum());
n = getfixnum(xlgafixnum());
ipvt = xlgetarg();
z = xlgetarg();
xllastarg();
checkldim(lda, n);
da = getlinalgdvec(offa, lda * n, a);
dipvt = getlinalgivec(0, n, ipvt);
dz = getlinalgdvec(0, n, z);
linpack_dgeco(da, lda, n, dipvt, &rcond, dz);
return cvflonum((FLOTYPE) rcond);
}
// Copy a node (recursively if appropriate)
LOCAL LVAL nyx_dup_value(LVAL val)
{
LVAL nval = val;
// Protect old and new values
xlprot1(val);
xlprot1(nval);
// Copy the node
if (val != NIL) {
switch (ntype(val))
{
case FIXNUM:
nval = cvfixnum(getfixnum(val));
break;
case FLONUM:
nval = cvflonum(getflonum(val));
break;
case CHAR:
nval = cvchar(getchcode(val));
break;
case STRING:
nval = cvstring((char *) getstring(val));
break;
case VECTOR:
{
int len = getsize(val);
int i;
nval = newvector(len);
nval->n_type = ntype(val);
for (i = 0; i < len; i++) {
if (getelement(val, i) == val) {
setelement(nval, i, val);
}
else {
setelement(nval, i, nyx_dup_value(getelement(val, i)));
}
}
}
break;
case CONS:
nval = nyx_dup_value(cdr(val));
nval = cons(nyx_dup_value(car(val)), nval);
break;
case SUBR:
case FSUBR:
nval = cvsubr(getsubr(val), ntype(val), getoffset(val));
break;
// Symbols should never be copied since their addresses are cached
// all over the place.
case SYMBOL:
nval = val;
break;
// Streams are not copied (although USTREAM could be) and reference
// the original value.
case USTREAM:
case STREAM:
nval = val;
break;
// Externals aren't copied because I'm not entirely certain they can be.
case EXTERN:
nval = val;
break;
// For all other types, just allow them to reference the original
// value. Probably not the right thing to do, but easier.
case OBJECT:
case CLOSURE:
default:
nval = val;
break;
}
}
xlpop();
xlpop();
return nval;
}
}
}
/* multiseq_convert -- eval closure and convert to adds */
/**/
void multiseq_convert(multiseq_type ms)
{
LVAL result, new;
sound_type snd;
time_type now = ms->t0 + ms->horizon;
int i;
long size;
xlsave1(result);
result = xleval(cons(ms->closure, consa(cvflonum(now))));
if (exttypep(result, a_sound)) {
snd = sound_copy(getsound(result));
result = newvector(ms->nchans);
setelement(result, 0, cvsound(snd));
for (i = 1; i < ms->nchans; i++) {
setelement(result, i, cvsound(sound_zero(now, ms->sr)));
}
} else if (vectorp(result)) {
if (getsize(result) > ms->nchans) {
xlerror("too few channels", result);
} else if (getsize(result) < ms->nchans) {
new = newvector(ms->nchans);
for (i = 1; i < getsize(result); i++) {
setelement(new, i, getelement(result, i));
}
void nyx_set_input_audio(nyx_audio_callback callback,
void *userdata,
int num_channels,
long len, double rate)
{
sample_type scale_factor = 1.0;
time_type t0 = 0.0;
nyx_susp_type *susp;
sound_type *snd;
double stretch_len;
LVAL warp;
int ch;
susp = (nyx_susp_type *)malloc(num_channels * sizeof(nyx_susp_type));
snd = (sound_type *)malloc(num_channels * sizeof(sound_type));
for(ch=0; ch < num_channels; ch++) {
falloc_generic(susp[ch], nyx_susp_node, "nyx_set_input_audio");
susp[ch]->callback = callback;
susp[ch]->userdata = userdata;
susp[ch]->len = len;
susp[ch]->channel = ch;
susp[ch]->susp.sr = rate;
susp[ch]->susp.t0 = t0;
susp[ch]->susp.mark = NULL;
susp[ch]->susp.print_tree = nyx_susp_print_tree;
susp[ch]->susp.current = 0;
susp[ch]->susp.fetch = nyx_susp_fetch;
susp[ch]->susp.free = nyx_susp_free;
susp[ch]->susp.name = "nyx";
snd[ch] = sound_create((snd_susp_type)susp[ch], t0,
rate,
scale_factor);
}
/* Bind the sample rate to the "*sound-srate*" global */
setvalue(xlenter("*SOUND-SRATE*"), cvflonum(rate));
/* Bind selection len to "len" global */
setvalue(xlenter("LEN"), cvflonum(len));
if (len > 0)
stretch_len = len / rate;
else
stretch_len = 1.0;
/* Set the "*warp*" global based on the length of the audio */
xlprot1(warp);
warp = cons(cvflonum(0), /* time offset */
cons(cvflonum(stretch_len), /* time stretch */
cons(NULL, /* cont. time warp */
NULL)));
setvalue(xlenter("*WARP*"), warp);
xlpop();
if (num_channels > 1) {
LVAL array = newvector(num_channels);
for(ch=0; ch<num_channels; ch++)
setelement(array, ch, cvsound(snd[ch]));
setvalue(xlenter("S"), array);
}
else {
LVAL s = cvsound(snd[0]);
setvalue(xlenter("S"), s);
}
}
LVAL snd_fft(sound_type s, long len, long step, LVAL winval)
{
long i, maxlen, skip, fillptr;
float *samples;
float *temp_fft;
float *window;
LVAL result;
if (len < 1) xlfail("len < 1");
if (!s->extra) { /* this is the first call, so fix up s */
sound_type w = NULL;
if (winval) {
if (soundp(winval)) {
w = getsound(winval);
} else {
xlerror("expected a sound", winval);
}
}
/* note: any storage required by fft must be allocated here in a
* contiguous block of memory who's size is given by the first long
* in the block. Here, there are 4 more longs after the size, and
* then room for 4*len floats (assumes that floats and longs take
* equal space).
*
* The reason for 4*len floats is to provide space for:
* the samples to be transformed (len)
* the complex FFT result (2*len)
* the window coefficients (len)
*
* The reason for this storage restriction is that when a sound is
* freed, the block of memory pointed to by extra is also freed.
* There is no function call that might free a more complex
* structure (this could be added in sound.c, however, if it's
* really necessary).
*/
s->extra = (long *) malloc(sizeof(long) * (4 * len + OFFSET));
s->extra[0] = sizeof(long) * (4 * len + OFFSET);
s->CNT = s->INDEX = s->FILLCNT = 0;
s->TERMCNT = -1;
maxlen = len;
window = (float *) &(s->extra[OFFSET + 3 * len]);
/* fill the window from w */
if (!w) {
for (i = 0; i < len; i++) *window++ = 1.0F;
} else {
n_samples_from_sound(w, len, window);
}
} else {
maxlen = ((s->extra[0] / sizeof(long)) - OFFSET) / 4;
if (maxlen != len) xlfail("len changed from initial value");
}
samples = (float *) &(s->extra[OFFSET]);
temp_fft = samples + len;
window = temp_fft + 2 * len;
/* step 1: refill buffer with samples */
fillptr = s->FILLCNT;
while (fillptr < maxlen) {
if (s->INDEX == s->CNT) {
sound_get_next(s, &(s->CNT));
if (s->SAMPLES == zero_block->samples) {
if (s->TERMCNT < 0) s->TERMCNT = fillptr;
}
s->INDEX = 0;
}
samples[fillptr++] = s->SAMPLES[s->INDEX++] * s->scale;
}
s->FILLCNT = fillptr;
/* it is important to test here AFTER filling the buffer, because
* if fillptr WAS 0 when we hit the zero_block, then filling the
* buffer will set TERMCNT to 0.
*/
if (s->TERMCNT == 0) return NULL;
/* logical stop time is ignored by this code -- to fix this,
* you would need a way to return the logical stop time to
* the caller.
*/
/* step 2: construct an array and return it */
xlsave1(result);
result = newvector(len);
/* first len floats will be real part, second len floats imaginary
* copy buffer to temp_fft with windowing
*/
for (i = 0; i < len; i++) {
temp_fft[i] = samples[i] * *window++;
temp_fft[i + len] = 0.0F;
}
/* perform the fft: */
fftnf(1, (const int *) &len, temp_fft, temp_fft + len, 1, -1.0);
setelement(result, 0, cvflonum(temp_fft[0]));
for (i = 2; i < len; i += 2) {
setelement(result, i - 1, cvflonum(temp_fft[i / 2] * 2));
setelement(result, i, cvflonum(temp_fft[len + (i / 2)] * -2));
}
if (len % 2 == 0)
setelement(result, len - 1, cvflonum(temp_fft[len / 2]));
/* step 3: shift samples by step */
if (step < 0) xlfail("step < 0");
s->FILLCNT -= step;
if (s->FILLCNT < 0) s->FILLCNT = 0;
for (i = 0; i < s->FILLCNT; i++) {
samples[i] = samples[i + step];
}
if (s->TERMCNT >= 0) {
s->TERMCNT -= step;
if (s->TERMCNT < 0) s->TERMCNT = 0;
}
/* step 4: advance in sound to next sample we need
* (only does work if step > size of buffer)
*/
skip = step - maxlen;
while (skip > 0) {
long remaining = s->CNT - s->INDEX;
if (remaining >= skip) {
s->INDEX += skip;
skip = 0;
} else {
skip -= remaining;
sound_get_next(s, &(s->CNT));
s->INDEX = 0;
}
}
/* restore the stack */
xlpop();
return result;
} /* snd_fetch_array */
void nyx_set_audio_params( double rate )
{
/* Bind the sample rate to the "*sound-srate*" global */
setvalue(xlenter("*SOUND-SRATE*"), cvflonum(rate));
}
