PLplot  5.10.0
tclMatrix.c
Go to the documentation of this file.
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 }
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Defines