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