Пример #1
0
static void GetTNworker(int nArgs, int cycs)
{
  IOStream *file;
  long i, n= 0;
  long *ncycs= 0;
  double *times= 0;
  Array *array;
  HistoryInfo *history;
  Dimension *dims;
  if (nArgs!=1) YError("get_times/get_ncycs takes exactly one argument");

  file= yarg_file(0);
  history= file->history;

  if (history) {
    n= history->nRecords;
    if (cycs) ncycs= history->ncyc;
    else times= history->time;
  }
  if (n<=0 || (cycs? (!ncycs) : (!times))) {
    PushDataBlock(RefNC(&nilDB));
    return;
  }

  dims= tmpDims;
  tmpDims= 0;
  FreeDimension(dims);
  tmpDims= NewDimension(n, 1L, (Dimension *)0);
  array= PushDataBlock(NewArray(cycs? &longStruct : &doubleStruct, tmpDims));

  if (cycs)
    for (i=0 ; i<n ; i++) array->value.l[i]= ncycs[i];
  else
    for (i=0 ; i<n ; i++) array->value.d[i]= times[i];
}
Пример #2
0
void
Y_set_vars(int nArgs)
{
  Symbol *stack = sp - nArgs + 1;
  IOStream *file, *child;
  char **vars, **rvars;
  long i, nvars, nrvars;
  Dimension *dims;
  if (nArgs<2 || nArgs>3 || !stack[0].ops || !stack[1].ops)
    YError("set_vars takes exactly two or three arguments");

  file = YGetFile(stack++);
  child = file->history? file->history->child : 0;
  vars = YGet_Q(stack++, 1, &dims);
  nvars = (vars&&dims)? (dims->next? -1 : dims->number) : 0;
  if (nArgs==3) {
    rvars = YGet_Q(stack++, 1, &dims);
    nrvars = (vars&&dims)? (dims->next? -1 : dims->number) : 0;
  } else {
    rvars = 0;
    nrvars = 0;
  }
  if (nvars<0 || nrvars<0) YError("set_vars var lists must be 1D");
  if ((nvars && nvars!=file->dataTable.nItems) ||
      (nrvars && nrvars!=(child? child->dataTable.nItems : 0)))
    YError("set_vars var lists must match number of vars in file");

  if (nvars) {
    HashTable tmp;
    y_hashtmp *h = y_new_tmpobj(sizeof(y_hashtmp), y_zap_hashtmp);
    HashInit(&h->table, nvars);
    PushDataBlock(h);
    for (i=0 ; i<nvars ; i++)
      if (HashAdd(&h->table, vars[i], 0)) break;
    if (i<nvars) YError("duplicate names in set_vars static var list");
    if (p_signalling) p_abort();
    tmp = h->table;
    h->table = file->dataTable;
    file->dataTable = tmp;
    Drop(1);
  }

  if (nrvars) {
    HashTable tmp;
    y_hashtmp *h = y_new_tmpobj(sizeof(y_hashtmp), y_zap_hashtmp);
    HashInit(&h->table, nvars);
    PushDataBlock(h);
    for (i=0 ; i<nrvars ; i++)
      if (HashAdd(&h->table, rvars[i], 0)) break;
    if (i<nrvars) YError("duplicate names in set_vars record var list");
    if (p_signalling) p_abort();
    tmp = h->table;
    h->table = child->dataTable;
    child->dataTable = tmp;
    Drop(1);
  }
}
Пример #3
0
void Y_get_primitives(int nArgs)
{
  IOStream *file;
  Dimension *dims;
  Array *array;
  long *p;
  FPLayout *fpl;
  int i, j;
  if (nArgs!=1) YError("get_primitives requires exactly one argument");

  file = yarg_file(0);
  dims = tmpDims;
  tmpDims = 0;
  FreeDimension(dims);
  tmpDims = NewDimension(32L, 1L, (Dimension *)0);
  array = PushDataBlock(NewArray(&longStruct, tmpDims));
  p = array->value.l;

  for (i=j=0 ; i<6 ; i++) {
    p[j++] = file->structList[i]->size;
    p[j++] = file->structList[i]->alignment;
    p[j++] = file->structList[i]->order;
  }
  p[1] = file->structAlign;
  for (i=4 ; i<6 ; i++) {
    fpl = file->structList[i]->fpLayout;
    p[j++] = fpl->sgnAddr;
    p[j++] = fpl->expAddr;
    p[j++] = fpl->expSize;
    p[j++] = fpl->manAddr;
    p[j++] = fpl->manSize;
    p[j++] = fpl->manNorm;
    p[j++] = fpl->expBias;
  }
}
Пример #4
0
void Y_digitize(int nArgs)
{
  long number, origin, nbins, i, ip;
  double *x, *bins;
  Dimension *dimsx, *dimsb;
  long *ibin;
  if (nArgs!=2) YError("digitize takes exactly two arguments");

  bins= YGet_D(sp, 0, &dimsb);
  x= YGet_D(sp-1, 0, &dimsx);

  if (!dimsb || dimsb->number<2 || dimsb->next)
    YError("2nd argument to digitize must be 1D with >=2 elements");
  nbins= dimsb->number;
  origin= dimsb->origin;
  number= TotalNumber(dimsx);

  if (dimsx) {
    Array *array= PushDataBlock(NewArray(&longStruct, dimsx));
    ibin= array->value.l;
  } else {
    PushLongValue(0L);
    ibin= &sp->value.l;
  }
  ip= 0;
  for (i=0 ; i<number ; i++)
    ibin[i]= ip= origin+hunt(bins, nbins, x[i], ip);
}
void MultiversoSkipGramMixture::TrainNeuralNetwork()
{
    std::queue<DataBlock*>datablock_queue;
    int data_block_count = 0;

    multiverso::Multiverso::BeginTrain();

    for (int curr_epoch = 0; curr_epoch < m_option->epoch; ++curr_epoch)
    {
        m_reader->Open(m_option->train_file);
        while (1)
        {
            ++data_block_count;
            DataBlock *data_block = new (std::nothrow)DataBlock();
            assert(data_block != nullptr);
            clock_t start = clock();
            LoadData(data_block, m_reader, m_option->data_block_size);
            if (data_block->Size() <= 0)
            {
                delete data_block;
                break;
            }
            multiverso::Log::Info("Rank%d Load%d^thDataBlockTime:%lfs\n", m_process_id, data_block_count,
                                  (clock() - start) / (double)CLOCKS_PER_SEC);
            multiverso::Multiverso::BeginClock();
            PushDataBlock(datablock_queue, data_block);
            multiverso::Multiverso::EndClock();
        }

        m_reader->Close();

        multiverso::Multiverso::BeginClock();

        DataBlock *output_data_block = new DataBlock(); //Add a special data_block for dumping model files
        output_data_block->AddTable(kInputEmbeddingTableId);
        output_data_block->AddTable(kEmbeddingOutputTableId);
        output_data_block->AddTable(kWordSensePriorTableId);
        output_data_block->SetEpochId(curr_epoch);

        ++data_block_count;
        multiverso::Multiverso::PushDataBlock(output_data_block);
        multiverso::Multiverso::EndClock();
    }

    multiverso::Log::Info("Rank %d pushed %d blocks\n", multiverso::Multiverso::ProcessRank(), data_block_count);

    multiverso::Multiverso::EndTrain();

    //After EndTrain, all the datablock are done,
    //we remove all the datablocks
    RemoveDoneDataBlock(datablock_queue);
}
Пример #6
0
void
Y_mpeg_create(int nArgs)
{
  char *filename = (nArgs>=1 && nArgs<=2)? YGetString(sp-nArgs+1) : 0;
  long bad_params[4] = { -1, -1, -1, -1 };
  long *params = 0;
  if (nArgs == 2) {
    Dimension *dims = 0;
    params = YGet_L(sp-nArgs+2, 1, &dims);
    if (!dims || dims->next || dims->number!=4) params = bad_params;
  }
  PushDataBlock(ympg_create(filename, params));
}
Пример #7
0
void Y__write(int nArgs)
{
    Symbol *keySymbols[1];
    Symbol *stack= YGetKeywords(sp-nArgs+1, nArgs, wrtKeys, keySymbols);
    IOStream *file= 0;
    long address= 0;
    int got_address= 0;
    Symbol *object= 0;
    Operand op;
    StructDef *base;
    char *type;

    while (stack<=sp) {
        if (!stack->ops) {
            stack+= 2;
            continue;
        }
        if (!file) {
            file= YGetFile(stack);
            if (file->history) file= file->history->child;
        } else if (!got_address) {
            got_address= 1;
            address= YGetInteger(stack);
        } else if (!object) {
            object= stack;
        } else {
            object= 0;
        }
        stack++;
    }
    if (!object) YError("_write takes exactly three arguments");

    sp->ops->FormOperand(object, &op);
    if (!op.ops->isArray)
        YError("third argument to _write must be array or scalar data");
    if (YNotNil(keySymbols[0])) type= YGetString(keySymbols[0]);
    else type= StructName(op.type.base);
    if (!HashFind(&file->structTable, type, 0L))
        YError("data type of third argument to _write undefined for this file");
    base= file->structList[hashIndex];

    if (op.type.base==&charStruct) {
        /* special case type char, to have a way to do literal writes */
        YcWrite(file, op.value, address, op.type.number);

    } else {
        YWrite(op.value, address, base, op.type.number, (Strider *)0);
    }

    PushDataBlock(RefNC(&nilDB));
}
Пример #8
0
/* similar to BuildResultU in ops0.c */
static void *build_result(Operand *op, StructDef *base)
{
  if (! op->references && op->type.base == base) {
    /* similar to PushCopy in ydata.c */
    Symbol *stack = sp + 1;
    Symbol *s = op->owner;
    int isDB = (s->ops == &dataBlockSym);
    stack->ops = s->ops;
    if (isDB) stack->value.db = Ref(s->value.db);
    else stack->value = s->value;
    sp = stack; /* sp updated AFTER new stack element intact */
    return (isDB ? op->value : &sp->value);
  } else {
    return (void *)(((Array *)(PushDataBlock(NewArray(base, op->type.dims))))->value.c);
  }
}
Пример #9
0
void Y_set_tolerances(int nArgs)
{
  double *tols, t1, t2, t3;
  Dimension *dims;
  Array *array;

  if (nArgs!=1) YError("set_tolerances takes exactly one argument");

  tols= YGet_D(sp, 1, &dims);
  if (tols && (!dims || dims->number!=3 || dims->next))
    YError("argument to set_tolerances must be nil or array(double,3)");

  /* get current tolerances */
  if (polishRoot) {
    t1= polishTol1;
    t2= polishTol2;
  } else {
    t1= t2= -1.0;
  }
  t3= findRayTol;

  if (tols) {
    /* set tolerances to new values */
    if (tols[0]>=0.0) {
      if (tols[0]>0.0) polishTol1= tols[0];
      else polishTol1= 1.0e-3;   /* default value as set in track.c */
      if (tols[1]>0.0) polishTol2= tols[1];
      else polishTol2= 1.0e-6;   /* default value as set in track.c */
      polishRoot= 1;
    } else {
      polishRoot= 0;
    }
    if (tols[2]>0.0) findRayTol= tols[2];
    else findRayTol= 0.0;   /* default value as set in track.c */
  }

  dims= tmpDims;
  tmpDims= 0;
  FreeDimension(dims);
  tmpDims= NewDimension(3L, 1L, (Dimension *)0);
  array= (Array *)PushDataBlock(NewArray(&doubleStruct, tmpDims));
  tols= array->value.d;
  tols[0]= t1;
  tols[1]= t2;
  tols[2]= t3;
}
Пример #10
0
void Y_indgen(int nArgs)
{
  long number, origin, stride, i;
  Array *array;
  Dimension *tmp;
  Operand op;
  if (nArgs != 1) YError("indgen takes exactly one argument");

  sp->ops->FormOperand(sp, &op);
  if (op.ops==&rangeOps) {
    Range *range= op.value;
    if (range->rf || range->nilFlags)
      YError("range function and/or nil range component in indgen");
    origin= range->min;
    stride= range->inc;
    if (stride>0) number= (range->max-origin)/stride;
    else number= (origin-range->max)/(-stride);
    number++;  /* number of footprints, not number of strides */
  } else if (op.ops->promoteID<=T_LONG && !op.type.dims) {
    op.ops->ToLong(&op);
    number= *(long *)op.value;
    origin= 1L;
    stride= 1;
  } else {
    YError("indgen argument must be range or scalar integer");
    return;
  }

  if (number>0) {
    tmp= tmpDims;
    tmpDims= 0;
    FreeDimension(tmp);
    tmpDims= NewDimension(number, 1L, (Dimension *)0);
    array= PushDataBlock(NewArray(&longStruct, tmpDims));

    for (i=0 ; i<number ; i++) {
      array->value.l[i]= origin;
      origin+= stride;
    }

  } else {
    /* indgen(0) returns default origin */
    PushLongValue(1L);
  }
}
Пример #11
0
void Y__jc(int nArgs)
{
  IOStream *file;
  HistoryInfo *history;
  int noRecord;
  if (nArgs!=2) YError("jc takes exactly two arguments");

  file= yarg_file(1);
  history= file->history;
  if (!history)
    YError("binary file passed to jc has no history records");

  noRecord= JumpToCycle(history, YGetInteger(sp));

  if (!CalledAsSubroutine()) {
    if (noRecord) PushDataBlock(RefNC(&nilDB));
    else PushLongValue(history->ncyc[history->recNumber]);
  }
}
Пример #12
0
void Y_random(int nArgs)
{
  Symbol *stack= sp-nArgs+1;
  double *random;
  long n;
  if (nArgs==1 && !YNotNil(stack)) {
    /* return scalar result */
    PushDoubleValue(0.0);
    random= &sp->value.d;
    n= 1;
  } else {
    /* return array result */
    Array *array;
    BuildDimList(stack, nArgs);
    array= PushDataBlock(NewArray(&doubleStruct, tmpDims));
    random= array->value.d;
    n= array->type.number;
  }
  NextRandom(random, n);
}
Пример #13
0
void Y_get_vars(int nArgs)
{
  IOStream *file, *child;
  Array *array;
  char **pNames= 0, **cNames= 0;
  long i, nParent, nChild;
  Dimension *dims;
  if (nArgs!=1) YError("get_vars takes exactly one argument");

  file= yarg_file(0);

  child= file->history? file->history->child : 0;

  /* create result array */
  dims= tmpDims;
  tmpDims= 0;
  FreeDimension(dims);
  tmpDims= NewDimension(2L, 1L, (Dimension *)0);
  array= PushDataBlock(NewArray(&pointerStruct, tmpDims));
  nParent= file->dataTable.nItems;
  nChild= child? child->dataTable.nItems : 0;
  if (nParent) {
    dims= tmpDims;
    tmpDims= 0;
    FreeDimension(dims);
    tmpDims= NewDimension(nParent, 1L, (Dimension *)0);
    array->value.p[0]= pNames= NewArray(&stringStruct, tmpDims)->value.q;
  }
  if (nChild) {
    dims= tmpDims;
    tmpDims= 0;
    FreeDimension(dims);
    tmpDims= NewDimension(nChild, 1L, (Dimension *)0);
    array->value.p[1]= cNames= NewArray(&stringStruct, tmpDims)->value.q;
  }

  /* and fill it */
  for (i=0 ; i<nParent ; i++) pNames[i]= p_strcpy(file->dataTable.names[i]);
  for (i=0 ; i<nChild ; i++) cNames[i]= p_strcpy(child->dataTable.names[i]);
}
Пример #14
0
 void Multiverso::BeginClock()
 {
     static DataBlockBase begin_clock(DataBlockType::BeginClock);
     PushDataBlock(&begin_clock);
 }
