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; }