int
TkpUseWindow(
Tcl_Interp *interp, /* If not NULL, used for error reporting if
* string is bogus. */
Tk_Window tkwin, /* Tk window that does not yet have an
* associated X window. */
const char *string) /* String identifying an X window to use for
* tkwin; must be an integer value. */
{
TkWindow *winPtr = (TkWindow *) tkwin;
TkWindow *usePtr;
int id, anyError;
Window parent;
Tk_ErrorHandler handler;
Container *containerPtr;
XWindowAttributes parentAtts;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
if (winPtr->window != None) {
Tcl_AppendResult(interp,
"can't modify container after widget is created", NULL);
return TCL_ERROR;
}
if (Tcl_GetInt(interp, string, &id) != TCL_OK) {
return TCL_ERROR;
}
parent = (Window) id;
usePtr = (TkWindow *) Tk_IdToWindow(winPtr->display, parent);
if (usePtr != NULL) {
if (!(usePtr->flags & TK_CONTAINER)) {
Tcl_AppendResult(interp, "window \"", usePtr->pathName,
"\" doesn't have -container option set", NULL);
return TCL_ERROR;
}
}
/*
* Tk sets the window colormap to the screen default colormap in
* tkWindow.c:AllocWindow. This doesn't work well for embedded windows. So
* we override the colormap and visual settings to be the same as the
* parent window (which is in the container app).
*/
anyError = 0;
handler = Tk_CreateErrorHandler(winPtr->display, -1, -1, -1,
EmbedErrorProc, (ClientData) &anyError);
if (!XGetWindowAttributes(winPtr->display, parent, &parentAtts)) {
anyError = 1;
}
XSync(winPtr->display, False);
Tk_DeleteErrorHandler(handler);
if (anyError) {
if (interp != NULL) {
Tcl_AppendResult(interp, "couldn't create child of window \"",
string, "\"", NULL);
}
return TCL_ERROR;
}
Tk_SetWindowVisual(tkwin, parentAtts.visual, parentAtts.depth,
parentAtts.colormap);
/*
* Create an event handler to clean up the Container structure when tkwin
* is eventually deleted.
*/
Tk_CreateEventHandler(tkwin, StructureNotifyMask, EmbeddedEventProc,
(ClientData) winPtr);
/*
* Save information about the container and the embedded window in a
* Container structure. If there is already an existing Container
* structure, it means that both container and embedded app. are in the
* same process.
*/
for (containerPtr = tsdPtr->firstContainerPtr; containerPtr != NULL;
containerPtr = containerPtr->nextPtr) {
if (containerPtr->parent == parent) {
winPtr->flags |= TK_BOTH_HALVES;
containerPtr->parentPtr->flags |= TK_BOTH_HALVES;
break;
}
}
if (containerPtr == NULL) {
containerPtr = (Container *) ckalloc(sizeof(Container));
containerPtr->parent = parent;
containerPtr->parentRoot = parentAtts.root;
containerPtr->parentPtr = NULL;
containerPtr->wrapper = None;
containerPtr->nextPtr = tsdPtr->firstContainerPtr;
tsdPtr->firstContainerPtr = containerPtr;
}
containerPtr->embeddedPtr = winPtr;
winPtr->flags |= TK_EMBEDDED;
return TCL_OK;
}
static int tcl_whom(ClientData cd, Tcl_Interp *irp,
int argc, char *argv[])
{
int chan, i;
char c[2], idle[11], work[20], *p;
long tv = 0;
EGG_CONST char *list[7];
BADARGS(2, 2, " chan");
if (argv[1][0] == '*')
chan = -1;
else {
if ((argv[1][0] < '0') || (argv[1][0] > '9')) {
Tcl_SetVar(interp, "chan", argv[1], 0);
if ((Tcl_VarEval(interp, "assoc ", "$chan", NULL) != TCL_OK) ||
!interp->result[0]) {
Tcl_AppendResult(irp, "channel name is invalid", NULL);
return TCL_ERROR;
}
chan = atoi(interp->result);
} else
chan = atoi(argv[1]);
if ((chan < 0) || (chan > 199999)) {
Tcl_AppendResult(irp, "channel out of range; must be 0 through 199999",
NULL);
return TCL_ERROR;
}
}
for (i = 0; i < dcc_total; i++)
if (dcc[i].type == &DCC_CHAT) {
if (dcc[i].u.chat->channel == chan || chan == -1) {
c[0] = geticon(i);
c[1] = 0;
tv = (now - dcc[i].timeval) / 60;
egg_snprintf(idle, sizeof idle, "%li", tv);
list[0] = dcc[i].nick;
list[1] = botnetnick;
list[2] = dcc[i].host;
list[3] = c;
list[4] = idle;
list[5] = dcc[i].u.chat->away ? dcc[i].u.chat->away : "";
if (chan == -1) {
egg_snprintf(work, sizeof work, "%d", dcc[i].u.chat->channel);
list[6] = work;
}
p = Tcl_Merge((chan == -1) ? 7 : 6, list);
Tcl_AppendElement(irp, p);
Tcl_Free((char *) p);
}
}
for (i = 0; i < parties; i++) {
if (party[i].chan == chan || chan == -1) {
c[0] = party[i].flag;
c[1] = 0;
if (party[i].timer == 0L)
strcpy(idle, "0");
else {
tv = (now - party[i].timer) / 60;
egg_snprintf(idle, sizeof idle, "%li", tv);
}
list[0] = party[i].nick;
list[1] = party[i].bot;
list[2] = party[i].from ? party[i].from : "";
list[3] = c;
list[4] = idle;
list[5] = party[i].status & PLSTAT_AWAY ? party[i].away : "";
if (chan == -1) {
egg_snprintf(work, sizeof work, "%d", party[i].chan);
list[6] = work;
}
p = Tcl_Merge((chan == -1) ? 7 : 6, list);
Tcl_AppendElement(irp, p);
Tcl_Free((char *) p);
}
}
return TCL_OK;
}
static int
SetPixelFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
const Tcl_ObjType *typePtr;
char *string, *rest;
double d;
int i, units;
string = Tcl_GetString(objPtr);
d = strtod(string, &rest);
if (rest == string) {
goto error;
}
while ((*rest != '\0') && isspace(UCHAR(*rest))) {
rest++;
}
switch (*rest) {
case '\0':
units = -1;
break;
case 'm':
units = 0;
break;
case 'c':
units = 1;
break;
case 'i':
units = 2;
break;
case 'p':
units = 3;
break;
default:
goto error;
}
/*
* Free the old internalRep before setting the new one.
*/
typePtr = objPtr->typePtr;
if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
(*typePtr->freeIntRepProc)(objPtr);
}
objPtr->typePtr = &pixelObjType;
i = (int) d;
if ((units < 0) && (i == d)) {
SET_SIMPLEPIXEL(objPtr, i);
} else {
PixelRep *pixelPtr = (PixelRep *) ckalloc(sizeof(PixelRep));
pixelPtr->value = d;
pixelPtr->units = units;
pixelPtr->tkwin = NULL;
pixelPtr->returnValue = i;
SET_COMPLEXPIXEL(objPtr, pixelPtr);
}
return TCL_OK;
error:
if (interp != NULL) {
/*
* Must copy string before resetting the result in case a caller is
* trying to convert the interpreter's result to pixels.
*/
char buf[100];
sprintf(buf, "bad screen distance \"%.50s\"", string);
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, buf, NULL);
}
return TCL_ERROR;
}
int tclcommand_metadynamics_print_status(Tcl_Interp *interp)
{
char buffer[TCL_DOUBLE_SPACE];
/* metadynamics not initialized */
if(meta_pid1 == -1 || meta_pid2 == -1) {
Tcl_AppendResult(interp,"{ not initialized } ", (char *)NULL);
return (TCL_OK);
}
/* metdynamics off */
if(meta_switch == META_OFF) {
Tcl_AppendResult(interp,"{ off } ", (char *)NULL);
return (TCL_OK);
}
/* distance */
if(meta_switch == META_DIST ) {
sprintf(buffer,"%i", meta_pid1);
Tcl_AppendResult(interp,"{ distance ",buffer, (char *)NULL);
sprintf(buffer,"%i", meta_pid2);
Tcl_AppendResult(interp," ",buffer, (char *)NULL);
Tcl_PrintDouble(interp, meta_xi_min, buffer);
Tcl_AppendResult(interp," ",buffer, (char *)NULL);
Tcl_PrintDouble(interp, meta_xi_max, buffer);
Tcl_AppendResult(interp," ",buffer, (char *)NULL);
Tcl_PrintDouble(interp, meta_bias_height, buffer);
Tcl_AppendResult(interp," ",buffer, (char *)NULL);
Tcl_PrintDouble(interp, meta_bias_width, buffer);
Tcl_AppendResult(interp," ",buffer, (char *)NULL);
Tcl_PrintDouble(interp, meta_f_bound, buffer);
Tcl_AppendResult(interp," ",buffer, (char *)NULL);
sprintf(buffer,"%i", meta_xi_num_bins);
Tcl_AppendResult(interp," ",buffer," } ", (char *)NULL);
}
/* relative_z */
if(meta_switch == META_REL_Z ) {
sprintf(buffer,"%i", meta_pid1);
Tcl_AppendResult(interp,"{ relative_z ",buffer, (char *)NULL);
sprintf(buffer,"%i", meta_pid2);
Tcl_AppendResult(interp," ",buffer, (char *)NULL);
Tcl_PrintDouble(interp, meta_xi_min, buffer);
Tcl_AppendResult(interp," ",buffer, (char *)NULL);
Tcl_PrintDouble(interp, meta_xi_max, buffer);
Tcl_AppendResult(interp," ",buffer, (char *)NULL);
Tcl_PrintDouble(interp, meta_bias_height, buffer);
Tcl_AppendResult(interp," ",buffer, (char *)NULL);
Tcl_PrintDouble(interp, meta_bias_width, buffer);
Tcl_AppendResult(interp," ",buffer, (char *)NULL);
Tcl_PrintDouble(interp, meta_f_bound, buffer);
Tcl_AppendResult(interp," ",buffer, (char *)NULL);
sprintf(buffer,"%i", meta_xi_num_bins);
Tcl_AppendResult(interp," ",buffer," } ", (char *)NULL);
}
return (TCL_OK);
}
/** Reads a Tcl matrix and returns a C matrix.
\param interp The Tcl interpreter
\param data_in String containing a Tcl matrix of doubles
\param data Pointer to the C matrix
\param nrows Pointer to an int to store the height of the matrix
\param ncols Pointer to an int to store the width of the matrix
\return \em TCL_OK if everything went fine \em TCL_ERROR otherwise and
interp->result is set to an error message.
If \em TCL_OK is returned you have to make sure to free the memory
pointed to by data.
*/
int uwerr_read_matrix(Tcl_Interp *interp, char * data_in ,
double *** data, int * nrows, int * ncols)
{
char ** row;
char ** col;
int tmp_ncols = -1, i, j, k;
*nrows = *ncols = -1;
if (Tcl_SplitList(interp, data_in, nrows, &row) == TCL_ERROR)
return TCL_ERROR;
if (*nrows < 1) {
Tcl_AppendResult(interp, "first argument has to be a matrix.",
(char *)NULL);
return TCL_ERROR;
}
if (!(*data = (double**)malloc(*nrows*sizeof(double*)))) {
Tcl_AppendResult(interp, "Out of Memory.",
(char *)NULL);
Tcl_Free((char *)row);
return TCL_ERROR;
}
for (i = 0; i < *nrows; ++i) {
tmp_ncols = -1;
if (Tcl_SplitList(interp, row[i], &tmp_ncols, &col) == TCL_ERROR) {
Tcl_Free((char*)row);
return TCL_ERROR;
}
if (i == 0) {
if (tmp_ncols < 1) {
Tcl_AppendResult(interp, "first argument has to be a matrix.",
(char *)NULL);
Tcl_Free((char *)col);
Tcl_Free((char*)row);
return TCL_ERROR;
}
*ncols = tmp_ncols;
} else if (*ncols != tmp_ncols) {
Tcl_AppendResult(interp, "number of columns changed.",
(char *)NULL);
Tcl_Free((char *)col);
Tcl_Free((char*)row);
return TCL_ERROR;
}
if (!((*data)[i] = (double*)malloc(*ncols*sizeof(double)))) {
Tcl_AppendResult(interp,"Out of Memory.",
(char *)NULL);
Tcl_Free((char *)row);
Tcl_Free((char *)col);
for (k = 0; k < i; ++k)
free((*data)[i]);
free(*data);
return TCL_ERROR;
};
for (j = 0; j < *ncols; ++j) {
if (Tcl_GetDouble(interp, col[j], &((*data)[i][j])) == TCL_ERROR) {
Tcl_Free((char *)col);
Tcl_Free((char *)row);
for (k = 0; k <= i; ++k)
free((*data)[i]);
free(*data);
return TCL_ERROR;
}
}
Tcl_Free((char *)col);
}
Tcl_Free((char *)row);
return TCL_OK;
}
/*!
tux_events Tcl callback
Here's a sample call to tux_events:
tux_events {
{
-name "Herring Run" -icon noicon -cups {
{
-name "Cup 1" -icon noicon -races {
{
-course path_of_daggers \
-description "nice long description" \
-herring { 15 20 25 30 } \
-time { 40.0 35.0 30.0 25.0 } \
-score { 0 0 0 0 } \
-mirrored yes -conditions cloudy \
-windy no -snowing no
}
{
-course ingos_speedway \
-description "nice long description" \
-herring { 15 20 25 30 } \
-time { 40.0 35.0 30.0 25.0 } \
-score { 0 0 0 0 } \
-mirrored yes -conditions cloudy \
-windy no -snowing no
}
}
-name "Cup 2" -icon noicon -races {
{
-course penguins_cant_fly \
-description "nice long description" \
-herring { 15 20 25 30 } \
-time { 40.0 35.0 30.0 25.0 } \
-score { 0 0 0 0 } \
-mirrored yes -conditions cloudy \
-windy no -snowing no
}
{
-course ingos_speedway \
-description "nice long description" \
-herring { 15 20 25 30 } \
-time { 40.0 35.0 30.0 25.0 } \
-score { 0 0 0 0 } \
-mirrored yes -conditions cloudy \
-windy no -snowing no
}
}
}
}
}
}
\return Tcl error code
\author jfpatry
\date Created: 2000-09-19
\date Modified: 2000-09-19
*/
static int events_cb( ClientData cd, Tcl_Interp *ip,
int argc, const char **argv )
{
char *err_msg;
const char **list = NULL;
int num_events;
list_elem_t last_event = NULL;
int i;
/* Make sure module has been initialized */
check_assertion( initialized,
"course_mgr module not initialized" );
if ( argc != 2 ) {
err_msg = "Incorrect number of arguments";
goto bail_events;
}
if ( Tcl_SplitList( ip, argv[1], &num_events, &list ) == TCL_ERROR ) {
err_msg = "Argument is not a list";
goto bail_events;
}
/* We currently only allow tux_events to be called once */
last_event = get_list_tail( event_list );
if ( last_event != NULL ) {
err_msg = "tux_events has already been called; it can only be called "
"once.";
goto bail_events;
}
for (i=0; i<num_events; i++) {
event_data_t *data = create_event_data( ip, list[i], &err_msg );
if ( data == NULL ) {
goto bail_events;
}
last_event = insert_list_elem( event_list, last_event,
(list_elem_data_t) data );
}
Tcl_Free( (char*) list );
list = NULL;
return TCL_OK;
bail_events:
if ( list != NULL ) {
Tcl_Free( (char*) list );
}
/* Clean out event list */
if ( event_list != NULL ) {
last_event = get_list_tail( event_list );
while ( last_event != NULL ) {
event_data_t *data;
data = (event_data_t*) delete_list_elem( event_list,
last_event );
free( data );
last_event = get_list_tail( event_list );
}
}
Tcl_AppendResult(
ip,
"Error in call to tux_events: ",
err_msg,
"\n",
"Usage: tux_events { list of event data }",
(NULL) );
return TCL_ERROR;
}
Tk_Cursor
Tk_GetCursorFromData(
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
Tk_Window tkwin, /* Window in which cursor will be used. */
const char *source, /* Bitmap data for cursor shape. */
const char *mask, /* Bitmap data for cursor mask. */
int width, int height, /* Dimensions of cursor. */
int xHot, int yHot, /* Location of hot-spot in cursor. */
Tk_Uid fg, /* Foreground color for cursor. */
Tk_Uid bg) /* Background color for cursor. */
{
DataKey dataKey;
Tcl_HashEntry *dataHashPtr;
register TkCursor *cursorPtr;
int isNew;
XColor fgColor, bgColor;
TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr;
if (!dispPtr->cursorInit) {
CursorInit(dispPtr);
}
dataKey.source = source;
dataKey.mask = mask;
dataKey.width = width;
dataKey.height = height;
dataKey.xHot = xHot;
dataKey.yHot = yHot;
dataKey.fg = fg;
dataKey.bg = bg;
dataKey.display = Tk_Display(tkwin);
dataHashPtr = Tcl_CreateHashEntry(&dispPtr->cursorDataTable,
(char *) &dataKey, &isNew);
if (!isNew) {
cursorPtr = Tcl_GetHashValue(dataHashPtr);
cursorPtr->resourceRefCount++;
return cursorPtr->cursor;
}
/*
* No suitable cursor exists yet. Make one using the data available and
* add it to the database.
*/
if (XParseColor(dataKey.display, Tk_Colormap(tkwin), fg, &fgColor) == 0) {
Tcl_AppendResult(interp, "invalid color name \"", fg, "\"", NULL);
goto error;
}
if (XParseColor(dataKey.display, Tk_Colormap(tkwin), bg, &bgColor) == 0) {
Tcl_AppendResult(interp, "invalid color name \"", bg, "\"", NULL);
goto error;
}
cursorPtr = TkCreateCursorFromData(tkwin, source, mask, width, height,
xHot, yHot, fgColor, bgColor);
if (cursorPtr == NULL) {
goto error;
}
cursorPtr->resourceRefCount = 1;
cursorPtr->otherTable = &dispPtr->cursorDataTable;
cursorPtr->hashPtr = dataHashPtr;
cursorPtr->objRefCount = 0;
cursorPtr->idHashPtr = Tcl_CreateHashEntry(&dispPtr->cursorIdTable,
(char *) cursorPtr->cursor, &isNew);
cursorPtr->nextPtr = NULL;
if (!isNew) {
Tcl_Panic("cursor already registered in Tk_GetCursorFromData");
}
Tcl_SetHashValue(dataHashPtr, cursorPtr);
Tcl_SetHashValue(cursorPtr->idHashPtr, cursorPtr);
return cursorPtr->cursor;
error:
Tcl_DeleteHashEntry(dataHashPtr);
return None;
}
int
TkTextWindowCmd(
register TkText *textPtr, /* Information about text widget. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. Someone else has already
* parsed this command enough to know that
* objv[1] is "window". */
{
int optionIndex;
static const char *const windOptionStrings[] = {
"cget", "configure", "create", "names", NULL
};
enum windOptions {
WIND_CGET, WIND_CONFIGURE, WIND_CREATE, WIND_NAMES
};
register TkTextSegment *ewPtr;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "option ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], windOptionStrings,
"window option", 0, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum windOptions) optionIndex) {
case WIND_CGET: {
TkTextIndex index;
TkTextSegment *ewPtr;
Tcl_Obj *objPtr;
TkTextEmbWindowClient *client;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 3, objv, "index option");
return TCL_ERROR;
}
if (TkTextGetObjIndex(interp, textPtr, objv[3], &index) != TCL_OK) {
return TCL_ERROR;
}
ewPtr = TkTextIndexToSeg(&index, NULL);
if (ewPtr->typePtr != &tkTextEmbWindowType) {
Tcl_AppendResult(interp, "no embedded window at index \"",
Tcl_GetString(objv[3]), "\"", NULL);
return TCL_ERROR;
}
/*
* Copy over client specific value before querying.
*/
client = EmbWinGetClient(textPtr, ewPtr);
if (client != NULL) {
ewPtr->body.ew.tkwin = client->tkwin;
} else {
ewPtr->body.ew.tkwin = NULL;
}
objPtr = Tk_GetOptionValue(interp, (char *) &ewPtr->body.ew,
ewPtr->body.ew.optionTable, objv[4], textPtr->tkwin);
if (objPtr == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
}
case WIND_CONFIGURE: {
TkTextIndex index;
TkTextSegment *ewPtr;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 3, objv, "index ?-option value ...?");
return TCL_ERROR;
}
if (TkTextGetObjIndex(interp, textPtr, objv[3], &index) != TCL_OK) {
return TCL_ERROR;
}
ewPtr = TkTextIndexToSeg(&index, NULL);
if (ewPtr->typePtr != &tkTextEmbWindowType) {
Tcl_AppendResult(interp, "no embedded window at index \"",
Tcl_GetString(objv[3]), "\"", NULL);
return TCL_ERROR;
}
if (objc <= 5) {
TkTextEmbWindowClient *client;
Tcl_Obj* objPtr;
/*
* Copy over client specific value before querying.
*/
client = EmbWinGetClient(textPtr, ewPtr);
if (client != NULL) {
ewPtr->body.ew.tkwin = client->tkwin;
} else {
ewPtr->body.ew.tkwin = NULL;
}
objPtr = Tk_GetOptionInfo(interp, (char *) &ewPtr->body.ew,
ewPtr->body.ew.optionTable, (objc == 5) ? objv[4] : NULL,
textPtr->tkwin);
if (objPtr == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
} else {
TkTextChanged(textPtr->sharedTextPtr, NULL, &index, &index);
/*
* It's probably not true that all window configuration can change
* the line height, so we could be more efficient here and only
* call this when necessary.
*/
TkTextInvalidateLineMetrics(textPtr->sharedTextPtr, NULL,
index.linePtr, 0, TK_TEXT_INVALIDATE_ONLY);
return EmbWinConfigure(textPtr, ewPtr, objc-4, objv+4);
}
}
case WIND_CREATE: {
TkTextIndex index;
int lineIndex;
TkTextEmbWindowClient *client;
int res;
/*
* Add a new window. Find where to put the new window, and mark that
* position for redisplay.
*/
if (objc < 4) {
Tcl_WrongNumArgs(interp, 3, objv, "index ?-option value ...?");
return TCL_ERROR;
}
if (TkTextGetObjIndex(interp, textPtr, objv[3], &index) != TCL_OK) {
return TCL_ERROR;
}
/*
* Don't allow insertions on the last (dummy) line of the text.
*/
lineIndex = TkBTreeLinesTo(textPtr, index.linePtr);
if (lineIndex == TkBTreeNumLines(textPtr->sharedTextPtr->tree,
textPtr)) {
lineIndex--;
TkTextMakeByteIndex(textPtr->sharedTextPtr->tree, textPtr,
lineIndex, 1000000, &index);
}
/*
* Create the new window segment and initialize it.
*/
ewPtr = (TkTextSegment *) ckalloc(EW_SEG_SIZE);
ewPtr->typePtr = &tkTextEmbWindowType;
ewPtr->size = 1;
ewPtr->body.ew.sharedTextPtr = textPtr->sharedTextPtr;
ewPtr->body.ew.linePtr = NULL;
ewPtr->body.ew.tkwin = NULL;
ewPtr->body.ew.create = NULL;
ewPtr->body.ew.align = ALIGN_CENTER;
ewPtr->body.ew.padX = ewPtr->body.ew.padY = 0;
ewPtr->body.ew.stretch = 0;
ewPtr->body.ew.optionTable = Tk_CreateOptionTable(interp, optionSpecs);
client = (TkTextEmbWindowClient *)
ckalloc(sizeof(TkTextEmbWindowClient));
client->next = NULL;
client->textPtr = textPtr;
client->tkwin = NULL;
client->chunkCount = 0;
client->displayed = 0;
client->parent = ewPtr;
ewPtr->body.ew.clients = client;
/*
* Link the segment into the text widget, then configure it (delete it
* again if the configuration fails).
*/
TkTextChanged(textPtr->sharedTextPtr, NULL, &index, &index);
TkBTreeLinkSegment(ewPtr, &index);
res = EmbWinConfigure(textPtr, ewPtr, objc-4, objv+4);
client->tkwin = ewPtr->body.ew.tkwin;
if (res != TCL_OK) {
TkTextIndex index2;
TkTextIndexForwChars(NULL, &index, 1, &index2, COUNT_INDICES);
TkBTreeDeleteIndexRange(textPtr->sharedTextPtr->tree, &index,
&index2);
return TCL_ERROR;
}
TkTextInvalidateLineMetrics(textPtr->sharedTextPtr, NULL,
index.linePtr, 0, TK_TEXT_INVALIDATE_ONLY);
break;
}
case WIND_NAMES: {
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 3, objv, NULL);
return TCL_ERROR;
}
for (hPtr = Tcl_FirstHashEntry(&textPtr->sharedTextPtr->windowTable,
&search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
Tcl_AppendElement(interp,
Tcl_GetHashKey(&textPtr->sharedTextPtr->markTable, hPtr));
}
break;
}
}
return TCL_OK;
}
static int
EmbWinConfigure(
TkText *textPtr, /* Information about text widget that contains
* embedded window. */
TkTextSegment *ewPtr, /* Embedded window to be configured. */
int objc, /* Number of strings in objv. */
Tcl_Obj *const objv[]) /* Array of objects describing configuration
* options. */
{
Tk_Window oldWindow;
TkTextEmbWindowClient *client;
/*
* Copy over client specific value before querying or setting.
*/
client = EmbWinGetClient(textPtr, ewPtr);
if (client != NULL) {
ewPtr->body.ew.tkwin = client->tkwin;
} else {
ewPtr->body.ew.tkwin = NULL;
}
oldWindow = ewPtr->body.ew.tkwin;
if (Tk_SetOptions(textPtr->interp, (char *) &ewPtr->body.ew,
ewPtr->body.ew.optionTable, objc, objv, textPtr->tkwin, NULL,
NULL) != TCL_OK) {
return TCL_ERROR;
}
if (oldWindow != ewPtr->body.ew.tkwin) {
if (oldWindow != NULL) {
Tcl_DeleteHashEntry(Tcl_FindHashEntry(
&textPtr->sharedTextPtr->windowTable,
Tk_PathName(oldWindow)));
Tk_DeleteEventHandler(oldWindow, StructureNotifyMask,
EmbWinStructureProc, (ClientData) client);
Tk_ManageGeometry(oldWindow, NULL, (ClientData) NULL);
if (textPtr->tkwin != Tk_Parent(oldWindow)) {
Tk_UnmaintainGeometry(oldWindow, textPtr->tkwin);
} else {
Tk_UnmapWindow(oldWindow);
}
}
if (client != NULL) {
client->tkwin = NULL;
}
if (ewPtr->body.ew.tkwin != NULL) {
Tk_Window ancestor, parent;
Tcl_HashEntry *hPtr;
int isNew;
/*
* Make sure that the text is either the parent of the embedded
* window or a descendant of that parent. Also, don't allow a
* top-level window to be managed inside a text.
*/
parent = Tk_Parent(ewPtr->body.ew.tkwin);
for (ancestor = textPtr->tkwin; ; ancestor = Tk_Parent(ancestor)) {
if (ancestor == parent) {
break;
}
if (Tk_TopWinHierarchy(ancestor)) {
badMaster:
Tcl_AppendResult(textPtr->interp, "can't embed ",
Tk_PathName(ewPtr->body.ew.tkwin), " in ",
Tk_PathName(textPtr->tkwin), NULL);
ewPtr->body.ew.tkwin = NULL;
if (client != NULL) {
client->tkwin = NULL;
}
return TCL_ERROR;
}
}
if (Tk_TopWinHierarchy(ewPtr->body.ew.tkwin)
|| (ewPtr->body.ew.tkwin == textPtr->tkwin)) {
goto badMaster;
}
if (client == NULL) {
/*
* Have to make the new client.
*/
client = (TkTextEmbWindowClient *)
ckalloc(sizeof(TkTextEmbWindowClient));
client->next = ewPtr->body.ew.clients;
client->textPtr = textPtr;
client->tkwin = NULL;
client->chunkCount = 0;
client->displayed = 0;
client->parent = ewPtr;
ewPtr->body.ew.clients = client;
}
client->tkwin = ewPtr->body.ew.tkwin;
/*
* Take over geometry management for the window, plus create an
* event handler to find out when it is deleted.
*/
Tk_ManageGeometry(ewPtr->body.ew.tkwin, &textGeomType,
(ClientData) client);
Tk_CreateEventHandler(ewPtr->body.ew.tkwin, StructureNotifyMask,
EmbWinStructureProc, (ClientData) client);
/*
* Special trick! Must enter into the hash table *after* calling
* Tk_ManageGeometry: if the window was already managed elsewhere
* in this text, the Tk_ManageGeometry call will cause the entry
* to be removed, which could potentially lose the new entry.
*/
hPtr = Tcl_CreateHashEntry(&textPtr->sharedTextPtr->windowTable,
Tk_PathName(ewPtr->body.ew.tkwin), &isNew);
Tcl_SetHashValue(hPtr, ewPtr);
}
}
return TCL_OK;
}
/* parser for hole cluster analyzation:
analyze holes <prob_part_type_number> <mesh_size>.
Needs feature LENNARD_JONES compiled in. */
int tclcommand_analyze_parse_holes(Tcl_Interp *interp, int argc, char **argv)
{
int i,j;
int probe_part_type;
int mesh_size=1, meshdim[3];
double freevol=0.0;
char buffer[TCL_INTEGER_SPACE+TCL_DOUBLE_SPACE];
IntList mesh;
int n_holes;
int **holes;
int max_size=0;
int *surface;
#ifndef LENNARD_JONES
Tcl_AppendResult(interp, "analyze holes needs feature LENNARD_JONES compiled in.\n", (char *)NULL);
return TCL_ERROR;
#endif
/* check # of parameters */
if (argc < 2) {
Tcl_AppendResult(interp, "analyze holes needs 2 parameters:\n", (char *)NULL);
Tcl_AppendResult(interp, "<prob_part_type_number> <mesh_size>", (char *)NULL);
return TCL_ERROR;
}
/* check parameter types */
if( (! ARG_IS_I(0, probe_part_type)) ||
(! ARG_IS_I(1, mesh_size)) ) {
Tcl_AppendResult(interp, "analyze holes needs 2 parameters of type and meaning:\n", (char *)NULL);
Tcl_AppendResult(interp, "INT INT\n", (char *)NULL);
Tcl_AppendResult(interp, "<prob_part_type_number> <mesh_size>", (char *)NULL);
return TCL_ERROR;
}
/* check parameter values */
if( probe_part_type > n_particle_types || probe_part_type < 0 ) {
Tcl_AppendResult(interp, "analyze holes: probe particle type number does not exist", (char *)NULL);
return TCL_ERROR;
}
if( mesh_size < 1 ) {
Tcl_AppendResult(interp, "analyze holes: mesh size must be positive (min=1)", (char *)NULL);
return TCL_ERROR;
}
/* preparation */
updatePartCfg(WITHOUT_BONDS);
meshdim[0]=mesh_size;
meshdim[1]=mesh_size;
meshdim[2]=mesh_size;
alloc_intlist(&mesh, (meshdim[0]*meshdim[1]*meshdim[2]));
/* perform free space identification*/
create_free_volume_grid(mesh, meshdim, probe_part_type);
/* perfrom hole cluster algorithm */
n_holes = cluster_free_volume_grid(mesh, meshdim, &holes);
/* surface to volume ratio */
surface = (int *) malloc(sizeof(int)*(n_holes+1));
cluster_free_volume_surface(mesh, meshdim, n_holes, holes, surface);
/* calculate accessible volume / max size*/
for ( i=0; i<=n_holes; i++ ) {
freevol += holes[i][0];
if ( holes[i][0]> max_size ) max_size = holes[i][0];
}
/* Append result to tcl interpreter */
Tcl_AppendResult(interp, "{ n_holes mean_hole_size max_hole_size free_volume_fraction { sizes } { surfaces } { element_lists } } ", (char *)NULL);
Tcl_AppendResult(interp, "{", (char *)NULL);
/* number of holes */
sprintf(buffer,"%d ",n_holes+1); Tcl_AppendResult(interp, buffer, " ", (char *)NULL);
/* mean hole size */
sprintf(buffer,"%f ",freevol/(n_holes+1.0)); Tcl_AppendResult(interp, buffer, " ", (char *)NULL);
/* max hole size */
sprintf(buffer,"%d ",max_size); Tcl_AppendResult(interp, buffer, " ", (char *)NULL);
/* free volume fraction */
sprintf(buffer,"%f ",freevol/(meshdim[0]*meshdim[1]*meshdim[2]));
Tcl_AppendResult(interp, buffer, " ", (char *)NULL);
/* hole sizes */
Tcl_AppendResult(interp, "{ ", (char *)NULL);
for ( i=0; i<=n_holes; i++ ) {
sprintf(buffer,"%d ",holes[i][0]); Tcl_AppendResult(interp, buffer, " ", (char *)NULL);
}
Tcl_AppendResult(interp, "} ", (char *)NULL);
/* hole surfaces */
Tcl_AppendResult(interp, "{ ", (char *)NULL);
for ( i=0; i<=n_holes; i++ ) {
sprintf(buffer,"%d ",surface[i]); Tcl_AppendResult(interp, buffer, " ", (char *)NULL);
}
Tcl_AppendResult(interp, "} ", (char *)NULL);
/* hole elements */
Tcl_AppendResult(interp, "{ ", (char *)NULL);
for ( i=0; i<=n_holes; i++ ) {
Tcl_AppendResult(interp, "{ ", (char *)NULL);
for ( j=1; j <= holes[i][0]; j++ ) {
sprintf(buffer,"%d",holes[i][j]);
Tcl_AppendResult(interp, buffer, " ",(char *)NULL);
}
Tcl_AppendResult(interp, "} ", (char *)NULL);
}
Tcl_AppendResult(interp, "} ", (char *)NULL);
Tcl_AppendResult(interp, "}", (char *)NULL);
/* free allocated memory */
realloc_intlist(&mesh, 0);
free(surface);
for ( i=0; i<=n_holes; i++ ) { free(holes[i]); }
free(holes);
return (TCL_OK);
}
/* parser for necklace cluster analyzation:
analyze necklace <pearl_treshold> <back_dist> <space_dist> <first> <length>
*/
int tclcommand_analyze_parse_necklace(Tcl_Interp *interp, int argc, char **argv)
{
double space_dist;
int first,length;
Particle *part;
Cluster *cluster;
char buffer[TCL_INTEGER_SPACE];
int n_pearls;
/* check # of parameters */
if (argc < 5) {
Tcl_AppendResult(interp, "analyze necklace needs 5 parameters:\n", (char *)NULL);
Tcl_AppendResult(interp, "<pearl_treshold> <back_dist> <space_dist> <first> <length>", (char *)NULL);
return TCL_ERROR;
}
/* check parameter types */
if( (! ARG_IS_I(0, pearl_treshold)) ||
(! ARG_IS_I(1, backbone_distance)) ||
(! ARG_IS_D(2, space_dist)) ||
(! ARG_IS_I(3, first)) ||
(! ARG_IS_I(4, length)) ) {
Tcl_AppendResult(interp, "analyze necklace needs 5 parameters of type and meaning:\n", (char *)NULL);
Tcl_AppendResult(interp, "INT INT DOUBLE INT INT\n", (char *)NULL);
Tcl_AppendResult(interp, "<pearl_treshold> <back_dist> <space_dist> <first> <length>", (char *)NULL);
return TCL_ERROR;
}
/* check parameter values */
if( pearl_treshold < 10 ) {
Tcl_AppendResult(interp, "analyze necklace: pearl_treshold should be >= 10", (char *)NULL);
return TCL_ERROR;
}
if( backbone_distance < 2 ) {
Tcl_AppendResult(interp, "analyze necklace: backbone_dist should be >= 2", (char *)NULL);
return TCL_ERROR;
}
if( space_dist <= 0.0 ) {
Tcl_AppendResult(interp, "analyze necklace: space_dist must be positive", (char *)NULL);
return TCL_ERROR;
}
if( first < 0 ) {
Tcl_AppendResult(interp, "analyze necklace: identity of first particle can not be negative", (char *)NULL);
return TCL_ERROR;
}
if( first+length > n_total_particles+1) {
Tcl_AppendResult(interp, "analyze necklace: identity of last particle out of partCfg array", (char *)NULL);
return TCL_ERROR;
}
/* preparation */
space_distance2 = SQR(space_dist);
sortPartCfg();
part = &partCfg[first];
/* perform necklace cluster algorithm */
n_pearls = analyze_necklace(part, length) ;
/* Append result to tcl interpreter */
sprintf(buffer,"%d",n_pearls);
Tcl_AppendResult(interp, buffer, " pearls { ", (char *)NULL);
if( n_pearls > 0 ) {
cluster = first_cluster;
sprintf(buffer,"%d",cluster->size);
Tcl_AppendResult(interp, buffer, " ",(char *)NULL);
cluster = cluster->next;
while(cluster->prev != last_cluster) {
sprintf(buffer,"%d",cluster->size);
Tcl_AppendResult(interp, buffer, " ",(char *)NULL);
cluster = cluster->next;
}
}
Tcl_AppendResult(interp, "} ", (char *)NULL);
/* free analyzation memory */
cluster_free();
return (TCL_OK);
}
/*
*---------------------------------------------------------------------------
*
* HtmlImageServerGet --
*
* Retrieve an HtmlImage2 object for the image at URL zUrl from
* an image-server. The caller should match this call with a single
* HtmlImageFree() when the image object is no longer required.
*
* If the image is not already in the cache, the Tcl script
* configured as the widget -imagecmd is invoked. If this command
* raises an error or returns an invalid result, then this function
* returns NULL. A Tcl back-ground error is propagated in this case
* also.
*
* Results:
* Pointer to HtmlImage2 object containing the image from zUrl, or
* NULL, if zUrl was invalid for some reason.
*
* Side effects:
* May invoke -imagecmd script.
*
*---------------------------------------------------------------------------
*/
HtmlImage2 *
HtmlImageServerGet (HtmlImageServer *p, const char *zUrl)
{
Tcl_Obj *pImageCmd = p->pTree->options.imagecmd;
Tcl_Interp *interp = p->pTree->interp;
Tcl_HashEntry *pEntry = 0;
HtmlImage2 *pImage = 0;
/* Try to find the requested image in the hash table. */
if (pImageCmd) {
int new_entry;
pEntry = Tcl_CreateHashEntry(&p->aImage, zUrl, &new_entry);
if (new_entry) {
Tcl_Obj *pEval;
Tcl_Obj *pResult;
int rc;
int nObj;
Tcl_Obj **apObj = 0;
Tk_Image img;
/* The image could not be found in the hash table and an
* -imagecmd callback is configured. The callback script
* must be executed to obtain an image. Build up a script
* in pEval and execute it. Put the result in variable pResult.
*/
pEval = Tcl_DuplicateObj(pImageCmd);
Tcl_IncrRefCount(pEval);
Tcl_ListObjAppendElement(interp, pEval, Tcl_NewStringObj(zUrl, -1));
rc = Tcl_EvalObjEx(interp, pEval, TCL_EVAL_DIRECT|TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(pEval);
if (rc != TCL_OK) {
goto image_get_out;
}
pResult = Tcl_GetObjResult(interp);
/* Read the result into array apObj. If the result was
* not a valid Tcl list, return NULL and raise a background
* error about the badly formed list.
*/
rc = Tcl_ListObjGetElements(interp, pResult, &nObj, &apObj);
if (rc != TCL_OK) {
goto image_get_out;
}
if (nObj==0) {
Tcl_DeleteHashEntry(pEntry);
goto image_unavailable;
}
pImage = HtmlNew(HtmlImage2);
if (nObj == 1 || nObj == 2) {
img = Tk_GetImage(
interp, p->pTree->tkwin, Tcl_GetString(apObj[0]),
imageChanged, pImage
);
}
if ((nObj != 1 && nObj != 2) || !img) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "-imagecmd returned bad value", 0);
HtmlFree(pImage);
pImage = 0;
goto image_get_out;
}
Tcl_SetHashValue(pEntry, (ClientData)pImage);
Tcl_IncrRefCount(apObj[0]);
pImage->pImageName = apObj[0];
if (nObj == 2) {
Tcl_IncrRefCount(apObj[1]);
pImage->pDelete = apObj[1];
}
pImage->pImageServer = p;
pImage->zUrl = Tcl_GetHashKey(&p->aImage, pEntry);
pImage->image = img;
Tk_SizeOfImage(pImage->image, &pImage->width, &pImage->height);
pImage->isValid = 1;
HtmlImagePixmap(pImage);
}
}
image_get_out:
pImage = (HtmlImage2 *)(pEntry ? Tcl_GetHashValue(pEntry) : 0);
HtmlImageRef(pImage);
if (!pImage && pImageCmd) {
Tcl_BackgroundError(interp);
Tcl_ResetResult(interp);
assert(pEntry);
Tcl_DeleteHashEntry(pEntry);
}
image_unavailable:
return pImage;
}
int
Tclae_Init(Tcl_Interp *interp)
{
OSErr err;
SInt32 attr;
//Check for AppleEvents
err = Gestalt(gestaltAppleEventsAttr, &attr);
if ((err != noErr)
|| !(attr & (1 << gestaltAppleEventsPresent))) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "The AppleEvent Manager is either missing or misbehaving",
(char *) NULL);
}
err = AEObjectInit();
if (Tcl_InitStubs(interp, "8.0", 0) == NULL) {
return TCL_ERROR;
}
if (Tcl_PkgRequire(interp, "Tcl", TCL_VERSION, 0) == NULL) {
if (TCL_VERSION[0] == '7') {
if (Tcl_PkgRequire(interp, "Tcl", "8.0", 0) == NULL) {
return TCL_ERROR;
}
}
}
if (Tcl_PkgProvide(interp, TCLAE_NAME, TCLAE_BASIC_VERSION) != TCL_OK) {
return TCL_ERROR;
}
/* Why?!? */
Tcl_SetVar(interp, "tclAE_version", TCLAE_VERSION, TCL_GLOBAL_ONLY);
tclAE_macRoman_encoding = Tcl_GetEncoding(interp,"macRoman");
TclaeInitAEAddresses();
TclaeInitAEDescs();
TclaeInitEventHandlers(interp);
TclaeInitCoercionHandlers(interp);
TclaeInitObjectAccessors(interp);
/* Define Tcl commands */
Tcl_CreateObjCommand(interp, "tclAE::build", Tclae_BuildCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::send", Tclae_SendCmd, NULL, 0L);
/* Handler commands */
Tcl_CreateObjCommand(interp, "tclAE::getCoercionHandler", Tclae_GetCoercionHandlerCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::getEventHandler", Tclae_GetEventHandlerCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::installCoercionHandler", Tclae_InstallCoercionHandlerCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::installEventHandler", Tclae_InstallEventHandlerCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::removeCoercionHandler", Tclae_RemoveCoercionHandlerCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::removeEventHandler", Tclae_RemoveEventHandlerCmd, NULL, 0L);
/* Target commands */
#if !TARGET_API_MAC_CARBON && !defined(TCLAE_NO_EPPC) // das 25/10/00: Carbonization
Tcl_CreateObjCommand(interp, "tclAE::IPCListPorts", Tclae_IPCListPortsCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::PPCBrowser", Tclae_PPCBrowserCmd, NULL, 0L);
#endif
#if TARGET_API_MAC_CARBON
Tcl_CreateObjCommand(interp, "tclAE::getPOSIXPath", Tclae_GetPOSIXPathCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::getHFSPath", Tclae_GetHFSPathCmd, NULL, 0L);
#endif
Tcl_CreateObjCommand(interp, "tclAE::launch", Tclae_LaunchCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::processes", Tclae_ProcessesCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::remoteProcessResolverGetProcesses", Tclae_RemoteProcessResolverGetProcessesCmd, NULL, 0L);
/* AEDesc commands */
Tcl_CreateObjCommand(interp, "tclAE::coerceData", Tclae_CoerceDataCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::coerceDesc", Tclae_CoerceDescCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::countItems", Tclae_CountItemsCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::createDesc", Tclae_CreateDescCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::createList", Tclae_CreateListCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::deleteItem", Tclae_DeleteItemCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::deleteKeyDesc", Tclae_DeleteKeyDescCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::duplicateDesc", Tclae_DuplicateDescCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::getAttributeData", Tclae_GetAttributeDataCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::getAttributeDesc", Tclae_GetAttributeDescCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::getData", Tclae_GetDataCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::getDescType", Tclae_GetDescTypeCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::getKeyData", Tclae_GetKeyDataCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::getKeyDesc", Tclae_GetKeyDescCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::getNthData", Tclae_GetNthDataCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::getNthDesc", Tclae_GetNthDescCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::putData", Tclae_PutDataCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::putDesc", Tclae_PutDescCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::putKeyData", Tclae_PutKeyDataCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::putKeyDesc", Tclae_PutKeyDescCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::replaceDescData", Tclae_ReplaceDescDataCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::setDescType", Tclae_SetDescTypeCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::_private::_getAEDesc", Tclae__GetAEDescCmd, NULL, 0L);
/* Object commands */
Tcl_CreateObjCommand(interp, "tclAE::setObjectCallbacks", Tclae_SetObjectCallbacksCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::resolve", Tclae_ResolveCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::callObjectAccessor", Tclae_CallObjectAccessorCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::getObjectAccessor", Tclae_GetObjectAccessorCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::installObjectAccessor", Tclae_InstallObjectAccessorCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::removeObjectAccessor", Tclae_RemoveObjectAccessorCmd, NULL, 0L);
Tcl_CreateObjCommand(interp, "tclAE::disposeToken", Tclae_DisposeTokenCmd, NULL, 0L);
return TCL_OK;
}
static int
PyAggImagePhoto(ClientData clientdata, Tcl_Interp* interp,
int argc, char **argv)
{
Tk_PhotoHandle photo;
Tk_PhotoImageBlock block;
PyObject* aggo;
// vars for blitting
PyObject* bboxo;
unsigned long aggl, bboxl;
bool has_bbox;
agg::int8u *destbuffer;
double l, b, r, t;
int destx, desty, destwidth, destheight, deststride;
//unsigned long tmp_ptr;
long mode;
long nval;
if (Tk_MainWindow(interp) == NULL)
{
// Will throw a _tkinter.TclError with "this isn't a Tk application"
return TCL_ERROR;
}
if (argc != 5)
{
Tcl_AppendResult(interp, "usage: ", argv[0],
" destPhoto srcImage", (char *) NULL);
return TCL_ERROR;
}
/* get Tcl PhotoImage handle */
photo = Tk_FindPhoto(interp, argv[1]);
if (photo == NULL)
{
Tcl_AppendResult(interp, "destination photo must exist", (char *) NULL);
return TCL_ERROR;
}
/* get array (or object that can be converted to array) pointer */
if (sscanf(argv[2], "%lu", &aggl) != 1)
{
Tcl_AppendResult(interp, "error casting pointer", (char *) NULL);
return TCL_ERROR;
}
aggo = (PyObject*)aggl;
//aggo = (PyObject*)atol(argv[2]);
//std::stringstream agg_ptr_ss;
//agg_ptr_ss.str(argv[2]);
//agg_ptr_ss >> tmp_ptr;
//aggo = (PyObject*)tmp_ptr;
RendererAgg *aggRenderer = (RendererAgg *)aggo;
int srcheight = (int)aggRenderer->get_height();
/* XXX insert aggRenderer type check */
/* get array mode (0=mono, 1=rgb, 2=rgba) */
mode = atol(argv[3]);
if ((mode != 0) && (mode != 1) && (mode != 2))
{
Tcl_AppendResult(interp, "illegal image mode", (char *) NULL);
return TCL_ERROR;
}
/* check for bbox/blitting */
if (sscanf(argv[4], "%lu", &bboxl) != 1)
{
Tcl_AppendResult(interp, "error casting pointer", (char *) NULL);
return TCL_ERROR;
}
bboxo = (PyObject*)bboxl;
//bboxo = (PyObject*)atol(argv[4]);
//std::stringstream bbox_ptr_ss;
//bbox_ptr_ss.str(argv[4]);
//bbox_ptr_ss >> tmp_ptr;
//bboxo = (PyObject*)tmp_ptr;
if (py_convert_bbox(bboxo, l, b, r, t))
{
has_bbox = true;
destx = (int)l;
desty = srcheight - (int)t;
destwidth = (int)(r - l);
destheight = (int)(t - b);
deststride = 4 * destwidth;
destbuffer = new agg::int8u[deststride*destheight];
if (destbuffer == NULL)
{
throw Py::MemoryError("_tkagg could not allocate memory for destbuffer");
}
agg::rendering_buffer destrbuf;
destrbuf.attach(destbuffer, destwidth, destheight, deststride);
pixfmt destpf(destrbuf);
renderer_base destrb(destpf);
agg::rect_base<int> region(destx, desty, (int)r, srcheight - (int)b);
destrb.copy_from(aggRenderer->renderingBuffer, ®ion,
-destx, -desty);
}
else
{
has_bbox = false;
destbuffer = NULL;
destx = desty = destwidth = destheight = deststride = 0;
}
/* setup tkblock */
block.pixelSize = 1;
if (mode == 0)
{
block.offset[0] = block.offset[1] = block.offset[2] = 0;
nval = 1;
}
else
{
block.offset[0] = 0;
block.offset[1] = 1;
block.offset[2] = 2;
if (mode == 1)
{
block.offset[3] = 0;
block.pixelSize = 3;
nval = 3;
}
else
{
block.offset[3] = 3;
block.pixelSize = 4;
nval = 4;
}
}
if (has_bbox)
{
block.width = destwidth;
block.height = destheight;
block.pitch = deststride;
block.pixelPtr = destbuffer;
Tk_PhotoPutBlock(photo, &block, destx, desty, destwidth, destheight);
delete [] destbuffer;
}
else
{
block.width = aggRenderer->get_width();
block.height = aggRenderer->get_height();
block.pitch = block.width * nval;
block.pixelPtr = aggRenderer->pixBuffer;
/* Clear current contents */
Tk_PhotoBlank(photo);
/* Copy opaque block to photo image, and leave the rest to TK */
Tk_PhotoPutBlock(photo, &block, 0, 0, block.width, block.height);
}
return TCL_OK;
}
int
Pg_execute(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[])
{
Pg_ConnectionId *connid;
PGconn *conn;
PGresult *result;
int i;
int tupno;
int ntup;
int loop_rc;
CONST84 char *oid_varname = NULL;
CONST84 char *array_varname = NULL;
char buf[64];
char *usage = "Wrong # of arguments\n"
"pg_execute ?-array arrayname? ?-oid varname? "
"connection queryString ?loop_body?";
/*
* First we parse the options
*/
i = 1;
while (i < argc)
{
if (argv[i][0] != '-')
break;
if (strcmp(argv[i], "-array") == 0)
{
/*
* The rows should appear in an array vs. to single variables
*/
i++;
if (i == argc)
{
Tcl_SetResult(interp, usage, TCL_VOLATILE);
return TCL_ERROR;
}
array_varname = argv[i++];
continue;
}
if (strcmp(argv[i], "-oid") == 0)
{
/*
* We should place PQoidValue() somewhere
*/
i++;
if (i == argc)
{
Tcl_SetResult(interp, usage, TCL_VOLATILE);
return TCL_ERROR;
}
oid_varname = argv[i++];
continue;
}
Tcl_AppendResult(interp, "Unknown option '", argv[i], "'", NULL);
return TCL_ERROR;
}
/*
* Check that after option parsing at least 'connection' and 'query'
* are left
*/
if (argc - i < 2)
{
Tcl_SetResult(interp, usage, TCL_VOLATILE);
return TCL_ERROR;
}
/*
* Get the connection and make sure no COPY command is pending
*/
conn = PgGetConnectionId(interp, argv[i++], &connid);
if (conn == (PGconn *) NULL)
return TCL_ERROR;
if (connid->res_copyStatus != RES_COPY_NONE)
{
Tcl_SetResult(interp, "Attempt to query while COPY in progress", TCL_STATIC);
return TCL_ERROR;
}
/*
* Execute the query
*/
result = PQexec(conn, argv[i++]);
/*
* Transfer any notify events from libpq to Tcl event queue.
*/
PgNotifyTransferEvents(connid);
/*
* Check for errors
*/
if (result == NULL)
{
Tcl_SetResult(interp, PQerrorMessage(conn), TCL_VOLATILE);
return TCL_ERROR;
}
/*
* Set the oid variable to the returned oid of an INSERT statement if
* requested (or 0 if it wasn't an INSERT)
*/
if (oid_varname != NULL)
{
char oid_buf[32];
sprintf(oid_buf, "%u", PQoidValue(result));
if (Tcl_SetVar(interp, oid_varname, oid_buf,
TCL_LEAVE_ERR_MSG) == NULL)
{
PQclear(result);
return TCL_ERROR;
}
}
/*
* Decide how to go on based on the result status
*/
switch (PQresultStatus(result))
{
case PGRES_TUPLES_OK:
/* fall through if we have tuples */
break;
case PGRES_EMPTY_QUERY:
case PGRES_COMMAND_OK:
case PGRES_COPY_IN:
case PGRES_COPY_OUT:
/* tell the number of affected tuples for non-SELECT queries */
Tcl_SetResult(interp, PQcmdTuples(result), TCL_VOLATILE);
PQclear(result);
return TCL_OK;
default:
/* anything else must be an error */
Tcl_ResetResult(interp);
Tcl_AppendElement(interp, PQresStatus(PQresultStatus(result)));
Tcl_AppendElement(interp, PQresultErrorMessage(result));
PQclear(result);
return TCL_ERROR;
}
/*
* We reach here only for queries that returned tuples
*/
if (i == argc)
{
/*
* We don't have a loop body. If we have at least one result row,
* we set all the variables to the first one and return.
*/
if (PQntuples(result) > 0)
{
if (execute_put_values(interp, array_varname, result, 0) != TCL_OK)
{
PQclear(result);
return TCL_ERROR;
}
}
sprintf(buf, "%d", PQntuples(result));
Tcl_SetResult(interp, buf, TCL_VOLATILE);
PQclear(result);
return TCL_OK;
}
/*
* We have a loop body. For each row in the result set put the values
* into the Tcl variables and execute the body.
*/
ntup = PQntuples(result);
for (tupno = 0; tupno < ntup; tupno++)
{
if (execute_put_values(interp, array_varname, result, tupno) != TCL_OK)
{
PQclear(result);
return TCL_ERROR;
}
loop_rc = Tcl_Eval(interp, argv[i]);
/* The returncode of the loop body controls the loop execution */
if (loop_rc == TCL_OK || loop_rc == TCL_CONTINUE)
/* OK or CONTINUE means start next loop invocation */
continue;
if (loop_rc == TCL_RETURN)
{
/* RETURN means hand up the given interpreter result */
PQclear(result);
return TCL_RETURN;
}
if (loop_rc == TCL_BREAK)
/* BREAK means leave the loop */
break;
PQclear(result);
return TCL_ERROR;
}
/*
* At the end of the loop we put the number of rows we got into the
* interpreter result and clear the result set.
*/
sprintf(buf, "%d", ntup);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
PQclear(result);
return TCL_OK;
}
/*ARGSUSED*/
static int
EmbWinLayoutProc(
TkText *textPtr, /* Text widget being layed out. */
TkTextIndex *indexPtr, /* Identifies first character in chunk. */
TkTextSegment *ewPtr, /* Segment corresponding to indexPtr. */
int offset, /* Offset within segPtr corresponding to
* indexPtr (always 0). */
int maxX, /* Chunk must not occupy pixels at this
* position or higher. */
int maxChars, /* Chunk must not include more than this many
* characters. */
int noCharsYet, /* Non-zero means no characters have been
* assigned to this line yet. */
TkWrapMode wrapMode, /* Wrap mode to use for line:
* TEXT_WRAPMODE_CHAR, TEXT_WRAPMODE_NONE, or
* TEXT_WRAPMODE_WORD. */
register TkTextDispChunk *chunkPtr)
/* Structure to fill in with information about
* this chunk. The x field has already been
* set by the caller. */
{
int width, height;
TkTextEmbWindowClient *client;
if (offset != 0) {
Tcl_Panic("Non-zero offset in EmbWinLayoutProc");
}
client = EmbWinGetClient(textPtr, ewPtr);
if (client == NULL) {
ewPtr->body.ew.tkwin = NULL;
} else {
ewPtr->body.ew.tkwin = client->tkwin;
}
if ((ewPtr->body.ew.tkwin == NULL) && (ewPtr->body.ew.create != NULL)) {
int code, isNew;
Tk_Window ancestor;
Tcl_HashEntry *hPtr;
const char *before, *string;
Tcl_DString name, buf, *dsPtr = NULL;
before = ewPtr->body.ew.create;
/*
* Find everything up to the next % character and append it to the
* result string.
*/
string = before;
while (*string != 0) {
if ((*string == '%') && (string[1] == '%' || string[1] == 'W')) {
if (dsPtr == NULL) {
Tcl_DStringInit(&buf);
dsPtr = &buf;
}
if (string != before) {
Tcl_DStringAppend(dsPtr, before, (int) (string-before));
before = string;
}
if (string[1] == '%') {
Tcl_DStringAppend(dsPtr, "%", 1);
} else {
/*
* Substitute string as proper Tcl list element.
*/
int spaceNeeded, cvtFlags, length;
const char *str = Tk_PathName(textPtr->tkwin);
spaceNeeded = Tcl_ScanElement(str, &cvtFlags);
length = Tcl_DStringLength(dsPtr);
Tcl_DStringSetLength(dsPtr, length + spaceNeeded);
spaceNeeded = Tcl_ConvertElement(str,
Tcl_DStringValue(dsPtr) + length,
cvtFlags | TCL_DONT_USE_BRACES);
Tcl_DStringSetLength(dsPtr, length + spaceNeeded);
}
before += 2;
string++;
}
string++;
}
/*
* The window doesn't currently exist. Create it by evaluating the
* creation script. The script must return the window's path name:
* look up that name to get back to the window token. Then register
* ourselves as the geometry manager for the window.
*/
if (dsPtr != NULL) {
Tcl_DStringAppend(dsPtr, before, (int) (string-before));
code = Tcl_GlobalEval(textPtr->interp, Tcl_DStringValue(dsPtr));
Tcl_DStringFree(dsPtr);
} else {
code = Tcl_GlobalEval(textPtr->interp, ewPtr->body.ew.create);
}
if (code != TCL_OK) {
createError:
Tcl_BackgroundException(textPtr->interp, code);
goto gotWindow;
}
Tcl_DStringInit(&name);
Tcl_DStringAppend(&name, Tcl_GetStringResult(textPtr->interp), -1);
Tcl_ResetResult(textPtr->interp);
ewPtr->body.ew.tkwin = Tk_NameToWindow(textPtr->interp,
Tcl_DStringValue(&name), textPtr->tkwin);
Tcl_DStringFree(&name);
if (ewPtr->body.ew.tkwin == NULL) {
goto createError;
}
for (ancestor = textPtr->tkwin; ; ancestor = Tk_Parent(ancestor)) {
if (ancestor == Tk_Parent(ewPtr->body.ew.tkwin)) {
break;
}
if (Tk_TopWinHierarchy(ancestor)) {
badMaster:
Tcl_AppendResult(textPtr->interp, "can't embed ",
Tk_PathName(ewPtr->body.ew.tkwin), " relative to ",
Tk_PathName(textPtr->tkwin), NULL);
Tcl_BackgroundError(textPtr->interp);
ewPtr->body.ew.tkwin = NULL;
goto gotWindow;
}
}
if (Tk_TopWinHierarchy(ewPtr->body.ew.tkwin)
|| (textPtr->tkwin == ewPtr->body.ew.tkwin)) {
goto badMaster;
}
if (client == NULL) {
/*
* We just used a '-create' script to make a new window, which we
* now need to add to our client list.
*/
client = (TkTextEmbWindowClient *)
ckalloc(sizeof(TkTextEmbWindowClient));
client->next = ewPtr->body.ew.clients;
client->textPtr = textPtr;
client->tkwin = NULL;
client->chunkCount = 0;
client->displayed = 0;
client->parent = ewPtr;
ewPtr->body.ew.clients = client;
}
client->tkwin = ewPtr->body.ew.tkwin;
Tk_ManageGeometry(client->tkwin, &textGeomType,
(ClientData) client);
Tk_CreateEventHandler(client->tkwin, StructureNotifyMask,
EmbWinStructureProc, (ClientData) client);
/*
* Special trick! Must enter into the hash table *after* calling
* Tk_ManageGeometry: if the window was already managed elsewhere in
* this text, the Tk_ManageGeometry call will cause the entry to be
* removed, which could potentially lose the new entry.
*/
hPtr = Tcl_CreateHashEntry(&textPtr->sharedTextPtr->windowTable,
Tk_PathName(client->tkwin), &isNew);
Tcl_SetHashValue(hPtr, ewPtr);
}
/*
* See if there's room for this window on this line.
*/
gotWindow:
if (ewPtr->body.ew.tkwin == NULL) {
width = 0;
height = 0;
} else {
width = Tk_ReqWidth(ewPtr->body.ew.tkwin) + 2*ewPtr->body.ew.padX;
height = Tk_ReqHeight(ewPtr->body.ew.tkwin) + 2*ewPtr->body.ew.padY;
}
if ((width > (maxX - chunkPtr->x))
&& !noCharsYet && (textPtr->wrapMode != TEXT_WRAPMODE_NONE)) {
return 0;
}
/*
* Fill in the chunk structure.
*/
chunkPtr->displayProc = TkTextEmbWinDisplayProc;
chunkPtr->undisplayProc = EmbWinUndisplayProc;
chunkPtr->measureProc = NULL;
chunkPtr->bboxProc = EmbWinBboxProc;
chunkPtr->numBytes = 1;
if (ewPtr->body.ew.align == ALIGN_BASELINE) {
chunkPtr->minAscent = height - ewPtr->body.ew.padY;
chunkPtr->minDescent = ewPtr->body.ew.padY;
chunkPtr->minHeight = 0;
} else {
chunkPtr->minAscent = 0;
chunkPtr->minDescent = 0;
chunkPtr->minHeight = height;
}
chunkPtr->width = width;
chunkPtr->breakIndex = -1;
chunkPtr->breakIndex = 1;
chunkPtr->clientData = (ClientData) ewPtr;
if (client != NULL) {
client->chunkCount += 1;
}
return 1;
}
int
TclpMatchInDirectory(
Tcl_Interp *interp, /* Interpreter to receive errors. */
Tcl_Obj *resultPtr, /* List object to lappend results. */
Tcl_Obj *pathPtr, /* Contains path to directory to search. */
CONST char *pattern, /* Pattern to match against. */
Tcl_GlobTypeData *types) /* Object containing list of acceptable types.
* May be NULL. In particular the directory
* flag is very important. */
{
CONST char *native;
Tcl_Obj *fileNamePtr;
int matchResult = 0;
if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) {
/*
* The native filesystem never adds mounts.
*/
return TCL_OK;
}
fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
if (fileNamePtr == NULL) {
return TCL_ERROR;
}
if (pattern == NULL || (*pattern == '\0')) {
/*
* Match a file directly.
*/
Tcl_Obj *tailPtr;
CONST char *nativeTail;
native = (CONST char*) Tcl_FSGetNativePath(pathPtr);
tailPtr = TclPathPart(interp, pathPtr, TCL_PATH_TAIL);
nativeTail = (CONST char*) Tcl_FSGetNativePath(tailPtr);
matchResult = NativeMatchType(interp, native, nativeTail, types);
if (matchResult == 1) {
Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
}
Tcl_DecrRefCount(tailPtr);
Tcl_DecrRefCount(fileNamePtr);
} else {
DIR *d;
Tcl_DirEntry *entryPtr;
CONST char *dirName;
int dirLength;
int matchHidden, matchHiddenPat;
int nativeDirLen;
Tcl_StatBuf statBuf;
Tcl_DString ds; /* native encoding of dir */
Tcl_DString dsOrig; /* utf-8 encoding of dir */
Tcl_DStringInit(&dsOrig);
dirName = Tcl_GetStringFromObj(fileNamePtr, &dirLength);
Tcl_DStringAppend(&dsOrig, dirName, dirLength);
/*
* Make sure that the directory part of the name really is a
* directory. If the directory name is "", use the name "." instead,
* because some UNIX systems don't treat "" like "." automatically.
* Keep the "" for use in generating file names, otherwise "glob
* foo.c" would return "./foo.c".
*/
if (dirLength == 0) {
dirName = ".";
} else {
dirName = Tcl_DStringValue(&dsOrig);
/*
* Make sure we have a trailing directory delimiter.
*/
if (dirName[dirLength-1] != '/') {
dirName = Tcl_DStringAppend(&dsOrig, "/", 1);
dirLength++;
}
}
/*
* Now open the directory for reading and iterate over the contents.
*/
native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds);
if ((TclOSstat(native, &statBuf) != 0) /* INTL: Native. */
|| !S_ISDIR(statBuf.st_mode)) {
Tcl_DStringFree(&dsOrig);
Tcl_DStringFree(&ds);
Tcl_DecrRefCount(fileNamePtr);
return TCL_OK;
}
d = opendir(native); /* INTL: Native. */
if (d == NULL) {
Tcl_DStringFree(&ds);
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "couldn't read directory \"",
Tcl_DStringValue(&dsOrig), "\": ",
Tcl_PosixError(interp), (char *) NULL);
}
Tcl_DStringFree(&dsOrig);
Tcl_DecrRefCount(fileNamePtr);
return TCL_ERROR;
}
nativeDirLen = Tcl_DStringLength(&ds);
/*
* Check to see if -type or the pattern requests hidden files.
*/
matchHiddenPat = (pattern[0] == '.')
|| ((pattern[0] == '\\') && (pattern[1] == '.'));
matchHidden = matchHiddenPat
|| (types && (types->perm & TCL_GLOB_PERM_HIDDEN));
while ((entryPtr = TclOSreaddir(d)) != NULL) { /* INTL: Native. */
Tcl_DString utfDs;
CONST char *utfname;
/*
* Skip this file if it doesn't agree with the hidden parameters
* requested by the user (via -type or pattern).
*/
if (*entryPtr->d_name == '.') {
if (!matchHidden) continue;
} else {
#ifdef MAC_OSX_TCL
if (matchHiddenPat) continue;
/* Also need to check HFS hidden flag in TclMacOSXMatchType. */
#else
if (matchHidden) continue;
#endif
}
/*
* Now check to see if the file matches, according to both type
* and pattern. If so, add the file to the result.
*/
utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1,
&utfDs);
if (Tcl_StringCaseMatch(utfname, pattern, 0)) {
int typeOk = 1;
if (types != NULL) {
Tcl_DStringSetLength(&ds, nativeDirLen);
native = Tcl_DStringAppend(&ds, entryPtr->d_name, -1);
matchResult = NativeMatchType(interp, native,
entryPtr->d_name, types);
typeOk = (matchResult == 1);
}
if (typeOk) {
Tcl_ListObjAppendElement(interp, resultPtr,
TclNewFSPathObj(pathPtr, utfname,
Tcl_DStringLength(&utfDs)));
}
}
Tcl_DStringFree(&utfDs);
if (matchResult < 0) {
break;
}
}
closedir(d);
Tcl_DStringFree(&ds);
Tcl_DStringFree(&dsOrig);
Tcl_DecrRefCount(fileNamePtr);
}
if (matchResult < 0) {
return TCL_ERROR;
} else {
return TCL_OK;
}
}
int adress_set(Tcl_Interp *interp,int argc, char **argv){
int topo=-1,i,wf=0,set_center=0;
double width[2],center[3];
char buffer[3*TCL_DOUBLE_SPACE];
argv+=2;argc-=2;
for(i=0;i<3;i++) center[i]=box_l[i]/2;
if (argc < 2) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "Wrong # of args! adress set needs at least 2 arguments\n", (char *)NULL);
Tcl_AppendResult(interp, "Usage: adress set topo [0|1|2|3] width X.X Y.Y (center X.X Y.Y Z.Z) (wf [0|1])\n", (char *)NULL);
Tcl_AppendResult(interp, "topo: 0 - switched off (no more values needed)\n", (char *)NULL);
Tcl_AppendResult(interp, " 1 - constant (weight will be first value of width)\n", (char *)NULL);
Tcl_AppendResult(interp, " 2 - divided in one direction (default x, or give a negative center coordinate\n", (char *)NULL);
Tcl_AppendResult(interp, " 3 - spherical topology\n", (char *)NULL);
Tcl_AppendResult(interp, "width: X.X - half of size of ex zone(r0/2 in the papers)\n", (char *)NULL);
Tcl_AppendResult(interp, " Y.Y - size of hybrid zone (d in the papers)\n", (char *)NULL);
Tcl_AppendResult(interp, " Note: Only one value need for topo 1 \n", (char *)NULL);
Tcl_AppendResult(interp, "center: center of the ex zone (default middle of the box) \n", (char *)NULL);
Tcl_AppendResult(interp, " Note: x|y|x X.X for topo 2 \n", (char *)NULL);
Tcl_AppendResult(interp, " Note: X.X Y.Y Z.Z for topo 3 \n", (char *)NULL);
Tcl_AppendResult(interp, "wf: 0 - cos weighting function (default)\n", (char *)NULL);
Tcl_AppendResult(interp, " 1 - polynom weighting function\n", (char *)NULL);
Tcl_AppendResult(interp, "ALWAYS set box_l first !!!", (char *)NULL);
return (TCL_ERROR);
}
//parse topo
if ( (argc<2) || (!ARG0_IS_S("topo")) || (!ARG1_IS_I(topo)) || (topo < 0) || (topo > 3) ) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "expected \'topo 0|1|2|3\'\n", (char *)NULL);
return (TCL_ERROR);
}
argv+=2;argc-=2;
//stop if topo is 0
if (topo==0) {
adress_vars[0]=0.0;
mpi_bcast_parameter(FIELD_ADRESS);
return TCL_OK;
}
//parse width
if ( (argc>1) && (ARG0_IS_S("width")) ) {
if (topo==1) {
if ( (!ARG1_IS_D(width[0])) || (width[0]<0) ){
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "expected \'width X.X (X.X non-negative)\'", (char *)NULL);
return (TCL_ERROR);
}
if ((width[0]> 1.0) || (width[0]< 0.0)) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "for constant topo, first width must be between 0 and 1", (char *)NULL);
return (TCL_ERROR);
}
//stop if topo is 1
adress_vars[0]=1;
adress_vars[1]=width[0];
mpi_bcast_parameter(FIELD_ADRESS);
return TCL_OK;
}
else {//topo 2 and 3 are left over
if ( (argc<3) || (!ARG1_IS_D(width[0])) || (width[0]<0) ||(!ARG_IS_D(2,width[1])) || (width[1]<0) ){
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "expected \'width X.X Y.Y (both non-negative)\'", (char *)NULL);
return (TCL_ERROR);
}
argv+=3;argc-=3;
}
}
else{
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "expected \'width\'", (char *)NULL);
return (TCL_ERROR);
}
while (argc!=0){
if (ARG0_IS_S("wf")){
if ( (argc<2) || (!ARG1_IS_I(wf)) || (wf < 0) || (wf > 1) ){
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "expected \'wf 0|1\'", (char *)NULL);
return (TCL_ERROR);
}
else{
argv+=2;argc-=2;
}
}
else if (ARG0_IS_S("center")){
if (topo == 2) {
if ( (argc<3) || ( (!ARG1_IS_S("x"))&&(!ARG1_IS_S("y"))&&(!ARG1_IS_S("z")) ) || (!ARG_IS_D(2,center[1])) ){
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "expected \'center x|y|z X.X\'", (char *)NULL);
return (TCL_ERROR);
}
if (ARG1_IS_S("x")) center[0]=0;
else if (ARG1_IS_S("y")) center[0]=1;
else center[0]=2;
if ( (center[1]<0) || (center[1]>box_l[(int)center[0]]) ) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "The center component is outside the box", (char *)NULL);
return (TCL_ERROR);
}
set_center=1;
argv+=3;argc-=3;
}
else { //topo 3
if ( (argc<4) || (!ARG_IS_D(1,center[0])) || (!ARG_IS_D(2,center[1])) || (!ARG_IS_D(3,center[2])) ){
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "expected \'center X.X Y.Y Z.Z\'", (char *)NULL);
return (TCL_ERROR);
}
argv+=4;argc-=4;
//check components of center
for (i=0;i<3;i++){
if ( (center[i]<0)||(center[i]>box_l[i]) ){
Tcl_ResetResult(interp);
sprintf(buffer,"%i",i);
Tcl_AppendResult(interp, "The ",buffer," th component of center is outside the box\n", (char *)NULL);
return (TCL_ERROR);
}
}
}
}
else{
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "The unknown operation \"", argv[0],"\".", (char *)NULL);
return (TCL_ERROR);
}
}
//set standard center value for topo 2
if ((topo==2) && (set_center==0) ) center[0]=0;
//width check
if (topo==2){
if (width[0]+width[1]>box_l[(int)center[0]]/2){
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "The width of ex+hy must smaller than box_l/2\n", (char *)NULL);
return (TCL_ERROR);
}
}
else if (topo==3){
for (i=0;i<3;i++){
if (width[0]+width[1]>box_l[i]/2){
Tcl_ResetResult(interp);
sprintf(buffer,"%i",i);
Tcl_AppendResult(interp, "The width of ex+hy must smaller than box_l/2 in dim " ,buffer,"\n", (char *)NULL);
return (TCL_ERROR);
}
}
}
adress_vars[0]=topo;
adress_vars[1]=width[0];
adress_vars[2]=width[1];
adress_vars[3]=center[0];
adress_vars[4]=center[1];
adress_vars[5]=center[2];
adress_vars[6]=wf;
mpi_bcast_parameter(FIELD_ADRESS);
return TCL_OK;
}
/*!
tux_open_courses Tcl callback
\author jfpatry
\date Created: 2000-09-19
\date Modified: 2000-09-19
*/
static int open_courses_cb( ClientData cd, Tcl_Interp *ip,
int argc, const char **argv )
{
char *err_msg;
const char **list = NULL;
int num_courses;
list_elem_t last_elem = NULL;
list_elem_t last_speed_elem = NULL;
list_elem_t last_score_elem = NULL;
int i, j;
char preview_file[100];
check_assertion( initialized,
"course_mgr module not initialized" );
if ( argc != 2 ) {
err_msg = "Wrong number of arguments";
goto bail_open_courses;
}
if ( Tcl_SplitList( ip, argv[1], &num_courses, &list ) == TCL_ERROR ) {
err_msg = "Argument is not a list";
goto bail_open_courses;
}
/* Add items to end of list */
last_elem = get_list_tail( open_course_list );
last_speed_elem = get_list_tail( speed_course_list );
last_score_elem = get_list_tail( score_course_list );
for ( i=0; i<num_courses; i++ ) {
open_course_data_t *data;
data = create_open_course_data( ip, list[i], &err_msg );
#ifdef __ANDROID__
sprintf(preview_file, "courses/%s/preview.jpg", data->course);
#else
sprintf(preview_file, "%s/courses/%s/preview.jpg", getparam_data_dir(), data->course);
#endif
load_texture(data->course, preview_file, 1);
bind_texture(data->course, data->course);
if ( data == NULL ) {
goto bail_open_courses;
}
last_elem = insert_list_elem(
open_course_list,
last_elem,
(list_elem_data_t) data );
if(data->speed)
{
last_speed_elem = insert_list_elem(
speed_course_list,
last_speed_elem,
(list_elem_data_t) data );
}
if(data->score)
{
last_score_elem = insert_list_elem(
score_course_list,
last_score_elem,
(list_elem_data_t) data );
}
}
Tcl_Free( (char*) list );
list = NULL;
return TCL_OK;
bail_open_courses:
/* We'll leave the data that was successfully added in the list. */
Tcl_AppendResult(
ip,
"Error in call to tux_open_courses: ",
err_msg,
"\n",
"Usage: tux_open_courses { list of open courses }",
(NULL) );
return TCL_ERROR;
}
int tclcommand_analyze_parse_and_print_energy(Tcl_Interp *interp, int argc, char **argv)
{
/* 'analyze energy [{ fene <type_num> | harmonic <type_num> | subt_lj_harm <type_num> | subt_lj_fene <type_num> | subt_lj <type_num> | lj <type1> <type2> | ljcos <type1> <type2> | ljcos2 <type1> <type2> | gb <type1> <type2> | coulomb | kinetic | total }]' */
char buffer[TCL_DOUBLE_SPACE + TCL_INTEGER_SPACE + 2];
int i, j;
double value;
value = 0.0;
if (n_part == 0) {
Tcl_AppendResult(interp, "(no particles)",
(char *)NULL);
return (TCL_OK);
}
if (total_energy.init_status == 0) {
init_energies(&total_energy);
master_energy_calc();
}
if (argc == 0)
tclcommand_analyze_print_all(interp);
else {
if (ARG0_IS_S("kinetic"))
value = total_energy.data.e[0];
else if (ARG0_IS_S("bonded") ||
ARG0_IS_S("fene") ||
ARG0_IS_S("subt_lj_harm") ||
ARG0_IS_S("subt_lj_fene") ||
ARG0_IS_S("subt_lj") ||
ARG0_IS_S("harmonic") ||
ARG0_IS_S("umbrella") ||
ARG0_IS_S("endangledist")) {
if(argc<2 || ! ARG1_IS_I(i)) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "wrong # or type of arguments for: analyze energy bonded <type_num>",
(char *)NULL);
return (TCL_ERROR);
}
if(i < 0 || i >= n_bonded_ia) {
Tcl_AppendResult(interp, "bond type does not exist", (char *)NULL);
return (TCL_ERROR);
}
value = *obsstat_bonded(&total_energy, i);
}
else if (ARG0_IS_S("nonbonded") ||
ARG0_IS_S("lj") ||
ARG0_IS_S("buckingham") ||
ARG0_IS_S("lj-cos") ||
ARG0_IS_S("lj-cos2") ||
ARG0_IS_S("cos2") ||
ARG0_IS_S("gb") ||
ARG0_IS_S("tabulated")) {
if(argc<3 || ! ARG_IS_I(1, i) || ! ARG_IS_I(2, j)) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "wrong # or type of arguments for: analyze energy nonbonded <type1> <type2>",
(char *)NULL);
return (TCL_ERROR);
}
if(i < 0 || i >= n_particle_types || j < 0 || j >= n_particle_types) {
Tcl_AppendResult(interp, "particle type does not exist", (char *)NULL);
return (TCL_ERROR);
}
value = *obsstat_nonbonded(&total_energy, i, j);
}
else if( ARG0_IS_S("coulomb")) {
#ifdef ELECTROSTATICS
value = 0;
for (i = 0; i < total_energy.n_coulomb; i++)
value += total_energy.coulomb[i];
#else
Tcl_AppendResult(interp, "ELECTROSTATICS not compiled (see myconfig.hpp)\n", (char *)NULL);
#endif
}
else if( ARG0_IS_S("magnetic")) {
#ifdef DIPOLES
value = 0;
for (i = 0; i < total_energy.n_dipolar; i++)
value += total_energy.dipolar[i];
#else
Tcl_AppendResult(interp, "DIPOLES not compiled (see myconfig.hpp)\n", (char *)NULL);
#endif
}
else if (ARG0_IS_S("total")) {
value = total_energy.data.e[0];
for (i = 1; i < total_energy.data.n; i++)
value += total_energy.data.e[i];
for (i = 0; i < n_external_potentials; i++) {
value += external_potentials[i].energy;
}
}
else {
Tcl_AppendResult(interp, "unknown feature of: analyze energy",
(char *)NULL);
return (TCL_ERROR);
}
Tcl_PrintDouble(interp, value, buffer);
Tcl_AppendResult(interp, buffer, (char *)NULL);
}
return (TCL_OK);
}
int tclcommand_metadynamics_parse_load_stat(Tcl_Interp *interp, int argc, char **argv){
/* Parse free energy profile and biased force that were provided from an
* earlier simulation. Allows one to restart from a loaded state, and can
* even be used to allow multiple walkers communicating their data through TCL. */
if(meta_switch == META_OFF) {
Tcl_AppendResult(interp, "Metadynamics hasn't been initialized yet", (char *)NULL);
return (TCL_ERROR);
}
argc -= 1; argv += 1;
// There should be
if (argc != 3) {
Tcl_AppendResult(interp, "Incorrect number of arguments: 'metadynamics load_stat <profile_list> <force_list>'", (char *)NULL);
return (TCL_ERROR);
}
// load free energy profile
int i, tmp_argc, parse_error = 0, empty_line=0;
char **tmp_argv;
DoubleList profile, force;
init_doublelist(&profile);
Tcl_ResetResult(interp);
Tcl_SplitList(interp, argv[1], &tmp_argc, (const char ***)&tmp_argv);
realloc_doublelist(&profile, profile.n = tmp_argc);
//printf("profile.n %d, meta_xi_num_bins %d\n",profile.n,meta_xi_num_bins);
/* Now check that the number of items parsed is equal to the number of bins */
/* If there's one extra line, assume it's an empty line */
if (profile.n == meta_xi_num_bins+1)
empty_line = 1;
else if (profile.n != meta_xi_num_bins) {
Tcl_AppendResult(interp, "Size of profile list loaded is different than expected from number of bins", (char *)NULL);
return (TCL_ERROR);
}
/* call meta_init() in case it has been loaded yet */
meta_init();
for(i = 0 ; i < tmp_argc-empty_line; i++) {
int tmp_argc2;
char **tmp_argv2;
Tcl_SplitList(interp, tmp_argv[i], &tmp_argc2, (const char ***)&tmp_argv2);
if (tmp_argc2 != 1) {
Tcl_AppendResult(interp, "data set has to be a list of doubles", (char *) NULL);
parse_error = 1; break;
}
if (Tcl_GetDouble(interp, tmp_argv2[0], &(profile.e[i])) == TCL_ERROR) { parse_error = 1; break; }
/* Load data into meta_acc_fprofile */
meta_acc_fprofile[i] = profile.e[i];
Tcl_Free((char *)tmp_argv2);
}
Tcl_Free((char *)tmp_argv);
if (parse_error) return TCL_ERROR;
// load force
argc -= 1; argv += 1;
init_doublelist(&force);
Tcl_ResetResult(interp);
Tcl_SplitList(interp, argv[1], &tmp_argc, (const char ***)&tmp_argv);
realloc_doublelist(&force, force.n = tmp_argc);
/* Now check that the number of items parsed is equal to the number of bins */
if (profile.n == meta_xi_num_bins+1)
empty_line = 1;
else if (profile.n != meta_xi_num_bins) {
Tcl_AppendResult(interp, "Size of force list loaded is different than expected from number of bins", (char *)NULL);
return (TCL_ERROR);
}
for(i = 0 ; i < tmp_argc-empty_line; i++) {
int tmp_argc2;
char **tmp_argv2;
Tcl_SplitList(interp, tmp_argv[i], &tmp_argc2, (const char ***)&tmp_argv2);
if (tmp_argc2 != 1) {
Tcl_AppendResult(interp, "data set has to be a list of doubles", (char *) NULL);
parse_error = 1; break;
}
if (Tcl_GetDouble(interp, tmp_argv2[0], &(force.e[i])) == TCL_ERROR) { parse_error = 1; break; }
/* Load data into meta_acc_fprofile */
meta_acc_force[i] = -1.*force.e[i];
Tcl_Free((char *)tmp_argv2);
}
Tcl_Free((char *)tmp_argv);
if (parse_error) return TCL_ERROR;
return (TCL_OK);
}
static void tclcommand_analyze_print_all(Tcl_Interp *interp)
{
char buffer[TCL_DOUBLE_SPACE + TCL_INTEGER_SPACE + 2];
double value;
int i, j;
value = total_energy.data.e[0];
for (i = 1; i < total_energy.data.n; i++)
value += total_energy.data.e[i];
for (i = 0; i < n_external_potentials; i++) {
value+=external_potentials[i].energy;
}
Tcl_PrintDouble(interp, value, buffer);
Tcl_AppendResult(interp, "{ energy ", buffer, " } ", (char *)NULL);
Tcl_PrintDouble(interp, total_energy.data.e[0], buffer);
Tcl_AppendResult(interp, "{ kinetic ", buffer, " } ", (char *)NULL);
for(i=0;i<n_bonded_ia;i++) {
if (bonded_ia_params[i].type != BONDED_IA_NONE) {
sprintf(buffer, "%d ", i);
Tcl_AppendResult(interp, "{ ", buffer, (char *)NULL);
Tcl_PrintDouble(interp, *obsstat_bonded(&total_energy, i), buffer);
Tcl_AppendResult(interp,
get_name_of_bonded_ia(bonded_ia_params[i].type),
" ", buffer, " } ", (char *) NULL);
}
}
for (i = 0; i < n_particle_types; i++)
for (j = i; j < n_particle_types; j++) {
if (checkIfParticlesInteract(i, j)) {
sprintf(buffer, "%d ", i);
Tcl_AppendResult(interp, "{ ", buffer, (char *)NULL);
sprintf(buffer, "%d ", j);
Tcl_AppendResult(interp, " ", buffer, (char *)NULL);
Tcl_PrintDouble(interp, *obsstat_nonbonded(&total_energy, i, j), buffer);
Tcl_AppendResult(interp, "nonbonded ", buffer, " } ", (char *)NULL);
}
}
#if defined(ELECTROSTATICS) || defined(DIPOLES)
if(
#if defined(ELECTROSTATICS) && defined(DIPOLES)
coulomb.method != COULOMB_NONE || coulomb.Dmethod != DIPOLAR_NONE
#elif defined(ELECTROSTATICS)
coulomb.method != COULOMB_NONE
#elif defined(DIPOLES)
coulomb.Dmethod != DIPOLAR_NONE
#endif
) {
/* total Coulomb energy */
value = 0;
for (i = 0; i < total_energy.n_coulomb; i++)
value += total_energy.coulomb[i];
for (i = 0; i < total_energy.n_dipolar; i++)
value += total_energy.dipolar[i];
Tcl_PrintDouble(interp, value, buffer);
#if defined(ELECTROSTATICS) && defined(DIPOLES)
Tcl_AppendResult(interp, "{ coulomb+magdipoles ", buffer, (char *)NULL);
#elif defined(ELECTROSTATICS)
Tcl_AppendResult(interp, "{ coulomb ", buffer, (char *)NULL);
#elif defined(DIPOLES)
Tcl_AppendResult(interp, "{ magdipoles ", buffer, (char *)NULL);
#endif
/* if it is split up, then print the split up parts */
#ifdef ELECTROSTATICS
if (total_energy.n_coulomb > 1) {
for (i = 0; i < total_energy.n_coulomb; i++) {
Tcl_PrintDouble(interp, total_energy.coulomb[i], buffer);
Tcl_AppendResult(interp, " ", buffer, (char *)NULL);
}
}
Tcl_AppendResult(interp, " }", (char *)NULL);
#endif
#ifdef DIPOLES
if (total_energy.n_dipolar > 1) {
for (i = 0; i < total_energy.n_dipolar; i++) {
Tcl_PrintDouble(interp, total_energy.dipolar[i], buffer);
Tcl_AppendResult(interp, " ", buffer, (char *)NULL);
}
}
#endif
}
#endif
if (n_external_potentials > 0) {
Tcl_AppendResult(interp, " { external_potential", (char *)NULL);
for (i = 0; i < n_external_potentials; i++) {
Tcl_PrintDouble(interp, external_potentials[i].energy, buffer);
Tcl_AppendResult(interp, " ", buffer, (char *)NULL);
}
}
}
/** The main function.
The function implementing the algorithm described in
arXiv:hep-lat/0306017 v1 13 Jun 2003 \em Wolff, U. \em Monte Carlo errors with less errors.
*/
int UWerr_f(Tcl_Interp *interp, Tcl_CmdInfo * cmdInfo, int argc, char ** argv,
double ** data, int rows, int cols,
int * n_rep, int len, double s_tau, int plot)
{
struct UWerr_t ret;
int a, k, i, sum = 0, W_opt = 0, W_max = 0;
double Fbb = 0, bF = 0, Fb = 0, * abb = 0L, tau = 0, tmp;
double ** abr = 0L, * Fbr = 0L, * fgrad = 0L, * delpro = 0L;
double * gFbb = 0L, CFbb_opt = 0, G_int = 0, std_a;
char flag = 0;
char * str = 0L;
char * tcl_vector = 0L;
char ** my_argv;
FILE * plotDataf, * plotScriptf;
ret.Q_val = 0;
if (!data) {
Tcl_AppendElement(interp, "No data matrix given.");
return TCL_ERROR;
}
if (rows < 1) {
Tcl_AppendElement(interp, "Data matrix has no rows.");
return TCL_ERROR;
}
if (cols < 1) {
Tcl_AppendElement(interp, "Data matrix has no columns.");
return TCL_ERROR;
}
if(!cmdInfo && !cmdInfo->proc) {
Tcl_AppendElement(interp, "No function to call given.");
return TCL_ERROR;
}
if (!n_rep) {
Tcl_AppendElement(interp, "No representations vector given.");
return TCL_ERROR;
}
if (len < 1) {
Tcl_AppendElement(interp, "Representations vector is empty.");
return TCL_ERROR;
}
/* \sum_{i=1}^{len} n_rep[i-1] = rows */
k = rows; /* for now k is going to be min(n_rep) */
for (i = 0; i < len; ++i) {
sum += n_rep[i];
if (n_rep[i] < k)
k = n_rep[i];
}
if (sum != rows || k <= 0) {
Tcl_AppendElement(interp, "Representations vector is invalid.");
return TCL_ERROR;
}
if (s_tau > 0) {
W_max = (int)rint(k/2.); /* until here: k = min(n_rep) */
flag = 1;
if (W_max < 1) W_max = 1;
}
/* string for output of numbers */
str = (char *)malloc((TCL_INTEGER_SPACE + TCL_DOUBLE_SPACE)*sizeof(char));
if (!(delpro = (double*)malloc(rows*sizeof(double)))) {
Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
free(str);
return TCL_ERROR;
}
if (!(Fbr = (double*)malloc(len*sizeof(double)))) {
free(delpro);
free(str);
Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
return TCL_ERROR;
}
if (!(fgrad = (double*)malloc(cols*sizeof(double)))) {
free(delpro);
free(Fbr);
free(str);
Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
return TCL_ERROR;
}
if (!(abb = (double*)malloc(cols*sizeof(double)))) {
free(delpro);
free(Fbr);
free(fgrad);
free(str);
Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
return TCL_ERROR;
}
/* abr \in (\Real)_{len, cols} */
if (!(abr = (double**)malloc(len*sizeof(double*)))) {
free(delpro);
free(Fbr);
free(fgrad);
free(abb);
free(str);
Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
return TCL_ERROR;
}
for (i = 0; i < len; ++i)
if (!(abr[i] = (double*)malloc(cols*sizeof(double)))) {
for (k = 0; k < i; ++k)
free(abr[k]);
free(abr);
free(delpro);
free(Fbr);
free(fgrad);
free(abb);
free(str);
Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
return TCL_ERROR;
}
if (W_max > 0) {
if (!(gFbb = (double*)malloc((W_max+1)*sizeof(double)))) {
free(delpro);
free(Fbr);
free(fgrad);
free(abb);
for (k = 0; k < len; ++k)
free(abr[k]);
free(abr);
free(str);
Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
return TCL_ERROR;
}
}
if (uwerr_create_tcl_vector(&tcl_vector, cols)) {
free(delpro);
free(Fbr);
free(fgrad);
free(abb);
for (k = 0; k < len; ++k)
free(abr[k]);
free(abr);
free(gFbb);
free(str);
Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
return TCL_ERROR;
}
if (!(my_argv=(char**)malloc((argc+1)*sizeof(char*)))) {
free(delpro);
free(Fbr);
free(fgrad);
free(abb);
for (k = 0; k < len; ++k)
free(abr[k]);
free(abr);
free(gFbb);
free(str);
uwerr_free_tcl_vector(tcl_vector);
Tcl_AppendResult(interp, "Out of Memory.", __LINE__, (char *) NULL);
return TCL_ERROR;
}
my_argv[0] = argv[0];
my_argv[1] = tcl_vector;
for (i = 1; i < argc; ++i)
my_argv[i+1] = argv[i];
/* first we calculate N_r\bar{a}_\alpha^r \forall r, alpha */
sum = 0;
for (k = 0; k < len; ++k) {
for (i = 0; i < n_rep[k]; ++i) {
for (a = 0; a < cols; ++a) {
if (i > 0)
abr[k][a] += data[sum + i][a];
else
abr[k][a] = data[sum][a];
}
}
sum += n_rep[k];
}
/* now we calculate \bar{\bar{a}}_\alpha \forall \alpha */
for (k = 0; k < len; ++k) {
for (a = 0; a < cols; ++a) {
if (k > 0)
abb[a] += abr[k][a];
else
abb[a] = abr[k][a];
}
}
for (a =0; a < cols; ++a)
abb[a] /= rows;
/* now we calculate \bar{a}_\alpha^r with \forall \alpha */
for (k = 0; k < len; ++k)
for (a = 0; a < cols; ++a)
abr[k][a] /= n_rep[k];
uwerr_write_tcl_vector(interp, abb, cols, tcl_vector);
Tcl_ResetResult(interp);
if (cmdInfo->proc(cmdInfo->clientData, interp, argc+1, my_argv) != TCL_OK)
goto err_exit;
Fbb = strtod(Tcl_GetStringResult(interp),0);
for (k = 0; k < len; ++k) {
uwerr_write_tcl_vector(interp, abr[k], cols, tcl_vector);
Tcl_ResetResult(interp);
if (cmdInfo->proc(cmdInfo->clientData, interp, argc+1, my_argv) != TCL_OK)
goto err_exit;
Fbr[k] = strtod(Tcl_GetStringResult(interp),0);
}
Fb = UWerr_dsum_int(n_rep, Fbr, len);
Fb /= rows;
for (a = 0; a < cols; ++a) {
std_a = 0;
for (k = 0; k < rows; ++k)
std_a += (data[k][a]-abb[a])*(data[k][a]-abb[a]);
std_a = sqrt(std_a)/rows;
/* calc the gradient of f using df/da ~ (f(a+h)-f(a-h))/2*h
where h is the standard deviation divided by the sqrt of the
number of samples (= rows).
Remember: abb[a] is the average for column a of data */
if (std_a == 0)
fgrad[a] = 0;
else {
tmp = abb[a];
abb[a] += std_a;
uwerr_write_tcl_vector(interp, abb, cols, tcl_vector);
Tcl_ResetResult(interp);
if (cmdInfo->proc(cmdInfo->clientData, interp, argc+1, my_argv) != TCL_OK)
goto err_exit;
fgrad[a] = strtod(Tcl_GetStringResult(interp),0);
abb[a] = tmp - std_a;
uwerr_write_tcl_vector(interp, abb, cols, tcl_vector);
Tcl_ResetResult(interp);
if (cmdInfo->proc(cmdInfo->clientData, interp, argc+1, my_argv) != TCL_OK)
goto err_exit;
fgrad[a] -= strtod(Tcl_GetStringResult(interp),0);
abb[a] = tmp;
fgrad[a] /= 2*std_a;
}
}
/* calc delpro = data*fgrad - abb.*fgrad and
the mean of delpro.^2 = gFbb[0] */
tmp = UWerr_dsum_double(abb, fgrad, cols);
gFbb[0] = 0;
for (i = 0; i < rows; ++i) {
delpro[i] = 0;
for (a = 0; a < cols; a++) {
delpro[i] += data[i][a]*fgrad[a];
}
delpro[i] -= tmp;
gFbb[0] += delpro[i]*delpro[i];
}
gFbb[0] /= rows;
i = 0;
while(i < W_max) {
gFbb[i+1] = 0;
sum = 0;
for (k = 0; k < len; ++k) {
gFbb[i+1] += UWerr_dsum_double(delpro + sum, delpro + sum + i + 1, n_rep[k]-i-1);
sum += n_rep[k];
}
gFbb[i+1] /= rows-(i+1)*len;
if (flag) {
G_int += gFbb[i+1]/gFbb[0];
if (G_int <= 0)
tau = UW_EPS;
else
tau = s_tau/log((G_int+1)/G_int);
if (exp(-(i+1)/tau)-tau/sqrt((i+1)*rows) < 0) {
W_opt = i+1;
W_max = (W_max < 2*W_opt) ? W_max : 2*W_opt;
flag = 0;
}
}
++i;
}
--i;
if (flag) {
W_opt = W_max;
sprintf(str, "%d", W_max);
Tcl_AppendResult(interp, "Windowing condition failed up to W = ", str, ".\n", (char *)NULL);
}
ret.W = W_opt;
CFbb_opt = (gFbb[0] + 2*UWerr_sum(gFbb+1, W_opt))/rows;
for (k = 0; k < i; ++k)
gFbb[k] += CFbb_opt;
CFbb_opt = (gFbb[0] + 2*UWerr_sum(gFbb+1, W_opt));
ret.dvalue = sqrt(CFbb_opt/rows); /* sigmaF */
if (len >= 2) {
bF = (Fb-Fbb)/(len-1);
Fbb -= bF;
if (fabs(bF) > ret.dvalue/4) {
Tcl_PrintDouble(interp, bF/ret.dvalue, str);
Tcl_AppendResult(interp, "A ", str, " sigma bias of the mean has been cancelled./n", (char *)NULL);
}
for (i = 0; i < len; ++i)
Fbr[i] -= bF*rows/n_rep[i];
Fb -= bF*len;
ret.bias = bF/ret.dvalue;
}
ret.tau_int = 0;
for (i = 0; i <= W_opt; ++i)
ret.tau_int += gFbb[i];
ret.tau_int /= gFbb[0];
ret.tau_int -= .5;
ret.value = Fbb;
ret.ddvalue = ret.dvalue*sqrt((W_opt + .5)/rows);
ret.dtau_int = 2 * ret.tau_int * sqrt((W_opt + .5 - ret.tau_int)/rows);
if (len > 1) {
for (i = 0; i < len; ++i)
Fbr[i] = (Fbr[i] - Fb)*(Fbr[i] - Fb)*n_rep[i];
ret.Q_val = UWerr_sum(Fbr, len);
ret.Q_val /= CFbb_opt;
ret.Q_val = gammaq((len-1)/2., ret.Q_val/2.);
}
if (plot) {
plotScriptf = fopen("uwerr_plot_script", "w");
fprintf(plotScriptf, "set ylabel \"Gamma\"; set xlabel \"W\"; set label \"W_opt=%d\" at %d,0 center; plot f(x) = 0, f(x) notitle, 'uwerr_plot_data' using 1:2 title \"normalized autocorrelation\" with lines; show label; pause -1\n", W_opt, W_opt);
fprintf(plotScriptf, "set ylabel \"tau_int\"; plot f(x) = %.3f, 'uwerr_plot_data' using 1:3 title \"tau_int with statistical errors\" with lines,", ret.tau_int);
fprintf(plotScriptf, " 'uwerr_plot_data' using 1:3:4 notitle with errorbars, f(x) title \"estimate\"; pause -1\n");
fclose(plotScriptf);
plotDataf = fopen("uwerr_plot_data", "w");
tmp = 0;
for (i = 0; i < W_max; ++i) {
tmp += gFbb[i];
/* print values for x-Axis, Gamma/Gamma[0], tau_int, and its errors */
fprintf(plotDataf, "%d %.3f %.3f %.3f\n", i, gFbb[i]/gFbb[0],
tmp/gFbb[0]-.5, 2*sqrt((i+tmp/gFbb[0])/rows));
}
fclose(plotDataf);
puts("Press Return to continue ...");
Tcl_Eval(interp, "[exec gnuplot uwerr_plot_script]");
}
Tcl_ResetResult(interp);
Tcl_PrintDouble(interp, ret.value, str);
Tcl_AppendResult(interp, str, " ", (char *)NULL);
Tcl_PrintDouble(interp, ret.dvalue, str);
Tcl_AppendResult(interp, str, " ", (char *)NULL);
Tcl_PrintDouble(interp, ret.ddvalue, str);
Tcl_AppendResult(interp, str, " ", (char *)NULL);
Tcl_PrintDouble(interp, ret.tau_int, str);
Tcl_AppendResult(interp, str, " ", (char *)NULL);
Tcl_PrintDouble(interp, ret.dtau_int, str);
Tcl_AppendResult(interp, str, (char *)NULL);
if (len > 1) {
Tcl_PrintDouble(interp, ret.Q_val, str);
Tcl_AppendResult(interp, " ", str, (char *)NULL);
}
err_exit:
free(abb);
for (k = 0; k < len; ++k)
free(abr[k]);
free(abr);
free(delpro);
free(gFbb);
free(Fbr);
free(fgrad);
free(str);
free(my_argv);
uwerr_free_tcl_vector(tcl_vector);
return TCL_OK;
}
int
Pg_lo_open(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[])
{
PGconn *conn;
int lobjId;
int mode;
int fd;
if (argc != 4)
{
Tcl_AppendResult(interp, "Wrong # of arguments\n",
"pg_lo_open connection lobjOid mode", 0);
return TCL_ERROR;
}
conn = PgGetConnectionId(interp, argv[1], (Pg_ConnectionId **) NULL);
if (conn == (PGconn *) NULL)
return TCL_ERROR;
lobjId = atoi(argv[2]);
if (strlen(argv[3]) < 1 ||
strlen(argv[3]) > 2)
{
Tcl_AppendResult(interp, "mode argument must be 'r', 'w', or 'rw'", 0);
return TCL_ERROR;
}
switch (argv[3][0])
{
case 'r':
case 'R':
mode = INV_READ;
break;
case 'w':
case 'W':
mode = INV_WRITE;
break;
default:
Tcl_AppendResult(interp, "mode argument must be 'r', 'w', or 'rw'", 0);
return TCL_ERROR;
}
switch (argv[3][1])
{
case '\0':
break;
case 'r':
case 'R':
mode |= INV_READ;
break;
case 'w':
case 'W':
mode |= INV_WRITE;
break;
default:
Tcl_AppendResult(interp, "mode argument must be 'r', 'w', or 'rw'", 0);
return TCL_ERROR;
}
fd = lo_open(conn, lobjId, mode);
sprintf(interp->result, "%d", fd);
return TCL_OK;
}
int uwerr(ClientData cd, Tcl_Interp *interp, int argc, char *argv[])
{
int i, nrows, ncols, len, plot = 0,
col_to_analyze = -1, analyze_col = 0, error = 0,
result = TCL_OK;
double s_tau = 1.5;
int * nrep;
double ** data;
char * str;
char ** my_argv;
Tcl_CmdInfo cmdInfo;
if (argc < 4) {
Tcl_AppendResult(interp, argv[0], " needs at least 3 arguments.\n",
"usage: ", argv[0], " <data> <nrep> {<col>|<f>} [<s_tau> [<f_args>]] [plot]\n",
(char *)NULL);
return TCL_ERROR;
}
/* read the matrix containing the data */
if (uwerr_read_matrix(interp, argv[1], &data, &nrows, &ncols) == TCL_ERROR)
return TCL_ERROR;
/* read the vector containing the length of each representation */
if (uwerr_read_int_vector(interp, argv[2], &nrep, &len) == TCL_ERROR)
return TCL_ERROR;
/* check if we analyze a column or a function of the columns */
if (!Tcl_GetCommandInfo(interp, argv[3], &cmdInfo)) {
analyze_col = 1;
if (Tcl_GetInt(interp, argv[3], &col_to_analyze) == TCL_ERROR) {
error = 1;
str = (char *)malloc(TCL_INTEGER_SPACE*sizeof(char));
sprintf(str, "%d", ncols);
Tcl_AppendResult(interp, "third argument has to be a function or a ",
"number between 1 and ", str, "!", (char *)NULL);
free(str);
}
}
if (!error && analyze_col &&
(col_to_analyze < 1 || col_to_analyze > ncols)) {
error = 1;
str = (char *)malloc(TCL_INTEGER_SPACE*sizeof(char));
sprintf(str, "%d", ncols);
Tcl_AppendResult(interp, "third argument has to be a function or a ",
"number between 1 and ", str, ".", (char *)NULL);
free(str);
}
/* check for plot as fourth argument */
if (argc > 4 && !error) {
if (!strcmp(argv[4], "plot"))
plot = 1;
else {
/* read s_tau if there is a fourth arg */
if (Tcl_GetDouble(interp, argv[4], &s_tau) == TCL_ERROR) {
error = 1;
Tcl_AppendResult(interp, "fourth argument has to be a double or 'plot'.", (char *)NULL);
}
}
}
if (argc > 5 && ! error)
if (!strcmp(argv[argc-1], "plot"))
plot = 1;
if (!error && analyze_col) {
result = UWerr(interp, data, nrows, ncols,
col_to_analyze-1, nrep, len, s_tau, plot);
}
if (!error && !analyze_col) {
my_argv = (char**)malloc((argc-3)*sizeof(char*));
my_argv[0] = argv[3];
for (i = 0; i < argc-5-plot; ++i)
my_argv[i+1] = argv[5+i];
result = UWerr_f(interp, &cmdInfo, argc-plot>4?argc-plot-4:1, my_argv,
data, nrows, ncols, nrep, len, s_tau, plot);
free(my_argv);
}
for (i = 0; i < nrows; ++i)
free(data[i]);
free(data);
free(nrep);
return error ? TCL_ERROR : TCL_OK;
}
int
Pg_connect(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[])
{
const char *pghost = NULL;
const char *pgtty = NULL;
const char *pgport = NULL;
const char *pgoptions = NULL;
const char *dbName;
int i;
PGconn *conn;
if (argc == 1)
{
Tcl_AppendResult(interp, "pg_connect: database name missing\n", 0);
Tcl_AppendResult(interp, "pg_connect databaseName [-host hostName] [-port portNumber] [-tty pgtty]\n", 0);
Tcl_AppendResult(interp, "pg_connect -conninfo conninfoString", 0);
return TCL_ERROR;
}
if (!strcmp("-conninfo", argv[1]))
{
/*
* Establish a connection using the new PQconnectdb() interface
*/
if (argc != 3)
{
Tcl_AppendResult(interp, "pg_connect: syntax error\n", 0);
Tcl_AppendResult(interp, "pg_connect -conninfo conninfoString", 0);
return TCL_ERROR;
}
conn = PQconnectdb(argv[2]);
}
else
{
/*
* Establish a connection using the old PQsetdb() interface
*/
if (argc > 2)
{
/* parse for pg environment settings */
i = 2;
while (i + 1 < argc)
{
if (strcmp(argv[i], "-host") == 0)
{
pghost = argv[i + 1];
i += 2;
}
else if (strcmp(argv[i], "-port") == 0)
{
pgport = argv[i + 1];
i += 2;
}
else if (strcmp(argv[i], "-tty") == 0)
{
pgtty = argv[i + 1];
i += 2;
}
else if (strcmp(argv[i], "-options") == 0)
{
pgoptions = argv[i + 1];
i += 2;
}
else
{
Tcl_AppendResult(interp, "Bad option to pg_connect: ",
argv[i], 0);
Tcl_AppendResult(interp, "\npg_connect databaseName [-host hostName] [-port portNumber] [-tty pgtty]", 0);
return TCL_ERROR;
}
} /* while */
if ((i % 2 != 0) || i != argc)
{
Tcl_AppendResult(interp, "wrong # of arguments to pg_connect: ",
argv[i], 0);
Tcl_AppendResult(interp, "\npg_connect databaseName [-host hostName] [-port portNumber] [-tty pgtty]", 0);
return TCL_ERROR;
}
}
dbName = argv[1];
conn = PQsetdb(pghost, pgport, pgoptions, pgtty, dbName);
}
if (PQstatus(conn) == CONNECTION_OK)
{
PgSetConnectionId(interp, conn);
return TCL_OK;
}
else
{
Tcl_AppendResult(interp, "Connection to database failed\n",
PQerrorMessage(conn), 0);
PQfinish(conn);
return TCL_ERROR;
}
}
/* Create a new listening port (or destroy one)
*
* listen <port> bots/all/users [mask]
* listen <port> script <proc> [flag]
* listen <port> off
*/
static int tcl_listen(ClientData cd, Tcl_Interp *irp,
int argc, char *argv[])
{
int i, j, idx = -1, port, realport;
char s[11], msg[256];
struct portmap *pmap = NULL, *pold = NULL;
BADARGS(3, 5, " port type ?mask?/?proc ?flag??");
port = realport = atoi(argv[1]);
for (pmap = root; pmap; pold = pmap, pmap = pmap->next)
if (pmap->realport == port) {
port = pmap->mappedto;
break;
}
for (i = 0; i < dcc_total; i++)
if ((dcc[i].type == &DCC_TELNET) && (dcc[i].port == port))
idx = i;
if (!egg_strcasecmp(argv[2], "off")) {
if (pmap) {
if (pold)
pold->next = pmap->next;
else
root = pmap->next;
nfree(pmap);
}
/* Remove */
if (idx < 0) {
Tcl_AppendResult(irp, "no such listen port is open", NULL);
return TCL_ERROR;
}
killsock(dcc[idx].sock);
lostdcc(idx);
return TCL_OK;
}
if (idx < 0) {
/* Make new one */
if (dcc_total >= max_dcc) {
Tcl_AppendResult(irp, "No more DCC slots available.", NULL);
return TCL_ERROR;
}
/* Try to grab port */
j = port + 20;
i = -1;
while (port < j && i < 0) {
i = open_listen(&port);
if (i == -1)
port++;
else if (i == -2)
break;
}
if (i == -1) {
egg_snprintf(msg, sizeof msg, "Couldn't listen on port '%d' on the "
"given address. Please make sure 'my-ip' is set correctly, "
"or try a different port.", realport);
Tcl_AppendResult(irp, msg, NULL);
return TCL_ERROR;
} else if (i == -2) {
Tcl_AppendResult(irp, "Couldn't assign the requested IP. Please make "
"sure 'my-ip' is set properly.", NULL);
return TCL_ERROR;
}
idx = new_dcc(&DCC_TELNET, 0);
dcc[idx].addr = iptolong(getmyip());
dcc[idx].port = port;
dcc[idx].sock = i;
dcc[idx].timeval = now;
}
/* script? */
if (!strcmp(argv[2], "script")) {
strcpy(dcc[idx].nick, "(script)");
if (argc < 4) {
Tcl_AppendResult(irp, "a proc name must be specified for a script listen", NULL);
killsock(dcc[idx].sock);
lostdcc(idx);
return TCL_ERROR;
}
if (argc == 5) {
if (strcmp(argv[4], "pub")) {
Tcl_AppendResult(irp, "unknown flag: ", argv[4], ". allowed flags: pub",
NULL);
killsock(dcc[idx].sock);
lostdcc(idx);
return TCL_ERROR;
}
dcc[idx].status = LSTN_PUBLIC;
}
strncpyz(dcc[idx].host, argv[3], UHOSTMAX);
egg_snprintf(s, sizeof s, "%d", port);
Tcl_AppendResult(irp, s, NULL);
return TCL_OK;
}
/* bots/users/all */
if (!strcmp(argv[2], "bots"))
strcpy(dcc[idx].nick, "(bots)");
else if (!strcmp(argv[2], "users"))
strcpy(dcc[idx].nick, "(users)");
else if (!strcmp(argv[2], "all"))
strcpy(dcc[idx].nick, "(telnet)");
if (!dcc[idx].nick[0]) {
Tcl_AppendResult(irp, "invalid listen type: must be one of ",
"bots, users, all, off, script", NULL);
killsock(dcc[idx].sock);
dcc_total--;
return TCL_ERROR;
}
if (argc == 4)
strncpyz(dcc[idx].host, argv[3], UHOSTMAX);
else
strcpy(dcc[idx].host, "*");
egg_snprintf(s, sizeof s, "%d", port);
Tcl_AppendResult(irp, s, NULL);
if (!pmap) {
pmap = nmalloc(sizeof(struct portmap));
pmap->next = root;
root = pmap;
}
pmap->realport = realport;
pmap->mappedto = port;
putlog(LOG_MISC, "*", "Listening at telnet port %d (%s).", port, argv[2]);
return TCL_OK;
}
/**********************************
* pg_result
get information about the results of a query
syntax:
pg_result result ?option?
the options are:
-status the status of the result
-error the error message, if the status indicates error; otherwise
an empty string
-conn the connection that produced the result
-oid if command was an INSERT, the OID of the inserted tuple
-numTuples the number of tuples in the query
-cmdTuples the number of tuples affected by the query
-numAttrs returns the number of attributes returned by the query
-assign arrayName
assign the results to an array, using subscripts of the form
(tupno,attributeName)
-assignbyidx arrayName ?appendstr?
assign the results to an array using the first field's value
as a key.
All but the first field of each tuple are stored, using
subscripts of the form (field0value,attributeNameappendstr)
-getTuple tupleNumber
returns the values of the tuple in a list
-tupleArray tupleNumber arrayName
stores the values of the tuple in array arrayName, indexed
by the attributes returned
-attributes
returns a list of the name/type pairs of the tuple attributes
-lAttributes
returns a list of the {name type len} entries of the tuple
attributes
-clear clear the result buffer. Do not reuse after this
**********************************/
int
Pg_result(ClientData cData, Tcl_Interp *interp, int argc, CONST84 char *argv[])
{
PGresult *result;
const char *opt;
int i;
int tupno;
CONST84 char *arrVar;
char nameBuffer[256];
const char *appendstr;
if (argc < 3 || argc > 5)
{
Tcl_AppendResult(interp, "Wrong # of arguments\n", 0);
goto Pg_result_errReturn; /* append help info */
}
result = PgGetResultId(interp, argv[1]);
if (result == (PGresult *) NULL)
{
Tcl_AppendResult(interp, "\n",
argv[1], " is not a valid query result", 0);
return TCL_ERROR;
}
opt = argv[2];
if (strcmp(opt, "-status") == 0)
{
Tcl_AppendResult(interp, PQresStatus(PQresultStatus(result)), 0);
return TCL_OK;
}
else if (strcmp(opt, "-error") == 0)
{
Tcl_SetResult(interp, (char *) PQresultErrorMessage(result),
TCL_STATIC);
return TCL_OK;
}
else if (strcmp(opt, "-conn") == 0)
return PgGetConnByResultId(interp, argv[1]);
else if (strcmp(opt, "-oid") == 0)
{
sprintf(interp->result, "%u", PQoidValue(result));
return TCL_OK;
}
else if (strcmp(opt, "-clear") == 0)
{
PgDelResultId(interp, argv[1]);
PQclear(result);
return TCL_OK;
}
else if (strcmp(opt, "-numTuples") == 0)
{
sprintf(interp->result, "%d", PQntuples(result));
return TCL_OK;
}
else if (strcmp(opt, "-cmdTuples") == 0)
{
sprintf(interp->result, "%s", PQcmdTuples(result));
return TCL_OK;
}
else if (strcmp(opt, "-numAttrs") == 0)
{
sprintf(interp->result, "%d", PQnfields(result));
return TCL_OK;
}
else if (strcmp(opt, "-assign") == 0)
{
if (argc != 4)
{
Tcl_AppendResult(interp, "-assign option must be followed by a variable name", 0);
return TCL_ERROR;
}
arrVar = argv[3];
/*
* this assignment assigns the table of result tuples into a giant
* array with the name given in the argument. The indices of the
* array are of the form (tupno,attrName). Note we expect field
* names not to exceed a few dozen characters, so truncating to
* prevent buffer overflow shouldn't be a problem.
*/
for (tupno = 0; tupno < PQntuples(result); tupno++)
{
for (i = 0; i < PQnfields(result); i++)
{
sprintf(nameBuffer, "%d,%.200s", tupno, PQfname(result, i));
if (Tcl_SetVar2(interp, arrVar, nameBuffer,
#ifdef TCL_ARRAYS
tcl_value(PQgetvalue(result, tupno, i)),
#else
PQgetvalue(result, tupno, i),
#endif
TCL_LEAVE_ERR_MSG) == NULL)
return TCL_ERROR;
}
}
Tcl_AppendResult(interp, arrVar, 0);
return TCL_OK;
}
else if (strcmp(opt, "-assignbyidx") == 0)
{
if (argc != 4 && argc != 5)
{
Tcl_AppendResult(interp, "-assignbyidx option requires an array name and optionally an append string", 0);
return TCL_ERROR;
}
arrVar = argv[3];
appendstr = (argc == 5) ? (const char *) argv[4] : "";
/*
* this assignment assigns the table of result tuples into a giant
* array with the name given in the argument. The indices of the
* array are of the form (field0Value,attrNameappendstr). Here, we
* still assume PQfname won't exceed 200 characters, but we dare
* not make the same assumption about the data in field 0 nor the
* append string.
*/
for (tupno = 0; tupno < PQntuples(result); tupno++)
{
const char *field0 =
#ifdef TCL_ARRAYS
tcl_value(PQgetvalue(result, tupno, 0));
#else
PQgetvalue(result, tupno, 0);
#endif
char *workspace = malloc(strlen(field0) + strlen(appendstr) + 210);
for (i = 1; i < PQnfields(result); i++)
{
sprintf(workspace, "%s,%.200s%s", field0, PQfname(result, i),
appendstr);
if (Tcl_SetVar2(interp, arrVar, workspace,
#ifdef TCL_ARRAYS
tcl_value(PQgetvalue(result, tupno, i)),
#else
PQgetvalue(result, tupno, i),
#endif
TCL_LEAVE_ERR_MSG) == NULL)
{
free(workspace);
return TCL_ERROR;
}
}
free(workspace);
}
Tcl_AppendResult(interp, arrVar, 0);
return TCL_OK;
}
else if (strcmp(opt, "-getTuple") == 0)
{
if (argc != 4)
{
Tcl_AppendResult(interp, "-getTuple option must be followed by a tuple number", 0);
return TCL_ERROR;
}
tupno = atoi(argv[3]);
if (tupno < 0 || tupno >= PQntuples(result))
{
Tcl_AppendResult(interp, "argument to getTuple cannot exceed number of tuples - 1", 0);
return TCL_ERROR;
}
#ifdef TCL_ARRAYS
for (i = 0; i < PQnfields(result); i++)
Tcl_AppendElement(interp, tcl_value(PQgetvalue(result, tupno, i)));
#else
for (i = 0; i < PQnfields(result); i++)
Tcl_AppendElement(interp, PQgetvalue(result, tupno, i));
#endif
return TCL_OK;
}
else if (strcmp(opt, "-tupleArray") == 0)
{
if (argc != 5)
{
Tcl_AppendResult(interp, "-tupleArray option must be followed by a tuple number and array name", 0);
return TCL_ERROR;
}
tupno = atoi(argv[3]);
if (tupno < 0 || tupno >= PQntuples(result))
{
Tcl_AppendResult(interp, "argument to tupleArray cannot exceed number of tuples - 1", 0);
return TCL_ERROR;
}
for (i = 0; i < PQnfields(result); i++)
{
if (Tcl_SetVar2(interp, argv[4], PQfname(result, i),
#ifdef TCL_ARRAYS
tcl_value(PQgetvalue(result, tupno, i)),
#else
PQgetvalue(result, tupno, i),
#endif
TCL_LEAVE_ERR_MSG) == NULL)
return TCL_ERROR;
}
return TCL_OK;
}
else if (strcmp(opt, "-attributes") == 0)
{
for (i = 0; i < PQnfields(result); i++)
Tcl_AppendElement(interp, PQfname(result, i));
return TCL_OK;
}
else if (strcmp(opt, "-lAttributes") == 0)
{
for (i = 0; i < PQnfields(result); i++)
{
/* start a sublist */
if (i > 0)
Tcl_AppendResult(interp, " {", 0);
else
Tcl_AppendResult(interp, "{", 0);
Tcl_AppendElement(interp, PQfname(result, i));
sprintf(nameBuffer, "%ld", (long) PQftype(result, i));
Tcl_AppendElement(interp, nameBuffer);
sprintf(nameBuffer, "%ld", (long) PQfsize(result, i));
Tcl_AppendElement(interp, nameBuffer);
/* end the sublist */
Tcl_AppendResult(interp, "}", 0);
}
return TCL_OK;
}
else
{
Tcl_AppendResult(interp, "Invalid option\n", 0);
goto Pg_result_errReturn; /* append help info */
}
Pg_result_errReturn:
Tcl_AppendResult(interp,
"pg_result result ?option? where option is\n",
"\t-status\n",
"\t-error\n",
"\t-conn\n",
"\t-oid\n",
"\t-numTuples\n",
"\t-cmdTuples\n",
"\t-numAttrs\n"
"\t-assign arrayVarName\n",
"\t-assignbyidx arrayVarName ?appendstr?\n",
"\t-getTuple tupleNumber\n",
"\t-tupleArray tupleNumber arrayVarName\n",
"\t-attributes\n"
"\t-lAttributes\n"
"\t-clear\n",
(char *) 0);
return TCL_ERROR;
}
static int
SetMMFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
ThreadSpecificData *typeCache = GetTypeCache();
const Tcl_ObjType *typePtr;
char *string, *rest;
double d;
int units;
MMRep *mmPtr;
if (objPtr->typePtr == typeCache->doubleTypePtr) {
Tcl_GetDoubleFromObj(interp, objPtr, &d);
units = -1;
} else if (objPtr->typePtr == typeCache->intTypePtr) {
Tcl_GetIntFromObj(interp, objPtr, &units);
d = (double) units;
units = -1;
/*
* In the case of ints, we need to ensure that a valid string exists
* in order for int-but-not-string objects to be converted back to
* ints again from mm obj types.
*/
(void) Tcl_GetString(objPtr);
} else {
/*
* It wasn't a known int or double, so parse it.
*/
string = Tcl_GetString(objPtr);
d = strtod(string, &rest);
if (rest == string) {
/*
* Must copy string before resetting the result in case a caller
* is trying to convert the interpreter's result to mms.
*/
error:
Tcl_AppendResult(interp, "bad screen distance \"", string,
"\"", NULL);
return TCL_ERROR;
}
while ((*rest != '\0') && isspace(UCHAR(*rest))) {
rest++;
}
switch (*rest) {
case '\0':
units = -1;
break;
case 'c':
units = 0;
break;
case 'i':
units = 1;
break;
case 'm':
units = 2;
break;
case 'p':
units = 3;
break;
default:
goto error;
}
}
/*
* Free the old internalRep before setting the new one.
*/
typePtr = objPtr->typePtr;
if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
(*typePtr->freeIntRepProc)(objPtr);
}
objPtr->typePtr = &mmObjType;
mmPtr = (MMRep *) ckalloc(sizeof(MMRep));
mmPtr->value = d;
mmPtr->units = units;
mmPtr->tkwin = NULL;
mmPtr->returnValue = d;
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) mmPtr;
return TCL_OK;
}
int tclcommand_inter_parse_non_bonded(Tcl_Interp * interp,
int part_type_a, int part_type_b,
int argc, char ** argv)
{
int change;
Tcl_ResetResult(interp);
if (argc <= 0) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
"inter <type 1> <type 2> ?interaction? ?values?\"",
(char *) NULL);
return TCL_ERROR;
}
/* get interaction parameters */
while (argc > 0) {
/* The various parsers return the number of parsed parameters.
If an error occured, 0 should be returned, since none of the parameters were
understood */
/* that's just for the else below... */
if (0);
#define REGISTER_NONBONDED(name, parser) \
else if (ARG0_IS_S(name)) \
change = parser(interp, part_type_a, part_type_b, argc, argv)
#ifdef LENNARD_JONES
REGISTER_NONBONDED("lennard-jones", tclcommand_inter_parse_lj);
#endif
#ifdef LENNARD_JONES_GENERIC
REGISTER_NONBONDED("lj-gen", tclcommand_inter_parse_ljgen);
#endif
#ifdef LJ_ANGLE
REGISTER_NONBONDED("lj-angle", tclcommand_inter_parse_ljangle);
#endif
#ifdef SMOOTH_STEP
REGISTER_NONBONDED("smooth-step", tclcommand_inter_parse_SmSt);
#endif
#ifdef HERTZIAN
REGISTER_NONBONDED("hertzian", tclcommand_inter_parse_hertzian);
#endif
#ifdef GAUSSIAN
REGISTER_NONBONDED("gaussian", tclcommand_inter_parse_gaussian);
#endif
#ifdef BMHTF_NACL
REGISTER_NONBONDED("bmhtf-nacl", tclcommand_inter_parse_BMHTF);
#endif
#ifdef MORSE
REGISTER_NONBONDED("morse", tclcommand_inter_parse_morse);
#endif
#ifdef LJCOS
REGISTER_NONBONDED("lj-cos", tclcommand_inter_parse_ljcos);
#endif
#ifdef BUCKINGHAM
REGISTER_NONBONDED("buckingham", tclcommand_inter_parse_buckingham);
#endif
#ifdef SOFT_SPHERE
REGISTER_NONBONDED("soft-sphere", tclcommand_inter_parse_soft);
#endif
#ifdef AFFINITY
REGISTER_NONBONDED("affinity", tclcommand_inter_parse_affinity);
#endif
#ifdef MEMBRANE_COLLISION
REGISTER_NONBONDED("membrane", tclcommand_inter_parse_membrane);
#endif
#ifdef HAT
REGISTER_NONBONDED("hat", tclcommand_inter_parse_hat);
#endif
#ifdef COMFORCE
REGISTER_NONBONDED("comforce", tclcommand_inter_parse_comforce);
#endif
#ifdef LJCOS2
REGISTER_NONBONDED("lj-cos2", tclcommand_inter_parse_ljcos2);
#endif
#ifdef COS2
REGISTER_NONBONDED("cos2", tclcommand_inter_parse_cos2);
#endif
#ifdef COMFIXED
REGISTER_NONBONDED("comfixed", tclcommand_inter_parse_comfixed);
#endif
#ifdef GAY_BERNE
REGISTER_NONBONDED("gay-berne", tclcommand_inter_parse_gb);
#endif
#ifdef TABULATED
REGISTER_NONBONDED("tabulated", tclcommand_inter_parse_tab);
#endif
#ifdef INTER_DPD
REGISTER_NONBONDED("inter_dpd", tclcommand_inter_parse_inter_dpd);
#endif
#ifdef INTER_RF
REGISTER_NONBONDED("inter_rf", tclcommand_inter_parse_interrf);
#endif
#ifdef TUNABLE_SLIP
REGISTER_NONBONDED("tunable_slip", tclcommand_inter_parse_tunable_slip);
#endif
#ifdef MOL_CUT
REGISTER_NONBONDED("molcut", tclcommand_inter_parse_molcut);
#endif
#ifdef SHANCHEN
REGISTER_NONBONDED("affinity",tclcommand_inter_parse_affinity);
#endif
else {
Tcl_AppendResult(interp, "excessive parameter/unknown interaction type \"", argv[0],
"\" in parsing non bonded interaction",
(char *) NULL);
return TCL_ERROR;
}
if (change <= 0)
return TCL_ERROR;
argc -= change;
argv += change;
}