Пример #15
0
 void Multiverso::EndClock()
 {
     static DataBlockBase end_clock(DataBlockType::EndClock);
     PushDataBlock(&end_clock);
 }
Пример #16
0
void Y_ml4read(int nArgs)

{
  char *filename="";
  char *varname="";
  int leave_open = 0;
  
  if (nArgs==2) {
    filename=YGetString(sp-nArgs+1);
    varname=YGetString(sp-nArgs+2);
    leave_open = 0;
  } else if (nArgs==3) {
    filename=YGetString(sp-nArgs+1);
    varname=YGetString(sp-nArgs+2);
    leave_open=YGetInteger(sp-nArgs+3);
  }

  unsigned long bytes_read;
  int type,namelen;
  unsigned long nElements,nBytesToRead;
  int mrows,mcols,imagf;
  FILE *fs;
  int fileptr;
  int endian = 'L';
  int size=0,i;

  fs = openmat(filename);
  if (fs == NULL) YError(p_strncat("Can't open file ",filename,0));

  if (!matfind(fs,varname,50000)) YError(p_strncat("No Such variable ",varname,0));

  fileptr = ftell(fs);
  if (DEBUG) printf("@ position %d\n",fileptr);
  
  bytes_read = fread(&type,sizeof(int),1,fs);
  if (bytes_read==0) {
    matclose(filename);
    YError("Premature end of file");; // end of file
  }
  fread(&mrows,sizeof(int),1,fs);
  fread(&mcols,sizeof(int),1,fs);
  fread(&imagf,sizeof(int),1,fs);
    
  fread(&namelen,sizeof(int),1,fs);

  if (namelen & 0xffff0000) {
    if (DEBUG) printf("Big endian file\n");
    endian = 'B';
    SWAP_INT(type);
    SWAP_INT(mrows);
    SWAP_INT(mcols);
    SWAP_INT(imagf);
    SWAP_INT(namelen);
  }
  type = type%1000;

  if (DEBUG) printf("rows,cols,namelen= %d %d %d\n",mrows,mcols,namelen);

  if (namelen>255) {
    fseek(fs,fileptr,SEEK_SET);  // leave file ptr at begginning of this variable
    matclose(filename);
    YError("Variable name too long!");
  }

  fread(tempvarname,(unsigned int)namelen,1,fs);
  //  if ((*varname!='*') && strcmp(varname,tempvarname)) {  // error if not same varname
  if (!matchvarname(tempvarname,varname)) {  // error if not same varname
    fseek(fs,fileptr,SEEK_SET);  // leave file ptr at begginning of this variable
    matclose(filename);
    YError(p_strncat("Can't find variable",varname,0));
  }

  nElements = (unsigned)mrows*(unsigned)mcols;
  
  Dimension *tmp=tmpDims;
  tmpDims=0;
  FreeDimension(tmp);
  if (mrows<=1) {
    tmpDims= NewDimension(mcols, 1L, (Dimension *)0);
  } else if (mcols<=1) {
    tmpDims= NewDimension(mrows, 1L, (Dimension *)0);
  } else {
    tmpDims= NewDimension(mrows, 1L, (Dimension *)0);
    tmpDims= NewDimension(mcols, 1L, tmpDims);
  }
  
  if (type==0) {
    // 8-byte doubles
    size = 8;
    Array *a= PushDataBlock(NewArray(&doubleStruct, tmpDims));
    double *data = a->value.d;
    bytes_read = fread((void *)data,size,nElements,fs);
    if (endian=='B') { for (i=0;i<nElements;i++) SWAP_DOUBLE(data[i]); }

  } else if (type==10) {
    // 4-byte reals
    size = 4;
    Array *a= PushDataBlock(NewArray(&floatStruct, tmpDims));
    float *data = a->value.f;
    bytes_read = fread((void *)data,size,nElements,fs);
    if (endian=='B') { for (i=0;i<nElements;i++) SWAP_FLOAT(data[i]); }

  } else if ((type==120) || (type==20)) {
    // 4-byte int
    size = 4;
    Array *a= PushDataBlock(NewArray(&intStruct, tmpDims));
    int *data = a->value.l;
    bytes_read = fread((void *)data,size,nElements,fs);
    if (endian=='B') { for (i=0;i<nElements;i++) SWAP_INT(data[i]); }

  } else if (type==30) {
    // 2-byte signed (30) shorts
    size = 2;
    Array *a= PushDataBlock(NewArray(&shortStruct, tmpDims));
    short *data = a->value.s;
    bytes_read = fread((void *)data,size,nElements,fs);
    if (endian=='B') { for (i=0;i<nElements;i++) SWAP_SHORT(data[i]); }

  } else if (type==40) {
    // 2-byte unsigned (40) shorts
    size = 2;
    Array *a= PushDataBlock(NewArray(&shortStruct, tmpDims));
    short *data = a->value.s;
    Array *b= PushDataBlock(NewArray(&longStruct, tmpDims));
    long *data2 = b->value.l;
    bytes_read = fread((void *)data,size,nElements,fs);
    if (endian=='B') { for (i=0;i<nElements;i++) SWAP_SHORT(data[i]); }
    for (i=1;i<=nElements;i++) *(data2++) = (((long)*(data++))|0xFFFF0000)+65535;

  } else if (type==50) {
    // 1-byte signed or unsigned chars (50)
    size = 1;
    Array *a= PushDataBlock(NewArray(&charStruct, tmpDims));
    char *data = a->value.c;
    bytes_read = fread((void *)data,size,nElements,fs);

  } else if (type==51) {
    // text (51)
    size = 1;
    Array *a= PushDataBlock(NewArray(&stringStruct, (Dimension *)0));
    char *buf;
    a->value.q[0] = buf = p_malloc(nElements+1);
    if (DEBUG) printf("strlen: %d\n",(int)strlen((void *)a->value.q[0]));
    //    bytes_read = fread(a->value.q[0],1,nElements,fs);
    bytes_read = fread(buf,1,nElements,fs);
    *((char *)buf + nElements) = 0;  // append a NULL to text string

  } else {
    matclose(filename);
    sprintf(message,"Unknown type %d",type);
    YError(message);
  }

  if (bytes_read!=nElements) {
    fseek(fs,nElements*size,SEEK_CUR);
    matclose(filename);
    if (DEBUG) printf("read:%ld expected:%ld\n",bytes_read,nBytesToRead);
    YError("Premature end of file");
  }

  if (!leave_open) matclose(filename);
}
Пример #17
0
void matscan(FILE *fs, int maxVarsToSearch, int returnString)
{
  int  info[5];
  long i;
  long fileptr,tfileptr,tfp;
  long nbyt=0,nelem,skip;
  int  type;
  int  mrows,mcols;
  int  imagf;
  int  namelen;
  long varNumber = 0;
  char varname[80];
  char *stype="";
  int varnum=0;
  Array *a= PushDataBlock(NewArray(&stringStruct, (Dimension *)0));
  long extra=1;
  
  fileptr = ftell(fs);

  if (DEBUG) printf("Entering matscan\n");

  while (1) {
    tfileptr = ftell(fs);
    if (DEBUG) printf("at address %ld \n",tfileptr);
    if (fread(info,4,5,fs)==5) {

      if (info[4] & 0xffff0000) {	// convert header from little endian to big indian
        // info[0] changed to info[4] 2006/3/15 as double type can be 0, hence
        // no way to know big from little endian info[0] for doubles.
        if (DEBUG) printf("swapping!\n");
        for (i=0;i<5;i++) SWAP_INT(info[i]);
      }

      info[0] = info[0]%1000;

      tfp = ftell(fs);

      if (DEBUG) printf("at address %ld \n",tfp);
      if (DEBUG) printf("info = %d %d %d %d %d\n",info[0],info[1],info[2],info[3],info[4]);

      type = info[0]%1000;

      if ((namelen = info[4])<80L) {
        if (fread(varname,1,info[4],fs)==(int)info[4]) {
          if (type==0) {
            // 8-byte doubles 
            stype=p_strcpy("double*8"); nbyt=8;
          } else if (type==10) {
            // 4-byte reals 
            stype=p_strcpy("real*4  "); nbyt=4;
          } else if ((type==120) || (type==20)) {
            // 4-byte int 
            stype=p_strcpy("int*4   "); nbyt=4;
          } else if (type==30) {
            // 2-byte signed (30) shorts 
            stype=p_strcpy("short*2 "); nbyt=2;
          } else if (type==40)  {
            // 2-byte unsigned (40) shorts 
            stype=p_strcpy("ushort*2"); nbyt=2;
          } else if ((type==50) || (type==51))  {
            // 1-byte signed or unsigned chars (50) or text (51)
            stype=p_strcpy("char*1  "); nbyt=1; 
          } else {
            sprintf(message,"Unknown data type %d",type);
            YError(message);
          }
          
          if (returnString) {
            if (varnum!=0) a= PushDataBlock((void *)GrowArray(a, extra));
            a->value.q[varnum] = p_malloc(81);
            sprintf(a->value.q[varnum],"%30s  %s array [%d,%d]",varname,   \
                    stype,info[1],info[2]);
            varnum++;
          } else {
            printf("%30s  %s array [%d,%d]\n",varname,stype,info[1],info[2]);
          }

          mrows=info[1];
          mcols=info[2];
          nelem=mrows*mcols;
          imagf=info[3];
          if (imagf) nbyt=2*nbyt;
          skip = nbyt*nelem;
          if (DEBUG) printf("skiping data part: %ld bytes\n",skip);
          if (skip) fseek(fs,nbyt*nelem,SEEK_CUR);
        }
      }
    } else {
      break;
    }
    if (maxVarsToSearch) {
      if (++varNumber >= maxVarsToSearch) {
        break;
      }
    }
  }
}
Пример #18
0
void Y_integ(int nArgs)
{
  long which, nDims, number, nfast;
  long i, j, k, l, m, js, ms, ip, ipy;
  double *y, *x, *xp, *yi, *psum, c0, c1, dx;
  Array *array;
  Dimension *tmp;
  Operand opy, opx, opxp;
  if (nArgs!=3 && nArgs!=4)
    YError("integ takes exactly three or four arguments");

  if (nArgs==4) {
    which= YGetInteger(sp)-1;  /* use 0-origin which here */
    Drop(1);
  } else {
    which= 0;  /* use 0-origin which here */
    ClearTmpArray();  /* need a temporary for this calculation */
  }

  sp->ops->FormOperand(sp, &opxp);
  (sp-1)->ops->FormOperand(sp-1, &opx);
  (sp-2)->ops->FormOperand(sp-2, &opy);
  opxp.ops->ToDouble(&opxp);
  opx.ops->ToDouble(&opx);
  opy.ops->ToDouble(&opy);

  tmp= tmpDims;
  tmpDims= 0;
  FreeDimension(tmp);

  /* compute dimensions of y array -- nfast-by-number-by-(slow), where
     nfast are the first which dimensions of y, number is the length of
     the dimension to interpolate on, and (slow) are the rest */
  nDims= CountDims(opy.type.dims);
  if (which<0) which= nDims+which; /* handle which<0 like array index<0 */
  if (which>=nDims || which<0) YError("bad 4th argument to integ");
  i= nDims-1-which;
  tmp= opy.type.dims;
  while (i) { tmp= tmp->next; i--; }
  number= tmp? tmp->number : 1;
  if (number<2) YError("bad dimension (length 1) in integ");
  nfast= TotalNumber(tmp->next);
  if (opx.type.number!=number || opx.type.dims->next)
    YError("dimension of x does not match target dimension of y in integ");

  if (which==nDims-1) {
    /* can just tack new element(s) of dimension list onto old */
    tmpDims= Ref(opy.type.dims->next);
    tmpDims= CopyDims(opxp.type.dims, tmpDims, 1);
  } else {
    /* make a fresh copy of the index list and find where to insert new */
    Dimension *prev, *tmpprev;
    i= nDims-which;   /* guaranteed >1 AND opy is at least 2D */
    tmpDims= prev= CopyDims(opy.type.dims, tmpDims, 1);
    tmp= prev->next;  i--;
    tmp= tmp->next;  i--;   /* prev is two behind tmp */
    while (i) { prev= prev->next; tmp= tmp->next; i--; }
    tmpprev= prev->next;
    prev->next= 0;     /* cut off tail of dimension list */
    tmpprev->next= 0;  /* this pointed to tmp */
    FreeDimension(tmpprev);
    prev->next= CopyDims(opxp.type.dims, tmp, 1);
  }

  /* create partial sum array (integrals up to each xp) */
  array= NewTmpArray(&doubleStruct, opy.type.dims);
  psum= array->value.d;

  /* create result array */
  array= PushDataBlock(NewArray(&doubleStruct, tmpDims));
  yi= array->value.d;
  y= opy.value;
  x= opx.value;
  xp= opxp.value;

  /* The problem is as follows (same as interp):
     For each value of the faster indices, and each value of the slower
     indices of y, and for each value of xp, find the value of yi
     corresponding to xp.  Note that for each interpolation, the y
     vector has stride nfast, while the x vector always has stride 0.
     Note also that ALL of the yi for a given xp should be computed
     once xp is found.  */

  /* first compute partial sums */
  js= nfast*number;
  for (j=0 ; j<opy.type.number ; j+=js) {
    for (k=0 ; k<nfast ; k++) {
      psum[k+j]= 0.0;
      for (i=1, l=nfast ; i<number ; i++, l+=nfast)
        psum[k+l+j]= psum[k+l-nfast+j]+
          0.5*(y[k+l-nfast+j]+y[k+l+j])*(x[i]-x[i-1]);
    }
  }

  /* use that to compute interpolated integrals */
  ms= nfast*opxp.type.number;
  c0= c1= 0.0;
  ip= 0;  /* hunt takes this as no guess on 1st pass */
  for (i=l=0 ; i<opxp.type.number ; i++, l+=nfast) {
    ip= hunt(x, number, xp[i], ip);
    ipy= ip*nfast;
    if (ip>=1 && ip<number) {
      dx= xp[i]-x[ip-1];
      c1= 0.5*dx*dx/(x[ip]-x[ip-1]);
      c0= dx-c1;
    }
    for (j=m=0 ; j<opy.type.number ; j+=js, m+=ms) {
      for (k=0 ; k<nfast ; k++) {
        if (ip<1) {               /* point below minimum */
          yi[k+l+m]= 0.0;
        } else if (ip<number) {   /* point in range */
          yi[k+l+m]= c0*y[k+(ipy-nfast)+j]+c1*y[k+ipy+j]
            +psum[k+(ipy-nfast)+j];
        } else {                  /* point above maximum */
          yi[k+l+m]= psum[k+(ipy-nfast)+j];
        }
      }
    }
  }

  ClearTmpArray();
  PopToD(sp-4);
  Drop(3);
}
Пример #19
0
static void morph_op(int argc, int mop)
{
  char msg[80];
  Operand op;
  Dimension *dims;
  Symbol *s;
  Array *ap;
  long ndims, width, height, depth, number, *off, *dx, *dy, *dz;

  if (argc != 2) {
    sprintf(msg, "morph_%s takes exactly 2 arguments",
            (mop ? "dilation" : "erosion"));
    YError(msg);
  }

  /* Get input array. */
  s = sp - 1;
  if (! s->ops) YError("unexpected keyword argument");
  dims = s->ops->FormOperand(s, &op)->type.dims;
  ndims = 0;
  width = height = depth = 0;
  while (dims) {
    if (++ndims > 3) YError("too many dimensions for input array");
    depth = height;
    height = width;
    width = dims->number;
    dims = dims->next;
  }

  /* Get radius / offset array. */
  off = get_offset(sp, &dims);
  if (! dims) {
    /* Only one extra scalar argument: the structuring element is a
       sphere. */
    long x, y, z, r, n, lim0, lim1, lim2;
    r = off[0];
    if (r < 0) {
      YError("radius of structuring element must be a positive integer");
    }
    Drop(1); /* to be able to push temporary workspace */
    n = 2*r + 1;
    lim0 = r*(r + 1);
    number = 0;
    if (depth > 1) {
      n = n*n*n; /* maximum number of offsets per dimension */
      off = yeti_push_workspace(3*sizeof(long)*n);
      dx = off;
      dy = dx + n;
      dz = dy + n;
      for (z=-r ; z<=r ; ++z) {
        lim1 = lim0 - z*z;
        for (y=-r ; y<=r ; ++y) {
          lim2 = lim1 - y*y;
          for (x=-r ; x<=r ; ++x) {
            /* To be inside the structuring element, we must have
             *   sqrt(x*x + y*y + z*z) < r + 1/2
             * which is the same as:
             *   x*x + y*y + z*z <= r*(r + 1)
             * because X, Y, Z and R are integers.
             */
            if (x*x <= lim2) {
              dx[number] = x;
              dy[number] = y;
              dz[number] = z;
              ++number;
            }
          }
        }
      }
    } else if (height > 1) {
      n = n*n; /* maximum number of offsets per dimension */
      dx = yeti_push_workspace(2*sizeof(long)*n);
      dy = dx + n;
      dz = NULL;
      for (y=-r ; y<=r ; ++y) {
        lim1 = lim0 - y*y;
        for (x=-r ; x<=r ; ++x) {
          if (x*x <= lim1) {
            dx[number] = x;
            dy[number] = y;
            ++number;
          }
        }
      }
    } else {
      dx = yeti_push_workspace(sizeof(long)*n);
      dy = NULL;
      dz = NULL;
      for (x=-r ; x<=r ; ++x) {
        dx[number++] = x;
      }
    }
  } else {
    if (ndims > 1) {
      if (dims->number != ndims) {
        YError("last dimension of OFF not equal to number of dimensions of A");
      }
      dims = dims->next;
    }
    number = 1;
    while (dims) {
      number *= dims->number;
      dims = dims->next;
    }
    dx = off;
    dy = (ndims >= 2 ? dx + number : NULL);
    dz = (ndims >= 3 ? dy + number : NULL);
  }

  /* Allocate output array and apply the operation. */
  ap = ((Array *)PushDataBlock(NewArray(op.type.base, op.type.dims)));
  switch (op.ops->typeID) {
#undef _
#define _(ID) (mop ? dilation_##ID : erosion_##ID)((void *)ap->value.ID, \
              op.value, width, height, depth, dx, dy, dz, number); break
  case T_CHAR:   _(c);
  case T_SHORT:  _(s);
  case T_INT:    _(i);
  case T_LONG:   _(l);
  case T_FLOAT:  _(f);
  case T_DOUBLE: _(d);
#undef _
  default:
    YError("bad data type");
  }
}
Пример #20
0
void Y__raw_track(int nArgs)
{
  long nrays;
  Ray *rays;
  DratMesh *dm;
  double *slimits;
  Array *array;
  Ray_Path *result;
  long ncuts, i;
  long *zone, *pt1, *pt2;
  double *ds, *f;

  EraseRayPath(&path);

  if (nArgs!=4) YError("_raw_track takes exactly four arguments");

  /* no validity checking -- leave it to interpreted wrapper */
  nrays= YGetInteger(sp-3);
  rays= (Ray *)YGet_D(sp-2, 0, (Dimension **)0);
  dm= YGetDMesh(sp-1, 0);
  slimits= YGet_D(sp, 0, (Dimension **)0);

  /* push result array onto stack */
  array=
    (Array *)PushDataBlock(NewArray(sdRay_Path,
                                    NewDimension(nrays, 1L, (Dimension *)0)));
  array->type.dims->references--;
  result= (Ray_Path *)array->value.c;

  while (nrays>0) {
    TrackRay(&dm->mesh, rays, slimits, &path);
    result->fi= path.fi;
    result->ff= path.ff;
    ncuts= path.ncuts;
    if (ncuts>1) {
      Dimension *dims= tmpDims;
      tmpDims= 0;
      FreeDimension(dims);
      tmpDims= NewDimension(ncuts, 1L, (Dimension *)0);
      result->zone= zone= (NewArray(&longStruct, tmpDims))->value.l;
      result->ds= ds= (NewArray(&doubleStruct, tmpDims))->value.d;
      result->pt1= pt1= (NewArray(&longStruct, tmpDims))->value.l;
      result->pt2= pt2= (NewArray(&longStruct, tmpDims))->value.l;
      result->f= f= (NewArray(&doubleStruct, tmpDims))->value.d;
      /* convert zone, pt1, and pt2 to 1-origin index lists */
      for (i=0 ; i<ncuts ; i++) {
        zone[i]= path.zone[i]+1;
        ds[i]= path.ds[i];
        pt1[i]= path.pt1[i]+1;
        pt2[i]= path.pt2[i]+1;
        f[i]= path.f[i];
      }
    }

    rays++;
    slimits+= 2;
    result++;
    nrays--;
  }

  EraseRayPath(&path);
}
Пример #21
0
void Y_get_addrs(int nArgs)
{
  IOStream *file, *child;
  Array *array;
  long *pAddrs= 0, *cAddrs= 0, *rAddrs= 0;
  int *rFiles= 0;
  char **rNames= 0;
  long i, nParent, nChild, nFamily, nRecords;
  HistoryInfo *history;
  Dimension *dims;
  if (nArgs!=1) YError("get_addrs takes exactly one argument");

  file= yarg_file(0);

  history= file->history;
  child= history? history->child : 0;

  /* create result array */
  dims= tmpDims;
  tmpDims= 0;
  FreeDimension(dims);
  tmpDims= NewDimension(5L, 1L, (Dimension *)0);
  array= PushDataBlock(NewArray(&pointerStruct, tmpDims));
  nParent= file->dataTable.nItems;
  nChild= child? child->dataTable.nItems : 0;
  nRecords= child? history->nRecords : 0;
  nFamily= child? history->nFamily : 0;
  if (nParent) {
    dims= tmpDims;
    tmpDims= 0;
    FreeDimension(dims);
    tmpDims= NewDimension(nParent, 1L, (Dimension *)0);
    array->value.p[0]= pAddrs= NewArray(&longStruct, tmpDims)->value.l;
  }
  if (nChild) {
    dims= tmpDims;
    tmpDims= 0;
    FreeDimension(dims);
    tmpDims= NewDimension(nChild, 1L, (Dimension *)0);
    array->value.p[1]= cAddrs= NewArray(&longStruct, tmpDims)->value.l;
  }
  if (nRecords>0) {
    dims= tmpDims;
    tmpDims= 0;
    FreeDimension(dims);
    tmpDims= NewDimension(nRecords, 1L, (Dimension *)0);
    array->value.p[2]= rAddrs= NewArray(&longStruct, tmpDims)->value.l;
    array->value.p[3]= rFiles= NewArray(&intStruct, tmpDims)->value.i;
  }
  if (nFamily>0) {
    dims= tmpDims;
    tmpDims= 0;
    FreeDimension(dims);
    tmpDims= NewDimension(nFamily, 1L, (Dimension *)0);
    array->value.p[4]= rNames= NewArray(&stringStruct, tmpDims)->value.q;
  }

  /* and fill it */
  for (i=0 ; i<nParent ; i++) pAddrs[i]= file->addresses[i]+file->offset;
  for (i=0 ; i<nChild ; i++) cAddrs[i]= child->addresses[i];
  for (i=0 ; i<nRecords ; i++) rAddrs[i]= history->offset[i];
  for (i=0 ; i<nRecords ; i++) rFiles[i]= history->ifile[i];
  for (i=0 ; i<nFamily ; i++) rNames[i]= p_strcpy(history->famNames[i]);
}
Пример #22
0
void
Y_spawn(int nargs)
{
  Dimension *dims = 0;
  char **argv = yarg_q(nargs-1, &dims);
  long argc = 1;
  Operand op;
  Operand *pop = yarg_op(nargs-2, &op);
  long callout=-1, callerr=-1;
  spawn_proc *proc;

  if (nargs<2 || nargs>3)
    YError("spawn: accepts precisely two or three arguments");
  if (dims) {
    if (dims->next)
      YError("spawn: first argument must be string or 1D array of strings");
    argc = dims->number;
  }
  if (!argv || !argv[0] || !argv[0][0])
    YError("spawn: first element of first argument must be process name");
  if (!pop || (op.ops!=&functionOps && op.ops!=&builtinOps))
    YError("spawn: second argument must be callback function");
  if (op.ops==&builtinOps) callout = ((BIFunction *)op.value)->index;
  else callout = ((Function *)op.value)->code[0].index;
  if (nargs == 3) {
    pop = yarg_op(0, &op);
    if (!pop || (op.ops!=&functionOps && op.ops!=&builtinOps))
      YError("spawn: third argument must be callback function");
    if (op.ops==&builtinOps) callerr = ((BIFunction *)op.value)->index;
    else callerr = ((Function *)op.value)->code[0].index;
  }

  if (argv[argc-1]) {
    /* must construct a 0-terminated argv list */
    typedef struct tmpobj {
      int references;
      Operations *ops;
      void (*zapper)(void *to);
      char *argv[1];
    } tmpobj;
    tmpobj *tmp;
    long i;
    /* CheckStack(2); fnctn.c guarantees at least 2 free stack slots */
    tmp = PushDataBlock(y_new_tmpobj(sizeof(tmpobj)+argc*sizeof(char*),
                                     p_free));
    for (i=0 ; i<argc ; i++) tmp->argv[i] = argv[i];
    tmp->argv[i] = 0;
    argv = tmp->argv;
    /* tmp will be cleaned up when stack cleared */
  }

  /* push result object onto stack */
  proc = p_malloc(sizeof(spawn_proc));
  proc->references = 0;
  proc->ops = &spawn_ops;
  proc->proc = p_spawn(argv[0], argv, spawn_callback, proc, callerr>=0);
  proc->argv0 = p_strcpy(argv[0]);
  proc->callout = callout;
  proc->callerr = callerr;
  proc->next = spawn_list;
  spawn_list = proc;
  PushDataBlock(proc);
  if (!proc->proc) {
    Drop(1);
    PushDataBlock(RefNC(&nilDB));
  }

  if (!spawn_setclean) {
    spawn_setclean = 1;
    spawn_prevclean = CleanUpForExit;
    CleanUpForExit = spawn_cleanup;
  }
}
Пример #23
0
void Y_find_boundary(int nArgs)
{
  DratMesh *dm;
  int region, sense;
  Array *array;

  if (liveBoundary) {
    liveBoundary= 0;
    EraseBoundary(&boundary);
  }

  if (nArgs<1 || nArgs>3)
    YError("update_mesh takes exactly one, two, or three arguments");

  dm= YGetDMesh(sp-nArgs+1, 0);

  if (nArgs>1) {
    if (YNotNil(sp-nArgs+2)) region= (int)YGetInteger(sp-nArgs+2);
    else region= 0;
    if (nArgs>2 && YNotNil(sp)) sense= (int)YGetInteger(sp);
    else sense= 0;
  } else {
    /* here are the values used in UpdateMesh call to FindBoundaryPoints */
    region= 0;
    sense= 1;
  }

  boundary.zsym= dm->mesh.boundary.zsym;
  if (region!=0 || sense!=1) {
    /* must calculate boundary now */
    boundary.nk= boundary.nl= boundary.npoints= 0;
    boundary.zone= 0;
    boundary.side= 0;
    boundary.z= boundary.r= 0;
    liveBoundary= 1;
    FindBoundaryPoints(&dm->mesh.mesh, region, sense, &boundary,
                       dm->mesh.work);

  } else {
    /* boundary already calculated */
    boundary.nk= dm->mesh.boundary.nk;
    boundary.nl= dm->mesh.boundary.nl;
    boundary.npoints= dm->mesh.boundary.npoints;
    boundary.zone= dm->mesh.boundary.zone;
    boundary.side= dm->mesh.boundary.side;
    boundary.z= dm->mesh.boundary.z;
    boundary.r= dm->mesh.boundary.r;
  }

  /* form result -- 1-origin array of 4 pointers */
  array=
    (Array *)PushDataBlock(NewArray(&pointerStruct,
                                    NewDimension(4L, 1L, (Dimension *)0)));
  array->type.dims->references--;
  if (boundary.npoints>0) {
    long npoints= boundary.npoints;
    long i;
    void **result= array->value.p;
    long *zone;
    int *side;
    double *z, *r;

    Dimension *dims= tmpDims;
    tmpDims= 0;
    FreeDimension(dims);
    tmpDims= NewDimension(npoints, 1L, (Dimension *)0);

    result[0]= zone= (NewArray(&longStruct, tmpDims))->value.l;
    result[1]= side= (NewArray(&intStruct, tmpDims))->value.i;
    result[2]= z= (NewArray(&doubleStruct, tmpDims))->value.d;
    result[3]= r= (NewArray(&doubleStruct, tmpDims))->value.d;

    /* convert zone to 1-origin index list */
    for (i=0 ; i<npoints ; i++) {
      zone[i]= boundary.zone[i]+1;
      side[i]= boundary.side[i];
      z[i]= boundary.z[i];
      r[i]= boundary.r[i];
    }
  }

  if (liveBoundary) EraseBoundary(&boundary);
}
Пример #24
0
void Y__jt(int nArgs)
{
  Operand op;
  IOStream *file;
  HistoryInfo *history;
  double targetTime= 0.0;
  Symbol *stack= sp-nArgs+1;
  long recNumber;
  int noRecord;
  if (nArgs!=1 && nArgs!=2)
    YError("jt takes exactly one or two arguments");

  stack->ops->FormOperand(stack, &op);
  if (op.ops==&streamOps) {
    /* first argument is explicit binary file */
    file= op.value;
    history= file->history;
    if (!history)
      YError("binary file passed to jt has no history records");
    recNumber= history->recNumber;
    if (nArgs>1) {
      sp->ops->FormOperand(sp, &op);
      if (op.ops==&rangeOps) {        /* jt, file, - */
        /* look for   jt, file, -    (backup 1 record) */
        Range *range= op.value;
        if ((range->nilFlags&(~(R_MINNIL|R_MAXNIL|R_PSEUDO))) ||
            range->inc!=1)
          YError("did you want   jt, file, -   (jump to previous record)?");
        noRecord= recNumber>=0? JumpRecord(history, recNumber-1) :
                                JumpRecord(history, history->nRecords-1);

      } else if (op.ops==&voidOps) {  /* jt, file, [] */
        noRecord= recNumber>=0? JumpRecord(history, recNumber+1) :
                                JumpRecord(history, 0);

      } else {                        /* jt, file, time */
        targetTime= YGetReal(sp);
        noRecord= JumpToTime(history, targetTime);
        if (noRecord) {
          if (history->time) {
            noRecord= 2;
            targetTime= history->time[history->recNumber];
          } else {
            noRecord= 3;
          }
        }
      }

    } else {                          /* jt, file */
      noRecord= recNumber>=0? JumpRecord(history, recNumber+1) :
                              JumpRecord(history, 0);
    }

  } else {                            /* jt, time */
    IOFileLink *link;
    if (nArgs!=1)
      YError("did you want jt, file, time (instead of jt, time, file)?");

    targetTime= YGetReal(sp);
    for (link=yBinaryFiles ; link ; link=link->next) {
      file= link->ios;
      if (!file) continue;
      history= file->history;
      if (!history || history->recNumber<0) continue;
      JumpToTime(history, targetTime);
    }
    noRecord= 3;
  }

  if (!CalledAsSubroutine()) {
    if (noRecord>2) PushDataBlock(RefNC(&nilDB));
    if (noRecord>1) PushDoubleValue(targetTime);
    else if (noRecord) PushIntValue(0);
    else PushIntValue(1);
  }
}
Пример #25
0
void Y_sort(int nArgs)
{
  Operand op;
  Array *result;
  long *ilist, i, j, which, nDims, origin;
  Dimension *tmp;
  void (*ysort)(long *list, long n);
  if (nArgs!=1 && nArgs!=2)
    YError("sort takes exactly one or two arguments");

  if (nArgs==2) { which= YGetInteger(sp)-1; Drop(1); }
  else which= 0;  /* use 0-origin which here */

  /* get array to be sorted */
  sp->ops->FormOperand(sp, &op);
  if (op.ops->typeID <= T_LONG) {
    op.ops->ToLong(&op);
    ysort= &ysortL;
    longData= op.value;
  } else if (op.ops->typeID <= T_DOUBLE) {
    op.ops->ToDouble(&op);
    ysort= &ysortD;
    doubleData= op.value;
  } else if (op.ops==&stringOps) {
    ysort= &ysortQ;
    stringData= op.value;
  } else {
    YError("sort function requires integer, real, or string operand");
    ysort= 0;
  }

  /* figure out stride for the sort */
  nDims= CountDims(op.type.dims);
  if (nDims==0) {
    PushIntValue(0);
    sp->ops= &longScalar;
    sp->value.l= 0;
    return;
  }
  if (which<0) which+= nDims;
  if (which<0 || which>=nDims)
    YError("2nd argument to sort function out of range");
  if (nDims<2) {
    sortStride= 1;
    sortSize= op.type.number;
  } else {
    which= nDims-1-which;
    tmp= op.type.dims;
    while (which--) tmp= tmp->next;
    sortStride= TotalNumber(tmp->next);
    sortSize= sortStride*tmp->number;
  }
  sortLimit= 7*sortStride;  /* use straight insertion for <7 elements */

  /* push result Array, then fill it with index to be sorted */
  result= PushDataBlock(NewArray(&longStruct, op.type.dims));
  ilist= result->value.l;
  for (i=0 ; i<op.type.number ; i++) ilist[i]= i;

  for (i=0 ; i<sortStride ; i++)
    for (j=0 ; j<op.type.number ; j+=sortSize)
      ysort(&ilist[i+j], sortSize);

  if ((origin= op.type.dims->origin))
    for (i=0 ; i<op.type.number ; i++) ilist[i]+= origin;
}
Пример #26
0
void Y_form_mesh(int nArgs)
{
  if (nArgs!=3) YError("form_mesh takes exactly three arguments");
  PushDataBlock(NewDratMesh((int)YGetInteger(sp-2),
                            YGetInteger(sp-1)-1, YGetInteger(sp)-1));
}
Пример #27
0
void Y_transpose(int nArgs)
{
  Symbol *stack= sp-nArgs+1;
  Operand op, opp;
  int i, nDims, order[10];
  long numbers[10], origins[10], strides[10];
  long stride, *cycle, index, prev, next, last;
  Dimension *dims;
  LValue *lvalue;
  Strider *strider;
  if (nArgs < 1) YError("transpose needs at least argument");

  stack->ops->FormOperand(stack, &op);
  if (!op.ops->isArray) YError("1st argument to transpose must be array");
  nDims= CountDims(op.type.dims);
  if (nDims>10) YError("transpose fails for arrays with >10 dimensions");
  if (nDims<1) {
    if (nArgs>1) Drop(nArgs-1);
    return;
  }

  /* collect dimension lengths and strides into arrays to be permuted */
  dims= op.type.dims;
  stride= 1;
  for (i=0 ; i<nDims ; i++) {
    numbers[nDims-1-i]= dims->number;
    origins[nDims-1-i]= dims->origin;
    dims= dims->next;
  }
  stride= op.type.base->size;
  for (i=0 ; i<nDims ; i++) {
    strides[i]= stride;
    stride*= numbers[i];
  }

  /* compute the permutation from the remaining arguments */
  for (i=0 ; i<nDims ; i++) order[i]= i;
  if (nArgs<2) {
    /* default is to swap first and last indices */
    if (nDims) {
      prev= order[0];
      order[0]= order[nDims-1];
      order[nDims-1]= prev;
    }
  } else {
    /* read permutation list */
    while (stack<sp) {
      stack++;
      stack->ops->FormOperand(stack, &opp);
      if (opp.ops->promoteID>T_LONG ||
          (opp.type.dims && opp.type.dims->next))
        YError("bad permutation list in transpose");
      opp.ops->ToLong(&opp);
      cycle= opp.value;
      if (opp.type.dims) {
        /* this is a cycle list */
        last= cycle[0]-1;
        if (last<0) last+= nDims;
        if (last<0 || last>=nDims)
          YError("permutation list references non-existent dimension "
                 "in transpose");
        prev= order[last];
        for (i=1 ; i<opp.type.number ; i++) {
          index= cycle[i]-1;
          if (index<0) index+= nDims;
          if (index<0 || index>=nDims)
            YError("permutation list references non-existent dimension "
                   "in transpose");
          next= order[index];
          order[index]= prev;
          prev= next;
        }
        order[last]= prev;
      } else {
        /* this is a cyclic permutation of all nDims indices */
        long inc= cycle[0]-1;           /* index which 0 should go to */
        long now;
        if (inc<0) inc= nDims - (-inc)%nDims;
        if (inc>=nDims) inc%= nDims;
        prev= order[0];
        now= inc;
        last= now;
        for (i=0 ; i<nDims ; i++) {
          next= order[now];
          order[now]= prev;
          prev= next;
          now+= inc;
          if (now>=nDims) now-= nDims;
          if (last==now) {
            /* handle case of several independent cycles when nDims is
               evenly divisible by inc */
            prev= order[++now];
            now+= inc;
            if (now>=nDims) now-= nDims;
            last= now;
          }
        }
      }
    }
    Drop(nArgs-1);
  }

  /* build re-ordered dimension list */
  dims= tmpDims;
  tmpDims= 0;
  FreeDimension(dims);
  for (i=0 ; i<nDims ; i++)
    tmpDims= NewDimension(numbers[order[i]], origins[order[i]], tmpDims);

  /* push LValue describing result onto stack */
  lvalue= PushDataBlock(NewLValueM((Array *)sp->value.db, op.value,
                                   op.type.base, tmpDims));

  /* build strider list describing re-ordering */
  for (i=0 ; i<nDims ; i++) {
    strider= NewStrider(strides[order[i]], numbers[order[i]]);
    strider->next= lvalue->strider;
    lvalue->strider= strider;
  }

  PopTo(sp-2);
  Drop(1);
  FetchLValue(lvalue, sp);
}
Пример #28
0
void Y_span(int nArgs)
{
  long which, nDims, number, nfast, i, j, k, kx;
  double rnumber, dp, *p0, *p1, *p;
  Array *array;
  Dimension *tmp;
  Operand op0, op1;
  if (nArgs!=3 && nArgs!=4)
    YError("span takes exactly three or four arguments");

  if (nArgs==4) { which= YGetInteger(sp)-1; Drop(1); }
  else which= 0;  /* use 0-origin which here */

  number= YGetInteger(sp);
  if (number<1) YError("3rd argument to span function must be >0");
  Drop(1);

  sp->ops->FormOperand(sp, &op1);
  (sp-1)->ops->FormOperand(sp-1, &op0);
  op1.ops->ToDouble(&op1);
  op0.ops->ToDouble(&op0);
  if (BinaryConform(&op1, &op0) & 4)
    YError("start and stop not conformable in span function");

  tmp= tmpDims;
  tmpDims= 0;
  FreeDimension(tmp);

  /* compute dimensions of result -- nfast-by-number-by-(slow),
     where nfast are the first which indices of op0 (or op1),
     and (slow) are the rest */
  nDims= CountDims(op0.type.dims);
  if (which<0) which= nDims+1+which; /* handle which<0 like array index<0 */
  if (which>8 || nDims-which>8)
    YError("the 4th argument to span is unreasonably large");
  while (which<0) {
    tmpDims= NewDimension(1L, 1L, tmpDims);
    which++;
  }
  if (which>=nDims) {
    /* can just tack new element of dimension list onto old */
    tmpDims= Ref(op0.type.dims);
    while (which>nDims) {
      tmpDims= NewDimension(1L, 1L, tmpDims);
      which--;
    }
    tmpDims= NewDimension(number, 1L, tmpDims);
    nfast= op0.type.number;
  } else {
    /* make a fresh copy of the index list, then insert new element */
    Dimension *prev;

    which= nDims-which;  /* guaranteed this is >0 */
    tmpDims= tmp= CopyDims(op0.type.dims, tmpDims, 1);
    do {
      prev= tmp;
      tmp= tmp->next;
    } while (--which);
    prev->next= NewDimension(number, 1L, tmp);
    nfast= TotalNumber(tmp);
  }

  /* create result array and fill it */
  array= PushDataBlock(NewArray(&doubleStruct, tmpDims));
  p= array->value.d;
  p0= op0.value;
  p1= op1.value;
  rnumber= 1.0/(double)(number-1);
  kx= array->type.number - nfast;
  for (i=0 ; i<op0.type.number ; i+=nfast) {
    for (j=0 ; j<nfast ; j++) {
      dp= (p1[i+j]-p0[i+j])*rnumber;
      k= j+number*i;
      p[k]= p0[i+j];
      for (k+=nfast ; k<kx ; k+=nfast) p[k]= p[k-nfast]+dp;
      p[k]= p1[i+j];  /* do after loop to assure exact equality */
    }
  }
}
Пример #29
0
void
Y_lsdir(int nArgs)
{
  Symbol *stack = sp-nArgs+1;
  Symbol *glob = 0;
  Dimension *dims;
  y_dirlist *dlist;
  char *name, **list;
  long i;
  int is_dir = 0;
  if (nArgs<1 || nArgs>2) YError("lsdir takes one or two arguments");
  if (nArgs==2) {
    if (!stack->ops || sp->ops!=&referenceSym)
      YError("lsdir second argument not simple variable reference");
    glob = &globTab[sp->index];
    sp--;
  }

  dlist = y_new_tmpobj(sizeof(y_dirlist), y_zap_dirlist);
  dlist->dir = 0;
  dlist->fils = dlist->subs = 0;
  dlist->nfils = dlist->nsubs = 0;
  PushDataBlock(dlist);

  name = YGetString(stack);
  if (!name)
    YError("first argument to lsdir must be a non-nil scalar string");
  dlist->dir = p_dopen(name);

  if (!dlist->dir) {
    Drop(1);
    PushLongValue(0);
    return;
  }

  while ((name = p_dnext(dlist->dir, &is_dir))) {
    if (is_dir && nArgs==2)
      y_add_item(&dlist->subs, &dlist->nsubs, p_strcpy(name));
    else
      y_add_item(&dlist->fils, &dlist->nfils, p_strcpy(name));
  }

  if (stack->ops==&dataBlockSym) {
    stack->ops = &intScalar;
    Unref(stack->value.db);
  }
  if (dlist->nfils) {
    char *nm;
    dims = tmpDims;
    tmpDims = 0;
    FreeDimension(dims);
    tmpDims = NewDimension(dlist->nfils, 1L, (Dimension *)0);
    stack->value.db = (DataBlock *)NewArray(&stringStruct, tmpDims);
    stack->ops = &dataBlockSym;
    list = ((Array *)stack->value.db)->value.q;
    for (i=0 ; i<dlist->nfils ; i++) {
      nm = dlist->fils[i];
      dlist->fils[i] = 0;
      list[i] = nm;
    }
    list = dlist->fils;
    dlist->fils = 0;
    p_free(list);
  } else {
    stack->value.db = (DataBlock *)(RefNC(&nilDB));
    stack->ops = &dataBlockSym;
  }

  if (glob) {
    if (glob->ops==&dataBlockSym) {
      glob->ops = &intScalar;
      Unref(glob->value.db);
    }
    if (dlist->nsubs) {
      char *nm;
      dims = tmpDims;
      tmpDims = 0;
      FreeDimension(dims);
      tmpDims = NewDimension(dlist->nsubs, 1L, (Dimension *)0);
      glob->value.db = (DataBlock *)NewArray(&stringStruct, tmpDims);
      glob->ops = &dataBlockSym;
      list = ((Array *)glob->value.db)->value.q;
      for (i=0 ; i<dlist->nsubs ; i++) {
        nm = dlist->subs[i];
        dlist->subs[i] = 0;
        list[i] = nm;
      }
      list = dlist->subs;
      dlist->subs = 0;
      p_free(list);
    } else {
      glob->value.db = (DataBlock *)(RefNC(&nilDB));
      glob->ops = &dataBlockSym;
    }
  }

  Drop(1);
}
Пример #30
0
void Y_grow(int nArgs)
{
  Symbol *s0, *s= sp-nArgs+1;
  long index= s->index;
  Array *array;
  Dimension *dims;
  StructDef *base;
  Operand op;
  long extra, number;
  int nDims;
  DataBlock *db;
  int amSubroutine= CalledAsSubroutine();

  if (nArgs < 2) YError("grow function needs at least two arguments");
  if (amSubroutine && s->ops!=&referenceSym)
    YError("1st argument to grow must be a variable reference");
  if (!s->ops) YError("unxepected keyword argument in grow");

  dims= growDims;
  growDims= 0;
  FreeDimension(dims);

  /* scan argument list to find first non-nil argument */
  base= 0;
  s0= 0;
  for (;;) {
    if (!s0 && amSubroutine) array= (Array *)ForceToDB(&globTab[index]);
    else array= (Array *)ForceToDB(s);  /* does ReplaceRef if required */
    s0= s;
    if (array->ops==&lvalueOps) array= FetchLValue(array, s);
    if (array->ops->isArray) {
      base= array->type.base;
      if (array->references) {
        /* the grow operation is destructive, must copy 1st arg */
        Array *copy= PushDataBlock(NewArray(base, array->type.dims));
        base->Copy(base, copy->value.c, array->value.c, array->type.number);
        PopTo(s);
        array= copy;
      }
      if (array->type.dims) {
        growDims= NewDimension(1L, 1L, Ref(array->type.dims->next));
      } else {
        growDims= NewDimension(1L, 1L, (Dimension *)0);
        array->type.dims= NewDimension(1L, 1L, (Dimension *)0);
      }
      break;
    } else if (array->ops!=&voidOps) {
      YError("bad data type in function grow");
    }
    if (++s > sp) {  /* all arguments void, will return nil */
      Drop(nArgs-1);
      PopTo(sp-1);
      return;
    }
  }
  nDims= CountDims(growDims);

  /* scan through remaining arguments to force right-conformability with
     growDims and count the number of extra dimensions */
  extra= 0;
  while (s<sp) {
    s++;
    if (!s->ops) YError("unxepected keyword argument in grow");
    s->ops->FormOperand(s, &op);
    if (op.ops->isArray) {
      if (nDims==CountDims(op.type.dims))
        growDims->number= op.type.dims->number;
      else
        growDims->number= 1;
      if (RightConform(growDims, &op))
        YError("later arguments not conformable with 1st in grow");
      extra+= growDims->number;
    } else if (op.ops!=&voidOps) {
      YError("illegal data type in function grow");
    }
  }

  if (extra) {
    LValue lvalue;
    long size;
    BinaryOp *Assign= base->dataOps->Assign;

    /* phony LValue necessary for Assign virtual function */
    lvalue.references= nArgs;    /* NEVER want to free this */
    lvalue.ops= &lvalueOps;
    lvalue.owner= 0;             /* not true, but safer */
    lvalue.type.base= base;      /* NOT Ref(base) -- won't be freed */
    lvalue.address.m= 0;
    lvalue.strider= 0;

    size= base->size;
    /* copy 1st non-nil argument */
    number= array->type.number;
    array= PushDataBlock(GrowArray(array, extra));
    lvalue.address.m= array->value.c + size*number;

    /* second pass through argument list copies 2nd-Nth arguments
       into result array using the Assign virtual function */
    s= s0;
    while (++s<sp) {  /* note that sp is bigger than for previous loop */
      s->ops->FormOperand(s, &op);
      if (op.ops->isArray) {
        lvalue.type.dims= op.type.dims; /* NOT Ref(dims) -- won't be freed */
        lvalue.type.number= op.type.number;
        /* Assign virtual functions assume their first parameter is an
           LValue* rather than an Operation* (like all other BinaryOps).  */
        (*Assign)((Operand *)&lvalue, &op);
        lvalue.address.m+= size*lvalue.type.number;
      }
    }
  }

  /* store result back to first reference -- will also be left on stack
     by EvalBI */
  if (amSubroutine) {
    s= &globTab[index];  /* guaranteed this is a dataBlockSym by ForceToDB */
    db= s->value.db;
    s->value.db= (DataBlock *)Ref(array);
    Unref(db);
    if (extra) Drop(nArgs);
    else Drop(nArgs-1);
    ReplaceRef(sp);  /* result is 1st argument */
    PopTo(sp-1);
  } else {
    if (extra) {   /* result is on top of stack */
      PopTo(sp-nArgs-1);
      Drop(nArgs);
    } else {       /* result is unchanged s0 argument */
      int nAbove= sp-s0;
      Drop(nAbove);
      nArgs-= nAbove;
      PopTo(sp-nArgs);
      Drop(nArgs-1);
    }
  }
}