/* xlrinit - initialize the reader */
void xlrinit(void)
{
LVAL rtable;
char *p;
int ch;
/* create the read table */
rtable = newvector(256);
setvalue(s_rtable,rtable);
/* initialize the readtable */
for (p = WSPACE; ch = *p++; )
setelement(rtable,ch,k_wspace);
for (p = CONST1; ch = *p++; )
setelement(rtable,ch,k_const);
for (p = CONST2; ch = *p++; )
setelement(rtable,ch,k_const);
/* setup the escape characters */
setelement(rtable,'\\',k_sescape);
setelement(rtable,'|', k_mescape);
/* install the read macros */
defmacro('#', k_nmacro,FT_RMHASH);
defmacro('\'',k_tmacro,FT_RMQUOTE);
defmacro('"', k_tmacro,FT_RMDQUOTE);
defmacro('`', k_tmacro,FT_RMBQUOTE);
defmacro(',', k_tmacro,FT_RMCOMMA);
defmacro('(', k_tmacro,FT_RMLPAR);
defmacro(')', k_tmacro,FT_RMRPAR);
defmacro(';', k_tmacro,FT_RMSEMI);
}
/* Internal version of Common Lisp MAP function */
LOCAL LVAL map P4C(LVAL, type, LVAL, fcn, LVAL, args, int, rlen)
{
LVAL nextr, result;
int nargs, i;
/* protect some pointers */
xlstkcheck(2);
xlsave(result);
xlprotect(fcn);
if (rlen < 0) rlen = findmaprlen(args);
if (type == a_vector)
result = newvector(rlen);
else
result = mklist(rlen, NIL);
nargs = llength(args);
for (i = 0, nextr = result; i < rlen; i++) {
pushnextargs(fcn, nargs, args, i);
setnextelement(&nextr, i, xlapply(nargs));
}
/* restore the stack frame */
xlpopn(2);
return(result);
}
int luaI_lock (Object *object)
{
Word i;
Word oldSize;
if (tag(object) == LUA_T_NIL)
return -1;
for (i=0; i<lockSize; i++)
if (tag(&lockArray[i]) == LUA_T_NIL)
{
lockArray[i] = *object;
return i;
}
/* no more empty spaces */
oldSize = lockSize;
if (lockArray == NULL)
{
lockSize = 10;
lockArray = newvector(lockSize, Object);
}
else
{
lockSize = 3*oldSize/2 + 5;
lockArray = growvector(lockArray, lockSize, Object);
}
for (i=oldSize; i<lockSize; i++)
tag(&lockArray[i]) = LUA_T_NIL;
lockArray[oldSize] = *object;
return oldSize;
}
void mqmscan(int Nind, int Nmark,int Npheno,int **Geno,int **Chromo, double **Dist, double **Pheno, int **Cofactors, int Backwards, int RMLorML,double Alfa,
int Emiter, double Windowsize,double Steps, double Stepmi,double Stepma,int NRUN,int out_Naug,int **INDlist, double **QTL, int re_estimate,
RqtlCrossType rqtlcrosstype,int domi,int verbose){
int cof_cnt=0;
MQMMarkerMatrix markers = newMQMMarkerMatrix(Nmark+1,Nind);
cvector cofactor = newcvector(Nmark);
vector mapdistance = newvector(Nmark);
MQMCrossType crosstype = determine_MQMCross(Nmark,Nind,(const int **)Geno,rqtlcrosstype);
change_coding(&Nmark, &Nind, Geno, markers, crosstype); // Change all the markers from R/qtl format to MQM internal
for (int i=0; i< Nmark; i++) {
mapdistance[i] = POSITIONUNKNOWN; // Mapdistances
mapdistance[i] = Dist[0][i];
cofactor[i] = MNOCOF; // Cofactors
if (Cofactors[0][i] == 1) {
cofactor[i] = MCOF; // Set cofactor
cof_cnt++;
}
if (Cofactors[0][i] == 2) {
cofactor[i] = MSEX;
cof_cnt++;
}
if (cof_cnt+10 > Nind){ fatal("Setting %d cofactors would leave less than 10 degrees of freedom.\n", cof_cnt); }
}
char reestimate = 'y';
if(re_estimate == 0) reestimate = 'n';
if (crosstype != CF2) { // Determine what kind of cross we have
if (verbose==1) Rprintf("INFO: Dominance setting ignored (setting dominance to 0)\n"); // Update dominance accordingly
domi = 0;
}
bool dominance=false;
if(domi != 0){ dominance=true; }
//WE HAVE EVERYTHING START WITH MAIN SCANNING FUNCTION
analyseF2(Nind, &Nmark, &cofactor, (MQMMarkerMatrix)markers, Pheno[(Npheno-1)], Backwards, QTL, &mapdistance, Chromo, NRUN, RMLorML, Windowsize,
Steps, Stepmi, Stepma, Alfa, Emiter, out_Naug, INDlist, reestimate, crosstype, dominance, verbose);
if (re_estimate) {
if (verbose==1) Rprintf("INFO: Sending back the re-estimated map used during the MQM analysis\n");
for (int i=0; i< Nmark; i++) {
Dist[0][i] = mapdistance[i];
}
}
if (Backwards) {
if (verbose==1) Rprintf("INFO: Sending back the model\n");
for (int i=0; i< Nmark; i++) { Cofactors[0][i] = cofactor[i]; }
}
if(verbose) Rprintf("INFO: All done in C returning to R\n");
#ifndef STANDALONE
R_CheckUserInterrupt(); /* check for ^C */
R_FlushConsole();
#endif
return;
} /* end of function mqmscan */
/* clisnew - initialize a new class */
LVAL clisnew(void)
{
LVAL self,ivars,cvars,super;
int n;
/* get self, the ivars, cvars and superclass */
self = xlgaobject();
ivars = xlgalist();
cvars = (moreargs() ? xlgalist() : NIL);
super = (moreargs() ? xlgaobject() : object);
xllastarg();
/* store the instance and class variable lists and the superclass */
setivar(self,IVARS,ivars);
setivar(self,CVARS,cvars);
setivar(self,CVALS,(cvars ? newvector(listlength(cvars)) : NIL));
setivar(self,SUPERCLASS,super);
/* compute the instance variable count */
n = listlength(ivars);
setivar(self,IVARCNT,cvfixnum((FIXTYPE)n));
n += getivcnt(super,IVARTOTAL);
setivar(self,IVARTOTAL,cvfixnum((FIXTYPE)n));
/* return the new class object */
return (self);
}
float Line::distPointToLine(Point q){
float _x = p.coord.x - q.coord.x;
float _y = p.coord.y - q.coord.y;
float _z = p.coord.z - q.coord.z;
vec3 newvector(_x,_y,_z);
return length(cross(direction,newvector))/length(direction);
}
/* newobject - allocate and initialize a new object */
NODE *newobject(NODE *cls, int size)
{
NODE *val;
val = newvector(size+1);
setelement(val,0,cls);
val->n_type = OBJ;
return (val);
}
matrix newmatrix(int rows, int cols) {
matrix m = (double **)calloc_init(rows, sizeof(double*));
if(!m){ warning("Not enough memory for new double matrix"); }
for (int i=0; i<rows; i++) {
m[i]= newvector(cols);
}
return m;
}
/*
** Init stack
*/
static void lua_initstack (void)
{
Long maxstack = STACK_SIZE;
stack = newvector(maxstack, Object);
stackLimit = stack+maxstack;
top = stack;
*(top++) = initial_stack;
}
/*
** Alloc a vector node
*/
static Node *hashnodecreate (int nhash)
{
int i;
Node *v = newvector (nhash, Node);
for (i=0; i<nhash; i++)
tag(ref(&v[i])) = LUA_T_NIL;
return v;
}
/* newobject - allocate and initialize a new object */
LVAL newobject(LVAL cls, int size)
{
LVAL val;
val = newvector(size+1);
val->n_type = OBJECT;
setelement(val,0,cls);
return (val);
}
/* newclosure - allocate and initialize a new closure */
LVAL newclosure(LVAL name, LVAL type, LVAL env, LVAL fenv)
{
LVAL val;
val = newvector(CLOSIZE);
val->n_type = CLOSURE;
setname(val,name);
settype(val,type);
setenv(val,env);
setfenv(val,fenv);
return (val);
}
void luaI_initsymbol (void)
{
int i;
lua_maxsymbol = BUFFER_BLOCK;
lua_table = newvector(lua_maxsymbol, Symbol);
for (i=0; i<INTFUNCSIZE; i++)
{
Word n = luaI_findsymbolbyname(int_funcs[i].name);
s_tag(n) = LUA_T_CFUNCTION; s_fvalue(n) = int_funcs[i].func;
}
}
xlsinit(void)
{
NODE *array,*p;
obarray = xlmakesym("*OBARRAY*",1);
array = newvector(199);
((obarray)->n_info.n_xsym.xsy_value = (array));
p = consa(obarray);
((array)->n_info.n_xvect.xv_data[hash("*OBARRAY*",199)] = (p));
s_unbound = xlsenter("*UNBOUND*");
((s_unbound)->n_info.n_xsym.xsy_value = (s_unbound));
}
/* xmkarray - make a new array */
LVAL xmkarray(void)
{
LVAL size;
int n;
/* get the size of the array */
size = xlgafixnum() ; n = (int)getfixnum(size);
xllastarg();
/* create the array */
return (newvector(n));
}
/* cvsymbol - convert a string to a symbol */
LVAL cvsymbol(char *pname)
{
LVAL val;
xlsave1(val);
val = newvector(SYMSIZE);
val->n_type = SYMBOL;
setvalue(val,s_unbound);
setfunction(val,s_unbound);
setpname(val,cvstring(pname));
xlpop();
return (val);
}
LVAL snd_make_yin(sound_type s, double low_step, double high_step, long stepsize)
{
LVAL result;
int j;
register yin_susp_type susp;
rate_type sr = s->sr;
time_type t0 = s->t0;
falloc_generic(susp, yin_susp_node, "snd_make_yin");
susp->susp.fetch = yin_fetch;
susp->terminate_cnt = UNKNOWN;
/* initialize susp state */
susp->susp.free = yin_free;
susp->susp.sr = sr / stepsize;
susp->susp.t0 = t0;
susp->susp.mark = yin_mark;
susp->susp.print_tree = yin_print_tree;
susp->susp.name = "yin";
susp->logically_stopped = false;
susp->susp.log_stop_cnt = logical_stop_cnt_cvt(s);
susp->susp.current = 0;
susp->s = s;
susp->s_cnt = 0;
susp->m = (long) (sr / step_to_hz(high_step));
if (susp->m < 2) susp->m = 2;
/* add 1 to make sure we round up */
susp->middle = (long) (sr / step_to_hz(low_step)) + 1;
susp->blocksize = susp->middle * 2;
susp->stepsize = stepsize;
/* blocksize must be at least step size to implement stepping */
if (susp->stepsize > susp->blocksize) susp->blocksize = susp->stepsize;
susp->block = (sample_type *) malloc(susp->blocksize * sizeof(sample_type));
susp->temp = (float *) malloc((susp->middle - susp->m + 1) * sizeof(float));
susp->fillptr = susp->block;
susp->endptr = susp->block + susp->blocksize;
xlsave1(result);
result = newvector(2); /* create array for F0 and harmonicity */
/* create sounds to return */
for (j = 0; j < 2; j++) {
sound_type snd = sound_create((snd_susp_type)susp,
susp->susp.t0, susp->susp.sr, 1.0);
LVAL snd_lval = cvsound(snd);
/* nyquist_printf("yin_create: sound %d is %x, LVAL %x\n", j, snd, snd_lval); */
setelement(result, j, snd_lval);
susp->chan[j] = snd->list;
/* DEBUG: ysnd[j] = snd; */
}
xlpop();
return result;
}
void nyx_set_input_audio(nyx_audio_callback callback,
void *userdata,
int num_channels,
long len, double rate)
{
LVAL val;
int ch;
nyx_set_audio_params(rate, len);
if (num_channels > 1) {
val = newvector(num_channels);
}
xlprot1(val);
for (ch = 0; ch < num_channels; ch++) {
nyx_susp_type susp;
sound_type snd;
falloc_generic(susp, nyx_susp_node, "nyx_set_input_audio");
susp->callback = callback;
susp->userdata = userdata;
susp->len = len;
susp->channel = ch;
susp->susp.fetch = nyx_susp_fetch;
susp->susp.keep_fetch = NULL;
susp->susp.free = nyx_susp_free;
susp->susp.mark = NULL;
susp->susp.print_tree = nyx_susp_print_tree;
susp->susp.name = "nyx";
susp->susp.toss_cnt = 0;
susp->susp.current = 0;
susp->susp.sr = rate;
susp->susp.t0 = 0.0;
susp->susp.log_stop_cnt = 0;
snd = sound_create((snd_susp_type) susp, 0.0, rate, 1.0);
if (num_channels > 1) {
setelement(val, ch, cvsound(snd));
}
else {
val = cvsound(snd);
}
}
setvalue(xlenter("S"), val);
xlpop();
}
/* xlsinit - symbol initialization routine */
void xlsinit(void)
{
LVAL array,p;
/* initialize the obarray */
obarray = xlmakesym("*OBARRAY*");
array = newvector(HSIZE);
setvalue(obarray,array);
/* add the symbol *OBARRAY* to the obarray */
p = consa(obarray);
setelement(array,hash("*OBARRAY*",HSIZE),p);
}
/*
** Parse LUA code.
*/
void lua_parse (Byte **code)
{
initcode = code;
*initcode = newvector(CODE_BLOCK, Byte);
maincode = 0;
maxmain = CODE_BLOCK;
if (yyparse ()) lua_error("parse error");
(*initcode)[maincode++] = RETCODE0;
#if LISTING
{ static void PrintCode (Byte *c, Byte *end);
PrintCode(*initcode,*initcode+maincode); }
#endif
}
LOCAL LVAL linalg2genvec P2C(LVAL, x, int, n)
{
LVAL y;
if (! tvecp(x)) xlbadtype(x);
if (n <= 0 || gettvecsize(x) < n) xlfail("bad dimensions");
xlsave1(y);
y = newvector(n);
xlreplace(y, x, 0, n, 0, n);
xlpop();
return y;
}
PUBLIC VECTOR vector_concat(VECTOR a, VECTOR b) {
int alen = a->_.length;
int blen = b->_.length;
VECTOR n = newvector(alen + blen);
int i, j;
for (i = 0; i < alen; i++)
ATPUT(n, i, AT(a, i));
for (i = alen, j = 0; j < blen; i++, j++)
ATPUT(n, i, AT(b, j));
return n;
}
/* pvector - parse a vector */
LOCAL LVAL pvector(LVAL fptr)
{
LVAL list,expr,val,lastnptr,nptr;
int len,ch,i;
/* protect some pointers */
xlstkcheck(2);
xlsave(list);
xlsave(expr);
/* keep appending nodes until a closing paren is found */
for (lastnptr = NIL, len = 0; (ch = nextch(fptr)) != ')'; ) {
/* check for end of file */
if (ch == EOF)
badeof(fptr);
/* get the next expression */
switch (readone(fptr,&expr)) {
case EOF:
badeof(fptr);
case TRUE:
nptr = consa(expr);
if (lastnptr == NIL)
list = nptr;
else
rplacd(lastnptr,nptr);
lastnptr = nptr;
len++;
break;
}
}
/* skip the closing paren */
xlgetc(fptr);
/* make a vector of the appropriate length */
val = newvector(len);
/* copy the list into the vector */
for (i = 0; i < len; ++i, list = cdr(list))
setelement(val,i,car(list));
/* restore the stack */
xlpopn(2);
/* return successfully */
return (val);
}
/* Make a copy of the obarray so that we can erase any
changes the user makes to global variables */
LOCAL void nyx_copy_obarray()
{
LVAL newarray;
int i;
// Create and set the new vector.
newarray = newvector(HSIZE);
setvalue(obarray, newarray);
for (i = 0; i < HSIZE; i++) {
LVAL from = getelement(nyx_obarray, i);
if (from) {
setelement(newarray, i, copylist(from));
}
}
}
static void init_function (TreeNode *func)
{
if (funcCode == NULL) /* first function */
{
funcCode = newvector(CODE_BLOCK, Byte);
maxcode = CODE_BLOCK;
}
pc=0; basepc=funcCode; maxcurr=maxcode;
nlocalvar=0;
if (lua_debug)
{
code_byte(SETFUNCTION);
code_code((Byte *)luaI_strdup(lua_file[lua_nfile-1]));
code_word(luaI_findconstant(func));
}
}
/* xvector - make a vector */
LVAL xvector(void)
{
LVAL val;
int i;
/* make the vector */
val = newvector(xlargc);
/* store each argument */
for (i = 0; moreargs(); ++i)
setelement(val,i,nextarg());
xllastarg();
/* return the vector */
return (val);
}
// Make a copy of the original obarray, leaving the original in place
LOCAL void nyx_save_obarray()
{
LVAL newarray;
int i;
// This provide permanent protection for nyx_obarray as we do not want it
// to be garbage-collected.
xlprot1(nyx_obarray);
nyx_obarray = getvalue(obarray);
// Create and set the new vector. This allows us to use xlenter() to
// properly add the new symbol. Probably slower than adding directly,
// but guarantees proper hashing.
newarray = newvector(HSIZE);
setvalue(obarray, newarray);
// Scan all obarray vectors
for (i = 0; i < HSIZE; i++) {
LVAL sym;
// Scan all elements
for (sym = getelement(nyx_obarray, i); sym; sym = cdr(sym)) {
LVAL syma = car(sym);
char *name = (char *) getstring(getpname(syma));
LVAL nsym = xlenter(name);
// Ignore *OBARRAY* since there's no need to copy it
if (strcmp(name, "*OBARRAY*") == 0) {
continue;
}
// Ignore *SCRATCH* since it's allowed to be updated
if (strcmp(name, "*SCRATCH*") == 0) {
continue;
}
// Duplicate the symbol's values
setvalue(nsym, nyx_dup_value(getvalue(syma)));
setplist(nsym, nyx_dup_value(getplist(syma)));
setfunction(nsym, nyx_dup_value(getfunction(syma)));
}
}
// Swap the obarrays, so that the original is put back into service
setvalue(obarray, nyx_obarray);
nyx_obarray = newarray;
}
/* xlsinit - symbol initialization routine */
void xlsinit(void)
{
NODE *array,*p;
/* initialize the obarray */
obarray = xlmakesym("*OBARRAY*",STATIC);
array = newvector(HSIZE);
setvalue(obarray,array);
/* add the symbol *OBARRAY* to the obarray */
p = consa(obarray);
setelement(array,hash("*OBARRAY*",HSIZE),p);
/* enter the unbound symbol indicator */
s_unbound = xlsenter("*UNBOUND*");
setvalue(s_unbound,s_unbound);
}
PUBLIC void init_vm(VMSTATE vms) {
vms->r->vm_acc = NULL;
vms->r->vm_code = NULL;
vms->r->vm_env = NULL;
vms->r->vm_lits = NULL;
vms->r->vm_self = NULL;
vms->r->vm_stack = newvector(VMSTACKLENGTH);
vms->r->vm_frame = NULL;
vms->r->vm_method = NULL;
vms->c.vm_ip = vms->c.vm_top = 0;
vms->r->vm_trap_closure = NULL;
vms->r->vm_uid = NULL;
vms->r->vm_effuid = NULL;
vms->r->vm_locked = NULL;
vms->c.vm_state = VM_DEFAULT_CPU_QUOTA;
vms->c.vm_locked_count = 0;
}
//NOTE checking for r[j] <0 (marker ordering) can ahppen at contract
vector recombination_frequencies(const unsigned int nmark, const cvector position, const vector mapdistance)
{
// contract: if DEBUG is_valid(positionarray)
// info("Estimating recombinant frequencies");
vector r = newvector(nmark);
for (unsigned int j=0; j<nmark; j++) {
r[j]= RFUNKNOWN;
if ((position[j]==MLEFT)||(position[j]==MMIDDLE)) {
r[j]= recombination_frequentie((mapdistance[j+1]-mapdistance[j]));
if (r[j]<0) {
Rprintf("ERROR: Position=%d r[j]=%f\n", position[j], r[j]);
fatal("Recombination frequency is negative, (Marker ordering problem ?)");
return NULL;
}
}
}
return r;
}
