PLplot  5.10.0
 All Classes Namespaces Files Functions Variables Typedefs Enumerations Enumerator Macros
tclMatrix.c
Go to the documentation of this file.
1 // Copyright 1994, 1995
2 // Maurice LeBrun mjl@dino.ph.utexas.edu
3 // Institute for Fusion Studies University of Texas at Austin
4 //
5 // Copyright (C) 2004 Joao Cardoso
6 //
7 // This file is part of PLplot.
8 //
9 // PLplot is free software; you can redistribute it and/or modify
10 // it under the terms of the GNU Library General Public License as published
11 // by the Free Software Foundation; either version 2 of the License, or
12 // (at your option) any later version.
13 //
14 // PLplot is distributed in the hope that it will be useful,
15 // but WITHOUT ANY WARRANTY; without even the implied warranty of
16 // MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 // GNU Library General Public License for more details.
18 //
19 // You should have received a copy of the GNU Library General Public License
20 // along with PLplot; if not, write to the Free Software
21 // Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
22 //
23 //--------------------------------------------------------------------------
24 //
25 // This file contains routines that implement Tcl matrices.
26 // These are operators that are used to store, return, and modify
27 // numeric data stored in binary array format. The emphasis is
28 // on high performance and low overhead, something that Tcl lists
29 // or associative arrays aren't so good at.
30 //
31 
32 //
33 // #define DEBUG
34 //
35 
36 #include <stdio.h>
37 #include <stdlib.h>
38 #include <string.h>
39 #include "pldll.h"
40 #include "tclMatrix.h"
41 
42 // Cool math macros
43 
44 #ifndef MAX
45 #define MAX( a, b ) ( ( ( a ) > ( b ) ) ? ( a ) : ( b ) )
46 #endif
47 #ifndef MIN
48 #define MIN( a, b ) ( ( ( a ) < ( b ) ) ? ( a ) : ( b ) )
49 #endif
50 
51 // For the truly desperate debugging task
52 
53 #ifdef DEBUG_ENTER
54 #define dbug_enter( a ) \
55  fprintf( stderr, "%s: Entered %s\n", __FILE__, a );
56 
57 #else
58 #define dbug_enter( a )
59 #endif
60 
61 // Internal data
62 
63 static int matTable_initted = 0; // Hash table initialization flag
64 static Tcl_HashTable matTable; // Hash table for external access to data
65 
66 // Function prototypes
67 
68 // Handles matrix initialization lists
69 
70 static int
71 matrixInitialize( Tcl_Interp* interp, tclMatrix* m,
72  int dim, int offs, int nargs, const char** args );
73 
74 // Invoked to process the "matrix" Tcl command.
75 
76 static int
77 MatrixCmd( ClientData clientData, Tcl_Interp *interp, int argc, const char **argv );
78 
79 // Causes matrix command to be deleted.
80 
81 static char *
82 DeleteMatrixVar( ClientData clientData,
83  Tcl_Interp *interp, char *name1, char *name2, int flags );
84 
85 // Releases all the resources allocated to the matrix command.
86 
87 static void
88 DeleteMatrixCmd( ClientData clientData );
89 
90 // These do the put/get operations for each supported type
91 
92 static void
93 MatrixPut_f( ClientData clientData, Tcl_Interp* interp, int index, const char *string );
94 
95 static void
96 MatrixGet_f( ClientData clientData, Tcl_Interp* interp, int index, char *string );
97 
98 static void
99 MatrixPut_i( ClientData clientData, Tcl_Interp* interp, int index, const char *string );
100 
101 static void
102 MatrixGet_i( ClientData clientData, Tcl_Interp* interp, int index, char *string );
103 
104 //--------------------------------------------------------------------------
105 //
106 // Tcl_MatCmd --
107 //
108 // Invoked to process the "matrix" Tcl command. Creates a multiply
109 // dimensioned array (matrix) of floats or ints. The number of
110 // arguments determines the dimensionality.
111 //
112 // Results:
113 // Returns the name of the new matrix.
114 //
115 // Side effects:
116 // A new matrix (operator) gets created.
117 //
118 //--------------------------------------------------------------------------
119 
120 int
121 Tcl_MatrixCmd( ClientData PL_UNUSED( clientData ), Tcl_Interp *interp,
122  int argc, const char **argv )
123 {
124  register tclMatrix *matPtr;
125  int i, j, length, new, index, persist = 0, initializer = 0;
126  Tcl_HashEntry *hPtr;
127  Tcl_CmdInfo infoPtr;
128  char c;
129 
130  dbug_enter( "Tcl_MatrixCmd" );
131 
132  if ( argc < 3 )
133  {
134  Tcl_AppendResult( interp, "wrong # args: should be \"", argv[0],
135  " ?-persist? var type dim1 ?dim2? ?dim3? ...\"", (char *) NULL );
136  return TCL_ERROR;
137  }
138 
139 // Create hash table on first call
140 
141  if ( !matTable_initted )
142  {
143  matTable_initted = 1;
144  Tcl_InitHashTable( &matTable, TCL_STRING_KEYS );
145  }
146 
147 // Check for -persist flag
148 
149  for ( i = 1; i < argc; i++ )
150  {
151  c = argv[i][0];
152  length = (int) strlen( argv[i] );
153 
154  // If found, set persist variable and compress argv-list
155 
156  if ( ( c == '-' ) && ( strncmp( argv[i], "-persist", (size_t) length ) == 0 ) )
157  {
158  persist = 1;
159  argc--;
160  for ( j = i; j < argc; j++ )
161  argv[j] = argv[j + 1];
162  break;
163  }
164  }
165 
166 // Create matrix data structure
167 
168  matPtr = (tclMatrix *) malloc( sizeof ( tclMatrix ) );
169  matPtr->fdata = NULL;
170  matPtr->idata = NULL;
171  matPtr->name = NULL;
172  matPtr->dim = 0;
173  matPtr->len = 1;
174  matPtr->tracing = 0;
175  for ( i = 0; i < MAX_ARRAY_DIM; i++ )
176  matPtr->n[i] = 1;
177 
178 // Create name
179 // It should be unique
180 
181  argc--; argv++;
182 
183  if ( Tcl_GetCommandInfo( interp, argv[0], &infoPtr ) )
184  {
185  Tcl_AppendResult( interp, "Matrix operator \"", argv[0],
186  "\" already in use", (char *) NULL );
187  free( (void *) matPtr );
188  return TCL_ERROR;
189  }
190 
191  if ( Tcl_GetVar( interp, argv[0], 0 ) != NULL )
192  {
193  Tcl_AppendResult( interp, "Illegal name for Matrix operator \"",
194  argv[0], "\": local variable of same name is active",
195  (char *) NULL );
196  free( (void *) matPtr );
197  return TCL_ERROR;
198  }
199 
200  matPtr->name = (char *) malloc( strlen( argv[0] ) + 1 );
201  strcpy( matPtr->name, argv[0] );
202 
203 // Initialize type
204 
205  argc--; argv++;
206  c = argv[0][0];
207  length = (int) strlen( argv[0] );
208 
209  if ( ( c == 'f' ) && ( strncmp( argv[0], "float", (size_t) length ) == 0 ) )
210  {
211  matPtr->type = TYPE_FLOAT;
212  matPtr->put = MatrixPut_f;
213  matPtr->get = MatrixGet_f;
214  }
215  else if ( ( c == 'i' ) && ( strncmp( argv[0], "int", (size_t) length ) == 0 ) )
216  {
217  matPtr->type = TYPE_INT;
218  matPtr->put = MatrixPut_i;
219  matPtr->get = MatrixGet_i;
220  }
221  else
222  {
223  Tcl_AppendResult( interp, "Matrix type \"", argv[0],
224  "\" not supported, should be \"float\" or \"int\"",
225  (char *) NULL );
226 
227  DeleteMatrixCmd( (ClientData) matPtr );
228  return TCL_ERROR;
229  }
230 
231 // Initialize dimensions
232 
233  argc--; argv++;
234  for (; argc > 0; argc--, argv++ )
235  {
236  // Check for initializer
237 
238  if ( strcmp( argv[0], "=" ) == 0 )
239  {
240  argc--; argv++;
241  initializer = 1;
242  break;
243  }
244 
245  // Must be a dimensional parameter. Increment number of dimensions.
246 
247  matPtr->dim++;
248  if ( matPtr->dim > MAX_ARRAY_DIM )
249  {
250  Tcl_AppendResult( interp,
251  "too many dimensions specified for Matrix operator \"",
252  matPtr->name, "\"", (char *) NULL );
253 
254  DeleteMatrixCmd( (ClientData) matPtr );
255  return TCL_ERROR;
256  }
257 
258  // Check to see if dimension is valid and store
259 
260  index = matPtr->dim - 1;
261  matPtr->n[index] = atoi( argv[0] );
262  if ( matPtr->n[index] < 1 )
263  {
264  Tcl_AppendResult( interp, "invalid matrix dimension \"", argv[0],
265  "\" for Matrix operator \"", matPtr->name, "\"",
266  (char *) NULL );
267 
268  DeleteMatrixCmd( (ClientData) matPtr );
269  return TCL_ERROR;
270  }
271  matPtr->len *= matPtr->n[index];
272  }
273 
274  if ( matPtr->dim < 1 )
275  {
276  Tcl_AppendResult( interp,
277  "insufficient dimensions given for Matrix operator \"",
278  matPtr->name, "\"", (char *) NULL );
279  DeleteMatrixCmd( (ClientData) matPtr );
280  return TCL_ERROR;
281  }
282 
283 // Allocate space for data
284 
285  switch ( matPtr->type )
286  {
287  case TYPE_FLOAT:
288  matPtr->fdata = (Mat_float *) malloc( (size_t) ( matPtr->len ) * sizeof ( Mat_float ) );
289  for ( i = 0; i < matPtr->len; i++ )
290  matPtr->fdata[i] = 0.0;
291  break;
292 
293  case TYPE_INT:
294  matPtr->idata = (Mat_int *) malloc( (size_t) ( matPtr->len ) * sizeof ( Mat_int ) );
295  for ( i = 0; i < matPtr->len; i++ )
296  matPtr->idata[i] = 0;
297  break;
298  }
299 
300 // Process the initializer, if present
301 
302  if ( initializer )
303  matrixInitialize( interp, matPtr, 0, 0, 1, &argv[0] );
304 
305 // Delete matrix when it goes out of scope unless -persist specified
306 // Use local variable of same name as matrix and trace it for unsets
307 
308  if ( !persist )
309  {
310  if ( Tcl_SetVar( interp, matPtr->name,
311  "old_bogus_syntax_please_upgrade", 0 ) == NULL )
312  {
313  Tcl_AppendResult( interp, "unable to schedule Matrix operator \"",
314  matPtr->name, "\" for automatic deletion", (char *) NULL );
315  DeleteMatrixCmd( (ClientData) matPtr );
316  return TCL_ERROR;
317  }
318  matPtr->tracing = 1;
319  Tcl_TraceVar( interp, matPtr->name, TCL_TRACE_UNSETS,
320  (Tcl_VarTraceProc *) DeleteMatrixVar, (ClientData) matPtr );
321  }
322 
323 // Create matrix operator
324 
325 #ifdef DEBUG
326  fprintf( stderr, "Creating Matrix operator of name %s\n", matPtr->name );
327 #endif
328  Tcl_CreateCommand( interp, matPtr->name, (Tcl_CmdProc *) MatrixCmd,
329  (ClientData) matPtr, (Tcl_CmdDeleteProc *) DeleteMatrixCmd );
330 
331 // Store pointer to interpreter to handle bizarre uses of multiple
332 // interpreters (e.g. as in [incr Tcl])
333 
334  matPtr->interp = interp;
335 
336 // Create hash table entry for this matrix operator's data
337 // This should never fail
338 
339  hPtr = Tcl_CreateHashEntry( &matTable, matPtr->name, &new );
340  if ( !new )
341  {
342  Tcl_AppendResult( interp,
343  "Unable to create hash table entry for Matrix operator \"",
344  matPtr->name, "\"", (char *) NULL );
345  return TCL_ERROR;
346  }
347  Tcl_SetHashValue( hPtr, matPtr );
348 
349  Tcl_SetResult( interp, matPtr->name, TCL_VOLATILE );
350  return TCL_OK;
351 }
352 
353 //--------------------------------------------------------------------------
354 //
355 // Tcl_GetMatrixPtr --
356 //
357 // Returns a pointer to the specified matrix operator's data.
358 //
359 // Results:
360 // None.
361 //
362 // Side effects:
363 // None.
364 //
365 //--------------------------------------------------------------------------
366 
367 tclMatrix *
368 Tcl_GetMatrixPtr( Tcl_Interp *interp, const char *matName )
369 {
370  Tcl_HashEntry *hPtr;
371 
372  dbug_enter( "Tcl_GetMatrixPtr" );
373 
374  if ( !matTable_initted )
375  {
376  return NULL;
377  }
378 
379  hPtr = Tcl_FindHashEntry( &matTable, matName );
380  if ( hPtr == NULL )
381  {
382  Tcl_AppendResult( interp, "No matrix operator named \"",
383  matName, "\"", (char *) NULL );
384  return NULL;
385  }
386  return (tclMatrix *) Tcl_GetHashValue( hPtr );
387 }
388 
389 //--------------------------------------------------------------------------
390 //
391 // Tcl_MatrixInstallXtnsn --
392 //
393 // Install a tclMatrix extension subcommand.
394 //
395 // Results:
396 // Should be 1. Have to think about error results.
397 //
398 // Side effects:
399 // Enables you to install special purpose compiled code to handle
400 // custom operations on a tclMatrix.
401 //
402 //--------------------------------------------------------------------------
403 
406 
407 int
409 {
410 //
411 // My goodness how I hate primitive/pathetic C. With C++ this
412 // could've been as easy as:
413 // List<TclMatrixXtnsnDescr> xtnlist;
414 // xtnlist.append( tclMatrixXtnsnDescr(cmd,proc) );
415 // grrrrr.
416 //
417 
418  tclMatrixXtnsnDescr *new =
419  (tclMatrixXtnsnDescr *) malloc( sizeof ( tclMatrixXtnsnDescr ) );
420 
421  dbug_enter( "Tcl_MatrixInstallXtnsn" );
422 
423 #ifdef DEBUG
424  fprintf( stderr, "Installing a tclMatrix extension -> %s\n", cmd );
425 #endif
426 
427  new->cmd = malloc( strlen( cmd ) + 1 );
428  strcpy( new->cmd, cmd );
429  new->cmdproc = proc;
430  new->next = (tclMatrixXtnsnDescr *) NULL;
431 
432  if ( !head )
433  {
434  tail = head = new;
435  return 1;
436  }
437  else
438  {
439  tail = tail->next = new;
440  return 1;
441  }
442 }
443 
444 //--------------------------------------------------------------------------
445 //
446 // matrixInitialize --
447 //
448 // Handles matrix initialization lists.
449 // Written by Martin L. Smith.
450 //
451 // Results:
452 // None.
453 //
454 // Side effects:
455 // None.
456 //
457 //--------------------------------------------------------------------------
458 
459 static int matrixInitialize( Tcl_Interp* interp, tclMatrix* m,
460  int dim, int offs, int nargs, const char** args )
461 {
462  static int verbose = 0;
463 
464  char ** newargs;
465  int numnewargs;
466  int newoffs;
467  int i;
468 
469  if ( verbose )
470  fprintf( stderr, "level %d offset %d args %d\n", dim, offs, nargs );
471 
472  if ( dim < m->dim )
473  {
474  for ( i = 0; i < nargs; i++ )
475  {
476  if ( Tcl_SplitList( interp, args[i], &numnewargs, (CONST char ***) &newargs )
477  != TCL_OK )
478  {
479  Tcl_AppendResult( interp, "bad matrix initializer list form: ",
480  args[i], (char *) NULL );
481  return TCL_ERROR;
482  }
483  if ( dim > 0 )
484  newoffs = offs * m->n[dim - 1] + i;
485  else
486  newoffs = 0;
487 
488  matrixInitialize( interp, m, dim + 1, newoffs, numnewargs, (const char **) newargs );
489  // Must use Tcl_Free since allocated by Tcl
490  Tcl_Free( (char *) newargs );
491  }
492  return TCL_OK;
493  }
494 
495  for ( i = 0; i < nargs; i++ )
496  {
497  newoffs = offs * m->n[dim - 1] + i;
498  ( m->put )( (ClientData) m, interp, newoffs, args[i] );
499  if ( verbose )
500  fprintf( stderr, "\ta[%d] = %s\n", newoffs, args[i] );
501  }
502  return TCL_OK;
503 }
504 
505 //--------------------------------------------------------------------------
506 //
507 // MatrixCmd --
508 //
509 // When a Tcl matrix command is invoked, this routine is called.
510 //
511 // Results:
512 // A standard Tcl result value, usually TCL_OK.
513 // On matrix get commands, one or a number of matrix elements are
514 // printed.
515 //
516 // Side effects:
517 // Depends on the matrix command.
518 //
519 //--------------------------------------------------------------------------
520 
521 static int
522 MatrixCmd( ClientData clientData, Tcl_Interp *interp,
523  int argc, const char **argv )
524 {
525  register tclMatrix *matPtr = (tclMatrix *) clientData;
526  int length, put = 0;
527  char c, tmp[80];
528  const char *name = argv[0];
529  int nmin[MAX_ARRAY_DIM], nmax[MAX_ARRAY_DIM];
530  int i, j, k;
531 
532 // Initialize
533 
534  if ( argc < 2 )
535  {
536  Tcl_AppendResult( interp, "wrong # args, type: \"",
537  argv[0], " help\" for more info", (char *) NULL );
538  return TCL_ERROR;
539  }
540 
541  for ( i = 0; i < MAX_ARRAY_DIM; i++ )
542  {
543  nmin[i] = 0;
544  nmax[i] = matPtr->n[i] - 1;
545  }
546 
547 // First check for a matrix command
548 
549  argc--; argv++;
550  c = argv[0][0];
551  length = (int) strlen( argv[0] );
552 
553 // dump -- send a nicely formatted listing of the array contents to stdout
554 // (very helpful for debugging)
555 
556  if ( ( c == 'd' ) && ( strncmp( argv[0], "dump", (size_t) length ) == 0 ) )
557  {
558  for ( i = nmin[0]; i <= nmax[0]; i++ )
559  {
560  for ( j = nmin[1]; j <= nmax[1]; j++ )
561  {
562  for ( k = nmin[2]; k <= nmax[2]; k++ )
563  {
564  ( *matPtr->get )( (ClientData) matPtr, interp, I3D( i, j, k ), tmp );
565  printf( "%s ", tmp );
566  }
567  if ( matPtr->dim > 2 )
568  printf( "\n" );
569  }
570  if ( matPtr->dim > 1 )
571  printf( "\n" );
572  }
573  printf( "\n" );
574  return TCL_OK;
575  }
576 
577 // delete -- delete the array
578 
579  else if ( ( c == 'd' ) && ( strncmp( argv[0], "delete", (size_t) length ) == 0 ) )
580  {
581 #ifdef DEBUG
582  fprintf( stderr, "Deleting array %s\n", name );
583 #endif
584  Tcl_DeleteCommand( interp, name );
585  return TCL_OK;
586  }
587 
588 // filter
589 // Only works on 1d matrices
590 
591  else if ( ( c == 'f' ) && ( strncmp( argv[0], "filter", (size_t) length ) == 0 ) )
592  {
593  Mat_float *tmpMat;
594  int ifilt, nfilt;
595 
596  if ( argc != 2 )
597  {
598  Tcl_AppendResult( interp, "wrong # args: should be \"",
599  name, " ", argv[0], " num-passes\"",
600  (char *) NULL );
601  return TCL_ERROR;
602  }
603 
604  if ( matPtr->dim != 1 || matPtr->type != TYPE_FLOAT )
605  {
606  Tcl_AppendResult( interp, "can only filter a 1d float matrix",
607  (char *) NULL );
608  return TCL_ERROR;
609  }
610 
611  nfilt = atoi( argv[1] );
612  tmpMat = (Mat_float *) malloc( (size_t) ( matPtr->len + 2 ) * sizeof ( Mat_float ) );
613 
614  for ( ifilt = 0; ifilt < nfilt; ifilt++ )
615  {
616  // Set up temporary filtering array. Use even boundary conditions.
617 
618  j = 0; tmpMat[j] = matPtr->fdata[0];
619  for ( i = 0; i < matPtr->len; i++ )
620  {
621  j++; tmpMat[j] = matPtr->fdata[i];
622  }
623  j++; tmpMat[j] = matPtr->fdata[matPtr->len - 1];
624 
625  // Apply 3-point binomial filter
626 
627  for ( i = 0; i < matPtr->len; i++ )
628  {
629  j = i + 1;
630  matPtr->fdata[i] = 0.25 * ( tmpMat[j - 1] + 2 * tmpMat[j] + tmpMat[j + 1] );
631  }
632  }
633 
634  free( (void *) tmpMat );
635  return TCL_OK;
636  }
637 
638 // help
639 
640  else if ( ( c == 'h' ) && ( strncmp( argv[0], "help", (size_t) length ) == 0 ) )
641  {
642  Tcl_AppendResult( interp,
643  "Available subcommands:\n\
644 dump - return the values in the matrix as a string\n\
645 delete - delete the matrix (including the matrix command)\n\
646 filter - apply a three-point averaging (with a number of passes; ome-dimensional only)\n\
647 help - this information\n\
648 info - return the dimensions\n\
649 max - return the maximum value for the entire matrix or for the first N entries\n\
650 min - return the minimum value for the entire matrix or for the first N entries\n\
651 redim - resize the matrix (for one-dimensional matrices only)\n\
652 scale - scale the values by a given factor (for one-dimensional matrices only)\n\
653 \n\
654 Set and get values:\n\
655 matrix m f 3 3 3 - define matrix command \"m\", three-dimensional, floating-point data\n\
656 m 1 2 3 - return the value of matrix element [1,2,3]\n\
657 m 1 2 3 = 2.0 - set the value of matrix element [1,2,3] to 2.0 (do not return the value)\n\
658 m * 2 3 = 2.0 - set a slice consisting of all elements with second index 2 and third index 3 to 2.0",
659  (char *) NULL );
660  return TCL_OK;
661  }
662 
663 // info
664 
665  else if ( ( c == 'i' ) && ( strncmp( argv[0], "info", (size_t) length ) == 0 ) )
666  {
667  for ( i = 0; i < matPtr->dim; i++ )
668  {
669  sprintf( tmp, "%d", matPtr->n[i] );
670  // Must avoid trailing space.
671  if ( i < matPtr->dim - 1 )
672  Tcl_AppendResult( interp, tmp, " ", (char *) NULL );
673  else
674  Tcl_AppendResult( interp, tmp, (char *) NULL );
675  }
676  return TCL_OK;
677  }
678 
679 // max
680 
681  else if ( ( c == 'm' ) && ( strncmp( argv[0], "max", (size_t) length ) == 0 ) )
682  {
683  int len;
684  if ( argc < 1 || argc > 2 )
685  {
686  Tcl_AppendResult( interp, "wrong # args: should be \"",
687  name, " ", argv[0], " ?length?\"",
688  (char *) NULL );
689  return TCL_ERROR;
690  }
691 
692  if ( argc == 2 )
693  len = atoi( argv[1] );
694  else
695  len = matPtr->len;
696 
697  switch ( matPtr->type )
698  {
699  case TYPE_FLOAT: {
700  Mat_float max = matPtr->fdata[0];
701  for ( i = 1; i < len; i++ )
702  max = MAX( max, matPtr->fdata[i] );
703  //sprintf(tmp, "%.17g", max);
704  Tcl_PrintDouble( interp, max, tmp );
705  Tcl_AppendResult( interp, tmp, (char *) NULL );
706  break;
707  }
708  case TYPE_INT: {
709  Mat_int max = matPtr->idata[0];
710  for ( i = 1; i < len; i++ )
711  max = MAX( max, matPtr->idata[i] );
712  sprintf( tmp, "%d", max );
713  Tcl_AppendResult( interp, tmp, (char *) NULL );
714  break;
715  }
716  }
717  return TCL_OK;
718  }
719 
720 // min
721 
722  else if ( ( c == 'm' ) && ( strncmp( argv[0], "min", (size_t) length ) == 0 ) )
723  {
724  int len;
725  if ( argc < 1 || argc > 2 )
726  {
727  Tcl_AppendResult( interp, "wrong # args: should be \"",
728  name, " ", argv[0], " ?length?\"",
729  (char *) NULL );
730  return TCL_ERROR;
731  }
732 
733  if ( argc == 2 )
734  len = atoi( argv[1] );
735  else
736  len = matPtr->len;
737 
738  switch ( matPtr->type )
739  {
740  case TYPE_FLOAT: {
741  Mat_float min = matPtr->fdata[0];
742  for ( i = 1; i < len; i++ )
743  min = MIN( min, matPtr->fdata[i] );
744  //sprintf(tmp, "%.17g", min);
745  Tcl_PrintDouble( interp, min, tmp );
746  Tcl_AppendResult( interp, tmp, (char *) NULL );
747  break;
748  }
749  case TYPE_INT: {
750  Mat_int min = matPtr->idata[0];
751  for ( i = 1; i < len; i++ )
752  min = MIN( min, matPtr->idata[i] );
753  sprintf( tmp, "%d", min );
754  Tcl_AppendResult( interp, tmp, (char *) NULL );
755  break;
756  }
757  }
758  return TCL_OK;
759  }
760 
761 // redim
762 // Only works on 1d matrices
763 
764  else if ( ( c == 'r' ) && ( strncmp( argv[0], "redim", (size_t) length ) == 0 ) )
765  {
766  int newlen;
767  void *data;
768 
769  if ( argc != 2 )
770  {
771  Tcl_AppendResult( interp, "wrong # args: should be \"",
772  name, " ", argv[0], " length\"",
773  (char *) NULL );
774  return TCL_ERROR;
775  }
776 
777  if ( matPtr->dim != 1 )
778  {
779  Tcl_AppendResult( interp, "can only redim a 1d matrix",
780  (char *) NULL );
781  return TCL_ERROR;
782  }
783 
784  newlen = atoi( argv[1] );
785  switch ( matPtr->type )
786  {
787  case TYPE_FLOAT:
788  data = realloc( matPtr->fdata, (size_t) newlen * sizeof ( Mat_float ) );
789  if ( data == NULL )
790  {
791  Tcl_AppendResult( interp, "redim failed!",
792  (char *) NULL );
793  return TCL_ERROR;
794  }
795  matPtr->fdata = (Mat_float *) data;
796  for ( i = matPtr->len; i < newlen; i++ )
797  matPtr->fdata[i] = 0.0;
798  break;
799 
800  case TYPE_INT:
801  data = realloc( matPtr->idata, (size_t) newlen * sizeof ( Mat_int ) );
802  if ( data == NULL )
803  {
804  Tcl_AppendResult( interp, "redim failed!",
805  (char *) NULL );
806  return TCL_ERROR;
807  }
808  matPtr->idata = (Mat_int *) data;
809  for ( i = matPtr->len; i < newlen; i++ )
810  matPtr->idata[i] = 0;
811  break;
812  }
813  matPtr->n[0] = matPtr->len = newlen;
814  return TCL_OK;
815  }
816 
817 // scale
818 // Only works on 1d matrices
819 
820  else if ( ( c == 's' ) && ( strncmp( argv[0], "scale", (size_t) length ) == 0 ) )
821  {
822  Mat_float scale;
823 
824  if ( argc != 2 )
825  {
826  Tcl_AppendResult( interp, "wrong # args: should be \"",
827  name, " ", argv[0], " scale-factor\"",
828  (char *) NULL );
829  return TCL_ERROR;
830  }
831 
832  if ( matPtr->dim != 1 )
833  {
834  Tcl_AppendResult( interp, "can only scale a 1d matrix",
835  (char *) NULL );
836  return TCL_ERROR;
837  }
838 
839  scale = atof( argv[1] );
840  switch ( matPtr->type )
841  {
842  case TYPE_FLOAT:
843  for ( i = 0; i < matPtr->len; i++ )
844  matPtr->fdata[i] *= scale;
845  break;
846 
847  case TYPE_INT:
848  for ( i = 0; i < matPtr->len; i++ )
849  matPtr->idata[i] = (Mat_int) ( (Mat_float) ( matPtr->idata[i] ) * scale );
850  break;
851  }
852  return TCL_OK;
853  }
854 
855 // Not a "standard" command, check the extension commands.
856 
857  {
859  for (; p; p = p->next )
860  {
861  if ( ( c == p->cmd[0] ) && ( strncmp( argv[0], p->cmd, (size_t) length ) == 0 ) )
862  {
863 #ifdef DEBUG
864  printf( "found a match, invoking %s\n", p->cmd );
865 #endif
866  return ( *( p->cmdproc ) )( matPtr, interp, --argc, ++argv );
867  }
868  }
869  }
870 
871 // Must be a put or get. Get array indices.
872 
873  if ( argc < matPtr->dim )
874  {
875  Tcl_AppendResult( interp, "not enough dimensions specified for \"",
876  name, (char *) NULL );
877  return TCL_ERROR;
878  }
879  for ( i = 0; i < matPtr->dim; i++ )
880  {
881  if ( strcmp( argv[0], "*" ) == 0 )
882  {
883  nmin[i] = 0;
884  nmax[i] = matPtr->n[i] - 1;
885  }
886  else
887  {
888  nmin[i] = atoi( argv[0] );
889  nmax[i] = nmin[i];
890  }
891  if ( nmin[i] < 0 || nmax[i] > matPtr->n[i] - 1 )
892  {
893  sprintf( tmp, "Array index %d out of bounds: %s; max: %d\n",
894  i, argv[0], matPtr->n[i] - 1 );
895  Tcl_AppendResult( interp, tmp, (char *) NULL );
896  return TCL_ERROR;
897  }
898  argc--; argv++;
899  }
900 
901 // If there is an "=" after indicies, it's a put. Do error checking.
902 
903  if ( argc > 0 )
904  {
905  put = 1;
906  if ( strcmp( argv[0], "=" ) == 0 )
907  {
908  argc--; argv++;
909  if ( argc == 0 )
910  {
911  Tcl_AppendResult( interp, "no value specified",
912  (char *) NULL );
913  return TCL_ERROR;
914  }
915  else if ( argc > 1 )
916  {
917  Tcl_AppendResult( interp, "extra characters after value: \"",
918  argv[1], "\"", (char *) NULL );
919  return TCL_ERROR;
920  }
921  }
922  else
923  {
924  Tcl_AppendResult( interp, "extra characters after indices: \"",
925  argv[0], "\"", (char *) NULL );
926  return TCL_ERROR;
927  }
928  }
929 
930 // Do the get/put.
931 // The loop over all elements takes care of the multi-element cases.
932 
933  for ( i = nmin[0]; i <= nmax[0]; i++ )
934  {
935  for ( j = nmin[1]; j <= nmax[1]; j++ )
936  {
937  for ( k = nmin[2]; k <= nmax[2]; k++ )
938  {
939  if ( put )
940  ( *matPtr->put )( (ClientData) matPtr, interp, I3D( i, j, k ), argv[0] );
941  else
942  {
943  ( *matPtr->get )( (ClientData) matPtr, interp, I3D( i, j, k ), tmp );
944  if ( i == nmax[0] && j == nmax[1] && k == nmax[2] )
945  Tcl_AppendResult( interp, tmp, (char *) NULL );
946  else
947  Tcl_AppendResult( interp, tmp, " ", (char *) NULL );
948  }
949  }
950  }
951  }
952 
953  return TCL_OK;
954 }
955 
956 //--------------------------------------------------------------------------
957 //
958 // Routines to handle Matrix get/put dependent on type:
959 //
960 // MatrixPut_f MatrixGet_f
961 // MatrixPut_i MatrixGet_i
962 //
963 // A "put" converts from string format to the intrinsic type, storing into
964 // the array.
965 //
966 // A "get" converts from the intrinsic type to string format, storing into
967 // a string buffer.
968 //
969 //--------------------------------------------------------------------------
970 
971 static void
972 MatrixPut_f( ClientData clientData, Tcl_Interp* PL_UNUSED( interp ), int index, const char *string )
973 {
974  tclMatrix *matPtr = (tclMatrix *) clientData;
975 
976  matPtr->fdata[index] = atof( string );
977 }
978 
979 static void
980 MatrixGet_f( ClientData clientData, Tcl_Interp* interp, int index, char *string )
981 {
982  tclMatrix *matPtr = (tclMatrix *) clientData;
983  double value = matPtr->fdata[index];
984 
985  //sprintf(string, "%.17g", value);
986  Tcl_PrintDouble( interp, value, string );
987 }
988 
989 static void
990 MatrixPut_i( ClientData clientData, Tcl_Interp* PL_UNUSED( interp ), int index, const char *string )
991 {
992  tclMatrix *matPtr = (tclMatrix *) clientData;
993 
994  if ( ( strlen( string ) > 2 ) && ( strncmp( string, "0x", 2 ) == 0 ) )
995  {
996  matPtr->idata[index] = (Mat_int) strtoul( &string[2], NULL, 16 );
997  }
998  else
999  matPtr->idata[index] = atoi( string );
1000 }
1001 
1002 static void
1003 MatrixGet_i( ClientData clientData, Tcl_Interp* PL_UNUSED( interp ), int index, char *string )
1004 {
1005  tclMatrix *matPtr = (tclMatrix *) clientData;
1006 
1007  sprintf( string, "%d", matPtr->idata[index] );
1008 }
1009 
1010 //--------------------------------------------------------------------------
1011 //
1012 // DeleteMatrixVar --
1013 //
1014 // Causes matrix command to be deleted. Invoked when variable
1015 // associated with matrix command is unset.
1016 //
1017 // Results:
1018 // None.
1019 //
1020 // Side effects:
1021 // See DeleteMatrixCmd.
1022 //
1023 //--------------------------------------------------------------------------
1024 
1025 static char *
1026 DeleteMatrixVar( ClientData clientData,
1027  Tcl_Interp * PL_UNUSED( interp ), char * PL_UNUSED( name1 ), char * PL_UNUSED( name2 ), int PL_UNUSED( flags ) )
1028 {
1029  tclMatrix *matPtr = (tclMatrix *) clientData;
1030  Tcl_CmdInfo infoPtr;
1031  char *name;
1032 
1033  dbug_enter( "DeleteMatrixVar" );
1034 
1035  if ( matPtr->tracing != 0 )
1036  {
1037  matPtr->tracing = 0;
1038  name = (char *) malloc( strlen( matPtr->name ) + 1 );
1039  strcpy( name, matPtr->name );
1040 
1041 #ifdef DEBUG
1042  if ( Tcl_GetCommandInfo( matPtr->interp, matPtr->name, &infoPtr ) )
1043  {
1044  if ( Tcl_DeleteCommand( matPtr->interp, matPtr->name ) == TCL_OK )
1045  fprintf( stderr, "Deleted command %s\n", name );
1046  else
1047  fprintf( stderr, "Unable to delete command %s\n", name );
1048  }
1049 #else
1050  if ( Tcl_GetCommandInfo( matPtr->interp, matPtr->name, &infoPtr ) )
1051  Tcl_DeleteCommand( matPtr->interp, matPtr->name );
1052 #endif
1053  free( (void *) name );
1054  }
1055  return (char *) NULL;
1056 }
1057 
1058 //--------------------------------------------------------------------------
1059 //
1060 // DeleteMatrixCmd --
1061 //
1062 // Releases all the resources allocated to the matrix command.
1063 // Invoked just before a matrix command is removed from an interpreter.
1064 //
1065 // Note: If the matrix has tracing enabled, it means the user
1066 // explicitly deleted a non-persistent matrix. Not a good idea,
1067 // because eventually the local variable that was being traced will
1068 // become unset and the matrix data will be referenced in
1069 // DeleteMatrixVar. So I've massaged this so that at worst it only
1070 // causes a minor memory leak instead of imminent program death.
1071 //
1072 // Results:
1073 // None.
1074 //
1075 // Side effects:
1076 // All memory associated with the matrix operator is freed (usually).
1077 //
1078 //--------------------------------------------------------------------------
1079 
1080 static void
1081 DeleteMatrixCmd( ClientData clientData )
1082 {
1083  tclMatrix *matPtr = (tclMatrix *) clientData;
1084  Tcl_HashEntry *hPtr;
1085 
1086  dbug_enter( "DeleteMatrixCmd" );
1087 
1088 #ifdef DEBUG
1089  fprintf( stderr, "Freeing space associated with matrix %s\n", matPtr->name );
1090 #endif
1091 
1092 // Remove hash table entry
1093 
1094  hPtr = Tcl_FindHashEntry( &matTable, matPtr->name );
1095  if ( hPtr != NULL )
1096  Tcl_DeleteHashEntry( hPtr );
1097 
1098 // Free data
1099 
1100  if ( matPtr->fdata != NULL )
1101  {
1102  free( (void *) matPtr->fdata );
1103  matPtr->fdata = NULL;
1104  }
1105  if ( matPtr->idata != NULL )
1106  {
1107  free( (void *) matPtr->idata );
1108  matPtr->idata = NULL;
1109  }
1110 
1111 // Attempt to turn off tracing if possible.
1112 
1113  if ( matPtr->tracing )
1114  {
1115  if ( Tcl_VarTraceInfo( matPtr->interp, matPtr->name, TCL_TRACE_UNSETS,
1116  (Tcl_VarTraceProc *) DeleteMatrixVar, NULL ) != NULL )
1117  {
1118  matPtr->tracing = 0;
1119  Tcl_UntraceVar( matPtr->interp, matPtr->name, TCL_TRACE_UNSETS,
1120  (Tcl_VarTraceProc *) DeleteMatrixVar, (ClientData) matPtr );
1121  Tcl_UnsetVar( matPtr->interp, matPtr->name, 0 );
1122  }
1123  }
1124 
1125 // Free name.
1126 
1127  if ( matPtr->name != NULL )
1128  {
1129  free( (void *) matPtr->name );
1130  matPtr->name = NULL;
1131  }
1132 
1133 // Free tclMatrix
1134 
1135  if ( !matPtr->tracing )
1136  free( (void *) matPtr );
1137 #ifdef DEBUG
1138  else
1139  fprintf( stderr, "OOPS! You just lost %d bytes\n", sizeof ( tclMatrix ) );
1140 #endif
1141 }