00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024
00025
00026
00027
00028
00029
00030
00031
00032
00033
00034
00035
00036
00037
00038 #include <stdio.h>
00039 #include <stdlib.h>
00040 #include <string.h>
00041 #include "pldll.h"
00042 #include "tclMatrix.h"
00043
00044
00045
00046 #ifndef MAX
00047 #define MAX( a, b ) ( ( ( a ) > ( b ) ) ? ( a ) : ( b ) )
00048 #endif
00049 #ifndef MIN
00050 #define MIN( a, b ) ( ( ( a ) < ( b ) ) ? ( a ) : ( b ) )
00051 #endif
00052
00053
00054
00055 #ifdef DEBUG_ENTER
00056 #define dbug_enter( a ) \
00057 fprintf( stderr, "%s: Entered %s\n", __FILE__, a );
00058
00059 #else
00060 #define dbug_enter( a )
00061 #endif
00062
00063
00064
00065 static int matTable_initted = 0;
00066 static Tcl_HashTable matTable;
00067
00068
00069
00070
00071
00072 static int
00073 matrixInitialize( Tcl_Interp* interp, tclMatrix* m,
00074 int dim, int offs, int nargs, const char** args );
00075
00076
00077
00078 static int
00079 MatrixCmd( ClientData clientData, Tcl_Interp *interp, int argc, const char **argv );
00080
00081
00082
00083 static char *
00084 DeleteMatrixVar( ClientData clientData,
00085 Tcl_Interp *interp, char *name1, char *name2, int flags );
00086
00087
00088
00089 static void
00090 DeleteMatrixCmd( ClientData clientData );
00091
00092
00093
00094 static void
00095 MatrixPut_f( ClientData clientData, Tcl_Interp* interp, int index, const char *string );
00096
00097 static void
00098 MatrixGet_f( ClientData clientData, Tcl_Interp* interp, int index, char *string );
00099
00100 static void
00101 MatrixPut_i( ClientData clientData, Tcl_Interp* interp, int index, const char *string );
00102
00103 static void
00104 MatrixGet_i( ClientData clientData, Tcl_Interp* interp, int index, char *string );
00105
00106
00107
00108
00109
00110
00111
00112
00113
00114
00115
00116
00117
00118
00119
00120
00121
00122 int
00123 Tcl_MatrixCmd( ClientData clientData, Tcl_Interp *interp,
00124 int argc, const char **argv )
00125 {
00126 register tclMatrix *matPtr;
00127 int i, j, length, new, index, persist = 0, initializer = 0;
00128 Tcl_HashEntry *hPtr;
00129 Tcl_CmdInfo infoPtr;
00130 char c;
00131
00132 dbug_enter( "Tcl_MatrixCmd" );
00133
00134 if ( argc < 3 )
00135 {
00136 Tcl_AppendResult( interp, "wrong # args: should be \"", argv[0],
00137 " ?-persist? var type dim1 ?dim2? ?dim3? ...\"", (char *) NULL );
00138 return TCL_ERROR;
00139 }
00140
00141
00142
00143 if ( !matTable_initted )
00144 {
00145 matTable_initted = 1;
00146 Tcl_InitHashTable( &matTable, TCL_STRING_KEYS );
00147 }
00148
00149
00150
00151 for ( i = 1; i < argc; i++ )
00152 {
00153 c = argv[i][0];
00154 length = strlen( argv[i] );
00155
00156
00157
00158 if ( ( c == '-' ) && ( strncmp( argv[i], "-persist", length ) == 0 ) )
00159 {
00160 persist = 1;
00161 argc--;
00162 for ( j = i; j < argc; j++ )
00163 argv[j] = argv[j + 1];
00164 break;
00165 }
00166 }
00167
00168
00169
00170 matPtr = (tclMatrix *) malloc( sizeof ( tclMatrix ) );
00171 matPtr->fdata = NULL;
00172 matPtr->idata = NULL;
00173 matPtr->name = NULL;
00174 matPtr->dim = 0;
00175 matPtr->len = 1;
00176 matPtr->tracing = 0;
00177 for ( i = 0; i < MAX_ARRAY_DIM; i++ )
00178 matPtr->n[i] = 1;
00179
00180
00181
00182
00183 argc--; argv++;
00184
00185 if ( Tcl_GetCommandInfo( interp, argv[0], &infoPtr ) )
00186 {
00187 Tcl_AppendResult( interp, "Matrix operator \"", argv[0],
00188 "\" already in use", (char *) NULL );
00189 free( (void *) matPtr );
00190 return TCL_ERROR;
00191 }
00192
00193 if ( Tcl_GetVar( interp, argv[0], 0 ) != NULL )
00194 {
00195 Tcl_AppendResult( interp, "Illegal name for Matrix operator \"",
00196 argv[0], "\": local variable of same name is active",
00197 (char *) NULL );
00198 free( (void *) matPtr );
00199 return TCL_ERROR;
00200 }
00201
00202 matPtr->name = (char *) malloc( strlen( argv[0] ) + 1 );
00203 strcpy( matPtr->name, argv[0] );
00204
00205
00206
00207 argc--; argv++;
00208 c = argv[0][0];
00209 length = strlen( argv[0] );
00210
00211 if ( ( c == 'f' ) && ( strncmp( argv[0], "float", length ) == 0 ) )
00212 {
00213 matPtr->type = TYPE_FLOAT;
00214 matPtr->put = MatrixPut_f;
00215 matPtr->get = MatrixGet_f;
00216 }
00217 else if ( ( c == 'i' ) && ( strncmp( argv[0], "int", length ) == 0 ) )
00218 {
00219 matPtr->type = TYPE_INT;
00220 matPtr->put = MatrixPut_i;
00221 matPtr->get = MatrixGet_i;
00222 }
00223 else
00224 {
00225 Tcl_AppendResult( interp, "Matrix type \"", argv[0],
00226 "\" not supported, should be \"float\" or \"int\"",
00227 (char *) NULL );
00228
00229 DeleteMatrixCmd( (ClientData) matPtr );
00230 return TCL_ERROR;
00231 }
00232
00233
00234
00235 argc--; argv++;
00236 for (; argc > 0; argc--, argv++ )
00237 {
00238
00239
00240 if ( strcmp( argv[0], "=" ) == 0 )
00241 {
00242 argc--; argv++;
00243 initializer = 1;
00244 break;
00245 }
00246
00247
00248
00249 matPtr->dim++;
00250 if ( matPtr->dim > MAX_ARRAY_DIM )
00251 {
00252 Tcl_AppendResult( interp,
00253 "too many dimensions specified for Matrix operator \"",
00254 matPtr->name, "\"", (char *) NULL );
00255
00256 DeleteMatrixCmd( (ClientData) matPtr );
00257 return TCL_ERROR;
00258 }
00259
00260
00261
00262 index = matPtr->dim - 1;
00263 matPtr->n[index] = atoi( argv[0] );
00264 if ( matPtr->n[index] < 1 )
00265 {
00266 Tcl_AppendResult( interp, "invalid matrix dimension \"", argv[0],
00267 "\" for Matrix operator \"", matPtr->name, "\"",
00268 (char *) NULL );
00269
00270 DeleteMatrixCmd( (ClientData) matPtr );
00271 return TCL_ERROR;
00272 }
00273 matPtr->len *= matPtr->n[index];
00274 }
00275
00276 if ( matPtr->dim < 1 )
00277 {
00278 Tcl_AppendResult( interp,
00279 "insufficient dimensions given for Matrix operator \"",
00280 matPtr->name, "\"", (char *) NULL );
00281 DeleteMatrixCmd( (ClientData) matPtr );
00282 return TCL_ERROR;
00283 }
00284
00285
00286
00287 switch ( matPtr->type )
00288 {
00289 case TYPE_FLOAT:
00290 matPtr->fdata = (Mat_float *) malloc( matPtr->len * sizeof ( Mat_float ) );
00291 for ( i = 0; i < matPtr->len; i++ )
00292 matPtr->fdata[i] = 0.0;
00293 break;
00294
00295 case TYPE_INT:
00296 matPtr->idata = (Mat_int *) malloc( matPtr->len * sizeof ( Mat_int ) );
00297 for ( i = 0; i < matPtr->len; i++ )
00298 matPtr->idata[i] = 0;
00299 break;
00300 }
00301
00302
00303
00304 if ( initializer )
00305 matrixInitialize( interp, matPtr, 0, 0, 1, &argv[0] );
00306
00307
00308
00309
00310 if ( !persist )
00311 {
00312 if ( Tcl_SetVar( interp, matPtr->name,
00313 "old_bogus_syntax_please_upgrade", 0 ) == NULL )
00314 {
00315 Tcl_AppendResult( interp, "unable to schedule Matrix operator \"",
00316 matPtr->name, "\" for automatic deletion", (char *) NULL );
00317 DeleteMatrixCmd( (ClientData) matPtr );
00318 return TCL_ERROR;
00319 }
00320 matPtr->tracing = 1;
00321 Tcl_TraceVar( interp, matPtr->name, TCL_TRACE_UNSETS,
00322 (Tcl_VarTraceProc *) DeleteMatrixVar, (ClientData) matPtr );
00323 }
00324
00325
00326
00327 #ifdef DEBUG
00328 fprintf( stderr, "Creating Matrix operator of name %s\n", matPtr->name );
00329 #endif
00330 Tcl_CreateCommand( interp, matPtr->name, (Tcl_CmdProc *) MatrixCmd,
00331 (ClientData) matPtr, (Tcl_CmdDeleteProc *) DeleteMatrixCmd );
00332
00333
00334
00335
00336 matPtr->interp = interp;
00337
00338
00339
00340
00341 hPtr = Tcl_CreateHashEntry( &matTable, matPtr->name, &new );
00342 if ( !new )
00343 {
00344 Tcl_AppendResult( interp,
00345 "Unable to create hash table entry for Matrix operator \"",
00346 matPtr->name, "\"", (char *) NULL );
00347 return TCL_ERROR;
00348 }
00349 Tcl_SetHashValue( hPtr, matPtr );
00350
00351 Tcl_SetResult( interp, matPtr->name, TCL_VOLATILE );
00352 return TCL_OK;
00353 }
00354
00355
00356
00357
00358
00359
00360
00361
00362
00363
00364
00365
00366
00367
00368
00369 tclMatrix *
00370 Tcl_GetMatrixPtr( Tcl_Interp *interp, const char *matName )
00371 {
00372 Tcl_HashEntry *hPtr;
00373
00374 dbug_enter( "Tcl_GetMatrixPtr" );
00375
00376 if ( !matTable_initted )
00377 {
00378 return NULL;
00379 }
00380
00381 hPtr = Tcl_FindHashEntry( &matTable, matName );
00382 if ( hPtr == NULL )
00383 {
00384 Tcl_AppendResult( interp, "No matrix operator named \"",
00385 matName, "\"", (char *) NULL );
00386 return NULL;
00387 }
00388 return (tclMatrix *) Tcl_GetHashValue( hPtr );
00389 }
00390
00391
00392
00393
00394
00395
00396
00397
00398
00399
00400
00401
00402
00403
00404
00405
00406 static tclMatrixXtnsnDescr *head = (tclMatrixXtnsnDescr *) NULL;
00407 static tclMatrixXtnsnDescr *tail = (tclMatrixXtnsnDescr *) NULL;
00408
00409 int
00410 Tcl_MatrixInstallXtnsn( char *cmd, tclMatrixXtnsnProc proc )
00411 {
00412
00413
00414
00415
00416
00417
00418
00419
00420 tclMatrixXtnsnDescr *new =
00421 (tclMatrixXtnsnDescr *) malloc( sizeof ( tclMatrixXtnsnDescr ) );
00422
00423 dbug_enter( "Tcl_MatrixInstallXtnsn" );
00424
00425 #ifdef DEBUG
00426 fprintf( stderr, "Installing a tclMatrix extension -> %s\n", cmd );
00427 #endif
00428
00429 new->cmd = malloc( strlen( cmd ) + 1 );
00430 strcpy( new->cmd, cmd );
00431 new->cmdproc = proc;
00432 new->next = (tclMatrixXtnsnDescr *) NULL;
00433
00434 if ( !head )
00435 {
00436 tail = head = new;
00437 return 1;
00438 }
00439 else
00440 {
00441 tail = tail->next = new;
00442 return 1;
00443 }
00444 }
00445
00446
00447
00448
00449
00450
00451
00452
00453
00454
00455
00456
00457
00458
00459
00460
00461 static int matrixInitialize( Tcl_Interp* interp, tclMatrix* m,
00462 int dim, int offs, int nargs, const char** args )
00463 {
00464 static int verbose = 0;
00465
00466 char ** newargs;
00467 int numnewargs;
00468 int newoffs;
00469 int i;
00470
00471 if ( verbose )
00472 fprintf( stderr, "level %d offset %d args %d\n", dim, offs, nargs );
00473
00474 if ( dim < m->dim )
00475 {
00476 for ( i = 0; i < nargs; i++ )
00477 {
00478 if ( Tcl_SplitList( interp, args[i], &numnewargs, (CONST char ***) &newargs )
00479 != TCL_OK )
00480 {
00481 Tcl_AppendResult( interp, "bad matrix initializer list form: ",
00482 args[i], (char *) NULL );
00483 return TCL_ERROR;
00484 }
00485 if ( dim > 0 )
00486 newoffs = offs * m->n[dim - 1] + i;
00487 else
00488 newoffs = 0;
00489
00490 matrixInitialize( interp, m, dim + 1, newoffs, numnewargs, (const char **) newargs );
00491
00492 Tcl_Free( (char *) newargs );
00493 }
00494 return TCL_OK;
00495 }
00496
00497 for ( i = 0; i < nargs; i++ )
00498 {
00499 newoffs = offs * m->n[dim - 1] + i;
00500 ( m->put )( (ClientData) m, interp, newoffs, args[i] );
00501 if ( verbose )
00502 fprintf( stderr, "\ta[%d] = %s\n", newoffs, args[i] );
00503 }
00504 return TCL_OK;
00505 }
00506
00507
00508
00509
00510
00511
00512
00513
00514
00515
00516
00517
00518
00519
00520
00521
00522
00523 static int
00524 MatrixCmd( ClientData clientData, Tcl_Interp *interp,
00525 int argc, const char **argv )
00526 {
00527 register tclMatrix *matPtr = (tclMatrix *) clientData;
00528 int length, put = 0;
00529 char c, tmp[80];
00530 const char *name = argv[0];
00531 int nmin[MAX_ARRAY_DIM], nmax[MAX_ARRAY_DIM];
00532 int i, j, k;
00533
00534
00535
00536 if ( argc < 2 )
00537 {
00538 Tcl_AppendResult( interp, "wrong # args, type: \"",
00539 argv[0], " help\" for more info", (char *) NULL );
00540 return TCL_ERROR;
00541 }
00542
00543 for ( i = 0; i < MAX_ARRAY_DIM; i++ )
00544 {
00545 nmin[i] = 0;
00546 nmax[i] = matPtr->n[i] - 1;
00547 }
00548
00549
00550
00551 argc--; argv++;
00552 c = argv[0][0];
00553 length = strlen( argv[0] );
00554
00555
00556
00557
00558 if ( ( c == 'd' ) && ( strncmp( argv[0], "dump", length ) == 0 ) )
00559 {
00560 for ( i = nmin[0]; i <= nmax[0]; i++ )
00561 {
00562 for ( j = nmin[1]; j <= nmax[1]; j++ )
00563 {
00564 for ( k = nmin[2]; k <= nmax[2]; k++ )
00565 {
00566 ( *matPtr->get )( (ClientData) matPtr, interp, I3D( i, j, k ), tmp );
00567 printf( "%s ", tmp );
00568 }
00569 if ( matPtr->dim > 2 )
00570 printf( "\n" );
00571 }
00572 if ( matPtr->dim > 1 )
00573 printf( "\n" );
00574 }
00575 printf( "\n" );
00576 return TCL_OK;
00577 }
00578
00579
00580
00581 else if ( ( c == 'd' ) && ( strncmp( argv[0], "delete", length ) == 0 ) )
00582 {
00583 #ifdef DEBUG
00584 fprintf( stderr, "Deleting array %s\n", name );
00585 #endif
00586 Tcl_DeleteCommand( interp, name );
00587 return TCL_OK;
00588 }
00589
00590
00591
00592
00593 else if ( ( c == 'f' ) && ( strncmp( argv[0], "filter", length ) == 0 ) )
00594 {
00595 Mat_float *tmp;
00596 int ifilt, nfilt;
00597
00598 if ( argc != 2 )
00599 {
00600 Tcl_AppendResult( interp, "wrong # args: should be \"",
00601 name, " ", argv[0], " num-passes\"",
00602 (char *) NULL );
00603 return TCL_ERROR;
00604 }
00605
00606 if ( matPtr->dim != 1 || matPtr->type != TYPE_FLOAT )
00607 {
00608 Tcl_AppendResult( interp, "can only filter a 1d float matrix",
00609 (char *) NULL );
00610 return TCL_ERROR;
00611 }
00612
00613 nfilt = atoi( argv[1] );
00614 tmp = (Mat_float *) malloc( ( matPtr->len + 2 ) * sizeof ( Mat_float ) );
00615
00616 for ( ifilt = 0; ifilt < nfilt; ifilt++ )
00617 {
00618
00619
00620 j = 0; tmp[j] = matPtr->fdata[0];
00621 for ( i = 0; i < matPtr->len; i++ )
00622 {
00623 j++; tmp[j] = matPtr->fdata[i];
00624 }
00625 j++; tmp[j] = matPtr->fdata[matPtr->len - 1];
00626
00627
00628
00629 for ( i = 0; i < matPtr->len; i++ )
00630 {
00631 j = i + 1;
00632 matPtr->fdata[i] = 0.25 * ( tmp[j - 1] + 2 * tmp[j] + tmp[j + 1] );
00633 }
00634 }
00635
00636 free( (void *) tmp );
00637 return TCL_OK;
00638 }
00639
00640
00641
00642 else if ( ( c == 'h' ) && ( strncmp( argv[0], "help", length ) == 0 ) )
00643 {
00644 Tcl_AppendResult( interp,
00645 "So you really thought there'd be help, eh? Sucker.",
00646 (char *) NULL );
00647 return TCL_OK;
00648 }
00649
00650
00651
00652 else if ( ( c == 'i' ) && ( strncmp( argv[0], "info", length ) == 0 ) )
00653 {
00654 for ( i = 0; i < matPtr->dim; i++ )
00655 {
00656 sprintf( tmp, "%d", matPtr->n[i] );
00657
00658 if ( i < matPtr->dim - 1 )
00659 Tcl_AppendResult( interp, tmp, " ", (char *) NULL );
00660 else
00661 Tcl_AppendResult( interp, tmp, (char *) NULL );
00662 }
00663 return TCL_OK;
00664 }
00665
00666
00667
00668 else if ( ( c == 'm' ) && ( strncmp( argv[0], "max", length ) == 0 ) )
00669 {
00670 int len;
00671 if ( argc < 1 || argc > 2 )
00672 {
00673 Tcl_AppendResult( interp, "wrong # args: should be \"",
00674 name, " ", argv[0], " ?length?\"",
00675 (char *) NULL );
00676 return TCL_ERROR;
00677 }
00678
00679 if ( argc == 2 )
00680 len = atoi( argv[1] );
00681 else
00682 len = matPtr->len;
00683
00684 switch ( matPtr->type )
00685 {
00686 case TYPE_FLOAT: {
00687 Mat_float max = matPtr->fdata[0];
00688 for ( i = 1; i < len; i++ )
00689 max = MAX( max, matPtr->fdata[i] );
00690
00691 Tcl_PrintDouble( interp, max, tmp );
00692 Tcl_AppendResult( interp, tmp, (char *) NULL );
00693 break;
00694 }
00695 case TYPE_INT: {
00696 Mat_int max = matPtr->idata[0];
00697 for ( i = 1; i < len; i++ )
00698 max = MAX( max, matPtr->idata[i] );
00699 sprintf( tmp, "%d", max );
00700 Tcl_AppendResult( interp, tmp, (char *) NULL );
00701 break;
00702 }
00703 }
00704 return TCL_OK;
00705 }
00706
00707
00708
00709 else if ( ( c == 'm' ) && ( strncmp( argv[0], "min", length ) == 0 ) )
00710 {
00711 int len;
00712 if ( argc < 1 || argc > 2 )
00713 {
00714 Tcl_AppendResult( interp, "wrong # args: should be \"",
00715 name, " ", argv[0], " ?length?\"",
00716 (char *) NULL );
00717 return TCL_ERROR;
00718 }
00719
00720 if ( argc == 2 )
00721 len = atoi( argv[1] );
00722 else
00723 len = matPtr->len;
00724
00725 switch ( matPtr->type )
00726 {
00727 case TYPE_FLOAT: {
00728 Mat_float min = matPtr->fdata[0];
00729 for ( i = 1; i < len; i++ )
00730 min = MIN( min, matPtr->fdata[i] );
00731
00732 Tcl_PrintDouble( interp, min, tmp );
00733 Tcl_AppendResult( interp, tmp, (char *) NULL );
00734 break;
00735 }
00736 case TYPE_INT: {
00737 Mat_int min = matPtr->idata[0];
00738 for ( i = 1; i < len; i++ )
00739 min = MIN( min, matPtr->idata[i] );
00740 sprintf( tmp, "%d", min );
00741 Tcl_AppendResult( interp, tmp, (char *) NULL );
00742 break;
00743 }
00744 }
00745 return TCL_OK;
00746 }
00747
00748
00749
00750
00751 else if ( ( c == 'r' ) && ( strncmp( argv[0], "redim", length ) == 0 ) )
00752 {
00753 int newlen;
00754 void *data;
00755
00756 if ( argc != 2 )
00757 {
00758 Tcl_AppendResult( interp, "wrong # args: should be \"",
00759 name, " ", argv[0], " length\"",
00760 (char *) NULL );
00761 return TCL_ERROR;
00762 }
00763
00764 if ( matPtr->dim != 1 )
00765 {
00766 Tcl_AppendResult( interp, "can only redim a 1d matrix",
00767 (char *) NULL );
00768 return TCL_ERROR;
00769 }
00770
00771 newlen = atoi( argv[1] );
00772 switch ( matPtr->type )
00773 {
00774 case TYPE_FLOAT:
00775 data = realloc( matPtr->fdata, newlen * sizeof ( Mat_float ) );
00776 if ( data == NULL )
00777 {
00778 Tcl_AppendResult( interp, "redim failed!",
00779 (char *) NULL );
00780 return TCL_ERROR;
00781 }
00782 matPtr->fdata = (Mat_float *) data;
00783 for ( i = matPtr->len; i < newlen; i++ )
00784 matPtr->fdata[i] = 0.0;
00785 break;
00786
00787 case TYPE_INT:
00788 data = realloc( matPtr->idata, newlen * sizeof ( Mat_int ) );
00789 if ( data == NULL )
00790 {
00791 Tcl_AppendResult( interp, "redim failed!",
00792 (char *) NULL );
00793 return TCL_ERROR;
00794 }
00795 matPtr->idata = (Mat_int *) data;
00796 for ( i = matPtr->len; i < newlen; i++ )
00797 matPtr->idata[i] = 0;
00798 break;
00799 }
00800 matPtr->n[0] = matPtr->len = newlen;
00801 return TCL_OK;
00802 }
00803
00804
00805
00806
00807 else if ( ( c == 's' ) && ( strncmp( argv[0], "scale", length ) == 0 ) )
00808 {
00809 Mat_float scale;
00810
00811 if ( argc != 2 )
00812 {
00813 Tcl_AppendResult( interp, "wrong # args: should be \"",
00814 name, " ", argv[0], " scale-factor\"",
00815 (char *) NULL );
00816 return TCL_ERROR;
00817 }
00818
00819 if ( matPtr->dim != 1 )
00820 {
00821 Tcl_AppendResult( interp, "can only scale a 1d matrix",
00822 (char *) NULL );
00823 return TCL_ERROR;
00824 }
00825
00826 scale = atof( argv[1] );
00827 switch ( matPtr->type )
00828 {
00829 case TYPE_FLOAT:
00830 for ( i = 0; i < matPtr->len; i++ )
00831 matPtr->fdata[i] *= scale;
00832 break;
00833
00834 case TYPE_INT:
00835 for ( i = 0; i < matPtr->len; i++ )
00836 matPtr->idata[i] *= scale;
00837 break;
00838 }
00839 return TCL_OK;
00840 }
00841
00842
00843
00844 {
00845 tclMatrixXtnsnDescr *p = head;
00846 for (; p; p = p->next )
00847 {
00848 if ( ( c == p->cmd[0] ) && ( strncmp( argv[0], p->cmd, length ) == 0 ) )
00849 {
00850 #ifdef DEBUG
00851 printf( "found a match, invoking %s\n", p->cmd );
00852 #endif
00853 return ( *( p->cmdproc ) )( matPtr, interp, --argc, ++argv );
00854 }
00855 }
00856 }
00857
00858
00859
00860 if ( argc < matPtr->dim )
00861 {
00862 Tcl_AppendResult( interp, "not enough dimensions specified for \"",
00863 name, (char *) NULL );
00864 return TCL_ERROR;
00865 }
00866 for ( i = 0; i < matPtr->dim; i++ )
00867 {
00868 if ( strcmp( argv[0], "*" ) == 0 )
00869 {
00870 nmin[i] = 0;
00871 nmax[i] = matPtr->n[i] - 1;
00872 }
00873 else
00874 {
00875 nmin[i] = atoi( argv[0] );
00876 nmax[i] = nmin[i];
00877 }
00878 if ( nmin[i] < 0 || nmax[i] > matPtr->n[i] - 1 )
00879 {
00880 sprintf( tmp, "Array index %d out of bounds: %s; max: %d\n",
00881 i, argv[0], matPtr->n[i] - 1 );
00882 Tcl_AppendResult( interp, tmp, (char *) NULL );
00883 return TCL_ERROR;
00884 }
00885 argc--; argv++;
00886 }
00887
00888
00889
00890 if ( argc > 0 )
00891 {
00892 put = 1;
00893 if ( strcmp( argv[0], "=" ) == 0 )
00894 {
00895 argc--; argv++;
00896 if ( argc == 0 )
00897 {
00898 Tcl_AppendResult( interp, "no value specified",
00899 (char *) NULL );
00900 return TCL_ERROR;
00901 }
00902 else if ( argc > 1 )
00903 {
00904 Tcl_AppendResult( interp, "extra characters after value: \"",
00905 argv[1], "\"", (char *) NULL );
00906 return TCL_ERROR;
00907 }
00908 }
00909 else
00910 {
00911 Tcl_AppendResult( interp, "extra characters after indices: \"",
00912 argv[0], "\"", (char *) NULL );
00913 return TCL_ERROR;
00914 }
00915 }
00916
00917
00918
00919
00920 for ( i = nmin[0]; i <= nmax[0]; i++ )
00921 {
00922 for ( j = nmin[1]; j <= nmax[1]; j++ )
00923 {
00924 for ( k = nmin[2]; k <= nmax[2]; k++ )
00925 {
00926 if ( put )
00927 ( *matPtr->put )( (ClientData) matPtr, interp, I3D( i, j, k ), argv[0] );
00928 else
00929 {
00930 ( *matPtr->get )( (ClientData) matPtr, interp, I3D( i, j, k ), tmp );
00931 if ( i == nmax[0] && j == nmax[1] && k == nmax[2] )
00932 Tcl_AppendResult( interp, tmp, (char *) NULL );
00933 else
00934 Tcl_AppendResult( interp, tmp, " ", (char *) NULL );
00935 }
00936 }
00937 }
00938 }
00939
00940 return TCL_OK;
00941 }
00942
00943
00944
00945
00946
00947
00948
00949
00950
00951
00952
00953
00954
00955
00956
00957
00958 static void
00959 MatrixPut_f( ClientData clientData, Tcl_Interp* interp, int index, const char *string )
00960 {
00961 tclMatrix *matPtr = (tclMatrix *) clientData;
00962
00963 matPtr->fdata[index] = atof( string );
00964 }
00965
00966 static void
00967 MatrixGet_f( ClientData clientData, Tcl_Interp* interp, int index, char *string )
00968 {
00969 tclMatrix *matPtr = (tclMatrix *) clientData;
00970 double value = matPtr->fdata[index];
00971
00972
00973 Tcl_PrintDouble( interp, value, string );
00974 }
00975
00976 static void
00977 MatrixPut_i( ClientData clientData, Tcl_Interp* interp, int index, const char *string )
00978 {
00979 tclMatrix *matPtr = (tclMatrix *) clientData;
00980
00981 if ( ( strlen( string ) > 2 ) && ( strncmp( string, "0x", 2 ) == 0 ) )
00982 {
00983 matPtr->idata[index] = strtoul( &string[2], NULL, 16 );
00984 }
00985 else
00986 matPtr->idata[index] = atoi( string );
00987 }
00988
00989 static void
00990 MatrixGet_i( ClientData clientData, Tcl_Interp* interp, int index, char *string )
00991 {
00992 tclMatrix *matPtr = (tclMatrix *) clientData;
00993
00994 sprintf( string, "%d", matPtr->idata[index] );
00995 }
00996
00997
00998
00999
01000
01001
01002
01003
01004
01005
01006
01007
01008
01009
01010
01011
01012 static char *
01013 DeleteMatrixVar( ClientData clientData,
01014 Tcl_Interp *interp, char *name1, char *name2, int flags )
01015 {
01016 tclMatrix *matPtr = (tclMatrix *) clientData;
01017 Tcl_CmdInfo infoPtr;
01018 char *name;
01019
01020 dbug_enter( "DeleteMatrixVar" );
01021
01022 if ( matPtr->tracing != 0 )
01023 {
01024 matPtr->tracing = 0;
01025 name = (char *) malloc( strlen( matPtr->name ) + 1 );
01026 strcpy( name, matPtr->name );
01027
01028 #ifdef DEBUG
01029 if ( Tcl_GetCommandInfo( matPtr->interp, matPtr->name, &infoPtr ) )
01030 {
01031 if ( Tcl_DeleteCommand( matPtr->interp, matPtr->name ) == TCL_OK )
01032 fprintf( stderr, "Deleted command %s\n", name );
01033 else
01034 fprintf( stderr, "Unable to delete command %s\n", name );
01035 }
01036 #else
01037 if ( Tcl_GetCommandInfo( matPtr->interp, matPtr->name, &infoPtr ) )
01038 Tcl_DeleteCommand( matPtr->interp, matPtr->name );
01039 #endif
01040 free( (void *) name );
01041 }
01042 return (char *) NULL;
01043 }
01044
01045
01046
01047
01048
01049
01050
01051
01052
01053
01054
01055
01056
01057
01058
01059
01060
01061
01062
01063
01064
01065
01066
01067 static void
01068 DeleteMatrixCmd( ClientData clientData )
01069 {
01070 tclMatrix *matPtr = (tclMatrix *) clientData;
01071 Tcl_HashEntry *hPtr;
01072
01073 dbug_enter( "DeleteMatrixCmd" );
01074
01075 #ifdef DEBUG
01076 fprintf( stderr, "Freeing space associated with matrix %s\n", matPtr->name );
01077 #endif
01078
01079
01080
01081 hPtr = Tcl_FindHashEntry( &matTable, matPtr->name );
01082 if ( hPtr != NULL )
01083 Tcl_DeleteHashEntry( hPtr );
01084
01085
01086
01087 if ( matPtr->fdata != NULL )
01088 {
01089 free( (void *) matPtr->fdata );
01090 matPtr->fdata = NULL;
01091 }
01092 if ( matPtr->idata != NULL )
01093 {
01094 free( (void *) matPtr->idata );
01095 matPtr->idata = NULL;
01096 }
01097
01098
01099
01100 if ( matPtr->tracing )
01101 {
01102 if ( Tcl_VarTraceInfo( matPtr->interp, matPtr->name, TCL_TRACE_UNSETS,
01103 (Tcl_VarTraceProc *) DeleteMatrixVar, NULL ) != NULL )
01104 {
01105 matPtr->tracing = 0;
01106 Tcl_UntraceVar( matPtr->interp, matPtr->name, TCL_TRACE_UNSETS,
01107 (Tcl_VarTraceProc *) DeleteMatrixVar, (ClientData) matPtr );
01108 Tcl_UnsetVar( matPtr->interp, matPtr->name, 0 );
01109 }
01110 }
01111
01112
01113
01114 if ( matPtr->name != NULL )
01115 {
01116 free( (void *) matPtr->name );
01117 matPtr->name = NULL;
01118 }
01119
01120
01121
01122 if ( !matPtr->tracing )
01123 free( (void *) matPtr );
01124 #ifdef DEBUG
01125 else
01126 fprintf( stderr, "OOPS! You just lost %d bytes\n", sizeof ( tclMatrix ) );
01127 #endif
01128 }