PLplot: tclMatrix.c Source File

PLplot 5.10.0

- Main Page
- Namespaces
- Classes
- Files

- File List
- File Members

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
406 static tclMatrixXtnsnDescr *head = (tclMatrixXtnsnDescr *) NULL;
407 static tclMatrixXtnsnDescr *tail = (tclMatrixXtnsnDescr *) NULL;
408
409 int
410 Tcl_MatrixInstallXtnsn( const char *cmd, tclMatrixXtnsnProc proc )
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 {
860 tclMatrixXtnsnDescr *p = head;
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 }