summaryrefslogtreecommitdiffstats
path: root/tkblt/generic/tkbltVector.C
diff options
context:
space:
mode:
authorWilliam Joye <wjoye@cfa.harvard.edu>2019-01-02 21:50:36 (GMT)
committerWilliam Joye <wjoye@cfa.harvard.edu>2019-01-02 21:50:36 (GMT)
commit4b458dac3f0ea680db57779eb3684e2136680306 (patch)
tree2b61d5f91c71b718dbee8631eccbbf3d47528432 /tkblt/generic/tkbltVector.C
parentd2825c8167bd0d1f1daa937aa3b6ab21f7522527 (diff)
downloadblt-4b458dac3f0ea680db57779eb3684e2136680306.zip
blt-4b458dac3f0ea680db57779eb3684e2136680306.tar.gz
blt-4b458dac3f0ea680db57779eb3684e2136680306.tar.bz2
update TEA 3.13
Diffstat (limited to 'tkblt/generic/tkbltVector.C')
-rw-r--r--tkblt/generic/tkbltVector.C1875
1 files changed, 0 insertions, 1875 deletions
diff --git a/tkblt/generic/tkbltVector.C b/tkblt/generic/tkbltVector.C
deleted file mode 100644
index 0837917..0000000
--- a/tkblt/generic/tkbltVector.C
+++ /dev/null
@@ -1,1875 +0,0 @@
-/*
- * Smithsonian Astrophysical Observatory, Cambridge, MA, USA
- * This code has been modified under the terms listed below and is made
- * available under the same terms.
- */
-
-/*
- * Copyright 1995-2004 George A Howlett.
- *
- * Permission is hereby granted, free of charge, to any person obtaining
- * a copy of this software and associated documentation files (the
- * "Software"), to deal in the Software without restriction, including
- * without limitation the rights to use, copy, modify, merge, publish,
- * distribute, sublicense, and/or sell copies of the Software, and to
- * permit persons to whom the Software is furnished to do so, subject to
- * the following conditions:
- *
- * The above copyright notice and this permission notice shall be
- * included in all copies or substantial portions of the Software.
- *
- * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
- * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
- * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
- * NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
- * LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
- * OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
- * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
- */
-
-/*
- * TODO:
- * o Add H. Kirsch's vector binary read operation
- * x binread file0
- * x binread -file file0
- *
- * o Add ASCII/binary file reader
- * x read fileName
- *
- * o Allow Tcl-based client notifications.
- * vector x
- * x notify call Display
- * x notify delete Display
- * x notify reorder #1 #2
- */
-
-#include <float.h>
-#include <time.h>
-#include <string.h>
-#include <stdlib.h>
-#include <stdio.h>
-#include <ctype.h>
-
-#include <cmath>
-
-#include "tkbltInt.h"
-#include "tkbltVecInt.h"
-#include "tkbltNsUtil.h"
-#include "tkbltSwitch.h"
-#include "tkbltOp.h"
-
-using namespace Blt;
-
-#define DEF_ARRAY_SIZE 64
-#define TRACE_ALL (TCL_TRACE_WRITES | TCL_TRACE_READS | TCL_TRACE_UNSETS)
-
-
-#define VECTOR_CHAR(c) ((isalnum((unsigned char)(c))) || \
- (c == '_') || (c == ':') || (c == '@') || (c == '.'))
-
-/*
- * VectorClient --
- *
- * A vector can be shared by several clients. Each client allocates this
- * structure that acts as its key for using the vector. Clients can also
- * designate a callback routine that is executed whenever the vector is
- * updated or destroyed.
- *
- */
-typedef struct {
- unsigned int magic; /* Magic value designating whether this really
- * is a vector token or not */
- Vector* serverPtr; /* Pointer to the master record of the vector.
- * If NULL, indicates that the vector has been
- * destroyed but as of yet, this client hasn't
- * recognized it. */
- Blt_VectorChangedProc *proc;/* Routine to call when the contents of the
- * vector change or the vector is deleted. */
- ClientData clientData; /* Data passed whenever the vector change
- * procedure is called. */
- ChainLink* link; /* Used to quickly remove this entry from its
- * server's client chain. */
-} VectorClient;
-
-static Tcl_CmdDeleteProc VectorInstDeleteProc;
-extern Tcl_ObjCmdProc VectorObjCmd;
-static Tcl_InterpDeleteProc VectorInterpDeleteProc;
-
-typedef struct {
- char *varName; /* Requested variable name. */
- char *cmdName; /* Requested command name. */
- int flush; /* Flush */
- int watchUnset; /* Watch when variable is unset. */
-} CreateSwitches;
-
-static Blt_SwitchSpec createSwitches[] =
- {
- {BLT_SWITCH_STRING, "-variable", "varName",
- Tk_Offset(CreateSwitches, varName), BLT_SWITCH_NULL_OK},
- {BLT_SWITCH_STRING, "-command", "command",
- Tk_Offset(CreateSwitches, cmdName), BLT_SWITCH_NULL_OK},
- {BLT_SWITCH_BOOLEAN, "-watchunset", "bool",
- Tk_Offset(CreateSwitches, watchUnset), 0},
- {BLT_SWITCH_BOOLEAN, "-flush", "bool",
- Tk_Offset(CreateSwitches, flush), 0},
- {BLT_SWITCH_END}
- };
-
-typedef int (VectorCmdProc)(Vector* vecObjPtr, Tcl_Interp* interp,
- int objc, Tcl_Obj* const objv[]);
-
-static char stringRep[200];
-
-const char *Blt::Itoa(int value)
-{
- snprintf(stringRep, 200, "%d", value);
- return stringRep;
-}
-
-static char* Blt_Strdup(const char *string)
-{
- size_t size = strlen(string) + 1;
- char* ptr = (char*)malloc(size * sizeof(char));
- if (ptr != NULL)
- strcpy(ptr, string);
-
- return ptr;
-}
-
-static Vector* FindVectorInNamespace(VectorInterpData *dataPtr,
- Blt_ObjectName *objNamePtr)
-{
- Tcl_DString dString;
- const char* name = MakeQualifiedName(objNamePtr, &dString);
- Tcl_HashEntry* hPtr = Tcl_FindHashEntry(&dataPtr->vectorTable, name);
- Tcl_DStringFree(&dString);
- if (hPtr != NULL)
- return (Vector*)Tcl_GetHashValue(hPtr);
-
- return NULL;
-}
-
-static Vector* GetVectorObject(VectorInterpData *dataPtr, const char *name,
- int flags)
-{
- Tcl_Interp* interp = dataPtr->interp;
- Blt_ObjectName objName;
- if (!ParseObjectName(interp, name, &objName, BLT_NO_ERROR_MSG | BLT_NO_DEFAULT_NS))
- return NULL;
-
- Vector* vPtr = NULL;
- if (objName.nsPtr != NULL)
- vPtr = FindVectorInNamespace(dataPtr, &objName);
- else {
- if (flags & NS_SEARCH_CURRENT) {
- objName.nsPtr = Tcl_GetCurrentNamespace(interp);
- vPtr = FindVectorInNamespace(dataPtr, &objName);
- }
- if ((vPtr == NULL) && (flags & NS_SEARCH_GLOBAL)) {
- objName.nsPtr = Tcl_GetGlobalNamespace(interp);
- vPtr = FindVectorInNamespace(dataPtr, &objName);
- }
- }
-
- return vPtr;
-}
-
-void Blt::Vec_UpdateRange(Vector* vPtr)
-{
- double* vp = vPtr->valueArr + vPtr->first;
- double* vend = vPtr->valueArr + vPtr->last;
- double min = *vp;
- double max = *vp++;
- for (/* empty */; vp <= vend; vp++) {
- if (min > *vp)
- min = *vp;
- else if (max < *vp)
- max = *vp;
- }
- vPtr->min = min;
- vPtr->max = max;
- vPtr->notifyFlags &= ~UPDATE_RANGE;
-}
-
-int Blt::Vec_GetIndex(Tcl_Interp* interp, Vector* vPtr, const char *string,
- int *indexPtr, int flags, Blt_VectorIndexProc **procPtrPtr)
-{
- int value;
- char c = string[0];
-
- // Treat the index "end" like a numeric index
- if ((c == 'e') && (strcmp(string, "end") == 0)) {
- if (vPtr->length < 1) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "bad index \"end\": vector is empty",
- (char *)NULL);
- }
- return TCL_ERROR;
- }
- *indexPtr = vPtr->length - 1;
- return TCL_OK;
- } else if ((c == '+') && (strcmp(string, "++end") == 0)) {
- *indexPtr = vPtr->length;
- return TCL_OK;
- }
- if (procPtrPtr != NULL) {
- Tcl_HashEntry *hPtr;
-
- hPtr = Tcl_FindHashEntry(&vPtr->dataPtr->indexProcTable, string);
- if (hPtr != NULL) {
- *indexPtr = SPECIAL_INDEX;
- *procPtrPtr = (Blt_VectorIndexProc*)Tcl_GetHashValue(hPtr);
- return TCL_OK;
- }
- }
- if (Tcl_GetInt(interp, (char *)string, &value) != TCL_OK) {
- long int lvalue;
- /*
- * Unlike Tcl_GetInt, Tcl_ExprLong needs a valid interpreter, but the
- * interp passed in may be NULL. So we have to use vPtr->interp and
- * then reset the result.
- */
- if (Tcl_ExprLong(vPtr->interp, (char *)string, &lvalue) != TCL_OK) {
- Tcl_ResetResult(vPtr->interp);
- if (interp != NULL) {
- Tcl_AppendResult(interp, "bad index \"", string, "\"",
- (char *)NULL);
- }
- return TCL_ERROR;
- }
- value = (int)lvalue;
- }
- /*
- * Correct the index by the current value of the offset. This makes all
- * the numeric indices non-negative, which is how we distinguish the
- * special non-numeric indices.
- */
- value -= vPtr->offset;
-
- if ((value < 0) || ((flags & INDEX_CHECK) && (value >= vPtr->length))) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "index \"", string, "\" is out of range",
- (char *)NULL);
- }
- return TCL_ERROR;
- }
- *indexPtr = (int)value;
- return TCL_OK;
-}
-
-int Blt::Vec_GetIndexRange(Tcl_Interp* interp, Vector* vPtr, const char *string,
- int flags, Blt_VectorIndexProc** procPtrPtr)
-{
- int ielem;
- char* colon = NULL;
- if (flags & INDEX_COLON)
- colon = (char*)strchr(string, ':');
-
- if (colon != NULL) {
- if (string == colon) {
- vPtr->first = 0; /* Default to the first index */
- }
- else {
- int result;
-
- *colon = '\0';
- result = Vec_GetIndex(interp, vPtr, string, &ielem, flags,
- (Blt_VectorIndexProc **) NULL);
- *colon = ':';
- if (result != TCL_OK) {
- return TCL_ERROR;
- }
- vPtr->first = ielem;
- }
- if (*(colon + 1) == '\0') {
- /* Default to the last index */
- vPtr->last = (vPtr->length > 0) ? vPtr->length - 1 : 0;
- } else {
- if (Vec_GetIndex(interp, vPtr, colon + 1, &ielem, flags,
- (Blt_VectorIndexProc **) NULL) != TCL_OK) {
- return TCL_ERROR;
- }
- vPtr->last = ielem;
- }
- if (vPtr->first > vPtr->last) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "bad range \"", string,
- "\" (first > last)", (char *)NULL);
- }
- return TCL_ERROR;
- }
- } else {
- if (Vec_GetIndex(interp, vPtr, string, &ielem, flags,
- procPtrPtr) != TCL_OK) {
- return TCL_ERROR;
- }
- vPtr->last = vPtr->first = ielem;
- }
- return TCL_OK;
-}
-
-Vector* Blt::Vec_ParseElement(Tcl_Interp* interp, VectorInterpData *dataPtr,
- const char* start, const char** endPtr, int flags)
-{
- char* p = (char*)start;
- // Find the end of the vector name
- while (VECTOR_CHAR(*p)) {
- p++;
- }
- char saved = *p;
- *p = '\0';
-
- Vector* vPtr = GetVectorObject(dataPtr, start, flags);
- if (vPtr == NULL) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "can't find vector \"", start, "\"",
- (char *)NULL);
- }
- *p = saved;
- return NULL;
- }
- *p = saved;
- vPtr->first = 0;
- vPtr->last = vPtr->length - 1;
- if (*p == '(') {
- int count, result;
-
- start = p + 1;
- p++;
-
- /* Find the matching right parenthesis */
- count = 1;
- while (*p != '\0') {
- if (*p == ')') {
- count--;
- if (count == 0) {
- break;
- }
- } else if (*p == '(') {
- count++;
- }
- p++;
- }
- if (count > 0) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "unbalanced parentheses \"", start,
- "\"", (char *)NULL);
- }
- return NULL;
- }
- *p = '\0';
- result = Vec_GetIndexRange(interp, vPtr, start, (INDEX_COLON | INDEX_CHECK), (Blt_VectorIndexProc **) NULL);
- *p = ')';
- if (result != TCL_OK) {
- return NULL;
- }
- p++;
- }
- if (endPtr != NULL) {
- *endPtr = p;
- }
- return vPtr;
-}
-
-void Blt_Vec_NotifyClients(ClientData clientData)
-{
- Vector* vPtr = (Vector*)clientData;
- ChainLink *link, *next;
- Blt_VectorNotify notify;
-
- notify = (vPtr->notifyFlags & NOTIFY_DESTROYED)
- ? BLT_VECTOR_NOTIFY_DESTROY : BLT_VECTOR_NOTIFY_UPDATE;
- vPtr->notifyFlags &= ~(NOTIFY_UPDATED | NOTIFY_DESTROYED | NOTIFY_PENDING);
- for (link = Chain_FirstLink(vPtr->chain); link; link = next) {
- next = Chain_NextLink(link);
- VectorClient *clientPtr = (VectorClient*)Chain_GetValue(link);
- if ((clientPtr->proc != NULL) && (clientPtr->serverPtr != NULL)) {
- (*clientPtr->proc) (vPtr->interp, clientPtr->clientData, notify);
- }
- }
-
- // Some clients may not handle the "destroy" callback properly (they
- // should call Blt_FreeVectorId to release the client identifier), so mark
- // any remaining clients to indicate that vector's server has gone away.
- if (notify == BLT_VECTOR_NOTIFY_DESTROY) {
- for (link = Chain_FirstLink(vPtr->chain); link;
- link = Chain_NextLink(link)) {
- VectorClient *clientPtr = (VectorClient*)Chain_GetValue(link);
- clientPtr->serverPtr = NULL;
- }
- }
-}
-
-void Blt::Vec_UpdateClients(Vector* vPtr)
-{
- vPtr->dirty++;
- vPtr->max = vPtr->min = NAN;
- if (vPtr->notifyFlags & NOTIFY_NEVER) {
- return;
- }
- vPtr->notifyFlags |= NOTIFY_UPDATED;
- if (vPtr->notifyFlags & NOTIFY_ALWAYS) {
- Blt_Vec_NotifyClients(vPtr);
- return;
- }
- if (!(vPtr->notifyFlags & NOTIFY_PENDING)) {
- vPtr->notifyFlags |= NOTIFY_PENDING;
- Tcl_DoWhenIdle(Blt_Vec_NotifyClients, vPtr);
- }
-}
-
-void Blt::Vec_FlushCache(Vector* vPtr)
-{
- Tcl_Interp* interp = vPtr->interp;
-
- if (vPtr->arrayName == NULL)
- return;
-
- /* Turn off the trace temporarily so that we can unset all the
- * elements in the array. */
-
- Tcl_UntraceVar2(interp, vPtr->arrayName, (char *)NULL,
- TRACE_ALL | vPtr->varFlags, Vec_VarTrace, vPtr);
-
- /* Clear all the element entries from the entire array */
- Tcl_UnsetVar2(interp, vPtr->arrayName, (char *)NULL, vPtr->varFlags);
-
- /* Restore the "end" index by default and the trace on the entire array */
- Tcl_SetVar2(interp, vPtr->arrayName, "end", "", vPtr->varFlags);
- Tcl_TraceVar2(interp, vPtr->arrayName, (char *)NULL,
- TRACE_ALL | vPtr->varFlags, Vec_VarTrace, vPtr);
-}
-
-int Blt::Vec_LookupName(VectorInterpData *dataPtr, const char *vecName,
- Vector** vPtrPtr)
-{
-
- const char *endPtr;
- Vector* vPtr = Vec_ParseElement(dataPtr->interp, dataPtr, vecName, &endPtr, NS_SEARCH_BOTH);
- if (vPtr == NULL)
- return TCL_ERROR;
-
- if (*endPtr != '\0') {
- Tcl_AppendResult(dataPtr->interp,
- "extra characters after vector name", (char *)NULL);
- return TCL_ERROR;
- }
-
- *vPtrPtr = vPtr;
- return TCL_OK;
-}
-
-double Blt::Vec_Min(Vector* vecObjPtr)
-{
- double* vp = vecObjPtr->valueArr + vecObjPtr->first;
- double* vend = vecObjPtr->valueArr + vecObjPtr->last;
- double min = *vp++;
- for (/* empty */; vp <= vend; vp++) {
- if (min > *vp)
- min = *vp;
- }
- vecObjPtr->min = min;
- return vecObjPtr->min;
-}
-
-double Blt::Vec_Max(Vector* vecObjPtr)
-{
- double max = NAN;
- double* vp = vecObjPtr->valueArr + vecObjPtr->first;
- double* vend = vecObjPtr->valueArr + vecObjPtr->last;
- max = *vp++;
- for (/* empty */; vp <= vend; vp++) {
- if (max < *vp)
- max = *vp;
- }
- vecObjPtr->max = max;
- return vecObjPtr->max;
-}
-
-static void DeleteCommand(Vector* vPtr)
-{
- Tcl_Interp* interp = vPtr->interp;
- char *qualName;
- Tcl_CmdInfo cmdInfo;
- Tcl_DString dString;
- Blt_ObjectName objName;
-
- Tcl_DStringInit(&dString);
- objName.name = Tcl_GetCommandName(interp, vPtr->cmdToken);
- objName.nsPtr = GetCommandNamespace(vPtr->cmdToken);
- qualName = MakeQualifiedName(&objName, &dString);
- if (Tcl_GetCommandInfo(interp, qualName, &cmdInfo)) {
- // Disable the callback before deleting the TCL command
- cmdInfo.deleteProc = NULL;
- Tcl_SetCommandInfo(interp, qualName, &cmdInfo);
- Tcl_DeleteCommandFromToken(interp, vPtr->cmdToken);
- }
- Tcl_DStringFree(&dString);
- vPtr->cmdToken = 0;
-}
-
-static void UnmapVariable(Vector* vPtr)
-{
- Tcl_Interp* interp = vPtr->interp;
-
- // Unset the entire array
- Tcl_UntraceVar2(interp, vPtr->arrayName, (char *)NULL,
- (TRACE_ALL | vPtr->varFlags), Vec_VarTrace, vPtr);
- Tcl_UnsetVar2(interp, vPtr->arrayName, (char *)NULL, vPtr->varFlags);
-
- if (vPtr->arrayName != NULL) {
- free((void*)(vPtr->arrayName));
- vPtr->arrayName = NULL;
- }
-}
-
-int Blt::Vec_MapVariable(Tcl_Interp* interp, Vector* vPtr, const char *path)
-{
- Blt_ObjectName objName;
- char *newPath;
- const char *result;
- Tcl_DString dString;
-
- if (vPtr->arrayName != NULL) {
- UnmapVariable(vPtr);
- }
- if ((path == NULL) || (path[0] == '\0')) {
- return TCL_OK; /* If the variable pathname is the empty
- * string, simply return after removing any
- * existing variable. */
- }
- /* Get the variable name (without the namespace qualifier). */
- if (!ParseObjectName(interp, path, &objName, BLT_NO_DEFAULT_NS)) {
- return TCL_ERROR;
- }
- if (objName.nsPtr == NULL) {
- /*
- * If there was no namespace qualifier, try harder to see if the
- * variable is non-local.
- */
- objName.nsPtr = GetVariableNamespace(interp, objName.name);
- }
- Tcl_DStringInit(&dString);
- vPtr->varFlags = 0;
- if (objName.nsPtr != NULL) { /* Global or namespace variable. */
- newPath = MakeQualifiedName(&objName, &dString);
- vPtr->varFlags |= (TCL_GLOBAL_ONLY);
- } else { /* Local variable. */
- newPath = (char *)objName.name;
- }
-
- /*
- * To play it safe, delete the variable first. This has the benefical
- * side-effect of unmapping the variable from another vector that may be
- * currently associated with it.
- */
- Tcl_UnsetVar2(interp, newPath, (char *)NULL, 0);
-
- /*
- * Set the index "end" in the array. This will create the variable
- * immediately so that we can check its namespace context.
- */
- result = Tcl_SetVar2(interp, newPath, "end", "", TCL_LEAVE_ERR_MSG);
- if (result == NULL) {
- Tcl_DStringFree(&dString);
- return TCL_ERROR;
- }
- /* Create a full-array trace on reads, writes, and unsets. */
- Tcl_TraceVar2(interp, newPath, (char *)NULL, TRACE_ALL, Vec_VarTrace,
- vPtr);
- vPtr->arrayName = Blt_Strdup(newPath);
- Tcl_DStringFree(&dString);
- return TCL_OK;
-}
-
-int Blt::Vec_SetSize(Tcl_Interp* interp, Vector* vPtr, int newSize)
-{
- if (newSize <= 0) {
- newSize = DEF_ARRAY_SIZE;
- }
- if (newSize == vPtr->size) {
- /* Same size, use the current array. */
- return TCL_OK;
- }
- if (vPtr->freeProc == TCL_DYNAMIC) {
- /* Old memory was dynamically allocated, so use realloc. */
- double* newArr = (double*)realloc(vPtr->valueArr, newSize * sizeof(double));
- if (newArr == NULL) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "can't reallocate ",
- Itoa(newSize), " elements for vector \"",
- vPtr->name, "\"", (char *)NULL);
- }
- return TCL_ERROR;
- }
- vPtr->size = newSize;
- vPtr->valueArr = newArr;
- return TCL_OK;
- }
-
- {
- /* Old memory was created specially (static or special allocator).
- * Replace with dynamically allocated memory (malloc-ed). */
-
- double* newArr = (double*)calloc(newSize, sizeof(double));
- if (newArr == NULL) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "can't allocate ",
- Itoa(newSize), " elements for vector \"",
- vPtr->name, "\"", (char *)NULL);
- }
- return TCL_ERROR;
- }
- {
- int used, wanted;
-
- /* Copy the contents of the old memory into the new. */
- used = vPtr->length;
- wanted = newSize;
-
- if (used > wanted) {
- used = wanted;
- }
- /* Copy any previous data */
- if (used > 0) {
- memcpy(newArr, vPtr->valueArr, used * sizeof(double));
- }
- }
-
- /*
- * We're not using the old storage anymore, so free it if it's not
- * TCL_STATIC. It's static because the user previously reset the
- * vector with a statically allocated array (setting freeProc to
- * TCL_STATIC).
- */
- if (vPtr->freeProc != TCL_STATIC) {
- if (vPtr->freeProc == TCL_DYNAMIC) {
- free(vPtr->valueArr);
- } else {
- (*vPtr->freeProc) ((char *)vPtr->valueArr);
- }
- }
- vPtr->freeProc = TCL_DYNAMIC; /* Set the type of the new storage */
- vPtr->valueArr = newArr;
- vPtr->size = newSize;
- }
- return TCL_OK;
-}
-
-int Blt::Vec_SetLength(Tcl_Interp* interp, Vector* vPtr, int newLength)
-{
- if (vPtr->size < newLength) {
- if (Vec_SetSize(interp, vPtr, newLength) != TCL_OK) {
- return TCL_ERROR;
- }
- }
- vPtr->length = newLength;
- vPtr->first = 0;
- vPtr->last = newLength - 1;
- return TCL_OK;
-}
-
-int Blt::Vec_ChangeLength(Tcl_Interp* interp, Vector* vPtr, int newLength)
-{
- if (newLength < 0) {
- newLength = 0;
- }
- if (newLength > vPtr->size) {
- int newSize; /* Size of array in elements */
-
- /* Compute the new size of the array. It's a multiple of
- * DEF_ARRAY_SIZE. */
- newSize = DEF_ARRAY_SIZE;
- while (newSize < newLength) {
- newSize += newSize;
- }
- if (newSize != vPtr->size) {
- if (Vec_SetSize(interp, vPtr, newSize) != TCL_OK) {
- return TCL_ERROR;
- }
- }
- }
- vPtr->length = newLength;
- vPtr->first = 0;
- vPtr->last = newLength - 1;
- return TCL_OK;
-
-}
-
-int Blt::Vec_Reset(Vector* vPtr, double *valueArr, int length,
- int size, Tcl_FreeProc *freeProc)
-{
- if (vPtr->valueArr != valueArr) { /* New array of values resides
- * in different memory than
- * the current vector. */
- if ((valueArr == NULL) || (size == 0)) {
- /* Empty array. Set up default values */
- valueArr = (double*)malloc(sizeof(double) * DEF_ARRAY_SIZE);
- size = DEF_ARRAY_SIZE;
- if (valueArr == NULL) {
- Tcl_AppendResult(vPtr->interp, "can't allocate ",
- Itoa(size), " elements for vector \"",
- vPtr->name, "\"", (char *)NULL);
- return TCL_ERROR;
- }
- freeProc = TCL_DYNAMIC;
- length = 0;
- }
- else if (freeProc == TCL_VOLATILE) {
- /* Data is volatile. Make a copy of the value array. */
- double* newArr = (double*)malloc(size * sizeof(double));
- if (newArr == NULL) {
- Tcl_AppendResult(vPtr->interp, "can't allocate ",
- Itoa(size), " elements for vector \"",
- vPtr->name, "\"", (char *)NULL);
- return TCL_ERROR;
- }
- memcpy((char *)newArr, (char *)valueArr,
- sizeof(double) * length);
- valueArr = newArr;
- freeProc = TCL_DYNAMIC;
- }
-
- if (vPtr->freeProc != TCL_STATIC) {
- /* Old data was dynamically allocated. Free it before attaching
- * new data. */
- if (vPtr->freeProc == TCL_DYNAMIC) {
- free(vPtr->valueArr);
- } else {
- (*freeProc) ((char *)vPtr->valueArr);
- }
- }
- vPtr->freeProc = freeProc;
- vPtr->valueArr = valueArr;
- vPtr->size = size;
- }
-
- vPtr->length = length;
- if (vPtr->flush) {
- Vec_FlushCache(vPtr);
- }
- Vec_UpdateClients(vPtr);
- return TCL_OK;
-}
-
-Vector* Blt::Vec_New(VectorInterpData *dataPtr)
-{
- Vector* vPtr = (Vector*)calloc(1, sizeof(Vector));
- vPtr->valueArr = (double*)malloc(sizeof(double) * DEF_ARRAY_SIZE);
- if (vPtr->valueArr == NULL) {
- free(vPtr);
- return NULL;
- }
- vPtr->size = DEF_ARRAY_SIZE;
- vPtr->freeProc = TCL_DYNAMIC;
- vPtr->length = 0;
- vPtr->interp = dataPtr->interp;
- vPtr->hashPtr = NULL;
- vPtr->chain = new Chain();
- vPtr->flush = 0;
- vPtr->min = vPtr->max = NAN;
- vPtr->notifyFlags = NOTIFY_WHENIDLE;
- vPtr->dataPtr = dataPtr;
- return vPtr;
-}
-
-void Blt::Vec_Free(Vector* vPtr)
-{
- ChainLink* link;
-
- if (vPtr->cmdToken != 0) {
- DeleteCommand(vPtr);
- }
- if (vPtr->arrayName != NULL) {
- UnmapVariable(vPtr);
- }
- vPtr->length = 0;
-
- /* Immediately notify clients that vector is going away */
- if (vPtr->notifyFlags & NOTIFY_PENDING) {
- vPtr->notifyFlags &= ~NOTIFY_PENDING;
- Tcl_CancelIdleCall(Blt_Vec_NotifyClients, vPtr);
- }
- vPtr->notifyFlags |= NOTIFY_DESTROYED;
- Blt_Vec_NotifyClients(vPtr);
-
- for (link = Chain_FirstLink(vPtr->chain); link; link = Chain_NextLink(link)) {
- VectorClient *clientPtr = (VectorClient*)Chain_GetValue(link);
- free(clientPtr);
- }
- delete vPtr->chain;
- if ((vPtr->valueArr != NULL) && (vPtr->freeProc != TCL_STATIC)) {
- if (vPtr->freeProc == TCL_DYNAMIC) {
- free(vPtr->valueArr);
- } else {
- (*vPtr->freeProc) ((char *)vPtr->valueArr);
- }
- }
- if (vPtr->hashPtr != NULL) {
- Tcl_DeleteHashEntry(vPtr->hashPtr);
- }
-#ifdef NAMESPACE_DELETE_NOTIFY
- if (vPtr->nsPtr != NULL) {
- Blt_DestroyNsDeleteNotify(vPtr->interp, vPtr->nsPtr, vPtr);
- }
-#endif /* NAMESPACE_DELETE_NOTIFY */
- free(vPtr);
-}
-
-static void VectorInstDeleteProc(ClientData clientData)
-{
- Vector* vPtr = (Vector*)clientData;
- vPtr->cmdToken = 0;
- Vec_Free(vPtr);
-}
-
-Vector* Blt::Vec_Create(VectorInterpData *dataPtr, const char *vecName,
- const char *cmdName, const char *varName, int *isNewPtr)
-{
- Tcl_DString dString;
- Blt_ObjectName objName;
- char *qualName;
- Tcl_HashEntry *hPtr;
- Tcl_Interp* interp = dataPtr->interp;
-
- int isNew = 0;
- Vector* vPtr = NULL;
-
- if (!ParseObjectName(interp, vecName, &objName, 0))
- return NULL;
-
- Tcl_DStringInit(&dString);
- if ((objName.name[0] == '#') && (strcmp(objName.name, "#auto") == 0)) {
-
- do { /* Generate a unique vector name. */
- char string[200];
-
- snprintf(string, 200, "vector%d", dataPtr->nextId++);
- objName.name = string;
- qualName = MakeQualifiedName(&objName, &dString);
- hPtr = Tcl_FindHashEntry(&dataPtr->vectorTable, qualName);
- } while (hPtr != NULL);
- } else {
- const char *p;
-
- for (p = objName.name; *p != '\0'; p++) {
- if (!VECTOR_CHAR(*p)) {
- Tcl_AppendResult(interp, "bad vector name \"", objName.name,
- "\": must contain digits, letters, underscore, or period",
- (char *)NULL);
- goto error;
- }
- }
- qualName = MakeQualifiedName(&objName, &dString);
- vPtr = Vec_ParseElement((Tcl_Interp *)NULL, dataPtr, qualName,
- NULL, NS_SEARCH_CURRENT);
- }
- if (vPtr == NULL) {
- hPtr = Tcl_CreateHashEntry(&dataPtr->vectorTable, qualName, &isNew);
- vPtr = Vec_New(dataPtr);
- vPtr->hashPtr = hPtr;
- vPtr->nsPtr = objName.nsPtr;
-
- vPtr->name = (const char*)Tcl_GetHashKey(&dataPtr->vectorTable, hPtr);
-#ifdef NAMESPACE_DELETE_NOTIFY
- Blt_CreateNsDeleteNotify(interp, objName.nsPtr, vPtr,
- VectorInstDeleteProc);
-#endif /* NAMESPACE_DELETE_NOTIFY */
- Tcl_SetHashValue(hPtr, vPtr);
- }
- if (cmdName != NULL) {
- Tcl_CmdInfo cmdInfo;
-
- if ((cmdName == vecName) ||
- ((cmdName[0] == '#') && (strcmp(cmdName, "#auto")==0))) {
- cmdName = qualName;
- }
- if (Tcl_GetCommandInfo(interp, (char *)cmdName, &cmdInfo)) {
- if (vPtr != cmdInfo.objClientData) {
- Tcl_AppendResult(interp, "command \"", cmdName,
- "\" already exists", (char *)NULL);
- goto error;
- }
- /* We get here only if the old name is the same as the new. */
- goto checkVariable;
- }
- }
- if (vPtr->cmdToken != 0) {
- DeleteCommand(vPtr); /* Command already exists, delete old first */
- }
- if (cmdName != NULL) {
- Tcl_DString dString2;
-
- Tcl_DStringInit(&dString2);
- if (cmdName != qualName) {
- if (!ParseObjectName(interp, cmdName, &objName, 0)) {
- goto error;
- }
- cmdName = MakeQualifiedName(&objName, &dString2);
- }
- vPtr->cmdToken = Tcl_CreateObjCommand(interp, (char *)cmdName, Vec_InstCmd,
- vPtr, VectorInstDeleteProc);
- Tcl_DStringFree(&dString2);
- }
- checkVariable:
- if (varName != NULL) {
- if ((varName[0] == '#') && (strcmp(varName, "#auto") == 0)) {
- varName = qualName;
- }
- if (Vec_MapVariable(interp, vPtr, varName) != TCL_OK) {
- goto error;
- }
- }
-
- Tcl_DStringFree(&dString);
- *isNewPtr = isNew;
- return vPtr;
-
- error:
- Tcl_DStringFree(&dString);
- if (vPtr != NULL) {
- Vec_Free(vPtr);
- }
- return NULL;
-}
-
-int Blt::Vec_Duplicate(Vector* destPtr, Vector* srcPtr)
-{
- size_t nBytes;
- size_t length;
-
- if (destPtr == srcPtr) {
- /* Copying the same vector. */
- }
- length = srcPtr->last - srcPtr->first + 1;
- if (Vec_ChangeLength(destPtr->interp, destPtr, length) != TCL_OK) {
- return TCL_ERROR;
- }
- nBytes = length * sizeof(double);
- memcpy(destPtr->valueArr, srcPtr->valueArr + srcPtr->first, nBytes);
- destPtr->offset = srcPtr->offset;
- return TCL_OK;
-}
-
-
-static int VectorNamesOp(ClientData clientData, Tcl_Interp* interp,
- int objc, Tcl_Obj* const objv[])
-{
- VectorInterpData* dataPtr = (VectorInterpData*)clientData;
- Tcl_Obj *listObjPtr;
-
- listObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
- if (objc == 2) {
- Tcl_HashEntry *hPtr;
- Tcl_HashSearch cursor;
-
- for (hPtr = Tcl_FirstHashEntry(&dataPtr->vectorTable, &cursor);
- hPtr != NULL; hPtr = Tcl_NextHashEntry(&cursor)) {
- char *name = (char*)Tcl_GetHashKey(&dataPtr->vectorTable, hPtr);
- Tcl_ListObjAppendElement(interp, listObjPtr,
- Tcl_NewStringObj(name, -1));
- }
- } else {
- Tcl_HashEntry *hPtr;
- Tcl_HashSearch cursor;
-
- for (hPtr = Tcl_FirstHashEntry(&dataPtr->vectorTable, &cursor);
- hPtr != NULL; hPtr = Tcl_NextHashEntry(&cursor)) {
- char *name = (char*)Tcl_GetHashKey(&dataPtr->vectorTable, hPtr);
- int i;
- for (i = 2; i < objc; i++) {
- char *pattern;
-
- pattern = Tcl_GetString(objv[i]);
- if (Tcl_StringMatch(name, pattern)) {
- Tcl_ListObjAppendElement(interp, listObjPtr,
- Tcl_NewStringObj(name, -1));
- break;
- }
- }
- }
- }
- Tcl_SetObjResult(interp, listObjPtr);
- return TCL_OK;
-}
-
-static int VectorCreate2(ClientData clientData, Tcl_Interp* interp,
- int argStart, int objc, Tcl_Obj* const objv[])
-{
- VectorInterpData *dataPtr = (VectorInterpData*)clientData;
- Vector* vPtr;
- int count, i;
- CreateSwitches switches;
-
- // Handle switches to the vector command and collect the vector name
- // arguments into an array.
- count = 0;
- vPtr = NULL;
- for (i = argStart; i < objc; i++) {
- char *string;
-
- string = Tcl_GetString(objv[i]);
- if (string[0] == '-') {
- break;
- }
- }
- count = i - argStart;
- if (count == 0) {
- Tcl_AppendResult(interp, "no vector names supplied", (char *)NULL);
- return TCL_ERROR;
- }
- memset(&switches, 0, sizeof(switches));
- if (ParseSwitches(interp, createSwitches, objc - i, objv + i,
- &switches, BLT_SWITCH_DEFAULTS) < 0) {
- return TCL_ERROR;
- }
- if (count > 1) {
- if (switches.cmdName != NULL) {
- Tcl_AppendResult(interp,
- "can't specify more than one vector with \"-command\" switch",
- (char *)NULL);
- goto error;
- }
- if (switches.varName != NULL) {
- Tcl_AppendResult(interp,
- "can't specify more than one vector with \"-variable\" switch",
- (char *)NULL);
- goto error;
- }
- }
- for (i = 0; i < count; i++) {
- char *leftParen, *rightParen;
- char *string;
- int isNew;
- int size, first, last;
-
- size = first = last = 0;
- string = Tcl_GetString(objv[i + argStart]);
- leftParen = strchr(string, '(');
- rightParen = strchr(string, ')');
- if (((leftParen != NULL) && (rightParen == NULL)) ||
- ((leftParen == NULL) && (rightParen != NULL)) ||
- (leftParen > rightParen)) {
- Tcl_AppendResult(interp, "bad vector specification \"", string,
- "\"", (char *)NULL);
- goto error;
- }
- if (leftParen != NULL) {
- int result;
- char *colon;
-
- *rightParen = '\0';
- colon = strchr(leftParen + 1, ':');
- if (colon != NULL) {
-
- /* Specification is in the form vecName(first:last) */
- *colon = '\0';
- result = Tcl_GetInt(interp, leftParen + 1, &first);
- if ((*(colon + 1) != '\0') && (result == TCL_OK)) {
- result = Tcl_GetInt(interp, colon + 1, &last);
- if (first > last) {
- Tcl_AppendResult(interp, "bad vector range \"",
- string, "\"", (char *)NULL);
- result = TCL_ERROR;
- }
- size = (last - first) + 1;
- }
- *colon = ':';
- } else {
- /* Specification is in the form vecName(size) */
- result = Tcl_GetInt(interp, leftParen + 1, &size);
- }
- *rightParen = ')';
- if (result != TCL_OK) {
- goto error;
- }
- if (size < 0) {
- Tcl_AppendResult(interp, "bad vector size \"", string, "\"",
- (char *)NULL);
- goto error;
- }
- }
- if (leftParen != NULL) {
- *leftParen = '\0';
- }
- /*
- * By default, we create a TCL command by the name of the vector.
- */
- vPtr = Vec_Create(dataPtr, string,
- (switches.cmdName == NULL) ? string : switches.cmdName,
- (switches.varName == NULL) ? string : switches.varName, &isNew);
- if (leftParen != NULL) {
- *leftParen = '(';
- }
- if (vPtr == NULL) {
- goto error;
- }
- vPtr->freeOnUnset = switches.watchUnset;
- vPtr->flush = switches.flush;
- vPtr->offset = first;
- if (size > 0) {
- if (Vec_ChangeLength(interp, vPtr, size) != TCL_OK) {
- goto error;
- }
- }
- if (!isNew) {
- if (vPtr->flush) {
- Vec_FlushCache(vPtr);
- }
- Vec_UpdateClients(vPtr);
- }
- }
- FreeSwitches(createSwitches, (char *)&switches, 0);
- if (vPtr != NULL) {
- /* Return the name of the last vector created */
- Tcl_SetStringObj(Tcl_GetObjResult(interp), vPtr->name, -1);
- }
- return TCL_OK;
- error:
- FreeSwitches(createSwitches, (char *)&switches, 0);
- return TCL_ERROR;
-}
-
-static int VectorCreateOp(ClientData clientData, Tcl_Interp* interp,
- int objc, Tcl_Obj* const objv[])
-{
- return VectorCreate2(clientData, interp, 2, objc, objv);
-}
-
-static int VectorDestroyOp(ClientData clientData, Tcl_Interp* interp,
- int objc,Tcl_Obj* const objv[])
-{
- VectorInterpData *dataPtr = (VectorInterpData*)clientData;
-
- for (int ii=2; ii<objc; ii++) {
- Vector* vPtr;
- if (Vec_LookupName(dataPtr, Tcl_GetString(objv[ii]), &vPtr) != TCL_OK)
- return TCL_ERROR;
- Vec_Free(vPtr);
- }
- return TCL_OK;
-}
-
-static int VectorExprOp(ClientData clientData, Tcl_Interp* interp,
- int objc, Tcl_Obj* const objv[])
-{
- return Blt_ExprVector(interp, Tcl_GetString(objv[2]), (Blt_Vector* )NULL);
-}
-
-static Blt_OpSpec vectorCmdOps[] =
- {
- {"create", 1, (void*)VectorCreateOp, 3, 0,
- "vecName ?vecName...? ?switches...?",},
- {"destroy", 1, (void*)VectorDestroyOp, 3, 0,
- "vecName ?vecName...?",},
- {"expr", 1, (void*)VectorExprOp, 3, 3, "expression",},
- {"names", 1, (void*)VectorNamesOp, 2, 3, "?pattern?...",},
- };
-
-static int nCmdOps = sizeof(vectorCmdOps) / sizeof(Blt_OpSpec);
-
-int VectorObjCmd(ClientData clientData, Tcl_Interp* interp,
- int objc, Tcl_Obj* const objv[])
-{
- VectorCmdProc *proc;
-
- if (objc > 1) {
- char *string;
- char c;
- int i;
- Blt_OpSpec *specPtr;
-
- string = Tcl_GetString(objv[1]);
- c = string[0];
- for (specPtr = vectorCmdOps, i = 0; i < nCmdOps; i++, specPtr++) {
- if ((c == specPtr->name[0]) &&
- (strcmp(string, specPtr->name) == 0)) {
- goto doOp;
- }
- }
- // The first argument is not an operation, so assume that its
- // actually the name of a vector to be created
- return VectorCreate2(clientData, interp, 1, objc, objv);
- }
- doOp:
- /* Do the usual vector operation lookup now. */
- proc = (VectorCmdProc*)GetOpFromObj(interp, nCmdOps, vectorCmdOps,
- BLT_OP_ARG1, objc, objv,0);
- if (proc == NULL) {
- return TCL_ERROR;
- }
- return (*proc) ((Vector*)clientData, interp, objc, objv);
-}
-
-static void VectorInterpDeleteProc(ClientData clientData, Tcl_Interp* interp)
-{
- VectorInterpData *dataPtr = (VectorInterpData*)clientData;
- Tcl_HashEntry *hPtr;
- Tcl_HashSearch cursor;
-
- for (hPtr = Tcl_FirstHashEntry(&dataPtr->vectorTable, &cursor);
- hPtr != NULL; hPtr = Tcl_NextHashEntry(&cursor)) {
- Vector* vPtr = (Vector*)Tcl_GetHashValue(hPtr);
- vPtr->hashPtr = NULL;
- Vec_Free(vPtr);
- }
- Tcl_DeleteHashTable(&dataPtr->vectorTable);
-
- /* If any user-defined math functions were installed, remove them. */
- Vec_UninstallMathFunctions(&dataPtr->mathProcTable);
- Tcl_DeleteHashTable(&dataPtr->mathProcTable);
-
- Tcl_DeleteHashTable(&dataPtr->indexProcTable);
- Tcl_DeleteAssocData(interp, VECTOR_THREAD_KEY);
- free(dataPtr);
-}
-
-VectorInterpData* Blt::Vec_GetInterpData(Tcl_Interp* interp)
-{
- VectorInterpData *dataPtr;
- Tcl_InterpDeleteProc *proc;
-
- dataPtr = (VectorInterpData *)
- Tcl_GetAssocData(interp, VECTOR_THREAD_KEY, &proc);
- if (dataPtr == NULL) {
- dataPtr = (VectorInterpData*)malloc(sizeof(VectorInterpData));
- dataPtr->interp = interp;
- dataPtr->nextId = 0;
- Tcl_SetAssocData(interp, VECTOR_THREAD_KEY, VectorInterpDeleteProc,
- dataPtr);
- Tcl_InitHashTable(&dataPtr->vectorTable, TCL_STRING_KEYS);
- Tcl_InitHashTable(&dataPtr->mathProcTable, TCL_STRING_KEYS);
- Tcl_InitHashTable(&dataPtr->indexProcTable, TCL_STRING_KEYS);
- Vec_InstallMathFunctions(&dataPtr->mathProcTable);
- Vec_InstallSpecialIndices(&dataPtr->indexProcTable);
- srand48((long)time((time_t *) NULL));
- }
- return dataPtr;
-}
-
-/* C Application interface to vectors */
-
-int Blt_CreateVector2(Tcl_Interp* interp, const char *vecName,
- const char *cmdName, const char *varName,
- int initialSize, Blt_Vector* *vecPtrPtr)
-{
- VectorInterpData *dataPtr; /* Interpreter-specific data. */
- Vector* vPtr;
- int isNew;
- char *nameCopy;
-
- if (initialSize < 0) {
- Tcl_AppendResult(interp, "bad vector size \"", Itoa(initialSize),
- "\"", (char *)NULL);
- return TCL_ERROR;
- }
- dataPtr = Vec_GetInterpData(interp);
-
- nameCopy = Blt_Strdup(vecName);
- vPtr = Vec_Create(dataPtr, nameCopy, cmdName, varName, &isNew);
- free(nameCopy);
-
- if (vPtr == NULL) {
- return TCL_ERROR;
- }
- if (initialSize > 0) {
- if (Vec_ChangeLength(interp, vPtr, initialSize) != TCL_OK) {
- return TCL_ERROR;
- }
- }
- if (vecPtrPtr != NULL) {
- *vecPtrPtr = (Blt_Vector* ) vPtr;
- }
- return TCL_OK;
-}
-
-int Blt_CreateVector(Tcl_Interp* interp, const char *name, int size,
- Blt_Vector* *vecPtrPtr)
-{
- return Blt_CreateVector2(interp, name, name, name, size, vecPtrPtr);
-}
-
-int Blt_DeleteVector(Blt_Vector* vecPtr)
-{
- Vector* vPtr = (Vector* )vecPtr;
-
- Vec_Free(vPtr);
- return TCL_OK;
-}
-
-int Blt_DeleteVectorByName(Tcl_Interp* interp, const char *name)
-{
- // If the vector name was passed via a read-only string (e.g. "x"), the
- // Vec_ParseElement routine will segfault when it tries to write into
- // the string. Therefore make a writable copy and free it when we're done.
- char* nameCopy = Blt_Strdup(name);
- VectorInterpData *dataPtr = Vec_GetInterpData(interp);
- Vector* vPtr;
- int result = Vec_LookupName(dataPtr, nameCopy, &vPtr);
- free(nameCopy);
-
- if (result != TCL_OK)
- return TCL_ERROR;
-
- Vec_Free(vPtr);
- return TCL_OK;
-}
-
-int Blt_VectorExists2(Tcl_Interp* interp, const char *vecName)
-{
- VectorInterpData *dataPtr;
-
- dataPtr = Vec_GetInterpData(interp);
- if (GetVectorObject(dataPtr, vecName, NS_SEARCH_BOTH) != NULL) {
- return 1;
- }
- return 0;
-}
-
-int Blt_VectorExists(Tcl_Interp* interp, const char *vecName)
-{
- char *nameCopy;
- int result;
-
- /*
- * If the vector name was passed via a read-only string (e.g. "x"), the
- * Blt_VectorParseName routine will segfault when it tries to write into
- * the string. Therefore make a writable copy and free it when we're
- * done.
- */
- nameCopy = Blt_Strdup(vecName);
- result = Blt_VectorExists2(interp, nameCopy);
- free(nameCopy);
- return result;
-}
-
-int Blt_GetVector(Tcl_Interp* interp, const char *name, Blt_Vector* *vecPtrPtr)
-{
- VectorInterpData *dataPtr; /* Interpreter-specific data. */
- Vector* vPtr;
- char *nameCopy;
- int result;
-
- dataPtr = Vec_GetInterpData(interp);
- /*
- * If the vector name was passed via a read-only string (e.g. "x"), the
- * Blt_VectorParseName routine will segfault when it tries to write into
- * the string. Therefore make a writable copy and free it when we're
- * done.
- */
- nameCopy = Blt_Strdup(name);
- result = Vec_LookupName(dataPtr, nameCopy, &vPtr);
- free(nameCopy);
- if (result != TCL_OK) {
- return TCL_ERROR;
- }
- Vec_UpdateRange(vPtr);
- *vecPtrPtr = (Blt_Vector* ) vPtr;
- return TCL_OK;
-}
-
-int Blt_GetVectorFromObj(Tcl_Interp* interp, Tcl_Obj *objPtr,
- Blt_Vector* *vecPtrPtr)
-{
- VectorInterpData *dataPtr; /* Interpreter-specific data. */
- Vector* vPtr;
-
- dataPtr = Vec_GetInterpData(interp);
- if (Vec_LookupName(dataPtr, Tcl_GetString(objPtr), &vPtr) != TCL_OK) {
- return TCL_ERROR;
- }
- Vec_UpdateRange(vPtr);
- *vecPtrPtr = (Blt_Vector* ) vPtr;
- return TCL_OK;
-}
-
-int Blt_ResetVector(Blt_Vector* vecPtr, double *valueArr, int length,
- int size, Tcl_FreeProc *freeProc)
-{
- Vector* vPtr = (Vector* )vecPtr;
-
- if (size < 0) {
- Tcl_AppendResult(vPtr->interp, "bad array size", (char *)NULL);
- return TCL_ERROR;
- }
- return Vec_Reset(vPtr, valueArr, length, size, freeProc);
-}
-
-int Blt_ResizeVector(Blt_Vector* vecPtr, int length)
-{
- Vector* vPtr = (Vector* )vecPtr;
-
- if (Vec_ChangeLength((Tcl_Interp *)NULL, vPtr, length) != TCL_OK) {
- Tcl_AppendResult(vPtr->interp, "can't resize vector \"", vPtr->name,
- "\"", (char *)NULL);
- return TCL_ERROR;
- }
- if (vPtr->flush) {
- Vec_FlushCache(vPtr);
- }
- Vec_UpdateClients(vPtr);
- return TCL_OK;
-}
-
-Blt_VectorId Blt_AllocVectorId(Tcl_Interp* interp, const char *name)
-{
- VectorInterpData *dataPtr; /* Interpreter-specific data. */
- Vector* vPtr;
- VectorClient *clientPtr;
- Blt_VectorId clientId;
- int result;
- char *nameCopy;
-
- dataPtr = Vec_GetInterpData(interp);
- /*
- * If the vector name was passed via a read-only string (e.g. "x"), the
- * Blt_VectorParseName routine will segfault when it tries to write into
- * the string. Therefore make a writable copy and free it when we're
- * done.
- */
- nameCopy = Blt_Strdup(name);
- result = Vec_LookupName(dataPtr, nameCopy, &vPtr);
- free(nameCopy);
-
- if (result != TCL_OK) {
- return (Blt_VectorId) 0;
- }
- /* Allocate a new client structure */
- clientPtr = (VectorClient*)calloc(1, sizeof(VectorClient));
- clientPtr->magic = VECTOR_MAGIC;
-
- /* Add the new client to the server's list of clients */
- clientPtr->link = vPtr->chain->append(clientPtr);
- clientPtr->serverPtr = vPtr;
- clientId = (Blt_VectorId) clientPtr;
- return clientId;
-}
-
-void Blt_SetVectorChangedProc(Blt_VectorId clientId,
- Blt_VectorChangedProc *proc,
- ClientData clientData)
-{
- VectorClient *clientPtr = (VectorClient *)clientId;
-
- if (clientPtr->magic != VECTOR_MAGIC) {
- return; /* Not a valid token */
- }
- clientPtr->clientData = clientData;
- clientPtr->proc = proc;
-}
-
-void Blt_FreeVectorId(Blt_VectorId clientId)
-{
- VectorClient *clientPtr = (VectorClient *)clientId;
-
- if (clientPtr->magic != VECTOR_MAGIC)
- return;
-
- if (clientPtr->serverPtr != NULL) {
- // Remove the client from the server's list
- clientPtr->serverPtr->chain->deleteLink(clientPtr->link);
- }
- free(clientPtr);
-}
-
-const char* Blt_NameOfVectorId(Blt_VectorId clientId)
-{
- VectorClient *clientPtr = (VectorClient *)clientId;
-
- if ((clientPtr->magic != VECTOR_MAGIC) || (clientPtr->serverPtr == NULL)) {
- return NULL;
- }
- return clientPtr->serverPtr->name;
-}
-
-const char* Blt_NameOfVector(Blt_Vector* vecPtr) /* Vector to query. */
-{
- Vector* vPtr = (Vector* )vecPtr;
- return vPtr->name;
-}
-
-int Blt_GetVectorById(Tcl_Interp* interp, Blt_VectorId clientId,
- Blt_Vector* *vecPtrPtr)
-{
- VectorClient *clientPtr = (VectorClient *)clientId;
-
- if (clientPtr->magic != VECTOR_MAGIC) {
- Tcl_AppendResult(interp, "bad vector token", (char *)NULL);
- return TCL_ERROR;
- }
- if (clientPtr->serverPtr == NULL) {
- Tcl_AppendResult(interp, "vector no longer exists", (char *)NULL);
- return TCL_ERROR;
- }
- Vec_UpdateRange(clientPtr->serverPtr);
- *vecPtrPtr = (Blt_Vector* ) clientPtr->serverPtr;
- return TCL_OK;
-}
-
-void Blt_InstallIndexProc(Tcl_Interp* interp, const char *string,
- Blt_VectorIndexProc *procPtr)
-{
- VectorInterpData *dataPtr; /* Interpreter-specific data. */
- Tcl_HashEntry *hPtr;
- int isNew;
-
- dataPtr = Vec_GetInterpData(interp);
- hPtr = Tcl_CreateHashEntry(&dataPtr->indexProcTable, string, &isNew);
- if (procPtr == NULL) {
- Tcl_DeleteHashEntry(hPtr);
- } else {
- Tcl_SetHashValue(hPtr, procPtr);
- }
-}
-
-#define SWAP(a,b) tempr=(a);(a)=(b);(b)=tempr
-
-/* routine by Brenner
- * data is the array of complex data points, perversely
- * starting at 1
- * nn is the number of complex points, i.e. half the length of data
- * isign is 1 for forward, -1 for inverse
- */
-static void four1(double *data, unsigned long nn, int isign)
-{
- unsigned long n,mmax,m,j,istep,i;
- double wtemp,wr,wpr,wpi,wi,theta;
- double tempr,tempi;
-
- n=nn << 1;
- j=1;
- for (i = 1;i<n;i+=2) {
- if (j > i) {
- SWAP(data[j],data[i]);
- SWAP(data[j+1],data[i+1]);
- }
- m=n >> 1;
- while (m >= 2 && j > m) {
- j -= m;
- m >>= 1;
- }
- j += m;
- }
- mmax=2;
- while (n > mmax) {
- istep=mmax << 1;
- theta=isign*(6.28318530717959/mmax);
- wtemp=sin(0.5*theta);
- wpr = -2.0*wtemp*wtemp;
- wpi=sin(theta);
- wr=1.0;
- wi=0.0;
- for (m=1;m<mmax;m+=2) {
- for (i=m;i<=n;i+=istep) {
- j=i+mmax;
- tempr=wr*data[j]-wi*data[j+1];
- tempi=wr*data[j+1]+wi*data[j];
- data[j]=data[i]-tempr;
- data[j+1]=data[i+1]-tempi;
- data[i] += tempr;
- data[i+1] += tempi;
- }
- wr=(wtemp=wr)*wpr-wi*wpi+wr;
- wi=wi*wpr+wtemp*wpi+wi;
- }
- mmax=istep;
- }
-}
-#undef SWAP
-
-static int
-smallest_power_of_2_not_less_than(int x)
-{
- int pow2 = 1;
-
- while (pow2 < x){
- pow2 <<= 1;
- }
- return pow2;
-}
-
-int Blt::Vec_FFT(Tcl_Interp* interp, Vector* realPtr, Vector* phasesPtr,
- Vector* freqPtr, double delta, int flags, Vector* srcPtr)
-{
- int length;
- int pow2len;
- double *paddedData;
- int i;
- double Wss = 0.0;
- /* TENTATIVE */
- int middle = 1;
- int noconstant;
-
- noconstant = (flags & FFT_NO_CONSTANT) ? 1 : 0;
-
- /* Length of the original vector. */
- length = srcPtr->last - srcPtr->first + 1;
- /* new length */
- pow2len = smallest_power_of_2_not_less_than( length );
-
- /* We do not do in-place FFTs */
- if (realPtr == srcPtr) {
- Tcl_AppendResult(interp, "real vector \"", realPtr->name,
- "\" can't be the same as the source", (char *)NULL);
- return TCL_ERROR;
- }
- if (phasesPtr != NULL) {
- if (phasesPtr == srcPtr) {
- Tcl_AppendResult(interp, "imaginary vector \"", phasesPtr->name,
- "\" can't be the same as the source", (char *)NULL);
- return TCL_ERROR;
- }
- if (Vec_ChangeLength(interp, phasesPtr,
- pow2len/2-noconstant+middle) != TCL_OK) {
- return TCL_ERROR;
- }
- }
- if (freqPtr != NULL) {
- if (freqPtr == srcPtr) {
- Tcl_AppendResult(interp, "frequency vector \"", freqPtr->name,
- "\" can't be the same as the source", (char *)NULL);
- return TCL_ERROR;
- }
- if (Vec_ChangeLength(interp, freqPtr,
- pow2len/2-noconstant+middle) != TCL_OK) {
- return TCL_ERROR;
- }
- }
-
- /* Allocate memory zero-filled array. */
- paddedData = (double*)calloc(pow2len * 2, sizeof(double));
- if (paddedData == NULL) {
- Tcl_AppendResult(interp, "can't allocate memory for padded data",
- (char *)NULL);
- return TCL_ERROR;
- }
-
- /*
- * Since we just do real transforms, only even locations will be
- * filled with data.
- */
- if (flags & FFT_BARTLETT) { /* Bartlett window 1 - ( (x - N/2) / (N/2) ) */
- double Nhalf = pow2len*0.5;
- double Nhalf_1 = 1.0 / Nhalf;
- double w;
-
- for (i = 0; i < length; i++) {
- w = 1.0 - fabs( (i-Nhalf) * Nhalf_1 );
- Wss += w;
- paddedData[2*i] = w * srcPtr->valueArr[i];
- }
- for(/*empty*/; i < pow2len; i++) {
- w = 1.0 - fabs((i-Nhalf) * Nhalf_1);
- Wss += w;
- }
- } else { /* Squared window, i.e. no data windowing. */
- for (i = 0; i < length; i++) {
- paddedData[2*i] = srcPtr->valueArr[i];
- }
- Wss = pow2len;
- }
-
- /* Fourier */
- four1(paddedData-1, pow2len, 1);
-
- /*
- for(i=0;i<pow2len;i++){
- printf( "(%f %f) ", paddedData[2*i], paddedData[2*i+1] );
- }
- */
-
- /* the spectrum is the modulus of the transforms, scaled by 1/N^2 */
- /* or 1/(N * Wss) for windowed data */
- if (flags & FFT_SPECTRUM) {
- double re, im, reS, imS;
- double factor = 1.0 / (pow2len*Wss);
- double *v = realPtr->valueArr;
-
- for (i = 0 + noconstant; i < pow2len / 2; i++) {
- re = paddedData[2*i];
- im = paddedData[2*i+1];
- reS = paddedData[2*pow2len-2*i-2];
- imS = paddedData[2*pow2len-2*i-1];
- v[i - noconstant] = factor * (
-# if 0
- hypot( paddedData[2*i], paddedData[2*i+1] )
- + hypot(
- paddedData[pow2len*2-2*i-2],
- paddedData[pow2len*2-2*i-1]
- )
-# else
- sqrt( re*re + im* im ) + sqrt( reS*reS + imS*imS )
-# endif
- );
- }
- } else {
- for(i = 0 + noconstant; i < pow2len / 2 + middle; i++) {
- realPtr->valueArr[i - noconstant] = paddedData[2*i];
- }
- }
- if( phasesPtr != NULL ){
- for (i = 0 + noconstant; i < pow2len / 2 + middle; i++) {
- phasesPtr->valueArr[i-noconstant] = paddedData[2*i+1];
- }
- }
-
- /* Compute frequencies */
- if (freqPtr != NULL) {
- double N = pow2len;
- double denom = 1.0 / N / delta;
- for( i=0+noconstant; i<pow2len/2+middle; i++ ){
- freqPtr->valueArr[i-noconstant] = ((double) i) * denom;
- }
- }
-
- /* Memory is necessarily dynamic, because nobody touched it ! */
- free(paddedData);
-
- realPtr->offset = 0;
- return TCL_OK;
-}
-
-
-int Blt::Vec_InverseFFT(Tcl_Interp* interp, Vector* srcImagPtr,
- Vector* destRealPtr, Vector* destImagPtr, Vector* srcPtr)
-{
- int length;
- int pow2len;
- double *paddedData;
- int i;
- double oneOverN;
-
- if ((destRealPtr == srcPtr) || (destImagPtr == srcPtr )){
- /* we do not do in-place FFTs */
- return TCL_ERROR;
- }
- length = srcPtr->last - srcPtr->first + 1;
-
- /* minus one because of the magical middle element! */
- pow2len = smallest_power_of_2_not_less_than( (length-1)*2 );
- oneOverN = 1.0 / pow2len;
-
- if (Vec_ChangeLength(interp, destRealPtr, pow2len) != TCL_OK) {
- return TCL_ERROR;
- }
- if (Vec_ChangeLength(interp, destImagPtr, pow2len) != TCL_OK) {
- return TCL_ERROR;
- }
-
- if( length != (srcImagPtr->last - srcImagPtr->first + 1) ){
- Tcl_AppendResult(srcPtr->interp,
- "the length of the imagPart vector must ",
- "be the same as the real one", (char *)NULL);
- return TCL_ERROR;
- }
-
- paddedData = (double*)malloc( pow2len*2*sizeof(double) );
- if( paddedData == NULL ){
- if (interp != NULL) {
- Tcl_AppendResult(interp, "memory allocation failed", (char *)NULL);
- }
- return TCL_ERROR;
- }
- for(i=0;i<pow2len*2;i++) { paddedData[i] = 0.0; }
- for(i=0;i<length-1;i++){
- paddedData[2*i] = srcPtr->valueArr[i];
- paddedData[2*i+1] = srcImagPtr->valueArr[i];
- paddedData[pow2len*2 - 2*i - 2 ] = srcPtr->valueArr[i+1];
- paddedData[pow2len*2 - 2*i - 1 ] = - srcImagPtr->valueArr[i+1];
- }
- /* mythical middle element */
- paddedData[(length-1)*2] = srcPtr->valueArr[length-1];
- paddedData[(length-1)*2+1] = srcImagPtr->valueArr[length-1];
-
- /*
- for(i=0;i<pow2len;i++){
- printf( "(%f %f) ", paddedData[2*i], paddedData[2*i+1] );
- }
- */
-
- /* fourier */
- four1( paddedData-1, pow2len, -1 );
-
- /* put values in their places, normalising by 1/N */
- for(i=0;i<pow2len;i++){
- destRealPtr->valueArr[i] = paddedData[2*i] * oneOverN;
- destImagPtr->valueArr[i] = paddedData[2*i+1] * oneOverN;
- }
-
- /* memory is necessarily dynamic, because nobody touched it ! */
- free( paddedData );
-
- return TCL_OK;
-}
-
-static double FindSplit(Point2d *points, int i, int j, int *split)
-{
- double maxDist2;
-
- maxDist2 = -1.0;
- if ((i + 1) < j) {
- int k;
- double a, b, c;
-
- /*
- *
- * dist2 P(k) = | 1 P(i).x P(i).y |
- * | 1 P(j).x P(j).y |
- * | 1 P(k).x P(k).y |
- * ------------------------------------------
- * (P(i).x - P(j).x)^2 + (P(i).y - P(j).y)^2
- */
-
- a = points[i].y - points[j].y;
- b = points[j].x - points[i].x;
- c = (points[i].x * points[j].y) - (points[i].y * points[j].x);
- for (k = (i + 1); k < j; k++) {
- double dist2;
-
- dist2 = (points[k].x * a) + (points[k].y * b) + c;
- if (dist2 < 0.0) {
- dist2 = -dist2;
- }
- if (dist2 > maxDist2) {
- maxDist2 = dist2; /* Track the maximum. */
- *split = k;
- }
- }
- /* Correction for segment length---should be redone if can == 0 */
- maxDist2 *= maxDist2 / (a * a + b * b);
- }
- return maxDist2;
-}
-
-// Douglas-Peucker line simplification algorithm */
-int Blt_SimplifyLine(Point2d *inputPts, int low, int high, double tolerance,
- int *indices)
-{
-#define StackPush(a) s++, stack[s] = (a)
-#define StackPop(a) (a) = stack[s], s--
-#define StackEmpty() (s < 0)
-#define StackTop() stack[s]
- int *stack;
- int split = -1;
- double dist2, tolerance2;
- int s = -1; /* Points to top stack item. */
- int count;
-
- stack = (int*)malloc(sizeof(int) * (high - low + 1));
- StackPush(high);
- count = 0;
- indices[count++] = 0;
- tolerance2 = tolerance * tolerance;
- while (!StackEmpty()) {
- dist2 = FindSplit(inputPts, low, StackTop(), &split);
- if (dist2 > tolerance2) {
- StackPush(split);
- } else {
- indices[count++] = StackTop();
- StackPop(low);
- }
- }
- free(stack);
- return count;
-}
-