• Main Page
  • Namespaces
  • Classes
  • Files
  • File List
  • File Members

tclMatrix.c

Go to the documentation of this file.
00001 // $Id: tclMatrix.c 11760 2011-06-01 19:29:11Z airwin $
00002 //
00003 //  Copyright 1994, 1995
00004 //  Maurice LeBrun                      mjl@dino.ph.utexas.edu
00005 //  Institute for Fusion Studies        University of Texas at Austin
00006 //
00007 //  Copyright (C) 2004  Joao Cardoso
00008 //
00009 //  This file is part of PLplot.
00010 //
00011 //  PLplot is free software; you can redistribute it and/or modify
00012 //  it under the terms of the GNU Library General Public License as published
00013 //  by the Free Software Foundation; either version 2 of the License, or
00014 //  (at your option) any later version.
00015 //
00016 //  PLplot is distributed in the hope that it will be useful,
00017 //  but WITHOUT ANY WARRANTY; without even the implied warranty of
00018 //  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
00019 //  GNU Library General Public License for more details.
00020 //
00021 //  You should have received a copy of the GNU Library General Public License
00022 //  along with PLplot; if not, write to the Free Software
00023 //  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
00024 //
00025 //--------------------------------------------------------------------------
00026 //
00027 //  This file contains routines that implement Tcl matrices.
00028 //  These are operators that are used to store, return, and modify
00029 //  numeric data stored in binary array format.  The emphasis is
00030 //  on high performance and low overhead, something that Tcl lists
00031 //  or associative arrays aren't so good at.
00032 //
00033 
00034 //
00035 // #define DEBUG
00036 //
00037 
00038 #include <stdio.h>
00039 #include <stdlib.h>
00040 #include <string.h>
00041 #include "pldll.h"
00042 #include "tclMatrix.h"
00043 
00044 // Cool math macros
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 // For the truly desperate debugging task
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 // Internal data
00064 
00065 static int           matTable_initted = 0; // Hash table initialization flag
00066 static Tcl_HashTable matTable;             // Hash table for external access to data
00067 
00068 // Function prototypes
00069 
00070 // Handles matrix initialization lists
00071 
00072 static int
00073 matrixInitialize( Tcl_Interp* interp, tclMatrix* m,
00074                   int dim, int offs, int nargs, const char** args );
00075 
00076 // Invoked to process the "matrix" Tcl command.
00077 
00078 static int
00079 MatrixCmd( ClientData clientData, Tcl_Interp *interp, int argc, const char **argv );
00080 
00081 // Causes matrix command to be deleted.
00082 
00083 static char *
00084 DeleteMatrixVar( ClientData clientData,
00085                  Tcl_Interp *interp, char *name1, char *name2, int flags );
00086 
00087 // Releases all the resources allocated to the matrix command.
00088 
00089 static void
00090 DeleteMatrixCmd( ClientData clientData );
00091 
00092 // These do the put/get operations for each supported type
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 // Tcl_MatCmd --
00109 //
00110 //      Invoked to process the "matrix" Tcl command.  Creates a multiply
00111 //      dimensioned array (matrix) of floats or ints.  The number of
00112 //      arguments determines the dimensionality.
00113 //
00114 // Results:
00115 //      Returns the name of the new matrix.
00116 //
00117 // Side effects:
00118 //      A new matrix (operator) gets created.
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 // Create hash table on first call
00142 
00143     if ( !matTable_initted )
00144     {
00145         matTable_initted = 1;
00146         Tcl_InitHashTable( &matTable, TCL_STRING_KEYS );
00147     }
00148 
00149 // Check for -persist flag
00150 
00151     for ( i = 1; i < argc; i++ )
00152     {
00153         c      = argv[i][0];
00154         length = strlen( argv[i] );
00155 
00156         // If found, set persist variable and compress argv-list
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 // Create matrix data structure
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 // Create name
00181 // It should be unique
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 // Initialize type
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 // Initialize dimensions
00234 
00235     argc--; argv++;
00236     for (; argc > 0; argc--, argv++ )
00237     {
00238         // Check for initializer
00239 
00240         if ( strcmp( argv[0], "=" ) == 0 )
00241         {
00242             argc--; argv++;
00243             initializer = 1;
00244             break;
00245         }
00246 
00247         // Must be a dimensional parameter.  Increment number of dimensions.
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         // Check to see if dimension is valid and store
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 // Allocate space for data
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 // Process the initializer, if present
00303 
00304     if ( initializer )
00305         matrixInitialize( interp, matPtr, 0, 0, 1, &argv[0] );
00306 
00307 // Delete matrix when it goes out of scope unless -persist specified
00308 // Use local variable of same name as matrix and trace it for unsets
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 // Create matrix operator
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 // Store pointer to interpreter to handle bizarre uses of multiple
00334 // interpreters (e.g. as in [incr Tcl])
00335 
00336     matPtr->interp = interp;
00337 
00338 // Create hash table entry for this matrix operator's data
00339 // This should never fail
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 // Tcl_GetMatrixPtr --
00358 //
00359 //      Returns a pointer to the specified matrix operator's data.
00360 //
00361 // Results:
00362 //      None.
00363 //
00364 // Side effects:
00365 //      None.
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 //  Tcl_MatrixInstallXtnsn --
00394 //
00395 //      Install a tclMatrix extension subcommand.
00396 //
00397 // Results:
00398 //      Should be 1.  Have to think about error results.
00399 //
00400 // Side effects:
00401 //      Enables you to install special purpose compiled code to handle
00402 //      custom operations on a tclMatrix.
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 // My goodness how I hate primitive/pathetic C.  With C++ this
00414 // could've been as easy as:
00415 //     List<TclMatrixXtnsnDescr> xtnlist;
00416 //     xtnlist.append( tclMatrixXtnsnDescr(cmd,proc) );
00417 // grrrrr.
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 // matrixInitialize --
00449 //
00450 //      Handles matrix initialization lists.
00451 //      Written by Martin L. Smith.
00452 //
00453 // Results:
00454 //      None.
00455 //
00456 // Side effects:
00457 //      None.
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             // Must use Tcl_Free since allocated by Tcl
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 // MatrixCmd --
00510 //
00511 //      When a Tcl matrix command is invoked, this routine is called.
00512 //
00513 // Results:
00514 //      A standard Tcl result value, usually TCL_OK.
00515 //      On matrix get commands, one or a number of matrix elements are
00516 //      printed.
00517 //
00518 // Side effects:
00519 //      Depends on the matrix command.
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 // Initialize
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 // First check for a matrix command
00550 
00551     argc--; argv++;
00552     c      = argv[0][0];
00553     length = strlen( argv[0] );
00554 
00555 // dump -- send a nicely formatted listing of the array contents to stdout
00556 // (very helpful for debugging)
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 // delete -- delete the array
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 // filter
00591 // Only works on 1d matrices
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             // Set up temporary filtering array.  Use even boundary conditions.
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             // Apply 3-point binomial filter
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 // help
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 // info
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             // Must avoid trailing space.
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 // max
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             //sprintf(tmp, "%.17g", max);
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 // min
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             //sprintf(tmp, "%.17g", min);
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 // redim
00749 // Only works on 1d matrices
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 // scale
00805 // Only works on 1d matrices
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 // Not a "standard" command, check the extension commands.
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 // Must be a put or get.  Get array indices.
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 // If there is an "=" after indicies, it's a put.  Do error checking.
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 // Do the get/put.
00918 // The loop over all elements takes care of the multi-element cases.
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 // Routines to handle Matrix get/put dependent on type:
00946 //
00947 // MatrixPut_f  MatrixGet_f
00948 // MatrixPut_i  MatrixGet_i
00949 //
00950 // A "put" converts from string format to the intrinsic type, storing into
00951 // the array.
00952 //
00953 // A "get" converts from the intrinsic type to string format, storing into
00954 // a string buffer.
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     //sprintf(string, "%.17g", value);
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 // DeleteMatrixVar --
01000 //
01001 //      Causes matrix command to be deleted.  Invoked when variable
01002 //      associated with matrix command is unset.
01003 //
01004 // Results:
01005 //      None.
01006 //
01007 // Side effects:
01008 //      See DeleteMatrixCmd.
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 // DeleteMatrixCmd --
01048 //
01049 //      Releases all the resources allocated to the matrix command.
01050 //      Invoked just before a matrix command is removed from an interpreter.
01051 //
01052 //      Note: If the matrix has tracing enabled, it means the user
01053 //      explicitly deleted a non-persistent matrix.  Not a good idea,
01054 //      because eventually the local variable that was being traced will
01055 //      become unset and the matrix data will be referenced in
01056 //      DeleteMatrixVar.  So I've massaged this so that at worst it only
01057 //      causes a minor memory leak instead of imminent program death.
01058 //
01059 // Results:
01060 //      None.
01061 //
01062 // Side effects:
01063 //      All memory associated with the matrix operator is freed (usually).
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 // Remove hash table entry
01080 
01081     hPtr = Tcl_FindHashEntry( &matTable, matPtr->name );
01082     if ( hPtr != NULL )
01083         Tcl_DeleteHashEntry( hPtr );
01084 
01085 // Free data
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 // Attempt to turn off tracing if possible.
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 // Free name.
01113 
01114     if ( matPtr->name != NULL )
01115     {
01116         free( (void *) matPtr->name );
01117         matPtr->name = NULL;
01118     }
01119 
01120 // Free tclMatrix
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 }

Generated on Wed Oct 12 2011 20:42:23 for PLplot by  doxygen 1.7.1