PLplot
5.10.0
|
00001 // Copyright 1994, 1995 00002 // Maurice LeBrun mjl@dino.ph.utexas.edu 00003 // Institute for Fusion Studies University of Texas at Austin 00004 // 00005 // Copyright (C) 2004 Joao Cardoso 00006 // 00007 // This file is part of PLplot. 00008 // 00009 // PLplot is free software; you can redistribute it and/or modify 00010 // it under the terms of the GNU Library General Public License as published 00011 // by the Free Software Foundation; either version 2 of the License, or 00012 // (at your option) any later version. 00013 // 00014 // PLplot is distributed in the hope that it will be useful, 00015 // but WITHOUT ANY WARRANTY; without even the implied warranty of 00016 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 00017 // GNU Library General Public License for more details. 00018 // 00019 // You should have received a copy of the GNU Library General Public License 00020 // along with PLplot; if not, write to the Free Software 00021 // Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 00022 // 00023 //-------------------------------------------------------------------------- 00024 // 00025 // This file contains routines that implement Tcl matrices. 00026 // These are operators that are used to store, return, and modify 00027 // numeric data stored in binary array format. The emphasis is 00028 // on high performance and low overhead, something that Tcl lists 00029 // or associative arrays aren't so good at. 00030 // 00031 00032 // 00033 // #define DEBUG 00034 // 00035 00036 #include <stdio.h> 00037 #include <stdlib.h> 00038 #include <string.h> 00039 #include "pldll.h" 00040 #include "tclMatrix.h" 00041 00042 // Cool math macros 00043 00044 #ifndef MAX 00045 #define MAX( a, b ) ( ( ( a ) > ( b ) ) ? ( a ) : ( b ) ) 00046 #endif 00047 #ifndef MIN 00048 #define MIN( a, b ) ( ( ( a ) < ( b ) ) ? ( a ) : ( b ) ) 00049 #endif 00050 00051 // For the truly desperate debugging task 00052 00053 #ifdef DEBUG_ENTER 00054 #define dbug_enter( a ) \ 00055 fprintf( stderr, "%s: Entered %s\n", __FILE__, a ); 00056 00057 #else 00058 #define dbug_enter( a ) 00059 #endif 00060 00061 // Internal data 00062 00063 static int matTable_initted = 0; // Hash table initialization flag 00064 static Tcl_HashTable matTable; // Hash table for external access to data 00065 00066 // Function prototypes 00067 00068 // Handles matrix initialization lists 00069 00070 static int 00071 matrixInitialize( Tcl_Interp* interp, tclMatrix* m, 00072 int dim, int offs, int nargs, const char** args ); 00073 00074 // Invoked to process the "matrix" Tcl command. 00075 00076 static int 00077 MatrixCmd( ClientData clientData, Tcl_Interp *interp, int argc, const char **argv ); 00078 00079 // Causes matrix command to be deleted. 00080 00081 static char * 00082 DeleteMatrixVar( ClientData clientData, 00083 Tcl_Interp *interp, char *name1, char *name2, int flags ); 00084 00085 // Releases all the resources allocated to the matrix command. 00086 00087 static void 00088 DeleteMatrixCmd( ClientData clientData ); 00089 00090 // These do the put/get operations for each supported type 00091 00092 static void 00093 MatrixPut_f( ClientData clientData, Tcl_Interp* interp, int index, const char *string ); 00094 00095 static void 00096 MatrixGet_f( ClientData clientData, Tcl_Interp* interp, int index, char *string ); 00097 00098 static void 00099 MatrixPut_i( ClientData clientData, Tcl_Interp* interp, int index, const char *string ); 00100 00101 static void 00102 MatrixGet_i( ClientData clientData, Tcl_Interp* interp, int index, char *string ); 00103 00104 //-------------------------------------------------------------------------- 00105 // 00106 // Tcl_MatCmd -- 00107 // 00108 // Invoked to process the "matrix" Tcl command. Creates a multiply 00109 // dimensioned array (matrix) of floats or ints. The number of 00110 // arguments determines the dimensionality. 00111 // 00112 // Results: 00113 // Returns the name of the new matrix. 00114 // 00115 // Side effects: 00116 // A new matrix (operator) gets created. 00117 // 00118 //-------------------------------------------------------------------------- 00119 00120 int 00121 Tcl_MatrixCmd( ClientData PL_UNUSED( clientData ), Tcl_Interp *interp, 00122 int argc, const char **argv ) 00123 { 00124 register tclMatrix *matPtr; 00125 int i, j, length, new, index, persist = 0, initializer = 0; 00126 Tcl_HashEntry *hPtr; 00127 Tcl_CmdInfo infoPtr; 00128 char c; 00129 00130 dbug_enter( "Tcl_MatrixCmd" ); 00131 00132 if ( argc < 3 ) 00133 { 00134 Tcl_AppendResult( interp, "wrong # args: should be \"", argv[0], 00135 " ?-persist? var type dim1 ?dim2? ?dim3? ...\"", (char *) NULL ); 00136 return TCL_ERROR; 00137 } 00138 00139 // Create hash table on first call 00140 00141 if ( !matTable_initted ) 00142 { 00143 matTable_initted = 1; 00144 Tcl_InitHashTable( &matTable, TCL_STRING_KEYS ); 00145 } 00146 00147 // Check for -persist flag 00148 00149 for ( i = 1; i < argc; i++ ) 00150 { 00151 c = argv[i][0]; 00152 length = (int) strlen( argv[i] ); 00153 00154 // If found, set persist variable and compress argv-list 00155 00156 if ( ( c == '-' ) && ( strncmp( argv[i], "-persist", (size_t) length ) == 0 ) ) 00157 { 00158 persist = 1; 00159 argc--; 00160 for ( j = i; j < argc; j++ ) 00161 argv[j] = argv[j + 1]; 00162 break; 00163 } 00164 } 00165 00166 // Create matrix data structure 00167 00168 matPtr = (tclMatrix *) malloc( sizeof ( tclMatrix ) ); 00169 matPtr->fdata = NULL; 00170 matPtr->idata = NULL; 00171 matPtr->name = NULL; 00172 matPtr->dim = 0; 00173 matPtr->len = 1; 00174 matPtr->tracing = 0; 00175 for ( i = 0; i < MAX_ARRAY_DIM; i++ ) 00176 matPtr->n[i] = 1; 00177 00178 // Create name 00179 // It should be unique 00180 00181 argc--; argv++; 00182 00183 if ( Tcl_GetCommandInfo( interp, argv[0], &infoPtr ) ) 00184 { 00185 Tcl_AppendResult( interp, "Matrix operator \"", argv[0], 00186 "\" already in use", (char *) NULL ); 00187 free( (void *) matPtr ); 00188 return TCL_ERROR; 00189 } 00190 00191 if ( Tcl_GetVar( interp, argv[0], 0 ) != NULL ) 00192 { 00193 Tcl_AppendResult( interp, "Illegal name for Matrix operator \"", 00194 argv[0], "\": local variable of same name is active", 00195 (char *) NULL ); 00196 free( (void *) matPtr ); 00197 return TCL_ERROR; 00198 } 00199 00200 matPtr->name = (char *) malloc( strlen( argv[0] ) + 1 ); 00201 strcpy( matPtr->name, argv[0] ); 00202 00203 // Initialize type 00204 00205 argc--; argv++; 00206 c = argv[0][0]; 00207 length = (int) strlen( argv[0] ); 00208 00209 if ( ( c == 'f' ) && ( strncmp( argv[0], "float", (size_t) length ) == 0 ) ) 00210 { 00211 matPtr->type = TYPE_FLOAT; 00212 matPtr->put = MatrixPut_f; 00213 matPtr->get = MatrixGet_f; 00214 } 00215 else if ( ( c == 'i' ) && ( strncmp( argv[0], "int", (size_t) length ) == 0 ) ) 00216 { 00217 matPtr->type = TYPE_INT; 00218 matPtr->put = MatrixPut_i; 00219 matPtr->get = MatrixGet_i; 00220 } 00221 else 00222 { 00223 Tcl_AppendResult( interp, "Matrix type \"", argv[0], 00224 "\" not supported, should be \"float\" or \"int\"", 00225 (char *) NULL ); 00226 00227 DeleteMatrixCmd( (ClientData) matPtr ); 00228 return TCL_ERROR; 00229 } 00230 00231 // Initialize dimensions 00232 00233 argc--; argv++; 00234 for (; argc > 0; argc--, argv++ ) 00235 { 00236 // Check for initializer 00237 00238 if ( strcmp( argv[0], "=" ) == 0 ) 00239 { 00240 argc--; argv++; 00241 initializer = 1; 00242 break; 00243 } 00244 00245 // Must be a dimensional parameter. Increment number of dimensions. 00246 00247 matPtr->dim++; 00248 if ( matPtr->dim > MAX_ARRAY_DIM ) 00249 { 00250 Tcl_AppendResult( interp, 00251 "too many dimensions specified for Matrix operator \"", 00252 matPtr->name, "\"", (char *) NULL ); 00253 00254 DeleteMatrixCmd( (ClientData) matPtr ); 00255 return TCL_ERROR; 00256 } 00257 00258 // Check to see if dimension is valid and store 00259 00260 index = matPtr->dim - 1; 00261 matPtr->n[index] = atoi( argv[0] ); 00262 if ( matPtr->n[index] < 1 ) 00263 { 00264 Tcl_AppendResult( interp, "invalid matrix dimension \"", argv[0], 00265 "\" for Matrix operator \"", matPtr->name, "\"", 00266 (char *) NULL ); 00267 00268 DeleteMatrixCmd( (ClientData) matPtr ); 00269 return TCL_ERROR; 00270 } 00271 matPtr->len *= matPtr->n[index]; 00272 } 00273 00274 if ( matPtr->dim < 1 ) 00275 { 00276 Tcl_AppendResult( interp, 00277 "insufficient dimensions given for Matrix operator \"", 00278 matPtr->name, "\"", (char *) NULL ); 00279 DeleteMatrixCmd( (ClientData) matPtr ); 00280 return TCL_ERROR; 00281 } 00282 00283 // Allocate space for data 00284 00285 switch ( matPtr->type ) 00286 { 00287 case TYPE_FLOAT: 00288 matPtr->fdata = (Mat_float *) malloc( (size_t) ( matPtr->len ) * sizeof ( Mat_float ) ); 00289 for ( i = 0; i < matPtr->len; i++ ) 00290 matPtr->fdata[i] = 0.0; 00291 break; 00292 00293 case TYPE_INT: 00294 matPtr->idata = (Mat_int *) malloc( (size_t) ( matPtr->len ) * sizeof ( Mat_int ) ); 00295 for ( i = 0; i < matPtr->len; i++ ) 00296 matPtr->idata[i] = 0; 00297 break; 00298 } 00299 00300 // Process the initializer, if present 00301 00302 if ( initializer ) 00303 matrixInitialize( interp, matPtr, 0, 0, 1, &argv[0] ); 00304 00305 // Delete matrix when it goes out of scope unless -persist specified 00306 // Use local variable of same name as matrix and trace it for unsets 00307 00308 if ( !persist ) 00309 { 00310 if ( Tcl_SetVar( interp, matPtr->name, 00311 "old_bogus_syntax_please_upgrade", 0 ) == NULL ) 00312 { 00313 Tcl_AppendResult( interp, "unable to schedule Matrix operator \"", 00314 matPtr->name, "\" for automatic deletion", (char *) NULL ); 00315 DeleteMatrixCmd( (ClientData) matPtr ); 00316 return TCL_ERROR; 00317 } 00318 matPtr->tracing = 1; 00319 Tcl_TraceVar( interp, matPtr->name, TCL_TRACE_UNSETS, 00320 (Tcl_VarTraceProc *) DeleteMatrixVar, (ClientData) matPtr ); 00321 } 00322 00323 // Create matrix operator 00324 00325 #ifdef DEBUG 00326 fprintf( stderr, "Creating Matrix operator of name %s\n", matPtr->name ); 00327 #endif 00328 Tcl_CreateCommand( interp, matPtr->name, (Tcl_CmdProc *) MatrixCmd, 00329 (ClientData) matPtr, (Tcl_CmdDeleteProc *) DeleteMatrixCmd ); 00330 00331 // Store pointer to interpreter to handle bizarre uses of multiple 00332 // interpreters (e.g. as in [incr Tcl]) 00333 00334 matPtr->interp = interp; 00335 00336 // Create hash table entry for this matrix operator's data 00337 // This should never fail 00338 00339 hPtr = Tcl_CreateHashEntry( &matTable, matPtr->name, &new ); 00340 if ( !new ) 00341 { 00342 Tcl_AppendResult( interp, 00343 "Unable to create hash table entry for Matrix operator \"", 00344 matPtr->name, "\"", (char *) NULL ); 00345 return TCL_ERROR; 00346 } 00347 Tcl_SetHashValue( hPtr, matPtr ); 00348 00349 Tcl_SetResult( interp, matPtr->name, TCL_VOLATILE ); 00350 return TCL_OK; 00351 } 00352 00353 //-------------------------------------------------------------------------- 00354 // 00355 // Tcl_GetMatrixPtr -- 00356 // 00357 // Returns a pointer to the specified matrix operator's data. 00358 // 00359 // Results: 00360 // None. 00361 // 00362 // Side effects: 00363 // None. 00364 // 00365 //-------------------------------------------------------------------------- 00366 00367 tclMatrix * 00368 Tcl_GetMatrixPtr( Tcl_Interp *interp, const char *matName ) 00369 { 00370 Tcl_HashEntry *hPtr; 00371 00372 dbug_enter( "Tcl_GetMatrixPtr" ); 00373 00374 if ( !matTable_initted ) 00375 { 00376 return NULL; 00377 } 00378 00379 hPtr = Tcl_FindHashEntry( &matTable, matName ); 00380 if ( hPtr == NULL ) 00381 { 00382 Tcl_AppendResult( interp, "No matrix operator named \"", 00383 matName, "\"", (char *) NULL ); 00384 return NULL; 00385 } 00386 return (tclMatrix *) Tcl_GetHashValue( hPtr ); 00387 } 00388 00389 //-------------------------------------------------------------------------- 00390 // 00391 // Tcl_MatrixInstallXtnsn -- 00392 // 00393 // Install a tclMatrix extension subcommand. 00394 // 00395 // Results: 00396 // Should be 1. Have to think about error results. 00397 // 00398 // Side effects: 00399 // Enables you to install special purpose compiled code to handle 00400 // custom operations on a tclMatrix. 00401 // 00402 //-------------------------------------------------------------------------- 00403 00404 static tclMatrixXtnsnDescr *head = (tclMatrixXtnsnDescr *) NULL; 00405 static tclMatrixXtnsnDescr *tail = (tclMatrixXtnsnDescr *) NULL; 00406 00407 int 00408 Tcl_MatrixInstallXtnsn( const char *cmd, tclMatrixXtnsnProc proc ) 00409 { 00410 // 00411 // My goodness how I hate primitive/pathetic C. With C++ this 00412 // could've been as easy as: 00413 // List<TclMatrixXtnsnDescr> xtnlist; 00414 // xtnlist.append( tclMatrixXtnsnDescr(cmd,proc) ); 00415 // grrrrr. 00416 // 00417 00418 tclMatrixXtnsnDescr *new = 00419 (tclMatrixXtnsnDescr *) malloc( sizeof ( tclMatrixXtnsnDescr ) ); 00420 00421 dbug_enter( "Tcl_MatrixInstallXtnsn" ); 00422 00423 #ifdef DEBUG 00424 fprintf( stderr, "Installing a tclMatrix extension -> %s\n", cmd ); 00425 #endif 00426 00427 new->cmd = malloc( strlen( cmd ) + 1 ); 00428 strcpy( new->cmd, cmd ); 00429 new->cmdproc = proc; 00430 new->next = (tclMatrixXtnsnDescr *) NULL; 00431 00432 if ( !head ) 00433 { 00434 tail = head = new; 00435 return 1; 00436 } 00437 else 00438 { 00439 tail = tail->next = new; 00440 return 1; 00441 } 00442 } 00443 00444 //-------------------------------------------------------------------------- 00445 // 00446 // matrixInitialize -- 00447 // 00448 // Handles matrix initialization lists. 00449 // Written by Martin L. Smith. 00450 // 00451 // Results: 00452 // None. 00453 // 00454 // Side effects: 00455 // None. 00456 // 00457 //-------------------------------------------------------------------------- 00458 00459 static int matrixInitialize( Tcl_Interp* interp, tclMatrix* m, 00460 int dim, int offs, int nargs, const char** args ) 00461 { 00462 static int verbose = 0; 00463 00464 char ** newargs; 00465 int numnewargs; 00466 int newoffs; 00467 int i; 00468 00469 if ( verbose ) 00470 fprintf( stderr, "level %d offset %d args %d\n", dim, offs, nargs ); 00471 00472 if ( dim < m->dim ) 00473 { 00474 for ( i = 0; i < nargs; i++ ) 00475 { 00476 if ( Tcl_SplitList( interp, args[i], &numnewargs, (CONST char ***) &newargs ) 00477 != TCL_OK ) 00478 { 00479 Tcl_AppendResult( interp, "bad matrix initializer list form: ", 00480 args[i], (char *) NULL ); 00481 return TCL_ERROR; 00482 } 00483 if ( dim > 0 ) 00484 newoffs = offs * m->n[dim - 1] + i; 00485 else 00486 newoffs = 0; 00487 00488 matrixInitialize( interp, m, dim + 1, newoffs, numnewargs, (const char **) newargs ); 00489 // Must use Tcl_Free since allocated by Tcl 00490 Tcl_Free( (char *) newargs ); 00491 } 00492 return TCL_OK; 00493 } 00494 00495 for ( i = 0; i < nargs; i++ ) 00496 { 00497 newoffs = offs * m->n[dim - 1] + i; 00498 ( m->put )( (ClientData) m, interp, newoffs, args[i] ); 00499 if ( verbose ) 00500 fprintf( stderr, "\ta[%d] = %s\n", newoffs, args[i] ); 00501 } 00502 return TCL_OK; 00503 } 00504 00505 //-------------------------------------------------------------------------- 00506 // 00507 // MatrixCmd -- 00508 // 00509 // When a Tcl matrix command is invoked, this routine is called. 00510 // 00511 // Results: 00512 // A standard Tcl result value, usually TCL_OK. 00513 // On matrix get commands, one or a number of matrix elements are 00514 // printed. 00515 // 00516 // Side effects: 00517 // Depends on the matrix command. 00518 // 00519 //-------------------------------------------------------------------------- 00520 00521 static int 00522 MatrixCmd( ClientData clientData, Tcl_Interp *interp, 00523 int argc, const char **argv ) 00524 { 00525 register tclMatrix *matPtr = (tclMatrix *) clientData; 00526 int length, put = 0; 00527 char c, tmp[80]; 00528 const char *name = argv[0]; 00529 int nmin[MAX_ARRAY_DIM], nmax[MAX_ARRAY_DIM]; 00530 int i, j, k; 00531 00532 // Initialize 00533 00534 if ( argc < 2 ) 00535 { 00536 Tcl_AppendResult( interp, "wrong # args, type: \"", 00537 argv[0], " help\" for more info", (char *) NULL ); 00538 return TCL_ERROR; 00539 } 00540 00541 for ( i = 0; i < MAX_ARRAY_DIM; i++ ) 00542 { 00543 nmin[i] = 0; 00544 nmax[i] = matPtr->n[i] - 1; 00545 } 00546 00547 // First check for a matrix command 00548 00549 argc--; argv++; 00550 c = argv[0][0]; 00551 length = (int) strlen( argv[0] ); 00552 00553 // dump -- send a nicely formatted listing of the array contents to stdout 00554 // (very helpful for debugging) 00555 00556 if ( ( c == 'd' ) && ( strncmp( argv[0], "dump", (size_t) length ) == 0 ) ) 00557 { 00558 for ( i = nmin[0]; i <= nmax[0]; i++ ) 00559 { 00560 for ( j = nmin[1]; j <= nmax[1]; j++ ) 00561 { 00562 for ( k = nmin[2]; k <= nmax[2]; k++ ) 00563 { 00564 ( *matPtr->get )( (ClientData) matPtr, interp, I3D( i, j, k ), tmp ); 00565 printf( "%s ", tmp ); 00566 } 00567 if ( matPtr->dim > 2 ) 00568 printf( "\n" ); 00569 } 00570 if ( matPtr->dim > 1 ) 00571 printf( "\n" ); 00572 } 00573 printf( "\n" ); 00574 return TCL_OK; 00575 } 00576 00577 // delete -- delete the array 00578 00579 else if ( ( c == 'd' ) && ( strncmp( argv[0], "delete", (size_t) length ) == 0 ) ) 00580 { 00581 #ifdef DEBUG 00582 fprintf( stderr, "Deleting array %s\n", name ); 00583 #endif 00584 Tcl_DeleteCommand( interp, name ); 00585 return TCL_OK; 00586 } 00587 00588 // filter 00589 // Only works on 1d matrices 00590 00591 else if ( ( c == 'f' ) && ( strncmp( argv[0], "filter", (size_t) length ) == 0 ) ) 00592 { 00593 Mat_float *tmpMat; 00594 int ifilt, nfilt; 00595 00596 if ( argc != 2 ) 00597 { 00598 Tcl_AppendResult( interp, "wrong # args: should be \"", 00599 name, " ", argv[0], " num-passes\"", 00600 (char *) NULL ); 00601 return TCL_ERROR; 00602 } 00603 00604 if ( matPtr->dim != 1 || matPtr->type != TYPE_FLOAT ) 00605 { 00606 Tcl_AppendResult( interp, "can only filter a 1d float matrix", 00607 (char *) NULL ); 00608 return TCL_ERROR; 00609 } 00610 00611 nfilt = atoi( argv[1] ); 00612 tmpMat = (Mat_float *) malloc( (size_t) ( matPtr->len + 2 ) * sizeof ( Mat_float ) ); 00613 00614 for ( ifilt = 0; ifilt < nfilt; ifilt++ ) 00615 { 00616 // Set up temporary filtering array. Use even boundary conditions. 00617 00618 j = 0; tmpMat[j] = matPtr->fdata[0]; 00619 for ( i = 0; i < matPtr->len; i++ ) 00620 { 00621 j++; tmpMat[j] = matPtr->fdata[i]; 00622 } 00623 j++; tmpMat[j] = matPtr->fdata[matPtr->len - 1]; 00624 00625 // Apply 3-point binomial filter 00626 00627 for ( i = 0; i < matPtr->len; i++ ) 00628 { 00629 j = i + 1; 00630 matPtr->fdata[i] = 0.25 * ( tmpMat[j - 1] + 2 * tmpMat[j] + tmpMat[j + 1] ); 00631 } 00632 } 00633 00634 free( (void *) tmpMat ); 00635 return TCL_OK; 00636 } 00637 00638 // help 00639 00640 else if ( ( c == 'h' ) && ( strncmp( argv[0], "help", (size_t) length ) == 0 ) ) 00641 { 00642 Tcl_AppendResult( interp, 00643 "Available subcommands:\n\ 00644 dump - return the values in the matrix as a string\n\ 00645 delete - delete the matrix (including the matrix command)\n\ 00646 filter - apply a three-point averaging (with a number of passes; ome-dimensional only)\n\ 00647 help - this information\n\ 00648 info - return the dimensions\n\ 00649 max - return the maximum value for the entire matrix or for the first N entries\n\ 00650 min - return the minimum value for the entire matrix or for the first N entries\n\ 00651 redim - resize the matrix (for one-dimensional matrices only)\n\ 00652 scale - scale the values by a given factor (for one-dimensional matrices only)\n\ 00653 \n\ 00654 Set and get values:\n\ 00655 matrix m f 3 3 3 - define matrix command \"m\", three-dimensional, floating-point data\n\ 00656 m 1 2 3 - return the value of matrix element [1,2,3]\n\ 00657 m 1 2 3 = 2.0 - set the value of matrix element [1,2,3] to 2.0 (do not return the value)\n\ 00658 m * 2 3 = 2.0 - set a slice consisting of all elements with second index 2 and third index 3 to 2.0", 00659 (char *) NULL ); 00660 return TCL_OK; 00661 } 00662 00663 // info 00664 00665 else if ( ( c == 'i' ) && ( strncmp( argv[0], "info", (size_t) length ) == 0 ) ) 00666 { 00667 for ( i = 0; i < matPtr->dim; i++ ) 00668 { 00669 sprintf( tmp, "%d", matPtr->n[i] ); 00670 // Must avoid trailing space. 00671 if ( i < matPtr->dim - 1 ) 00672 Tcl_AppendResult( interp, tmp, " ", (char *) NULL ); 00673 else 00674 Tcl_AppendResult( interp, tmp, (char *) NULL ); 00675 } 00676 return TCL_OK; 00677 } 00678 00679 // max 00680 00681 else if ( ( c == 'm' ) && ( strncmp( argv[0], "max", (size_t) length ) == 0 ) ) 00682 { 00683 int len; 00684 if ( argc < 1 || argc > 2 ) 00685 { 00686 Tcl_AppendResult( interp, "wrong # args: should be \"", 00687 name, " ", argv[0], " ?length?\"", 00688 (char *) NULL ); 00689 return TCL_ERROR; 00690 } 00691 00692 if ( argc == 2 ) 00693 len = atoi( argv[1] ); 00694 else 00695 len = matPtr->len; 00696 00697 switch ( matPtr->type ) 00698 { 00699 case TYPE_FLOAT: { 00700 Mat_float max = matPtr->fdata[0]; 00701 for ( i = 1; i < len; i++ ) 00702 max = MAX( max, matPtr->fdata[i] ); 00703 //sprintf(tmp, "%.17g", max); 00704 Tcl_PrintDouble( interp, max, tmp ); 00705 Tcl_AppendResult( interp, tmp, (char *) NULL ); 00706 break; 00707 } 00708 case TYPE_INT: { 00709 Mat_int max = matPtr->idata[0]; 00710 for ( i = 1; i < len; i++ ) 00711 max = MAX( max, matPtr->idata[i] ); 00712 sprintf( tmp, "%d", max ); 00713 Tcl_AppendResult( interp, tmp, (char *) NULL ); 00714 break; 00715 } 00716 } 00717 return TCL_OK; 00718 } 00719 00720 // min 00721 00722 else if ( ( c == 'm' ) && ( strncmp( argv[0], "min", (size_t) length ) == 0 ) ) 00723 { 00724 int len; 00725 if ( argc < 1 || argc > 2 ) 00726 { 00727 Tcl_AppendResult( interp, "wrong # args: should be \"", 00728 name, " ", argv[0], " ?length?\"", 00729 (char *) NULL ); 00730 return TCL_ERROR; 00731 } 00732 00733 if ( argc == 2 ) 00734 len = atoi( argv[1] ); 00735 else 00736 len = matPtr->len; 00737 00738 switch ( matPtr->type ) 00739 { 00740 case TYPE_FLOAT: { 00741 Mat_float min = matPtr->fdata[0]; 00742 for ( i = 1; i < len; i++ ) 00743 min = MIN( min, matPtr->fdata[i] ); 00744 //sprintf(tmp, "%.17g", min); 00745 Tcl_PrintDouble( interp, min, tmp ); 00746 Tcl_AppendResult( interp, tmp, (char *) NULL ); 00747 break; 00748 } 00749 case TYPE_INT: { 00750 Mat_int min = matPtr->idata[0]; 00751 for ( i = 1; i < len; i++ ) 00752 min = MIN( min, matPtr->idata[i] ); 00753 sprintf( tmp, "%d", min ); 00754 Tcl_AppendResult( interp, tmp, (char *) NULL ); 00755 break; 00756 } 00757 } 00758 return TCL_OK; 00759 } 00760 00761 // redim 00762 // Only works on 1d matrices 00763 00764 else if ( ( c == 'r' ) && ( strncmp( argv[0], "redim", (size_t) length ) == 0 ) ) 00765 { 00766 int newlen; 00767 void *data; 00768 00769 if ( argc != 2 ) 00770 { 00771 Tcl_AppendResult( interp, "wrong # args: should be \"", 00772 name, " ", argv[0], " length\"", 00773 (char *) NULL ); 00774 return TCL_ERROR; 00775 } 00776 00777 if ( matPtr->dim != 1 ) 00778 { 00779 Tcl_AppendResult( interp, "can only redim a 1d matrix", 00780 (char *) NULL ); 00781 return TCL_ERROR; 00782 } 00783 00784 newlen = atoi( argv[1] ); 00785 switch ( matPtr->type ) 00786 { 00787 case TYPE_FLOAT: 00788 data = realloc( matPtr->fdata, (size_t) newlen * sizeof ( Mat_float ) ); 00789 if ( data == NULL ) 00790 { 00791 Tcl_AppendResult( interp, "redim failed!", 00792 (char *) NULL ); 00793 return TCL_ERROR; 00794 } 00795 matPtr->fdata = (Mat_float *) data; 00796 for ( i = matPtr->len; i < newlen; i++ ) 00797 matPtr->fdata[i] = 0.0; 00798 break; 00799 00800 case TYPE_INT: 00801 data = realloc( matPtr->idata, (size_t) newlen * sizeof ( Mat_int ) ); 00802 if ( data == NULL ) 00803 { 00804 Tcl_AppendResult( interp, "redim failed!", 00805 (char *) NULL ); 00806 return TCL_ERROR; 00807 } 00808 matPtr->idata = (Mat_int *) data; 00809 for ( i = matPtr->len; i < newlen; i++ ) 00810 matPtr->idata[i] = 0; 00811 break; 00812 } 00813 matPtr->n[0] = matPtr->len = newlen; 00814 return TCL_OK; 00815 } 00816 00817 // scale 00818 // Only works on 1d matrices 00819 00820 else if ( ( c == 's' ) && ( strncmp( argv[0], "scale", (size_t) length ) == 0 ) ) 00821 { 00822 Mat_float scale; 00823 00824 if ( argc != 2 ) 00825 { 00826 Tcl_AppendResult( interp, "wrong # args: should be \"", 00827 name, " ", argv[0], " scale-factor\"", 00828 (char *) NULL ); 00829 return TCL_ERROR; 00830 } 00831 00832 if ( matPtr->dim != 1 ) 00833 { 00834 Tcl_AppendResult( interp, "can only scale a 1d matrix", 00835 (char *) NULL ); 00836 return TCL_ERROR; 00837 } 00838 00839 scale = atof( argv[1] ); 00840 switch ( matPtr->type ) 00841 { 00842 case TYPE_FLOAT: 00843 for ( i = 0; i < matPtr->len; i++ ) 00844 matPtr->fdata[i] *= scale; 00845 break; 00846 00847 case TYPE_INT: 00848 for ( i = 0; i < matPtr->len; i++ ) 00849 matPtr->idata[i] = (Mat_int) ( (Mat_float) ( matPtr->idata[i] ) * scale ); 00850 break; 00851 } 00852 return TCL_OK; 00853 } 00854 00855 // Not a "standard" command, check the extension commands. 00856 00857 { 00858 tclMatrixXtnsnDescr *p = head; 00859 for (; p; p = p->next ) 00860 { 00861 if ( ( c == p->cmd[0] ) && ( strncmp( argv[0], p->cmd, (size_t) length ) == 0 ) ) 00862 { 00863 #ifdef DEBUG 00864 printf( "found a match, invoking %s\n", p->cmd ); 00865 #endif 00866 return ( *( p->cmdproc ) )( matPtr, interp, --argc, ++argv ); 00867 } 00868 } 00869 } 00870 00871 // Must be a put or get. Get array indices. 00872 00873 if ( argc < matPtr->dim ) 00874 { 00875 Tcl_AppendResult( interp, "not enough dimensions specified for \"", 00876 name, (char *) NULL ); 00877 return TCL_ERROR; 00878 } 00879 for ( i = 0; i < matPtr->dim; i++ ) 00880 { 00881 if ( strcmp( argv[0], "*" ) == 0 ) 00882 { 00883 nmin[i] = 0; 00884 nmax[i] = matPtr->n[i] - 1; 00885 } 00886 else 00887 { 00888 nmin[i] = atoi( argv[0] ); 00889 nmax[i] = nmin[i]; 00890 } 00891 if ( nmin[i] < 0 || nmax[i] > matPtr->n[i] - 1 ) 00892 { 00893 sprintf( tmp, "Array index %d out of bounds: %s; max: %d\n", 00894 i, argv[0], matPtr->n[i] - 1 ); 00895 Tcl_AppendResult( interp, tmp, (char *) NULL ); 00896 return TCL_ERROR; 00897 } 00898 argc--; argv++; 00899 } 00900 00901 // If there is an "=" after indicies, it's a put. Do error checking. 00902 00903 if ( argc > 0 ) 00904 { 00905 put = 1; 00906 if ( strcmp( argv[0], "=" ) == 0 ) 00907 { 00908 argc--; argv++; 00909 if ( argc == 0 ) 00910 { 00911 Tcl_AppendResult( interp, "no value specified", 00912 (char *) NULL ); 00913 return TCL_ERROR; 00914 } 00915 else if ( argc > 1 ) 00916 { 00917 Tcl_AppendResult( interp, "extra characters after value: \"", 00918 argv[1], "\"", (char *) NULL ); 00919 return TCL_ERROR; 00920 } 00921 } 00922 else 00923 { 00924 Tcl_AppendResult( interp, "extra characters after indices: \"", 00925 argv[0], "\"", (char *) NULL ); 00926 return TCL_ERROR; 00927 } 00928 } 00929 00930 // Do the get/put. 00931 // The loop over all elements takes care of the multi-element cases. 00932 00933 for ( i = nmin[0]; i <= nmax[0]; i++ ) 00934 { 00935 for ( j = nmin[1]; j <= nmax[1]; j++ ) 00936 { 00937 for ( k = nmin[2]; k <= nmax[2]; k++ ) 00938 { 00939 if ( put ) 00940 ( *matPtr->put )( (ClientData) matPtr, interp, I3D( i, j, k ), argv[0] ); 00941 else 00942 { 00943 ( *matPtr->get )( (ClientData) matPtr, interp, I3D( i, j, k ), tmp ); 00944 if ( i == nmax[0] && j == nmax[1] && k == nmax[2] ) 00945 Tcl_AppendResult( interp, tmp, (char *) NULL ); 00946 else 00947 Tcl_AppendResult( interp, tmp, " ", (char *) NULL ); 00948 } 00949 } 00950 } 00951 } 00952 00953 return TCL_OK; 00954 } 00955 00956 //-------------------------------------------------------------------------- 00957 // 00958 // Routines to handle Matrix get/put dependent on type: 00959 // 00960 // MatrixPut_f MatrixGet_f 00961 // MatrixPut_i MatrixGet_i 00962 // 00963 // A "put" converts from string format to the intrinsic type, storing into 00964 // the array. 00965 // 00966 // A "get" converts from the intrinsic type to string format, storing into 00967 // a string buffer. 00968 // 00969 //-------------------------------------------------------------------------- 00970 00971 static void 00972 MatrixPut_f( ClientData clientData, Tcl_Interp* PL_UNUSED( interp ), int index, const char *string ) 00973 { 00974 tclMatrix *matPtr = (tclMatrix *) clientData; 00975 00976 matPtr->fdata[index] = atof( string ); 00977 } 00978 00979 static void 00980 MatrixGet_f( ClientData clientData, Tcl_Interp* interp, int index, char *string ) 00981 { 00982 tclMatrix *matPtr = (tclMatrix *) clientData; 00983 double value = matPtr->fdata[index]; 00984 00985 //sprintf(string, "%.17g", value); 00986 Tcl_PrintDouble( interp, value, string ); 00987 } 00988 00989 static void 00990 MatrixPut_i( ClientData clientData, Tcl_Interp* PL_UNUSED( interp ), int index, const char *string ) 00991 { 00992 tclMatrix *matPtr = (tclMatrix *) clientData; 00993 00994 if ( ( strlen( string ) > 2 ) && ( strncmp( string, "0x", 2 ) == 0 ) ) 00995 { 00996 matPtr->idata[index] = (Mat_int) strtoul( &string[2], NULL, 16 ); 00997 } 00998 else 00999 matPtr->idata[index] = atoi( string ); 01000 } 01001 01002 static void 01003 MatrixGet_i( ClientData clientData, Tcl_Interp* PL_UNUSED( interp ), int index, char *string ) 01004 { 01005 tclMatrix *matPtr = (tclMatrix *) clientData; 01006 01007 sprintf( string, "%d", matPtr->idata[index] ); 01008 } 01009 01010 //-------------------------------------------------------------------------- 01011 // 01012 // DeleteMatrixVar -- 01013 // 01014 // Causes matrix command to be deleted. Invoked when variable 01015 // associated with matrix command is unset. 01016 // 01017 // Results: 01018 // None. 01019 // 01020 // Side effects: 01021 // See DeleteMatrixCmd. 01022 // 01023 //-------------------------------------------------------------------------- 01024 01025 static char * 01026 DeleteMatrixVar( ClientData clientData, 01027 Tcl_Interp * PL_UNUSED( interp ), char * PL_UNUSED( name1 ), char * PL_UNUSED( name2 ), int PL_UNUSED( flags ) ) 01028 { 01029 tclMatrix *matPtr = (tclMatrix *) clientData; 01030 Tcl_CmdInfo infoPtr; 01031 char *name; 01032 01033 dbug_enter( "DeleteMatrixVar" ); 01034 01035 if ( matPtr->tracing != 0 ) 01036 { 01037 matPtr->tracing = 0; 01038 name = (char *) malloc( strlen( matPtr->name ) + 1 ); 01039 strcpy( name, matPtr->name ); 01040 01041 #ifdef DEBUG 01042 if ( Tcl_GetCommandInfo( matPtr->interp, matPtr->name, &infoPtr ) ) 01043 { 01044 if ( Tcl_DeleteCommand( matPtr->interp, matPtr->name ) == TCL_OK ) 01045 fprintf( stderr, "Deleted command %s\n", name ); 01046 else 01047 fprintf( stderr, "Unable to delete command %s\n", name ); 01048 } 01049 #else 01050 if ( Tcl_GetCommandInfo( matPtr->interp, matPtr->name, &infoPtr ) ) 01051 Tcl_DeleteCommand( matPtr->interp, matPtr->name ); 01052 #endif 01053 free( (void *) name ); 01054 } 01055 return (char *) NULL; 01056 } 01057 01058 //-------------------------------------------------------------------------- 01059 // 01060 // DeleteMatrixCmd -- 01061 // 01062 // Releases all the resources allocated to the matrix command. 01063 // Invoked just before a matrix command is removed from an interpreter. 01064 // 01065 // Note: If the matrix has tracing enabled, it means the user 01066 // explicitly deleted a non-persistent matrix. Not a good idea, 01067 // because eventually the local variable that was being traced will 01068 // become unset and the matrix data will be referenced in 01069 // DeleteMatrixVar. So I've massaged this so that at worst it only 01070 // causes a minor memory leak instead of imminent program death. 01071 // 01072 // Results: 01073 // None. 01074 // 01075 // Side effects: 01076 // All memory associated with the matrix operator is freed (usually). 01077 // 01078 //-------------------------------------------------------------------------- 01079 01080 static void 01081 DeleteMatrixCmd( ClientData clientData ) 01082 { 01083 tclMatrix *matPtr = (tclMatrix *) clientData; 01084 Tcl_HashEntry *hPtr; 01085 01086 dbug_enter( "DeleteMatrixCmd" ); 01087 01088 #ifdef DEBUG 01089 fprintf( stderr, "Freeing space associated with matrix %s\n", matPtr->name ); 01090 #endif 01091 01092 // Remove hash table entry 01093 01094 hPtr = Tcl_FindHashEntry( &matTable, matPtr->name ); 01095 if ( hPtr != NULL ) 01096 Tcl_DeleteHashEntry( hPtr ); 01097 01098 // Free data 01099 01100 if ( matPtr->fdata != NULL ) 01101 { 01102 free( (void *) matPtr->fdata ); 01103 matPtr->fdata = NULL; 01104 } 01105 if ( matPtr->idata != NULL ) 01106 { 01107 free( (void *) matPtr->idata ); 01108 matPtr->idata = NULL; 01109 } 01110 01111 // Attempt to turn off tracing if possible. 01112 01113 if ( matPtr->tracing ) 01114 { 01115 if ( Tcl_VarTraceInfo( matPtr->interp, matPtr->name, TCL_TRACE_UNSETS, 01116 (Tcl_VarTraceProc *) DeleteMatrixVar, NULL ) != NULL ) 01117 { 01118 matPtr->tracing = 0; 01119 Tcl_UntraceVar( matPtr->interp, matPtr->name, TCL_TRACE_UNSETS, 01120 (Tcl_VarTraceProc *) DeleteMatrixVar, (ClientData) matPtr ); 01121 Tcl_UnsetVar( matPtr->interp, matPtr->name, 0 ); 01122 } 01123 } 01124 01125 // Free name. 01126 01127 if ( matPtr->name != NULL ) 01128 { 01129 free( (void *) matPtr->name ); 01130 matPtr->name = NULL; 01131 } 01132 01133 // Free tclMatrix 01134 01135 if ( !matPtr->tracing ) 01136 free( (void *) matPtr ); 01137 #ifdef DEBUG 01138 else 01139 fprintf( stderr, "OOPS! You just lost %d bytes\n", sizeof ( tclMatrix ) ); 01140 #endif 01141 }