/**
* Expand/reduce number of pitch markers to new number.
*
* @param idSrc source object
* @param idDst target object
* @param n target number of pitch markers
* @return O_K if sucessfull, not exec otherwise
*/
INT16 CGEN_PUBLIC CPMproc::CompressPm(CData *idSrc, CData* idDst, INT32 n)
{
if(CData_IsEmpty(idSrc) == TRUE) return NOT_EXEC;
if(n <= 0) return NOT_EXEC;
CREATEVIRTUAL(CData,idSrc,idDst);
DLPASSERT(CData_GetNComps(idSrc) == 2);
CData_Reset(idDst, TRUE);
CData_Scopy(idDst,idSrc);
CData_Allocate(idDst, n);
if(dlm_pm_compress((INT16*)CData_XAddr(idSrc,0,0),
CData_GetNRecs(idSrc),
(INT16*)CData_XAddr(idDst,0,0),
CData_GetNRecs(idDst)) != O_K) {
return IERROR(this,ERR_NULLARG, "", NULL, NULL);
}
CData_CopyDescr(idDst,idSrc);
/* clean up */
DESTROYVIRTUAL(idSrc,idDst)
return(O_K);
}
/*
* Manual page at process.def
*/
INT16 CGEN_PUBLIC CProcess::Status()
{
CData* d;
char s[L_INPUTLINE];
INT32 i;
printf("\n"); dlp_fprint_x_line(stdout,'-',dlp_maxprintcols()); // Protocol
printf("\n Status of instance"); // Protocol
printf("\n process %s",BASEINST(_this)->m_lpInstanceName); // Protocol
printf("\n"); dlp_fprint_x_line(stdout,'-',dlp_maxprintcols()); // Protocol
printf("\n State : 0x%04X",m_nState); // Protocol
if (m_nState!=0) // In any but the maiden state
{ // >>
BOOL b = 0; // Comma flag
printf(" ("); // Protocol
if (m_nState&PRC_DATASENT ) { if(b) printf(", "); printf("data sent" ); b=1; }//...
if (m_nState&PRC_RUNNING ) { if(b) printf(", "); printf("running" ); b=1; }//...
if (m_nState&PRC_COMPLETE ) { if(b) printf(", "); printf("complete" ); b=1; }//...
if (m_nState&PRC_KILLED ) { if(b) printf(", "); printf("killed" ); b=1; }//...
if (m_nState&PRC_DATARECEIVED) { if(b) printf(", "); printf("data received"); b=1; }//...
printf(")"); // Protocol
} // <<
printf("\n Return value: %ld",(long)m_nRetVal ); // Protocol
if (dlp_strlen(m_psTmpFile)) printf("\n Temp. files : %s*",m_psTmpFile); // Protocol
dlp_strcpy(s,m_psCmdLine); dlp_strreplace(s,m_psTmpFile,"<tmpfile>"); // Abbreviate command line
if (dlp_strlen(m_psCmdLine)) printf("\n Command line: %s" ,s); // Protocol
// Show transferred data // ------------------------------------
if (m_iDto) // Have data transfer object
{ // >>
printf("\n"); dlp_fprint_x_line(stdout,'-',dlp_maxprintcols()); // Protocol
printf("\n Transferred data"); // Protocol
d = (CData*)CDlpObject_FindInstanceWord(m_iDto,PRC_S_IDSIGN,NULL); // Get signature table
printf("\n - function : %s",(char*)CData_XAddr(d,0,0)); // Protocol (job function name)
for (i=1; i<CData_GetNRecs(d); i++) // Loop over function arguemnts
printf("\n %13s %s",i==1?"- arguments :":"",(char*)CData_XAddr(d,i,0)); // Protocol (job function arg.)
d = (CData*)CDlpObject_FindInstanceWord(m_iDto,PRC_S_IDGLOB,NULL); // Get list of global instances
if (d) // Have one
for (i=0; i<CData_GetNRecs(d); i++) // Loop over entries
printf("\n %13s %-8s %s",i==0?"- globals :":"", // Protocol (global instance)
(char*)CData_XAddr(d,i,0),(char*)CData_XAddr(d,i,1)); // |
printf("\n"); dlp_fprint_x_line(stdout,'-',dlp_maxprintcols()); // Protocol
printf("\n Transferred program"); // Protocol
for (i=0; dlp_strlen(__sSlaveScript[i]); i++) // Loop over slave script lines
{ // >>
dlp_strcpy(s,__sSlaveScript[i]); // Get a line
if (strstr(s,"##"))*(strstr(s,"##"))='\0'; // Truncate at comment
printf("\n (%02ld) %s",i,dlp_strtrimright(s)); // Protocol (script line)
} // <<
} // <<
printf("\n"); dlp_fprint_x_line(stdout,'-',dlp_maxprintcols()); printf("\n"); // Protocol
return O_K; // All done
}
/**
* Initialize one record from a token list.
*
* @param lpsInit Null ('\0') separated list of tokens. A double null "\0\0"
* is expected as list terminator!
* @param nRec Record index of first cell to initialize
* @param nComp Component index of first cell to initialize
* @return O_K if successfull, a negative error code otherwise
*/
INT16 CGEN_PUBLIC CData_InitializeRecordEx
(
CData* _this,
const char* lpsInit,
INT32 nRec,
INT32 nComp
)
{
const char* lpsToken = NULL;
INT32 nXC = 0;
INT32 nC = 0;
nXC = CData_GetNComps(_this);
nC = nComp;
if (nC<0 || nC>=nXC ) return NOT_EXEC;
if (nRec<0 || nRec>=CData_GetNRecs(_this)) return NOT_EXEC;
for (lpsToken=lpsInit; *lpsToken && nC<nXC; lpsToken+=dlp_strlen(lpsToken)+1, nC++)
if (dlp_strcmp(lpsToken,"*")!=0)
IF_NOK(dlp_sscanx(lpsToken,CData_GetCompType(_this,nC),CData_XAddr(_this,nRec,nC)))
IERROR(_this,DATA_BADINITIALIZER,lpsToken,(int)nRec,(int)nC);
if (*lpsToken) return IERROR(_this,DATA_INITIALIZERS,"many",0,0);
if (nC<nXC ) IERROR(_this,DATA_INITIALIZERS,"few" ,0,0);
return O_K;
}
/**
* Expand/reduce number of pitch markers to fit new target sum of period length.
*
* @param idSrc source object
* @param idDst target object
* @param n target length
* @return O_K if sucessfull, not exec otherwise
*/
INT16 CGEN_PUBLIC CPMproc::ExpandPm(CData *idSrc, CData* idDst, INT32 n)
{
if(CData_IsEmpty(idSrc) == TRUE) return NOT_EXEC;
if(n <= 0) return NOT_EXEC;
CREATEVIRTUAL(CData,idSrc,idDst);
DLPASSERT(CData_GetNComps(idSrc) == 2);
CData_Reset(idDst, TRUE);
CData_Scopy(idDst,idSrc);
INT32 nRecsNew = 0;
INT32 nRecs = (INT32)CData_GetNRecs(idSrc);
INT16* pm_new = NULL;
if(dlm_pm_expand((INT16*)CData_XAddr(idSrc,0,0), nRecs, &pm_new, &nRecsNew, n) != O_K) {
return IERROR(this,ERR_NULLARG, "", NULL, NULL);
}
CData_Allocate(idDst,nRecsNew);
dlp_memmove(CData_XAddr(idDst,0,0), pm_new, nRecsNew*2*sizeof(INT16));
dlp_free(pm_new);
CData_CopyDescr(idDst,idSrc);
/* clean up */
DESTROYVIRTUAL(idSrc,idDst)
return(O_K);
}
/*
* Manual page at function.def
*/
const char* CGEN_PROTECTED CFunction::Argv(INT32 nArg)
{
CData* idArg = NULL;
idArg = GetRootFnc() ? GetRootFnc()->m_idArg : m_idArg;
if (nArg<1 || nArg>CData_GetNRecs(idArg)) return NULL;
if (CData_Dfetch(idArg,nArg-1,FNC_ALIC_TYPE)!=T_STRING) return NULL;
return *(const char**)CData_Pfetch(idArg,nArg-1,FNC_ALIC_PTR);
}
INT16 CDlpFile_OnFlistDataChanged(CDlpObject* __this)
{
GET_THIS_VIRTUAL_RV(CDlpFile,NOT_EXEC);
{
_this->m_nLen = CData_GetNRecs(AS(CData,_this->m_idFlistData));
}
return O_K;
}
/*
* Manual page at statistics.def
*/
INT16 CGEN_PUBLIC CStatistics_Setup
(
CStatistics* _this,
INT32 nOrder,
INT32 nDim,
INT32 nCls,
CData* idLtb,
INT32 nIcLtb
)
{
INT32 c = 0; /* Statistics class loop counter */
INT32 n = 0; /* Dimension loop couner */
FLOAT64* lpMin = NULL; /* Ptr. to class' k minimum vector */
FLOAT64* lpMax = NULL; /* Ptr. to class' k maximum vector */
/* Validate */ /* --------------------------------- */
CHECK_THIS_RV(NOT_EXEC); /* Check this pointer */
if (nOrder<2) nOrder = 2; /* Default order is 2 */
if (nDim <1) nDim = 1; /* Default dimensionality is 1 */
if (nCls <1) nCls = 1; /* Default number of classes is 1 */
/* Initialize statistics */ /* --------------------------------- */
CStatistics_Reset(_this,TRUE); /* Start over */
IFIELD_RESET(CData,"dat"); /* Create/reset statistic data */
CData_Array(_this->m_idDat,T_DOUBLE,nDim,nCls*(nOrder+nDim+2)); /* Allocate statistic data */
CData_SetNBlocks(_this->m_idDat,nCls); /* Set number of blocks */
if (CData_IsEmpty(_this->m_idDat)) return IERROR(_this,ERR_NOMEM,0,0,0); /* Check if it worked out... */
for (c=0; c<nCls; c++) /* Loop over classes */
{ /* >> */
lpMin = CStatistics_GetPtr(_this,c,STA_DAI_MIN); /* Get ptr. to class' k min. vec. */
lpMax = CStatistics_GetPtr(_this,c,STA_DAI_MAX); /* Get ptr. to class' k max. vec. */
for (n=0; n<nDim; n++) /* Loop over dimensions */
{ /* >> */
lpMin[n] = T_DOUBLE_MAX; /* Initialize minimum vector */
lpMax[n] = T_DOUBLE_MIN; /* Initialize maximum vector */
} /* << */
} /* << */
/* Initialize label table */ /* --------------------------------- */
if (CData_IsEmpty(idLtb)) return O_K; /* No label table -> that's it */
if (CData_GetNRecs(idLtb)!=nCls) /* Bad number of labels */
return IERROR(_this,STA_NOTSETUP," (wrong no. of labels in idLtb)",0,0); /* -> Error */
if (nIcLtb<0) /* Label component not specified */
for (nIcLtb=0; nIcLtb<CData_GetNComps(idLtb); nIcLtb++) /* Seek first symbolic component */
if (dlp_is_symbolic_type_code(CData_GetCompType(idLtb,nIcLtb))) /* ... */
break; /* ... */
if (!dlp_is_symbolic_type_code(CData_GetCompType(idLtb,nIcLtb))) /* Label component not symbolic */
return IERROR(_this,STA_NOTSETUP," (label comp. not found in idLtb)",0,0); /* -> Error */
IFIELD_RESET(CData,"ltb"); /* Create/reset label table */
CData_SelectComps(_this->m_idLtb,idLtb,nIcLtb,1); /* Copy label table */
return O_K; /* Done */
}
/*
* Manual page at process.def
*/
INT32 CGEN_PUBLIC CProcess::Start()
{
const SMic* pMic = NULL; // Method invocation context of Start()
CFunction* iCaller = NULL; // Function calling Start()
CFunction* iFnc = NULL; // Process function
StkItm* pStkItm = NULL; // Stack item
INT32 nArgs = 0; // Number of process function arguments
// Validate and initialize // ------------------------------------
if (m_nState!=0) // Not virginal
return IERROR(this,PRC_CANTSTART,"multiple starts not allowed",0,0); // Forget it!
if (!(pMic = CDlpObject_MicGet(_this))) return -1; // Get method invocation context
iCaller = (CFunction*)CDlpObject_OfKind("function",pMic->iCaller); // Get calling CFunction
if (!iCaller) return -1; // Must be a function!
// Initialize process // ------------------------------------
sprintf(m_psTmpFile,"%s%ld",dlp_tempnam(NULL,"~dLabPro#process#"),(long)dlp_time());// Initialize temp. file name prefix
// Marshal arguments // ------------------------------------
if (!(pStkItm=iCaller->StackGet(0))) return IERROR(this,PRC_TOOFEWARGS,0,0,0);// Get stack top
if (pStkItm->nType==T_INSTANCE) // Stack top is an instance
iFnc = (CFunction*)CDlpObject_OfKind("function",pStkItm->val.i); // Get function to be called
if (iFnc) // This process is a function call
{ // >>
IFIELD_RESET(CDlpObject,"dto"); // Create data transfer object
nArgs = CData_GetNRecs(iFnc->m_idArg); // Get number of function arguments
Marshal(m_iDto,iCaller,nArgs); // Marshal arguments for transfer
} // <<
else // This process is a program call
dlp_strcpy(m_psCmdLine,iCaller->PopString(0)); // Get program command line
#ifdef USE_FORK
if (iFnc) // This process is a function call
{ // >>
m_hPid=fork(); // Fork the process
if(m_hPid>0){ // Parent process >>
m_nState |= PRC_DATASENT; // Remember data have been sent
m_nState |= PRC_RUNNING; // Set running flag
m_hThread = 0; // Clear thread handle
return O_K; // Everything is fine
} // <<
if(m_hPid==0) return DoJobFork(iCaller,iFnc); // The child process runs the function
return IERROR(this,PRC_CANTSTART,"fork() failed",0,0); // On error (fid<0) we return
} // <<
#endif
// Start job in watcher thread // ------------------------------------
m_hPid = 0; // Reset process id
SendData(); // Send transfer data
m_hThread = dlp_create_thread(DoJob,this); // Do the job and watch it
return O_K; // Yo!
}
/**
* Prints the instance in text mode (exactly one component of type 1).
*/
INT16 CGEN_PRIVATE CData_PrintText(CData* _this)
{
INT32 nR = 0; /* Current record */
INT32 nXR = 0; /* Number of records */
char* tx = NULL; /* Auxilary char pointer #1 */
char* tx0 = NULL; /* Pointer to string */
char* ty = NULL; /* Auxilary char pointer #2 */
char* ty0 = NULL; /* Pointer to last white space */
INT32 nCtr = 0; /* Line counter */
char sBuf[255]; /* Printing buffer */
/* Initialize */ /* --------------------------------- */
nXR = CData_GetNRecs(_this); /* Get number of records */
/* Print data contents as text */ /* --------------------------------- */
DLPASSERT(FMSG("ALPHA: String mode not tested yet")); /* TODO: Remove after debugging */
printf("\n String Mode"); dlp_inc_printlines(1); /* Protocol */
tx0=tx=(char*)CData_XAddr(_this,0,0); /* Initialize char pointers */
if (!*tx) /* Empty string */
{ /* >> */
printf("\n [empty]"); /* Protocol */
dlp_inc_printlines(1); /* Adjust no. of printed lines */
} /* << */
else while (*tx) /* Loop over characters */
{ /* >> */
/* Make line breaks */ /* - - - - - - - - - - - - - - - - */
for (ty=tx,ty0=NULL; *ty && ty<tx0+nXR; ) /* Do until end of string */
{ /* >> */
while (*ty && ty<tx0+nXR && !iswspace(*ty)) ty++; /* Seek next white space */
while (*ty && ty<tx0+nXR && iswspace(*ty)) ty++; /* Skip following white spaces */
ty0=ty; /* Remember previous white spc. */
if (ty>tx+dlp_maxprintcols()-16) break; /* Line full */
} /* << */
if (ty0) ty=ty0; /* Go back to last white space */
/* Print one line */ /* - - - - - - - - - - - - - - - - */
dlp_memset(sBuf,0,255); /* Clear printing buffer */
dlp_memmove(sBuf,tx,ty-tx); /* Copy characters in */
printf("\n %4d(%06d): %s",(int)nCtr,(int)(tx-tx0),sBuf); /* Print 'em */
dlp_inc_printlines(1); /* Adjust no. of printed lines */
if (dlp_if_printstop()) break; /* Break listing */
/* End-of-line actions */ /* - - - - - - - - - - - - - - - - */
DLPASSERT(ty>tx); /* Should have made some progress */
tx=ty; /* Move to end of printed line */
nCtr++; /* Increment line counter */
} /* << */
if (nR>=nXR) printf("\n No more data - Stop."); /* Protocol */
else printf("\n Cancelled - Stop."); /* Protocol */
return O_K; /* Ok */
}
/////////////////////////////////////////////////////////////////////////////////////
//
// ModEx - generates excitation from pitch file
//
// CData *gain -> gains of excitation per frame
// CData *idPm -> both components must be type long
// CData *idExcite -> type FBA_FLOAT
//
INT16 CGEN_PUBLIC CFBAproc::ModEx(CData *idPm, CData *idExcite) {
// Error handling
if (idPm == NULL) return IERROR(this,ERR_NULLINST,0,0,0);
if (idPm -> IsEmpty() == TRUE) return IERROR(idPm,DATA_EMPTY,idPm->m_lpInstanceName,0,0);
if (idExcite == NULL) return IERROR(this,ERR_NULLINST,idExcite->m_lpInstanceName,0,0);
DLPASSERT(idPm->GetNComps()>1);
FLOAT64* exc = NULL;
INT32 n_exc = 0;
switch(m_lpsExcType[0]) {
case 'P':
if(dlm_pm2exc((INT16*)idPm->XAddr(0,0),(INT32)idPm->GetNRecs(),&exc,&n_exc,m_nSrate, (BOOL)TRUE,DLM_PITCH_PULSE ) != O_K) return NOT_EXEC;
break;
case 'G':
if(dlm_pm2exc((INT16*)idPm->XAddr(0,0),(INT32)idPm->GetNRecs(),&exc,&n_exc,m_nSrate, (BOOL)TRUE,DLM_PITCH_GLOTT ) != O_K) return NOT_EXEC;
break;
case 'R':
if(dlm_pm2exc((INT16*)idPm->XAddr(0,0),(INT32)idPm->GetNRecs(),&exc,&n_exc,m_nSrate, (BOOL)TRUE,DLM_PITCH_RANDPHASE) != O_K) return NOT_EXEC;
break;
case 'V':
if(dlm_pm2exc((INT16*)idPm->XAddr(0,0),(INT32)idPm->GetNRecs(),&exc,&n_exc,m_nSrate, (BOOL)TRUE,DLM_PITCH_VOICED ) != O_K) return NOT_EXEC;
break;
case 'U':
if(dlm_pm2exc((INT16*)idPm->XAddr(0,0),(INT32)idPm->GetNRecs(),&exc,&n_exc,m_nSrate, (BOOL)TRUE,DLM_PITCH_UNVOICED ) != O_K) return NOT_EXEC;
break;
case 'C':
if(m_idExc == NULL) return IERROR(this,ERR_BADPTR,NULL,"of CFBAproc->m_lpExc","(FBAproc.exc)");
for(INT32 i_pm=0; i_pm < idPm->GetNRecs(); i_pm++) n_exc += (INT16)idPm->Dfetch(i_pm,0);
if(CData_GetNRecs(m_idExc) < n_exc) return IERROR(this,FBA_BADEXCLEN,0,0,0);
exc = (FLOAT64*)dlp_malloc(n_exc*sizeof(FLOAT64));
dlp_memmove(exc,m_idExc->XAddr(0,0),n_exc*sizeof(FLOAT64));
break;
default:
return IERROR(this,FBA_BADARG,m_lpsExcType,"exc_type","P, G, R, V, U or C");
}
idExcite->Reset(TRUE);
idExcite->AddComp("exc", T_DOUBLE);
idExcite->Allocate(n_exc);
dlp_memmove(idExcite->XAddr(0,0), exc, n_exc*sizeof(FLOAT64));
dlp_free(exc);
return O_K;
}
INT16 CDlpFile_OnFlistChanged(CDlpObject* __this)
{
GET_THIS_VIRTUAL_RV(CDlpFile,NOT_EXEC);
{
CData_Reset(_this->m_idFlistData, TRUE);
if(dlp_strlen(_this->m_lpsFlist))
{
ISETOPTION(_this,"/strings");
CDlpFile_Import(_this,_this->m_lpsFlist,"ascii",_this->m_idFlistData);
IRESETOPTIONS(_this);
_this->m_nLen = CData_GetNRecs(AS(CData,_this->m_idFlistData));
}
else _this->m_nLen = 0;
_this->m_nNfile = -1;
}
return O_K;
}
/*
* Manual page at fst_man.def
*/
INT16 CGEN_PUBLIC CFst_CopyUi(CFst* _this, CFst* itSrc, CData* idIndex, INT32 nPar)
{
INT32 i = 0;
INT32 nU = 0;
/* Validate */
CHECK_THIS_RV(NOT_EXEC);
CFst_Check(_this);
CFst_Check(itSrc);
if (idIndex)
{
if (CData_IsEmpty(idIndex)) return NOT_EXEC;
if (nPar<0)
for (i=0; i<CData_GetNComps(idIndex); i++)
if (dlp_is_numeric_type_code(CData_GetCompType(idIndex,i)))
{ nPar=i; break; }
if
(
nPar<0 || nPar>=CData_GetNComps(idIndex) ||
!dlp_is_numeric_type_code(CData_GetCompType(idIndex,nPar))
)
{
return IERROR(_this,FST_BADID,"component",nPar,0);
}
}
/* Initialize */
CREATEVIRTUAL(CFst,itSrc,_this);
CFst_Reset(BASEINST(_this),TRUE);
if (idIndex)
{
/* Loop over records of idIndex */
for (i=0; i<CData_GetNRecs(idIndex); i++)
{
nU = (INT32)CData_Dfetch(idIndex,i,nPar);
if (nU>=0 && nU<UD_XXU(itSrc)) {
DLPASSERT(OK(CFst_CatEx(_this,itSrc,nU,1)))
} else IERROR(_this,FST_BADID2,"unit",nU,0);
}
}
else if (nPar<0)
/**
* Prints the instance in list mode (old style, with option /list).
*/
INT16 CGEN_PUBLIC CData_PrintList(CData* _this)
{
INT32 nR = 0; /* Current record */
INT32 nXR = 0; /* Number of records */
INT32 nXC = 0; /* Number of components */
INT32 nRpb = 0; /* Number of records per block */
/* Initialize */ /* --------------------------------- */
nXR = CData_GetNRecs(_this); /* Get number of records */
nXC = CData_GetNComps(_this); /* Get number of components */
nRpb = CData_GetNRecsPerBlock(_this); /* Get number of records per block */
/* Print headings */ /* --------------------------------- */
printf("\n Rec.(offset):"); /* Protocol */
dlp_inc_printlines(CData_PrintRec(_this,-1,0,nXC,16)-1); /* Protocol */
/* Print values */ /* --------------------------------- */
for (nR=0; nR<nXR; ) /* Loop over records */
{ /* >> */
printf("\n%c %4ld (%06ld):",CData_RecIsMarked(_this,nR)?'*':' ',(long)nR, /* Print line header */
(long)((char*)CData_XAddr(_this,nR,0)-(char*)CData_XAddr(_this,0,0))); /* | */
dlp_inc_printlines(CData_PrintRec(_this,nR,0,nXC,16)); /* Print values */
if (nRpb>0 && (nR+1)%nRpb==0) /* Block boundary */
{ /* >> */
printf("\n - %c End of block %ld - - - - -", /* Print block delimiter */
CData_BlockIsMarked(_this,nR/nRpb)?'*':' ',(long)nR/nRpb); /* | */
dlp_inc_printlines(1); /* Adjust no. of printed lines */
} /* << */
if ((nR=dlp_printstop_nix(nR,"record",NULL))==-1) break; /* Break listing */
if (nR< -2 ) nR=0; /* Bad user reply -> start over */
if (nR>=nXR) break; /* No more records -> break */
} /* << */
if (nR>=nXR) printf("\n No more data - Stop."); /* Protocol */
else printf("\n Cancelled - Stop."); /* Protocol */
return O_K; /* Ok */
}
INT16 CDlpFile_Reset(CDlpObject* __this, BOOL bResetMembers)
{
GET_THIS_VIRTUAL_RV(CDlpFile,NOT_EXEC);
DEBUGMSG(-1,"CDlpFile_Reset; (bResetMembers=%d)",(int)bResetMembers,0,0);
{
/*{{CGEN_RESETCODE */
CData* idFlistData;
char lpsB1[255];
char lpsB2[255];
char lpsB3[ 32];
char lpsB4[255];
if (_this->m_idFlistData==NULL) IFIELD_RESET(CData,"flist_data");
IFIELD_RESET(CData,"recfile");
dlp_strcpy(lpsB1,_this->m_lpsFlist);
dlp_strcpy(lpsB2,_this->m_lpsPath);
dlp_strcpy(lpsB3,_this->m_lpsExt);
dlp_strcpy(lpsB4,_this->m_lpsSep);
idFlistData = AS(CData,_this->m_idFlistData);
_this->m_idFlistData = NULL;
RESET;
_this->m_idFlistData = BASEINST(idFlistData);
dlp_strcpy(_this->m_lpsFlist,lpsB1);
dlp_strcpy(_this->m_lpsPath ,lpsB2);
dlp_strcpy(_this->m_lpsExt ,lpsB3);
dlp_strcpy(_this->m_lpsSep ,lpsB4);
_this->m_nLen = CData_GetNRecs(AS(CData,_this->m_idFlistData));
/*}}CGEN_RESETCODE */
}
return O_K;
}
INT32 CGEN_PRIVATE CProcess::DoJobFork(CFunction *iCaller, CFunction *iFnc)
{
CData* idSign = NULL; // Signature table in iDto
CDlpObject* iArg = NULL; // Argument Object
INT32 nArg = -1; // Argument loop counter
char sArg[L_NAMES]; // Current argument name
char lpsCmd[256]; // String buffer
// Initialize // ------------------------------------
idSign = (CData*)CDlpObject_OfKind("data", // Get signature table
CDlpObject_FindInstance(m_iDto,PRC_S_IDSIGN)); // |
// Push arguments on Stack // ------------------------------------
for (nArg=CData_GetNRecs(idSign)-1; nArg>0; nArg--) // Loop over signature table
{ // >>
dlp_strcpy(sArg,CData_Sfetch(idSign,nArg,0)); // Get argument name
iArg = CDlpObject_FindInstance(m_iDto,sArg); // Find argument in iDto
if (CDlpObject_OfKind("var",iArg)) switch(AS(CVar,iArg)->m_nType){ // Primitve data types >>
case T_BOOL : iCaller->PushLogic (AS(CVar,iArg)->m_bBVal); break; // Push bool
case T_COMPLEX: iCaller->PushNumber(AS(CVar,iArg)->m_nNVal); break; // Push number
case T_STRING : iCaller->PushString(AS(CVar,iArg)->m_lpsSVal); break; // Push string
default: iCaller->PushNumber(CMPLX(0.)); break; // Default: push something
}else iCaller->PushInstance(iArg); // Push instances
} // <<
// Post commands in queue // ------------------------------------
iCaller->PostCommand(CData_Sfetch(idSign,0,0),NULL,-1,FALSE); // Put in queue: run the function
snprintf(lpsCmd,255,"%s.dto %s -marshal_retval;", // Put in queue: save return value
this->m_lpInstanceName,this->m_lpInstanceName); // |
iCaller->PostCommand(lpsCmd,NULL,-1,FALSE); // |
snprintf(lpsCmd,255,"\"%s.xml\" %s.dto /xml /zip -save;", // Put in queue: save data transfer object
m_psTmpFile,this->m_lpInstanceName); // |
iCaller->PostCommand(lpsCmd,NULL,-1,FALSE); // |
iCaller->PostCommand("quit;",NULL,-1,FALSE); // Put in queue: Quit the client process
return O_K; // Ok, run the queue
}
/**
* Unpacks the data transfer object <code>iDto</code> into <code>iCaller</code>.
*/
void CGEN_PROTECTED CProcess::Unmarshal(CDlpObject* iDto, CFunction* iCaller)
{
CData* idSign = NULL; // Signature table in iDto
CDlpObject* iSrc = NULL; // Source object
CDlpObject* iDst = NULL; // Destination object
INT32 nArg = -1; // Argument loop counter
char sArg[L_NAMES]; // Current argument name
// Initialize // ------------------------------------
idSign = (CData*)CDlpObject_OfKind("data", // Get signature table
CDlpObject_FindInstance(iDto,PRC_S_IDSIGN)); // |
// Unmarshal arguments // ------------------------------------
for (nArg=1; nArg<CData_GetNRecs(idSign); nArg++) // Loop over signature table
{ // >>
dlp_strcpy(sArg,CData_Sfetch(idSign,nArg,0)); // Get argument name
iSrc = CDlpObject_FindInstance(iDto,sArg); // Find argument in iDto
if (CDlpObject_OfKind("var",iSrc)) continue; // Ignore primitve data types
iDst = CDlpObject_FindInstance(iCaller,sArg); // Find argument in iCaller
if (!iDst) continue; // Not there -> nothing to do
iDst->Copy(iSrc); // Copy unmarshaled arg. to caller
} // <<
// Unmarshal return value // ------------------------------------
iSrc = CDlpObject_FindInstance(iDto,PRC_S_RETV); // Find return value in iDto
if (CDlpObject_OfKind("var",iSrc)) // Return value is a primitive
switch (((CVar*)iSrc)->m_nType) // Branch for type
{ // |
case T_BOOL : iCaller->PushLogic (((CVar*)iSrc)->m_bBVal ); break; // Push a boolean
case T_DOUBLE : // Push a number
case T_COMPLEX: iCaller->PushNumber(((CVar*)iSrc)->m_nNVal ); break; // Push a complex number
case T_STRING : iCaller->PushString(((CVar*)iSrc)->m_lpsSVal); break; // Push a string
} // |
else if (iSrc) // Return value is an instance
iCaller->PushInstance(iSrc); // Push it
}
/*
* Manual page at statistics.def
*/
INT16 CGEN_PUBLIC CStatistics_Update
(
CStatistics* _this,
CData* idVec,
INT32 nIcLab,
CData* idW
)
{
INT32 i = 0; /* Update vector loop counter */
INT32 I = 0; /* Number of update vectors */
INT32 c = 0; /* Class of current update vector */
INT32 C = 0; /* Number of classes */
INT32 n = 0; /* Dimension loop counter */
INT32 N = 0; /* Statistics' dimensionality */
FLOAT64 w = 0.; /* Weight of current update vector */
char* lpsLab = NULL; /* Symbolic label of curr. upd. vec. */
FLOAT64* lpX = NULL; /* Vector copy buffer */
INT32 nVecIgnored = 0; /* Number of ignored vectors */
/* Validate */ /* --------------------------------- */
CHECK_THIS_RV(NOT_EXEC); /* Check this pointer */
IF_NOK(CStatistics_Check(_this)) /* Check instance data */
return IERROR(_this,STA_NOTSETUP," ( use -status for details)",0,0); /* ... */
if (CData_IsEmpty(idVec)) return O_K; /* No input vector(s), no service! */
I = CData_GetNRecs(idVec); /* Get number of update vectors */
C = CStatistics_GetNClasses(_this); /* Get number of statitistics classes*/
N = CStatistics_GetDim(_this); /* Get statistics vector dimension */
if (C>1) /* Multiclass statistics needs labels*/
{ /* >> */
if (_this->m_idLtb) /* Need symbolic labels */
{ /* >> */
if ((nIcLab<0 || nIcLab>=CData_GetNComps(idVec))) /* Symbolic label comp. not spec.*/
for (nIcLab=0; nIcLab<CData_GetNComps(idVec); nIcLab++) /* Seek label component */
if (dlp_is_symbolic_type_code(CData_GetCompType(idVec,nIcLab))) /* ... */
break; /* ... */
if (!dlp_is_symbolic_type_code(CData_GetCompType(idVec,nIcLab))) /* Symbolic label comp. not found*/
return /* -> Error */
IERROR(_this,STA_BADCOMP,"Label",idVec->m_lpInstanceName,"symbolic"); /* | */
} /* << */
else /* Need numeric labels */
{ /* >> */
if (!dlp_is_numeric_type_code(CData_GetCompType(idVec,nIcLab)) && /* Numeric label comp. not found */
(nIcLab>=0 || CData_GetNComps(idW)!=C)) /* | */
return /* -> Error */
IERROR(_this,STA_BADCOMP,"Label",idVec->m_lpInstanceName,"numeric"); /* | */
} /* << */
} /* << */
/*else if (nIcLab>=0) IERROR(_this,STA_IGNORE,"label component",0,0); / * Only one class -> ignore labels */
if (dlp_is_numeric_type_code(CData_GetCompType(idVec,nIcLab))) /* Check no. of comps. in idVec ... */
{ /* >> */
if (CData_GetNNumericComps(idVec)!=N+1) /* Wrong number of numeric comps. */
IERROR(_this,STA_DIM,idVec->m_lpInstanceName,"numeric components",N+1); /* -> Warning */
} /* << */
else if (CData_GetNNumericComps(idVec)!=N) /* Wrong number of numeric comps. */
IERROR(_this,STA_DIM,idVec->m_lpInstanceName,"numeric components",N); /* -> Warning */
if (idW) /* Weigths passed -> check 'em */
{ /* >> */
if (!dlp_is_numeric_type_code(CData_GetCompType(idW,0))) /* Component 0 not numeric */
return /* -> Error */
IERROR(_this,STA_BADCOMP,"Weight",idW->m_lpInstanceName,"numeric"); /* | */
if (CData_GetNComps(idW)!=1 && CData_GetNComps(idW)!=C) /* More than one component */
IERROR(_this,STA_IGNORE,"components in weight sequence",0,0); /* -> Warning */
if (CData_GetNRecs(idW)!=I) /* Not exactly one weight per vec. */
IERROR(_this,STA_DIM,idW->m_lpInstanceName,"records",I); /* -> Warning */
} /* << */
/* Initialize - NO RETURNS BEYOND THIS POINT! - */ /* --------------------------------- */
lpX = (FLOAT64*)dlp_calloc(N,sizeof(FLOAT64)); /* Allocate vector copy buffer */
/* Update statistics */ /* --------------------------------- */
for (i=0; i<I; i++) /* Loop over update vectors */
{ /* >> */
/* Get vector label */ /* - - - - - - - - - - - - - - - - */
if (C>1) /* Multiclass stats. needs labels */
{ /* >> */
if (_this->m_idLtb) /* idVec contains symbolic labs. */
{ /* >> */
INT32 nLIdx = 0;
DLPASSERT(dlp_is_symbolic_type_code(CData_GetCompType(idVec,nIcLab))); /* Must be checked before! */
lpsLab = (char*)CData_XAddr(idVec,i,nIcLab); /* Get string ptr. to label */
if(_this->m_bLabel){
nLIdx=strlen(lpsLab)-1;
if(nLIdx && lpsLab[nLIdx]==']') nLIdx--; else nLIdx=0;
if(nLIdx && lpsLab[nLIdx]>='0' && lpsLab[nLIdx]<='9') nLIdx--; else nLIdx=0;
while(nLIdx && lpsLab[nLIdx]>='0' && lpsLab[nLIdx]<='9') nLIdx--;
if(nLIdx && lpsLab[nLIdx]=='[') lpsLab[nLIdx]='\0'; else nLIdx=0;
}
c = CData_Find(_this->m_idLtb,0,C,1,0,lpsLab); /* Look up label -> class idx. */
if(nLIdx) lpsLab[nLIdx]='[';
if (c<0) /* Label invalid */
{ /* >> */
IERROR(_this,STA_SLAB,i,lpsLab?lpsLab:"(null)",0); /* Warning */
continue; /* Ignore record */
} /* << */
} /* << */
else if(nIcLab>=0) /* idVec contains numeric labs. */
{ /* >> */
c = (INT32)CData_Dfetch(idVec,i,nIcLab); /* Fetch label */
if (c<0 || c>=C) /* Label invalid */
{ /* >> */
IERROR(_this,STA_NLAB,i,c,0); /* Warning */
continue; /* Ignore record */
} /* << */
} /* << */
else c = 0; /* Default class is 0 */
} /* << */
else c = 0; /* Default class is 0 */
do /* Loop over classes */
{ /* >> */
/* Get (weighted) update vector and update statistics */ /* - - - - - - - - - - - - - - - - */
if (idW) /* Using weights */
{ /* >> */
w = CData_Dfetch(idW,i,_this->m_idLtb || nIcLab>=0 ? 0 : c); /* Fetch weight for this vector */
if(w==0.) continue; /* Nothing to do if no weight */
_this->m_bWeighted=TRUE;
} else w=1.; /* << */
CData_DrecFetch(idVec,lpX,i,N,nIcLab); /* Fetch update vector */
fpclassify(0.);
for (n=0; n<N; n++) /* Loop over vector components */
if (fabs(lpX[n])>1E100) /* Check value */
break; /* There's something wrong ... */
if (n<N) { nVecIgnored++; continue; } /* Ignore this vector */
CStatistics_UpdateVector(_this,lpX,c,w); /* Update statistics with vector */
} /* << */
while(!_this->m_idLtb && nIcLab<0 && ++c<C); /* Next class if there is one */
} /* << */
/* Clean up */ /* --------------------------------- */
if (nVecIgnored>0) IERROR(_this,STA_VECIGNORED,nVecIgnored,0,0); /* Error: some vectors ignored */
dlp_free(lpX); /* Free vector copy buffer */
return O_K; /* Done */
}
/**
* Prints the content of one record formatted as columns. If printing requires
* more than <a href="dlp_base.html#cfn_dlp_maxprintcols">dlp_maxprintcols</a>
* characters the listing will be continued on the next line(s).</p>
*
* @param _this
* Pointer to data instance
* @param nRec
* Index of record to print
* @param nIcFirst
* Index of first component to print
* @param nComps
* Number of components to print
* @param nIndent
* Indentation (spaces) at beginning of lines (<b>Note</b>: the first
* line will <em>not</em> be indented!)
* @return The number of lines printed
*/
INT16 CGEN_PUBLIC CData_PrintRec
(
CData* _this,
INT32 nRec,
INT32 nIcFirst,
INT32 nComps,
INT16 nIndent
)
{
INT16 nLines = 1;
INT16 nCol = nIndent;
INT32 nXC = 0;
INT32 nC = 0;
INT16 i = 0;
INT16 I = 0;
char sBuf[L_SSTR+1];
nXC = CData_GetNComps(_this);
if (nIcFirst<0 || nIcFirst>=nXC) return 1; /* NOTE: This is still one line! */
if (nIcFirst+nComps>nXC) nComps=nXC-nIcFirst;
if (nRec>=CData_GetNRecs(_this)) return 0;
for (nC=nIcFirst,nCol=nIndent; nC<nIcFirst+nComps; nC++)
{
if (nRec<0)
{
/* Heading */
I=dlp_printlen(CData_GetCompType(_this,nC));
strcpy(sBuf," ");
for (i=I-(INT16)dlp_strlen(CData_GetCname(_this,nC))-1; i>0; i--) strcat(sBuf," ");
if(CData_CompIsMarked(_this,nC)) sBuf[dlp_strlen(sBuf)-2]='*';
strcat(sBuf,CData_GetCname(_this,nC));
nCol+=dlp_printlen(CData_GetCompType(_this,nC)); /* Count standard width (!) */
printf(sBuf);
}
else
{
/* Print values */
dlp_sprintx(sBuf,(char*)CData_XAddr(_this,nRec,nC),CData_GetCompType(_this,nC),_this->m_bExact);
nCol+=dlp_printlen(CData_GetCompType(_this,nC)); /* Count standard width (!) */
dlp_strconvert(SC_PRC_ESCAPE,sBuf,sBuf);
dlp_strreplace(sBuf,"\n","\\n");
dlp_strreplace(sBuf,"\r","\\r");
dlp_strreplace(sBuf,"\t","\\t");
printf(sBuf);
}
if ((nC<nIcFirst+nComps-1) &&
(nCol+dlp_printlen(CData_GetCompType(_this,nC+1))>dlp_maxprintcols()) )
{
/* Line break */
strcpy(sBuf,"\n");
for (i=nIndent-(nIndent>7?7:0); i>0;i--) strcat(sBuf," ");
printf(sBuf);
if (nIndent>7) printf("%5ld ",(long)(nC+1));
nCol=nIndent;
nLines++;
}
}
return nLines;
}
/**
* Computes the print widths of the head column and one data vector.
*/
INT16 CGEN_PRIVATE CData_PrintVectors_GetColWidth
(
CData* _this, /* Pointer to data instance */
INT32 nR0, /* First record to be printed */
INT32 nC0, /* First component to be printed */
INT32* lpnWI, /* Print width of comp.idx.col.(ret) */
INT32* lpnW0, /* Print width of head column (ret) */
INT32* lpnW /* Print width of data column (ret) */
) /* Returns O_K or (neg.) error code */
{
INT32 nR = 0; /* Current record */
INT32 nXR = 0; /* Number of records */
INT32 nC = 0; /* Current component */
INT32 nXC = 0; /* Number of components */
INT32 nWn = 0; /* Widest number in cols. of screen */
INT32 nWs = 0; /* Widest string in cols. of screen */
FLOAT64 nBuf = 0.; /* Double buffer */
char sBuf[L_SSTR+1]; /* String buffer */
UINT64 nTime = 0;
/* Initialize */ /* --------------------------------- */
*lpnW = 0; /* Data column width */
*lpnWI = 0; /* Component index column width */
*lpnW0 = 0; /* Head column width */
nXR = CData_GetNRecs(_this); /* Get number of records */
nXC = CData_GetNComps(_this); /* Get number of components */
/* Compute head column print width */ /* --------------------------------- */
for (*lpnW0=0,nC=nC0; nC<nXC; nC++) /* Loop over remaining components */
{ /* >> */
if /* Displaying physical units? */
( /* | */
dlp_is_numeric_type_code(CData_GetCompType(_this,nC)) && /* | Numeric component */
dlp_strlen(_this->m_lpCunit) && _this->m_nCinc!=0. /* | Physical units specified */
) /* | */
{ /* >> */
nBuf = _this->m_nCofs + nC*_this->m_nCinc; /* The physical coordinate */
__sprintx(sBuf,&nBuf,T_DOUBLE,_this->m_bExact); /* Print to a string */
} /* << */
else /* String comp. or no phys. units */
__sprintx(sBuf,CData_GetCname(_this,nC),10,_this->m_bExact); /* Print component name to str. */
*lpnW0 = MAX(*lpnW0,(INT32)dlp_strlen(sBuf)); /* Get length of phys. unit / name */
} /* << */
/* Compute component index column print width */ /* --------------------------------- */
nC--; /* Last component to be printed */
__sprintx(sBuf,&nC,T_INT,_this->m_bExact); /* Print greatest comp. index to str.*/
*lpnWI = (INT32)dlp_strlen(sBuf); /* Get length of component index col.*/
/* Compute data vector print width */ /* --------------------------------- */
nTime = dlp_time();
for (*lpnW=0,nR=nR0; nR<nXR; nR++) /* Loop over remaining records */
{ /* >> */
/* Determine width of physical unit */ /* - - - - - - - - - - - - - - - - */
if (dlp_strlen(_this->m_lpRunit) && _this->m_lpTable->m_fsr!=0.) /* Displaying physical units? */
{ /* >> */
nBuf = _this->m_lpTable->m_ofs + nR*_this->m_lpTable->m_fsr; /* The physical coordinate */
__sprintx(sBuf,&nBuf,T_DOUBLE,_this->m_bExact); /* Print to a string */
*lpnW = MAX((INT32)dlp_strlen(sBuf),*lpnW); /* Aggregate actual print width */
} /* << */
/* Determine width of record index */ /* - - - - - - - - - - - - - - - - */
__sprintx(sBuf,&nR,T_INT,_this->m_bExact); /* Print record index to a string */
*lpnW = MAX((INT32)dlp_strlen(sBuf),*lpnW); /* Aggregate actual print width */
/* Determine greatest component width */ /* - - - - - - - - - - - - - - - - */
for (nC=nC0; nC<nXC; nC++) /* Loop over remaining components */
{ /* >> */
__sprintx(sBuf,CData_XAddr(_this,nR,nC), /* Print cell value to a string */
CData_GetCompType(_this,nC),_this->m_bExact); /* | */
if (dlp_is_numeric_type_code(CData_GetCompType(_this,nC))) /* It is a number */
nWn = MAX((INT32)dlp_strlen(sBuf),nWn); /* Aggr. number print width */
else if (dlp_is_symbolic_type_code(CData_GetCompType(_this,nC))) /* It is a string */
nWs = MAX((INT32)dlp_strlen(sBuf),nWs); /* Aggr. string print width */
if (dlp_time()-nTime>__TIMEOUT) break; /* Takes too long -> forget it! */
} /* << */
if (dlp_time()-nTime>__TIMEOUT) break; /* Takes too long -> forget it! */
if ((nR-nR0+2)*((*lpnW)+1)>dlp_maxprintcols()-*lpnWI-*lpnW0-3) break; /* Next vec. would not fit anymore*/
} /* << */
/* If computing data vector print width timed out ... */ /* --------------------------------- */
if (dlp_time()-nTime>__TIMEOUT) /* There was a time out */
for (nC=nC0; nC<nXC; nC++) /* Loop over remaining components */
if (dlp_is_numeric_type_code(CData_GetCompType(_this,nC))) /* It is a number */
nWn = MAX(dlp_printlen(CData_GetCompType(_this,nC)),nWn); /* Use standard print width */
else if (dlp_is_symbolic_type_code(CData_GetCompType(_this,nC))) /* It is a string */
nWs = MAX(dlp_printlen(CData_GetCompType(_this,nC)),nWs); /* Also use std. print width */
/* Aftermath */ /* --------------------------------- */
if (nWs>dlp_maxprintcols()-(*lpnW0)-(*lpnWI)-3) /* Limit string width to line length */
nWs=dlp_maxprintcols()-(*lpnW0)-(*lpnWI)-3; /* ... */
if (nWn<=0) *lpnW = MAX(nWs,*lpnW); /* No numbers -> complete strings */
else *lpnW = MAX(nWn,*lpnW); /* Minimal space req. for numbers */
/*if (nWn>0 && *lpnW+3<nWs) (*lpnW) += 3;*/ /* Print a little more of the strs. */
if (nWn>0 && *lpnW<nWs) *lpnW = MIN(16,nWs); /* Print max. 16 chars. of strings */
return O_K; /* Ok */
}
/**
* Packs <code>nArgs<code> function arguments plus the zero-th argument (the
* function itself) from <code>iCaller</code>'s stack into the data transfer
* object <code>iDto</code>.
*/
void CGEN_PROTECTED CProcess::Marshal
(
CDlpObject* iDto,
CFunction* iCaller,
INT32 nArgs
)
{
CData* idSign = NULL; // Signature table
StkItm* pStkItm = NULL; // Stack item to marshal
INT32 nArg = 0; // Argument loop counter
#ifndef USE_FORK
CDlpObject* iRoot = NULL;
CDlpObject* iSrc = NULL;
CDlpObject* iDst = NULL;
CData* idGlob = NULL; // Globals table
CData* idIncl = NULL; // Includes table
hscan_t hs;
hnode_t* hn;
SWord* lpWord = NULL;
char* psClsName;
char* psInsName;
#endif
// Marshal function arguments // ------------------------------------
idSign = (CData*)CDlpObject_Instantiate(iDto,"data",PRC_S_IDSIGN,FALSE); // Create signature table
CData_AddComp(idSign,"name",L_SSTR); // Add component to table
for (nArg=0; nArg<=nArgs; nArg++) // Loop over arguments
{ // >>
pStkItm = iCaller->StackGet(0); // Get stack top
Pack(iDto,idSign,pStkItm,NULL); // Pack into data transfer object
iCaller->Pop(FALSE); // Remove stack top
} // <<
#ifndef USE_FORK
// Marshal global variables // ------------------------------------
iRoot = GetRoot(); // Get root function
if (m_bGlobal && iRoot) // /global option set
{ // >>
idGlob = (CData*)CDlpObject_Instantiate(iDto,"data",PRC_S_IDGLOB,FALSE); // Create globals table
CData_AddComp(idGlob,"clas",L_SSTR); // Add component to table
CData_AddComp(idGlob,"name",L_SSTR); // Add component to table
hash_scan_begin(&hs,iRoot->m_lpDictionary); // Initialize
while ((hn = hash_scan_next(&hs))!=NULL) // Loop over root function's dict.
{ // >>
lpWord = (SWord*)hnode_get(hn); // Get pointer to SWord struct
if ((lpWord->nWordType == WL_TYPE_INSTANCE) && lpWord->lpData) // Entry is a non-NULL instance
{ // >>
iSrc = (CDlpObject*)lpWord->lpData; // Get instance pointer
psClsName = iSrc->m_lpClassName; // Get pointer to class name
psInsName = iSrc->m_lpInstanceName; // Get pointer to instance name
//if (CDlpObject_OfKind("function",iSrc)) continue; // No functions, please
if (iSrc==iCaller) continue; // Not the caller!
if (iSrc->m_nClStyle & CS_SINGLETON) continue; // No singletons!
if (CDlpObject_FindInstanceWord(m_iDto,psInsName,NULL)) continue; // Shadowed by an argument
iDst = CDlpObject_Instantiate(m_iDto,psClsName,psInsName,FALSE); // Create copy to pack
iDst->Copy(iSrc); // Copy content
CData_AddRecs(idGlob,1,10); // Add index entry
CData_Sstore(idGlob,psClsName,CData_GetNRecs(idGlob)-1,0); // Write index entry
CData_Sstore(idGlob,psInsName,CData_GetNRecs(idGlob)-1,1); // Write index entry
} // <<
} // <<
} // <<
// Marshal includes // ------------------------------------
if (m_bInclude && iRoot) // /include option set
{ // >>
idIncl = (CData*)CDlpObject_Instantiate(iDto,"data",PRC_S_IDINCL,FALSE); // Create include table
CData_Copy(idIncl,((CFunction*)iRoot)->m_idSfl); // Copy includes
} // <<
#endif
}
/**
* Prints one block of the instance in vector mode (standard).
*/
INT32 CGEN_PRIVATE CData_PrintVectors_Block
(
CData* _this, /* Pointer to data instance */
INT32 nBlock /* Block index (<0: ignore blocks) */
) /* Returns number of lines printed */
{
INT32 i = 0; /* Universal loop counter */
INT32 nR = 0; /* Current record */
INT32 nR_ = 0; /* First record to be printed */
INT32 nR0 = 0; /* First record of current page */
INT32 nSR = 0; /* Number of records of currenr page */
INT32 nXR = 0; /* Last record to print plus one */
INT32 nC = 0; /* Current component */
INT32 nXC = 0; /* Number of components */
INT32 nWI = 0; /* Component index column width */
INT32 nW0 = 0; /* Head column width */
INT32 nW = 0; /* Column width */
INT32 nP = 0; /* Current page */
INT32 nPps = 0; /* Pages per screen */
INT32 nL = 0; /* Line counter */
BOOL bPur = FALSE; /* Print physical record unit flag */
BOOL bPuc = FALSE; /* Print physical component unit flg.*/
FLOAT64 nBuf = 0.; /* Double buffer */
char sBuf[L_SSTR+1]; /* String buffer */
/* Validate */ /* --------------------------------- */
if (nBlock>=CData_GetNBlocks(_this)) return 0; /* Requested block does not exist */
/* Initialize */ /* --------------------------------- */
nR_ = nBlock>=0 ? CData_GetNRecsPerBlock(_this)*nBlock : 0; /* Get first record to print */
nXR = nBlock>=0 ? nR_+CData_GetNRecsPerBlock(_this) : CData_GetNRecs(_this); /* Get number of records */
nXC = CData_GetNComps(_this); /* Get number of components */
bPur = _this->m_lpTable->m_fsr!=1. && _this->m_lpTable->m_fsr!=0.; /* Displaying physical record units? */
bPuc = _this->m_nCinc!=1. && _this->m_nCinc!=0.; /* Displaying physical comp. units? */
nPps = dlp_maxprintlines()/(nXC+4); /* Compute no. of pages per sceeen */
/* Print vectors */ /* --------------------------------- */
if (nBlock>=0) /* Printing blockwise? */
{ /* >> */
printf("\n Block %ld (offset %ld)",(long)nBlock,(long)nR_); /* Show current block index */
dlp_inc_printlines(1); nL++; /* Adjust number of printed lines */
} /* << */
for (nR0=nR_; nR0<nXR; ) /* Loop over records */
{ /* >> */
CData_PrintVectors_GetColWidth(_this,nR0,0,&nWI,&nW0,&nW); /* Comp. head and data col. widths */
nSR = (dlp_maxprintcols()-nWI-nW0-4)/(nW+1); /* Number of columns to print */
if (nR0+nSR>nXR) nSR = nXR-nR0; /* No more than there are records! */
/* Print record header */ /* - - - - - - - - - - - - - - - - */
if (bPur) /* Display physical record units? */
{ /* >> */
printf("\n %s ->",__pad(strcpy(sBuf,_this->m_lpRunit),nW0+nWI,'r')); /* Print name of physical unit */
for (nR=nR0; nR<nR0+nSR; nR++) /* Loop over remaining records */
{ /* >> */
nBuf = _this->m_lpTable->m_ofs + (nR-nR_)*_this->m_lpTable->m_fsr; /* Compute abscissa value */
__sprintx(sBuf,&nBuf,T_DOUBLE,_this->m_bExact); /* Print to a string */
printf("%s ",__pad(sBuf,nW,'r')); /* Format and print to screen */
} /* << */
dlp_inc_printlines(1); nL++; /* Adjust number of printed lines*/
} /* << */
sBuf[0]='\0'; /* Clear string buffer */
if (bPuc) sprintf(sBuf,"%s| ",_this->m_lpCunit); /* Print phys. comp. unit name... */
printf("\n %s",__pad(sBuf,nW0+nWI+3,'r')); /* ... or empty string */
for (nR=nR0; nR<nR0+nSR; nR++) /* Loop over remaining records */
{ /* >> */
i=nR-nR_; __sprintx(sBuf,&i,T_INT,_this->m_bExact); /* Print record index to a str. */
printf("%s%c",__pad(sBuf,nW,'r'),CData_RecIsMarked(_this,nR)?'*':' '); /* Format and print to screen */
} /* << */
sBuf[0]='\0'; /* Clear string buffer */
if (bPuc) sprintf(sBuf,"%c ",bPuc?'v':' '); /* Print down arrow ... */
printf("\n %s",__pad(sBuf,nW0+nWI+3,'r')); /* ... or empty string */
sBuf[0]='\0'; for (i=0; i<nW; i++) sBuf[i]='.'; sBuf[i]='\0'; /* Make horizonal delimiter */
for (nR=nR0; nR<nR0+nSR; nR++) printf("%s ",sBuf); /* Print one per vector */
dlp_inc_printlines(2); nL+=2; /* Adjust number of printed lines */
/* Print data */ /* - - - - - - - - - - - - - - - - */
for (nC=0; nC<nXC; ) /* Loop over components */
{ /* >> */
__sprintx(sBuf,&nC,T_INT,_this->m_bExact); /* Print comp. index to a string */
printf("\n%c%s ", /* Format and print to screen */
CData_CompIsMarked(_this,nC)?'*':' ',__pad(sBuf,nWI,'r')); /* | (incl. "*" for "marked") */
if (bPuc && dlp_is_numeric_type_code(CData_GetCompType(_this,nC))) /* Display ordinate value? */
{ /* >> */
nBuf = _this->m_nCofs + nC*_this->m_nCinc; /* Compute it */
__sprintx(sBuf,&nBuf,T_DOUBLE,_this->m_bExact); /* Print it to a string */
} /* << */
else strcpy(sBuf,CData_GetCname(_this,nC)); /* else display component name */
printf("%s: ",__pad(dlp_strtrimleft(dlp_strtrimright(sBuf)),nW0,'r')); /* Format and print to screen */
for (nR=nR0; nR<nR0+nSR; nR++) /* Loop over remaining records */
{ /* >> */
__sprintx(sBuf,CData_XAddr(_this,nR,nC), /* Print cell value to a str. */
CData_GetCompType(_this,nC),_this->m_bExact); /* | */
if (dlp_is_symbolic_type_code(CData_GetCompType(_this,nC))) /* Is string value */
if ((INT32)dlp_strlen(sBuf)>nW) /* Will not fit in column */
dlp_strabbrv(sBuf,sBuf,nW); /* Abbreviate it */
if (dlp_is_numeric_type_code(CData_GetCompType(_this,nC))) /* Is numeric value */
if (_this->m_bNz && CMPLX_EQUAL(CData_Cfetch(_this,nR,nC),CMPLX(0.)))
dlp_strcpy(sBuf,"-");
printf("%s%c",__pad(sBuf,nW,'r'), /* Format and print to screen */
CData_CellIsMarked(_this,nR*CData_GetNComps(_this)+nC)?'*':' '); /* | (incl. "*" for "marked") */
} /* << */
dlp_inc_printlines(1); nL++; /* Adjust number of printed lines*/
/* Break component listing */ /* - - - - - - - - - - - - - - - */
if (nPps==0) /* Not all comps. fit on screen */
{ /* >> */
sprintf(sBuf,"component (0..%ld), cancel -3",(long)nXC-1); /* Make user hint */
if ((nC=dlp_printstop_nix(nC,sBuf,NULL))==-1) break; /* Break listing */
if (nC< -2 ) return -1; /* Cancelled by user */
if (nC>=nXC) break; /* No more components -> break */
} /* << */
else nC++; /* No breaking -> count comps. */
} /* << */
nR0+=nSR; /* First record on next page */
nP++; /* Count pages */
if (nR0<nXR) /* There are more records */
{ /* >> */
printf("\n"); dlp_fprint_x_line(stdout,'-',dlp_maxprintcols()); /* Print a separator */
dlp_inc_printlines(1); nL++; /* Adjust number of printed lines*/
} /* << */
/* Break record listing */ /* - - - - - - - - - - - - - - - - */
if (((nPps>0 && nP>=nPps) || nPps==0) && nR0<nXR) /* Complicated break condition :) */
{ /* >> */
dlp_inc_printlines(dlp_maxprintlines()); /* Do stop right here */
sprintf(sBuf,"record (%ld..%ld)%s",(long)nR_,(long)nXR-1, /* Make user hint */
nBlock>=0?", cancel -3":""); /* | */
if ((nR0=dlp_printstop_nix(--nR0,sBuf,NULL))==-1) break; /* Break listing */
if (nR0< -2 ) return -1; /* Cancelled by user */
if (nR0< nR_) nR0=nR_; /* No previous blocks, please! */
if (nR0>=nXR) break; /* No more records -> break */
nP=0; /* Reset page counter */
} /* << */
} /* << */
return nL; /* Return number of printed lines */
}
void CGEN_PUBLIC CVmap_MapVectorF
#else
void CGEN_PUBLIC CVmap_MapVectorD
#endif
(
CVmap* _this,
VMAP_FTYPE* lpX,
VMAP_FTYPE* lpY,
INT32 nXdim,
INT32 nYdim
)
{
BOOL f = 1; /* First non-zero summand flag */
INT32 n = 0; /* Input dimension loop counter */
INT32 m = 0; /* Output dimension loop counter */
INT32 N = 0; /* Input dimensionality of mapping */
INT32 M = 0; /* Output dimensionality of mapping */
VMAP_FTYPE* W = NULL; /* Pointer to transformation matrix */
VMAP_FTYPE* Wm = NULL; /* Pointer to column m of trafo.mtx. */
/* Initialize */ /* --------------------------------- */
CHECK_THIS(); /* Check this pointer */
if (!lpY) return; /* No output buffer, no service */
DLPASSERT(lpX!=lpY); /* Check in-/output ptrs. not equal */
for (m=0; m<nYdim; m++) lpY[m]=_this->m_nZero; /* Initialize output vector */
if (!lpX) return; /* If no input vector -> all done */
N = CData_GetNComps(AS(CData,_this->m_idTmx)); /* Get mapping input dimensionality */
M = CData_GetNRecs(AS(CData,_this->m_idTmx)); /* Get mapping output dimensionality */
if (nXdim>N) nXdim = N; /* Clip input dim. to mapping dim. */
if (nYdim>M) nYdim = M; /* Clip output dim. to mapping dim. */
if(CData_IsEmpty(AS(CData,_this->m_idWeakTmx))) /* Do not use weak tmx */
{ /* >> */
W = (VMAP_FTYPE*)CData_XAddr(AS(CData,_this->m_idTmx),0,0); /* Get pointer to trafo. matrix */
if (!W) return; /* No trafo. mat., also no service */
/* Compute generalized scalar product for each y[m] */ /* ------------------------------- */
for (m=0; m<nYdim; m++) /* Loop over output dimensions */
for (n=0,f=1,Wm=&W[m*N]; n<nXdim; n++) /* Loop over input dimensions */
if (Wm[n]!=_this->m_nZero) /* Weight of comp. n non-zero */
{ /* >> */
if (f) /* First summand */
{ /* >> */
lpY[m] = DLP_SCALOP(Wm[n],lpX[n],_this->m_nWop); /* Skip aggregation op */
f = 0; /* This WAS the first one..*/
} /* << */
else /* Second and further summd's*/
lpY[m] = DLP_SCALOP(lpY[m],DLP_SCALOP(Wm[n],lpX[n],_this->m_nWop), /* Weight & aggregate */
_this->m_nAop); /* | */
} /* << */
}else{ /* << Use weak tmx >> */
BYTE* Id = NULL; /* Pointer to index vector */
INT32 nRecLen = CData_GetRecLen(AS(CData,_this->m_idWeakTmx)); /* Get size of one record */
INT16 nIType = CData_GetCompType(AS(CData,_this->m_idWeakTmx),0);
nXdim = CData_GetNRecs(AS(CData,_this->m_idWeakTmx)); /* Get max. numb. of out's per in */
for (m=0;m<nYdim;m++) /* Loop over output dimensions */
{ /* >> */
Id=CData_XAddr(AS(CData,_this->m_idWeakTmx),0,m*2); /* Get start adress of component */
switch(nIType){
case T_LONG:
for (n=0;n<nXdim && *((INT64*)Id)>=0;n++,Id+=nRecLen) /* Loop over in's for this out */
if(!n) lpY[m]=DLP_SCALOP(*((VMAP_FTYPE *)(Id+sizeof(INT64))), /* First input => */
lpX[*((INT64*)Id)],_this->m_nWop); /* | Calc out from in */
else lpY[m]=DLP_SCALOP(lpY[m], /* Else => Calc out from */
DLP_SCALOP(*((VMAP_FTYPE *)(Id+sizeof(INT64))), /* | */
lpX[*((INT64*)Id)],_this->m_nWop),_this->m_nAop); /* | prev. out and in */
break;
case T_INT:
for (n=0;n<nXdim && *((INT32*)Id)>=0;n++,Id+=nRecLen) /* Loop over in's for this out */
if(!n) lpY[m]=DLP_SCALOP(*((VMAP_FTYPE *)(Id+sizeof(INT32))), /* First input => */
lpX[*((INT32*)Id)],_this->m_nWop); /* | Calc out from in */
else lpY[m]=DLP_SCALOP(lpY[m], /* Else => Calc out from */
DLP_SCALOP(*((VMAP_FTYPE *)(Id+sizeof(INT32))), /* | */
lpX[*((INT32*)Id)],_this->m_nWop),_this->m_nAop); /* | prev. out and in */
break;
default:
IERROR(_this,ERR_INVALARG,"weaktmx int type is wheter int nor long",0,0);
}
} /* << */
} /* << */
}
return NOT_EXEC;
}
IFCHECK printf("present");
nType = CData_IsHomogen(_this->m_idDat);
IFCHECK printf("\n - Data type : %ld ",(long)nType);
if (nType!=T_DOUBLE)
{
IFCHECK
{
if (nType==0) printf("NOT HOMOGENOUS -> INVALID");
else printf("BAD TYPE, should be double");
}
return NOT_EXEC;
}
IFCHECK printf("ok");
nXR = CData_GetNRecs(_this->m_idDat);
N = CStatistics_GetDim(_this);
C = CStatistics_GetNClasses(_this);
IFCHECK printf("\n - Number of records : %ld ",(long)nXR);
if (nXR<C*(N+4))
{
IFCHECK printf("NOT OK, should be >= %ld*(%ld+4)",(long)C,(long)N);
return NOT_EXEC;
}
IFCHECK printf("ok");
return O_K;
}
/**
* Checks the statistics' label table (field m_idLtb) for consistency.
/*
* Manual page at statistics.def
*/
INT16 CGEN_PUBLIC CStatistics_Pool
(
CStatistics* _this,
CStatistics* iSrc,
CData* idMap
)
{
INT32 i = 0; /* Current component index */
INT32 nC = 0; /* Current pooled statistics class */
INT32 nCs = 0; /* Current source class index */
INT32 nXC = 0; /* Number of pooled classes */
INT32 nRpb = 0; /* Statistics raw data block size */
INT16 nCheckSave = 0; /* Saved check level */
CData* idAux = NULL; /* Auxilary data instance #1 */
CData* idPmp = NULL; /* Pooling map */
CData* idPcd = NULL; /* Pooled class raw data buffer */
/* Initialize */ /* --------------------------------- */
CHECK_THIS_RV(0); /* Check this instance */
IF_NOK(CStatistics_Check(iSrc)) /* Check source statistics */
return IERROR(_this,ERR_INVALARG,"iSrc",0,0); /* ... */
nCheckSave = _this->m_nCheck; /* Save check level */
CStatistics_Reset(BASEINST(_this),TRUE); /* Reset destination */
_this->m_nCheck = nCheckSave; /* Restore check level */
IFIELD_RESET(CData,"dat"); /* Create pool raw stats. data inst. */
/* Protocol */ /* --------------------------------- */
IFCHECK /* On verbose level 1 */
{ /* >> */
printf("\n"); dlp_fprint_x_line(stdout,'-',dlp_maxprintcols()); /* Print protocol header */
printf("\n statistics -pool"); /* ... */
printf("\n"); dlp_fprint_x_line(stdout,'-',dlp_maxprintcols());printf("\n");/* ... */
} /* << */
/* No map --> pool all classes */ /* --------------------------------- */
if (CData_IsEmpty(idMap)) /* NULL or empty map instance */
{ /* >> */
IFCHECK printf("\n Empty pooling map --> pool all classes"); /* Protocol (verbose level 1) */
CStatistics_PoolInt(_this->m_idDat,iSrc->m_idDat,0); /* Pool sum data */
CStatistics_PoolInt(_this->m_idDat,iSrc->m_idDat,1); /* Pool min data */
CStatistics_PoolInt(_this->m_idDat,iSrc->m_idDat,2); /* Pool max data */
STA_PROTOCOL_FOOTER(1,"done"); /* Print protocol footer */
return O_K; /* That's it */
}
IFCHECK printf("\n Pooling by map"); /* Protocol (verbose level 1) */
ICREATEEX(CData,idAux,"CStatistics_Pool.~idAux",NULL); /* Create auxilary data instance #1 */
ICREATEEX(CData,idPmp,"CStatistics_Pool.~idPmp",NULL); /* Create pooling map */
ICREATEEX(CData,idPcd,"CStatistics_Pool.~idPcs",NULL); /* Create pooled raw stats.data inst.*/
/* Find and copy map component (pooled class) */ /* --------------------------------- */
for (i=0; i<CData_GetNComps(idMap); i++) /* Loop over components of idMap */
if (dlp_is_numeric_type_code(CData_GetCompType(idMap,i))) /* Is current component numeric? */
{ /* >> (Yes) */
CData_SelectComps(idPmp,idMap,i,1); /* Copy component */
break; /* Have ready :) */
} /* << */
if (CData_IsEmpty(idPmp)) /* Have not got map component */
{ /* >> */
IERROR(_this,STA_BADCOMP,"map",BASEINST(idMap)->m_lpInstanceName,"numeric");/* Error message */
DLPTHROW(STA_BADCOMP); /* Throw exception */
} /* << */
/* Create source class component */ /* --------------------------------- */
CData_AddComp(idPmp,"srcc",T_LONG); /* Add source class index component */
for (i=0; i<CData_GetNRecs(idPmp); i++) CData_Dstore(idPmp,i,i,1); /* Fill it */
/* Finish pooling map and initialize pooling */ /* --------------------------------- */
CData_Sortup(idPmp,idPmp,0); /* Sort map by pooled class index */
nXC = (INT32)CData_Dfetch(idPmp,CData_GetNRecs(idPmp)-1,0)+1; /* Get greatest pooled class index */
IFCHECK printf("\n Pooling %ld statistics classes",(long)nXC); /* Protocol (verbose level 1) */
IFCHECKEX(3) CData_Print(idPmp); /* Print pooling map (verbose lvl.3) */
nRpb = CData_GetNRecsPerBlock(iSrc->m_idDat); /* Get block size */
/* Prepare pooled statistics */ /* --------------------------------- */
CData_Scopy(_this->m_idDat,iSrc->m_idDat); /* Create target raw data components */
CData_Allocate(_this->m_idDat,nRpb*nXC); /* Allocate target raw data */
CData_SetNBlocks(_this->m_idDat,nXC); /* Set target statistics block number*/
/* Pooling loop */ /* --------------------------------- */
for (i=0; i<CData_GetNRecs(idPmp); ) /* Loop over pooling map */
{ /* >> */
/* - Copy raw statistics data of one pooled class */ /* - - - - - - - - - - - - - - - - */
nC = (INT32)CData_Dfetch(idPmp,0,0); /* Get pooled class index */
IFCHECK printf("\n Pooled class %3ld"); /* Protocol (verbose level 1) */
for (i=0; i<CData_GetNRecs(idPmp); i++) /* Loop over partition of pool.map */
{ /* >> */
if (nC != (INT32)CData_Dfetch(idPmp,0,0)) break; /* Not the current class anymore */
nCs = (INT32)CData_Dfetch(idPmp,i,1); /* Get source class index */
IFCHECK printf("\n - Source class %3ld",nCs); /* Protocol (verbose level 1) */
CData_SelectBlocks(idAux,iSrc->m_idDat,nCs,1); /* Copy raw stats. data block */
CData_Cat(idPcd,idAux); /* Append to buffer */
} /* << */
/* - Pool data */ /* - - - - - - - - - - - - - - - - */
CData_SetNBlocks(idPcd,CData_GetNRecs(idPcd)/nRpb); /* Set block count of aggr. buffer */
IFCHECK /* Protocol (verbose level 1) */
printf("\n - Aggregating %ld statistics classes", /* | */
(long)CData_GetNBlocks(idPcd)); /* | */
CStatistics_PoolInt(idAux,idPcd,0); /* Pool sum data */
CStatistics_PoolInt(idAux,idPcd,1); /* Pool min data */
CStatistics_PoolInt(idAux,idPcd,2); /* Pool max data */
/* - Store pooled raw statistics data block */ /* - - - - - - - - - - - - - - - - */
dlp_memmove /* Copy pooled raw stats. data */
( /* | */
CData_XAddr(_this->m_idDat,nC*nRpb,0), /* | To target statistics block */
CData_XAddr(idAux,0,0), /* | From aggregation buffer */
CData_GetNRecs(idAux)*CData_GetRecLen(idAux) /* | Length of aggregation buffer */
); /* | */
/* - Clean up auxilary instances */ /* - - - - - - - - - - - - - - - - */
CData_Reset(idPcd,TRUE); /* Clear aggregation buffer */
}
/* Clean up */ /* --------------------------------- */
IDESTROY(idAux); /* Destroy auxilary data instance #1 */
IDESTROY(idPmp); /* Destroy pooling map */
IDESTROY(idPcd); /* Destroy pooled cls. raw data inst.*/
STA_PROTOCOL_FOOTER(1,"done"); /* Print protocol footer */
return O_K; /* Ok */
DLPCATCH(STA_BADCOMP) /* == Catch STA_BADCOMP exception */
IDESTROY(idAux); /* Destroy auxilary data instance #1 */
IDESTROY(idPmp); /* Destroy pooling map */
IDESTROY(idPcd); /* Destroy pooled cls. raw data inst.*/
STA_PROTOCOL_FOOTER(1,"FAILED"); /* Print protocol footer */
return NOT_EXEC; /* Not ok */
}
