source: trunk/kitgen/8.x/blt/generic/bltVecCmd.c@ 201

Last change on this file since 201 was 175, checked in by demin, 12 years ago

initial commit

File size: 49.5 KB
Line 
1/*
2 * bltVecCmd.c --
3 *
4 * This module implements vector data objects.
5 *
6 * Copyright 1995-1998 Lucent Technologies, Inc.
7 *
8 * Permission to use, copy, modify, and distribute this software and
9 * its documentation for any purpose and without fee is hereby
10 * granted, provided that the above copyright notice appear in all
11 * copies and that both that the copyright notice and warranty
12 * disclaimer appear in supporting documentation, and that the names
13 * of Lucent Technologies any of their entities not be used in
14 * advertising or publicity pertaining to distribution of the software
15 * without specific, written prior permission.
16 *
17 * Lucent Technologies disclaims all warranties with regard to this
18 * software, including all implied warranties of merchantability and
19 * fitness. In no event shall Lucent Technologies be liable for any
20 * special, indirect or consequential damages or any damages
21 * whatsoever resulting from loss of use, data or profits, whether in
22 * an action of contract, negligence or other tortuous action, arising
23 * out of or in connection with the use or performance of this
24 * software.
25 */
26
27/*
28 * TODO:
29 * o Add H. Kirsch's vector binary read operation
30 * x binread file0
31 * x binread -file file0
32 *
33 * o Add ASCII/binary file reader
34 * x read fileName
35 *
36 * o Allow Tcl-based client notifications.
37 * vector x
38 * x notify call Display
39 * x notify delete Display
40 * x notify reorder #1 #2
41 */
42
43#include "bltVecInt.h"
44
45#if (TCL_MAJOR_VERSION == 7)
46
47static void
48GetValues(vPtr, first, last, resultPtr)
49 VectorObject *vPtr;
50 int first, last;
51 Tcl_DString *resultPtr;
52{
53 register int i;
54 char valueString[TCL_DOUBLE_SPACE + 1];
55
56 for (i = first; i <= last; i++) {
57 Tcl_PrintDouble(vPtr->interp, vPtr->valueArr[i], valueString);
58 Tcl_DStringAppendElement(resultPtr, valueString);
59 }
60}
61
62static void
63ReplicateValue(vPtr, first, last, value)
64 VectorObject *vPtr;
65 int first, last;
66 double value;
67{
68 register int i;
69 for (i = first; i <= last; i++) {
70 vPtr->valueArr[i] = value;
71 }
72 vPtr->notifyFlags |= UPDATE_RANGE;
73}
74
75static int
76CopyList(vPtr, nElem, elemArr)
77 VectorObject *vPtr;
78 int nElem;
79 char **elemArr;
80{
81 register int i;
82 double value;
83
84 if (Blt_VectorChangeLength(vPtr, nElem) != TCL_OK) {
85 return TCL_ERROR;
86 }
87 for (i = 0; i < nElem; i++) {
88 if (Tcl_GetDouble(vPtr->interp, elemArr[i], &value)!= TCL_OK) {
89 vPtr->length = i;
90 return TCL_ERROR;
91 }
92 vPtr->valueArr[i] = value;
93 }
94 return TCL_OK;
95}
96
97static int
98AppendVector(destPtr, srcPtr)
99 VectorObject *destPtr, *srcPtr;
100{
101 int nBytes;
102 int oldSize, newSize;
103
104 oldSize = destPtr->length;
105 newSize = oldSize + srcPtr->last - srcPtr->first + 1;
106 if (Blt_VectorChangeLength(destPtr, newSize) != TCL_OK) {
107 return TCL_ERROR;
108 }
109 nBytes = (newSize - oldSize) * sizeof(double);
110 memcpy((char *)(destPtr->valueArr + oldSize),
111 (srcPtr->valueArr + srcPtr->first), nBytes);
112 destPtr->notifyFlags |= UPDATE_RANGE;
113 return TCL_OK;
114}
115
116static int
117AppendList(vPtr, nElem, elemArr)
118 VectorObject *vPtr;
119 int nElem;
120 char **elemArr;
121{
122 int count;
123 register int i;
124 double value;
125 int oldSize;
126
127 oldSize = vPtr->length;
128 if (Blt_VectorChangeLength(vPtr, vPtr->length + nElem) != TCL_OK) {
129 return TCL_ERROR;
130 }
131 count = oldSize;
132 for (i = 0; i < nElem; i++) {
133 if (Tcl_ExprDouble(vPtr->interp, elemArr[i], &value)
134 != TCL_OK) {
135 vPtr->length = count;
136 return TCL_ERROR;
137 }
138 vPtr->valueArr[count++] = value;
139 }
140 vPtr->notifyFlags |= UPDATE_RANGE;
141 return TCL_OK;
142}
143
144/* Vector instance option commands */
145
146/*
147 * -----------------------------------------------------------------------
148 *
149 * AppendOp --
150 *
151 * Appends one of more Tcl lists of values, or vector objects
152 * onto the end of the current vector object.
153 *
154 * Results:
155 * A standard Tcl result. If a current vector can't be created,
156 * resized, any of the named vectors can't be found, or one of
157 * lists of values is invalid, TCL_ERROR is returned.
158 *
159 * Side Effects:
160 * Clients of current vector will be notified of the change.
161 *
162 * -----------------------------------------------------------------------
163 */
164static int
165AppendOp(vPtr, interp, argc, argv)
166 VectorObject *vPtr;
167 Tcl_Interp *interp;
168 int argc;
169 char **argv;
170{
171 register int i;
172 int result;
173 VectorObject *v2Ptr;
174
175 for (i = 2; i < argc; i++) {
176 v2Ptr = Blt_VectorParseElement((Tcl_Interp *)NULL, vPtr->dataPtr,
177 argv[i], (char **)NULL, NS_SEARCH_BOTH);
178 if (v2Ptr != NULL) {
179 result = AppendVector(vPtr, v2Ptr);
180 } else {
181 int nElem;
182 char **elemArr;
183
184 if (Tcl_SplitList(interp, argv[i], &nElem, &elemArr) != TCL_OK) {
185 return TCL_ERROR;
186 }
187 result = AppendList(vPtr, nElem, elemArr);
188 Blt_Free(elemArr);
189 }
190 if (result != TCL_OK) {
191 return TCL_ERROR;
192 }
193 }
194 if (argc > 2) {
195 if (vPtr->flush) {
196 Blt_VectorFlushCache(vPtr);
197 }
198 Blt_VectorUpdateClients(vPtr);
199 }
200 return TCL_OK;
201}
202
203/*
204 * -----------------------------------------------------------------------
205 *
206 * ClearOp --
207 *
208 * Deletes all the accumulated array indices for the Tcl array
209 * associated will the vector. This routine can be used to
210 * free excess memory from a large vector.
211 *
212 * Results:
213 * Always returns TCL_OK.
214 *
215 * Side Effects:
216 * Memory used for the entries of the Tcl array variable is freed.
217 *
218 * -----------------------------------------------------------------------
219 */
220/*ARGSUSED*/
221static int
222ClearOp(vPtr, interp, argc, argv)
223 VectorObject *vPtr;
224 Tcl_Interp *interp;
225 int argc;
226 char **argv;
227{
228 Blt_VectorFlushCache(vPtr);
229 return TCL_OK;
230}
231
232/*
233 * -----------------------------------------------------------------------
234 *
235 * DeleteOp --
236 *
237 * Deletes the given indices from the vector. If no indices are
238 * provided the entire vector is deleted.
239 *
240 * Results:
241 * A standard Tcl result. If any of the given indices is invalid,
242 * interp->result will an error message and TCL_ERROR is returned.
243 *
244 * Side Effects:
245 * The clients of the vector will be notified of the vector
246 * deletions.
247 *
248 * -----------------------------------------------------------------------
249 */
250/*ARGSUSED*/
251static int
252DeleteOp(vPtr, interp, argc, argv)
253 VectorObject *vPtr;
254 Tcl_Interp *interp;
255 int argc;
256 char **argv;
257{
258 unsigned char *unsetArr;
259 register int i, j;
260 register int count;
261
262 if (argc == 2) {
263 Blt_VectorFree(vPtr);
264 return TCL_OK;
265 }
266 /*
267 * Allocate an "unset" bitmap the size of the vector. We should
268 * try to use bit fields instead of a character array, since
269 * memory may be an issue if the vector is large.
270 */
271 unsetArr = Blt_Calloc(sizeof(unsigned char), vPtr->length);
272 assert(unsetArr);
273 for (i = 2; i < argc; i++) {
274 if (Blt_VectorGetIndexRange(interp, vPtr, argv[i],
275 (INDEX_COLON | INDEX_CHECK), (Blt_VectorIndexProc **) NULL)
276 != TCL_OK) {
277 Blt_Free(unsetArr);
278 return TCL_ERROR;
279 }
280 for (j = vPtr->first; j <= vPtr->last; j++) {
281 unsetArr[j] = TRUE;
282 }
283 }
284 count = 0;
285 for (i = 0; i < vPtr->length; i++) {
286 if (unsetArr[i]) {
287 continue;
288 }
289 if (count < i) {
290 vPtr->valueArr[count] = vPtr->valueArr[i];
291 }
292 count++;
293 }
294 Blt_Free(unsetArr);
295 vPtr->length = count;
296 if (vPtr->flush) {
297 Blt_VectorFlushCache(vPtr);
298 }
299 Blt_VectorUpdateClients(vPtr);
300 return TCL_OK;
301}
302
303/*
304 * -----------------------------------------------------------------------
305 *
306 * DupOp --
307 *
308 * Creates one or more duplicates of the vector object.
309 *
310 * Results:
311 * A standard Tcl result. If a new vector can't be created,
312 * or and existing vector resized, TCL_ERROR is returned.
313 *
314 * Side Effects:
315 * Clients of existing vectors will be notified of the change.
316 *
317 * -----------------------------------------------------------------------
318 */
319/*ARGSUSED*/
320static int
321DupOp(vPtr, interp, argc, argv)
322 VectorObject *vPtr;
323 Tcl_Interp *interp; /* Not used. */
324 int argc;
325 char **argv;
326{
327 VectorObject *v2Ptr;
328 int isNew;
329 register int i;
330
331 for (i = 2; i < argc; i++) {
332 v2Ptr = Blt_VectorCreate(vPtr->dataPtr, argv[i], argv[i], argv[i],
333 &isNew);
334 if (v2Ptr == NULL) {
335 return TCL_ERROR;
336 }
337 if (v2Ptr == vPtr) {
338 continue;
339 }
340 if (Blt_VectorDuplicate(v2Ptr, vPtr) != TCL_OK) {
341 return TCL_ERROR;
342 }
343 if (!isNew) {
344 if (v2Ptr->flush) {
345 Blt_VectorFlushCache(v2Ptr);
346 }
347 Blt_VectorUpdateClients(v2Ptr);
348 }
349 }
350 return TCL_OK;
351}
352
353/*
354 * -----------------------------------------------------------------------
355 *
356 * IndexOp --
357 *
358 * Sets or reads the value of the index. This simulates what the
359 * vector's variable does.
360 *
361 * Results:
362 * A standard Tcl result. If the index is invalid,
363 * interp->result will an error message and TCL_ERROR is returned.
364 * Otherwise interp->result will contain the values.
365 *
366 * -----------------------------------------------------------------------
367 */
368static int
369IndexOp(vPtr, interp, argc, argv)
370 VectorObject *vPtr;
371 Tcl_Interp *interp;
372 int argc;
373 char **argv;
374{
375 int first, last;
376
377 if (Blt_VectorGetIndexRange(interp, vPtr, argv[2], INDEX_ALL_FLAGS,
378 (Blt_VectorIndexProc **) NULL) != TCL_OK) {
379 return TCL_ERROR;
380 }
381 first = vPtr->first, last = vPtr->last;
382 if (argc == 3) {
383 Tcl_DString dString;
384
385 if (first == vPtr->length) {
386 Tcl_AppendResult(interp, "can't get index \"", argv[2], "\"",
387 (char *)NULL);
388 return TCL_ERROR; /* Can't read from index "++end" */
389 }
390 Tcl_DStringInit(&dString);
391 GetValues(vPtr, first, last, &dString);
392 Tcl_DStringResult(interp, &dString);
393 Tcl_DStringFree(&dString);
394 } else {
395 char string[TCL_DOUBLE_SPACE + 1];
396 double value;
397
398 if (first == SPECIAL_INDEX) {
399 Tcl_AppendResult(interp, "can't set index \"", argv[2], "\"",
400 (char *)NULL);
401 return TCL_ERROR; /* Tried to set "min" or "max" */
402 }
403 if (Tcl_ExprDouble(interp, argv[3], &value) != TCL_OK) {
404 return TCL_ERROR;
405 }
406 if (first == vPtr->length) {
407 if (Blt_VectorChangeLength(vPtr, vPtr->length + 1) != TCL_OK) {
408 return TCL_ERROR;
409 }
410 }
411 ReplicateValue(vPtr, first, last, value);
412
413 Tcl_PrintDouble(interp, value, string);
414 Tcl_SetResult(interp, string, TCL_VOLATILE);
415 if (vPtr->flush) {
416 Blt_VectorFlushCache(vPtr);
417 }
418 Blt_VectorUpdateClients(vPtr);
419 }
420 return TCL_OK;
421}
422
423/*
424 * -----------------------------------------------------------------------
425 *
426 * LengthOp --
427 *
428 * Returns the length of the vector. If a new size is given, the
429 * vector is resized to the new vector.
430 *
431 * Results:
432 * A standard Tcl result. If the new length is invalid,
433 * interp->result will an error message and TCL_ERROR is returned.
434 * Otherwise interp->result will contain the length of the vector.
435 *
436 * -----------------------------------------------------------------------
437 */
438static int
439LengthOp(vPtr, interp, argc, argv)
440 VectorObject *vPtr;
441 Tcl_Interp *interp;
442 int argc;
443 char **argv;
444{
445 if (argc == 3) {
446 int size;
447
448 if (Tcl_GetInt(interp, argv[2], &size) != TCL_OK) {
449 return TCL_ERROR;
450 }
451 if (size < 0) {
452 Tcl_AppendResult(interp, "bad vector size \"", argv[3], "\"",
453 (char *)NULL);
454 return TCL_ERROR;
455 }
456 if (Blt_VectorChangeLength(vPtr, size) != TCL_OK) {
457 return TCL_ERROR;
458 }
459 if (vPtr->flush) {
460 Blt_VectorFlushCache(vPtr);
461 }
462 Blt_VectorUpdateClients(vPtr);
463 }
464 Tcl_SetResult(interp, Blt_Itoa(vPtr->length), TCL_VOLATILE);
465 return TCL_OK;
466}
467
468/*
469 * -----------------------------------------------------------------------
470 *
471 * MapOp --
472 *
473 * Queries or sets the offset of the array index from the base
474 * address of the data array of values.
475 *
476 * Results:
477 * A standard Tcl result. If the source vector doesn't exist
478 * or the source list is not a valid list of numbers, TCL_ERROR
479 * returned. Otherwise TCL_OK is returned.
480 *
481 * -----------------------------------------------------------------------
482 */
483/*ARGSUSED*/
484static int
485MapOp(vPtr, interp, argc, argv)
486 VectorObject *vPtr;
487 Tcl_Interp *interp;
488 int argc; /* Not used. */
489 char **argv;
490{
491 if (argc > 2) {
492 if (Blt_VectorMapVariable(interp, vPtr, argv[2]) != TCL_OK) {
493 return TCL_ERROR;
494 }
495 }
496 if (vPtr->arrayName != NULL) {
497 Tcl_SetResult(interp, vPtr->arrayName, TCL_VOLATILE);
498 }
499 return TCL_OK;
500}
501
502/*
503 * -----------------------------------------------------------------------
504 *
505 * MergeOp --
506 *
507 * Merges the values from the given vectors to the current vector.
508 *
509 * Results:
510 * A standard Tcl result. If any of the given vectors differ in size,
511 * TCL_ERROR is returned. Otherwise TCL_OK is returned and the
512 * vector data will contain merged values of the given vectors.
513 *
514 * -----------------------------------------------------------------------
515 */
516/*ARGSUSED*/
517static int
518MergeOp(vPtr, interp, argc, argv)
519 VectorObject *vPtr;
520 Tcl_Interp *interp;
521 int argc;
522 char **argv;
523{
524 VectorObject *v2Ptr;
525 VectorObject **vecArr;
526 register VectorObject **vPtrPtr;
527 int refSize, length, nElem;
528 register int i;
529 double *valuePtr, *valueArr;
530
531 /* Allocate an array of vector pointers of each vector to be
532 * merged in the current vector. */
533 vecArr = Blt_Malloc(sizeof(VectorObject *) * argc);
534 assert(vecArr);
535 vPtrPtr = vecArr;
536
537 refSize = -1;
538 nElem = 0;
539 for (i = 2; i < argc; i++) {
540 if (Blt_VectorLookupName(vPtr->dataPtr, argv[i], &v2Ptr) != TCL_OK) {
541 Blt_Free(vecArr);
542 return TCL_ERROR;
543 }
544 /* Check that all the vectors are the same length */
545 length = v2Ptr->last - v2Ptr->first + 1;
546 if (refSize < 0) {
547 refSize = length;
548 } else if (length != refSize) {
549 Tcl_AppendResult(vPtr->interp, "vector \"", v2Ptr->name,
550 "\" has inconsistent length", (char *)NULL);
551 Blt_Free(vecArr);
552 return TCL_ERROR;
553 }
554 *vPtrPtr++ = v2Ptr;
555 nElem += refSize;
556 }
557 *vPtrPtr = NULL;
558 valueArr = Blt_Malloc(sizeof(double) * nElem);
559 if (valueArr == NULL) {
560 Tcl_AppendResult(vPtr->interp, "not enough memory to allocate ",
561 Blt_Itoa(nElem), " vector elements", (char *)NULL);
562 Blt_Free(vecArr);
563 return TCL_ERROR;
564 }
565 /* Merge the values from each of the vectors into the current vector */
566 valuePtr = valueArr;
567 for (i = 0; i < refSize; i++) {
568 for (vPtrPtr = vecArr; *vPtrPtr != NULL; vPtrPtr++) {
569 *valuePtr++ = (*vPtrPtr)->valueArr[i + (*vPtrPtr)->first];
570 }
571 }
572 Blt_Free(vecArr);
573 Blt_VectorReset(vPtr, valueArr, nElem, nElem, TCL_DYNAMIC);
574 return TCL_OK;
575}
576
577/*
578 * -----------------------------------------------------------------------
579 *
580 * NormalizeOp --
581 *
582 * Normalizes the vector.
583 *
584 * Results:
585 * A standard Tcl result. If the density is invalid, TCL_ERROR
586 * is returned. Otherwise TCL_OK is returned.
587 *
588 * -----------------------------------------------------------------------
589 */
590/*ARGSUSED*/
591static int
592NormalizeOp(vPtr, interp, argc, argv)
593 VectorObject *vPtr;
594 Tcl_Interp *interp;
595 int argc;
596 char **argv;
597{
598 register int i;
599 double range;
600
601 Blt_VectorUpdateRange(vPtr);
602 range = vPtr->max - vPtr->min;
603 if (argc > 2) {
604 VectorObject *v2Ptr;
605 int isNew;
606
607 v2Ptr = Blt_VectorCreate(vPtr->dataPtr, argv[2], argv[2], argv[2],
608 &isNew);
609 if (v2Ptr == NULL) {
610 return TCL_ERROR;
611 }
612 if (Blt_VectorChangeLength(v2Ptr, vPtr->length) != TCL_OK) {
613 return TCL_ERROR;
614 }
615 for (i = 0; i < vPtr->length; i++) {
616 v2Ptr->valueArr[i] = (vPtr->valueArr[i] - vPtr->min) / range;
617 }
618 Blt_VectorUpdateRange(v2Ptr);
619 if (!isNew) {
620 if (v2Ptr->flush) {
621 Blt_VectorFlushCache(v2Ptr);
622 }
623 Blt_VectorUpdateClients(v2Ptr);
624 }
625 } else {
626 double norm;
627
628 for (i = 0; i < vPtr->length; i++) {
629 norm = (vPtr->valueArr[i] - vPtr->min) / range;
630 Tcl_AppendElement(interp, Blt_Dtoa(interp, norm));
631 }
632 }
633 return TCL_OK;
634}
635
636/*
637 * -----------------------------------------------------------------------
638 *
639 * NotifyOp --
640 *
641 * Notify clients of vector.
642 *
643 * Results:
644 * A standard Tcl result. If any of the given vectors differ in size,
645 * TCL_ERROR is returned. Otherwise TCL_OK is returned and the
646 * vector data will contain merged values of the given vectors.
647 *
648 * x vector notify now
649 * x vector notify always
650 * x vector notify whenidle
651 * x vector notify update {}
652 * x vector notify delete {}
653 *
654 * -----------------------------------------------------------------------
655 */
656/*ARGSUSED*/
657static int
658NotifyOp(vPtr, interp, argc, argv)
659 VectorObject *vPtr;
660 Tcl_Interp *interp;
661 int argc;
662 char **argv;
663{
664 char c;
665 int length;
666
667 c = argv[2][0];
668 length = strlen(argv[2]);
669 if ((c == 'a') && (length > 1)
670 && (strncmp(argv[2], "always", length) == 0)) {
671 vPtr->notifyFlags &= ~NOTIFY_WHEN_MASK;
672 vPtr->notifyFlags |= NOTIFY_ALWAYS;
673 } else if ((c == 'n') && (length > 2)
674 && (strncmp(argv[2], "never", length) == 0)) {
675 vPtr->notifyFlags &= ~NOTIFY_WHEN_MASK;
676 vPtr->notifyFlags |= NOTIFY_NEVER;
677 } else if ((c == 'w') && (length > 1)
678 && (strncmp(argv[2], "whenidle", length) == 0)) {
679 vPtr->notifyFlags &= ~NOTIFY_WHEN_MASK;
680 vPtr->notifyFlags |= NOTIFY_WHENIDLE;
681 } else if ((c == 'n') && (length > 2)
682 && (strncmp(argv[2], "now", length) == 0)) {
683 /* How does this play when an update is pending? */
684 Blt_VectorNotifyClients(vPtr);
685 } else if ((c == 'c') && (length > 1)
686 && (strncmp(argv[2], "cancel", length) == 0)) {
687 if (vPtr->notifyFlags & NOTIFY_PENDING) {
688 vPtr->notifyFlags &= ~NOTIFY_PENDING;
689 Tcl_CancelIdleCall(Blt_VectorNotifyClients, vPtr);
690 }
691 } else if ((c == 'p') && (length > 1)
692 && (strncmp(argv[2], "pending", length) == 0)) {
693 Blt_SetBooleanResult(interp, (vPtr->notifyFlags & NOTIFY_PENDING));
694 } else {
695 Tcl_AppendResult(interp, "bad qualifier \"", argv[2], "\": should be \
696\"always\", \"never\", \"whenidle\", \"now\", \"cancel\", or \"pending\"",
697 (char *)NULL);
698 return TCL_ERROR;
699 }
700 return TCL_OK;
701}
702
703/*
704 * -----------------------------------------------------------------------
705 *
706 * PopulateOp --
707 *
708 * Creates or resizes a new vector based upon the density specified.
709 *
710 * Results:
711 * A standard Tcl result. If the density is invalid, TCL_ERROR
712 * is returned. Otherwise TCL_OK is returned.
713 *
714 * -----------------------------------------------------------------------
715 */
716/*ARGSUSED*/
717static int
718PopulateOp(vPtr, interp, argc, argv)
719 VectorObject *vPtr;
720 Tcl_Interp *interp;
721 int argc;
722 char **argv;
723{
724 VectorObject *v2Ptr;
725 int size, density;
726 int isNew;
727 register int i, j;
728 double slice, range;
729 register double *valuePtr;
730 int count;
731
732 v2Ptr = Blt_VectorCreate(vPtr->dataPtr, argv[2], argv[2], argv[2],
733 &isNew);
734 if (v2Ptr == NULL) {
735 return TCL_ERROR;
736 }
737 if (vPtr->length == 0) {
738 return TCL_OK; /* Source vector is empty. */
739 }
740 if (Tcl_GetInt(interp, argv[3], &density) != TCL_OK) {
741 return TCL_ERROR;
742 }
743 if (density < 1) {
744 Tcl_AppendResult(interp, "bad density \"", argv[3], "\"", (char *)NULL);
745 return TCL_ERROR;
746 }
747 size = (vPtr->length - 1) * (density + 1) + 1;
748 if (Blt_VectorChangeLength(v2Ptr, size) != TCL_OK) {
749 return TCL_ERROR;
750 }
751 count = 0;
752 valuePtr = v2Ptr->valueArr;
753 for (i = 0; i < (vPtr->length - 1); i++) {
754 range = vPtr->valueArr[i + 1] - vPtr->valueArr[i];
755 slice = range / (double)(density + 1);
756 for (j = 0; j <= density; j++) {
757 *valuePtr = vPtr->valueArr[i] + (slice * (double)j);
758 valuePtr++;
759 count++;
760 }
761 }
762 count++;
763 *valuePtr = vPtr->valueArr[i];
764 assert(count == v2Ptr->length);
765 if (!isNew) {
766 if (v2Ptr->flush) {
767 Blt_VectorFlushCache(v2Ptr);
768 }
769 Blt_VectorUpdateClients(v2Ptr);
770 }
771 return TCL_OK;
772}
773
774/*
775 * -----------------------------------------------------------------------
776 *
777 * RangeOp --
778 *
779 * Returns a Tcl list of the range of vector values specified.
780 *
781 * Results:
782 * A standard Tcl result. If the given range is invalid, TCL_ERROR
783 * is returned. Otherwise TCL_OK is returned and interp->result
784 * will contain the list of values.
785 *
786 * -----------------------------------------------------------------------
787 */
788/*ARGSUSED*/
789static int
790RangeOp(vPtr, interp, argc, argv)
791 VectorObject *vPtr;
792 Tcl_Interp *interp;
793 int argc; /* Not used. */
794 char **argv;
795{
796 int first, last;
797 register int i;
798
799 if ((Blt_VectorGetIndex(interp, vPtr, argv[2], &first, INDEX_CHECK,
800 (Blt_VectorIndexProc **) NULL) != TCL_OK) ||
801 (Blt_VectorGetIndex(interp, vPtr, argv[3], &last, INDEX_CHECK,
802 (Blt_VectorIndexProc **) NULL) != TCL_OK)) {
803 return TCL_ERROR;
804 }
805 if (first > last) {
806 /* Return the list reversed */
807 for (i = last; i <= first; i++) {
808 Tcl_AppendElement(interp, Blt_Dtoa(interp, vPtr->valueArr[i]));
809 }
810 } else {
811 for (i = first; i <= last; i++) {
812 Tcl_AppendElement(interp, Blt_Dtoa(interp, vPtr->valueArr[i]));
813 }
814 }
815 return TCL_OK;
816}
817
818/*
819 * ----------------------------------------------------------------------
820 *
821 * InRange --
822 *
823 * Determines if a value lies within a given range.
824 *
825 * The value is normalized and compared against the interval
826 * [0..1], where 0.0 is the minimum and 1.0 is the maximum.
827 * DBL_EPSILON is the smallest number that can be represented
828 * on the host machine, such that (1.0 + epsilon) != 1.0.
829 *
830 * Please note, min can't be greater than max.
831 *
832 * Results:
833 * If the value is within of the interval [min..max], 1 is
834 * returned; 0 otherwise.
835 *
836 * ----------------------------------------------------------------------
837 */
838INLINE static int
839InRange(value, min, max)
840 register double value, min, max;
841{
842 double range;
843
844 range = max - min;
845 if (range < DBL_EPSILON) {
846 return (FABS(max - value) < DBL_EPSILON);
847 } else {
848 double norm;
849
850 norm = (value - min) / range;
851 return ((norm >= -DBL_EPSILON) && ((norm - 1.0) < DBL_EPSILON));
852 }
853}
854
855enum NativeFormats {
856 FMT_UNKNOWN = -1,
857 FMT_UCHAR, FMT_CHAR,
858 FMT_USHORT, FMT_SHORT,
859 FMT_UINT, FMT_INT,
860 FMT_ULONG, FMT_LONG,
861 FMT_FLOAT, FMT_DOUBLE
862};
863
864/*
865 * -----------------------------------------------------------------------
866 *
867 * GetBinaryFormat
868 *
869 * Translates a format string into a native type. Formats may be
870 * as follows.
871 *
872 * signed i1, i2, i4, i8
873 * unsigned u1, u2, u4, u8
874 * real r4, r8, r16
875 *
876 * But there must be a corresponding native type. For example,
877 * this for reading 2-byte binary integers from an instrument and
878 * converting them to unsigned shorts or ints.
879 *
880 * -----------------------------------------------------------------------
881 */
882static enum NativeFormats
883GetBinaryFormat(interp, string, sizePtr)
884 Tcl_Interp *interp;
885 char *string;
886 int *sizePtr;
887{
888 char c;
889
890 c = tolower(string[0]);
891 if (Tcl_GetInt(interp, string + 1, sizePtr) != TCL_OK) {
892 Tcl_AppendResult(interp, "unknown binary format \"", string,
893 "\": incorrect byte size", (char *)NULL);
894 return TCL_ERROR;
895 }
896 switch (c) {
897 case 'r':
898 if (*sizePtr == sizeof(double)) {
899 return FMT_DOUBLE;
900 } else if (*sizePtr == sizeof(float)) {
901 return FMT_FLOAT;
902 }
903 break;
904
905 case 'i':
906 if (*sizePtr == sizeof(char)) {
907 return FMT_CHAR;
908 } else if (*sizePtr == sizeof(int)) {
909 return FMT_INT;
910 } else if (*sizePtr == sizeof(long)) {
911 return FMT_LONG;
912 } else if (*sizePtr == sizeof(short)) {
913 return FMT_SHORT;
914 }
915 break;
916
917 case 'u':
918 if (*sizePtr == sizeof(unsigned char)) {
919 return FMT_UCHAR;
920 } else if (*sizePtr == sizeof(unsigned int)) {
921 return FMT_UINT;
922 } else if (*sizePtr == sizeof(unsigned long)) {
923 return FMT_ULONG;
924 } else if (*sizePtr == sizeof(unsigned short)) {
925 return FMT_USHORT;
926 }
927 break;
928
929 default:
930 Tcl_AppendResult(interp, "unknown binary format \"", string,
931 "\": should be either i#, r#, u# (where # is size in bytes)",
932 (char *)NULL);
933 return FMT_UNKNOWN;
934 }
935 Tcl_AppendResult(interp, "can't handle format \"", string, "\"",
936 (char *)NULL);
937 return FMT_UNKNOWN;
938}
939
940static int
941CopyValues(vPtr, byteArr, fmt, size, length, swap, indexPtr)
942 VectorObject *vPtr;
943 char *byteArr;
944 enum NativeFormats fmt;
945 int size;
946 int length;
947 int swap;
948 int *indexPtr;
949{
950 register int i, n;
951 int newSize;
952
953 if ((swap) && (size > 1)) {
954 int nBytes = size * length;
955 register unsigned char *p;
956 register int left, right;
957
958 for (i = 0; i < nBytes; i += size) {
959 p = (unsigned char *)(byteArr + i);
960 for (left = 0, right = size - 1; left < right; left++, right--) {
961 p[left] ^= p[right];
962 p[right] ^= p[left];
963 p[left] ^= p[right];
964 }
965
966 }
967 }
968 newSize = *indexPtr + length;
969 if (newSize > vPtr->length) {
970 if (Blt_VectorChangeLength(vPtr, newSize) != TCL_OK) {
971 return TCL_ERROR;
972 }
973 }
974#define CopyArrayToVector(vPtr, arr) \
975 for (i = 0, n = *indexPtr; i < length; i++, n++) { \
976 (vPtr)->valueArr[n] = (double)(arr)[i]; \
977 }
978
979 switch (fmt) {
980 case FMT_CHAR:
981 CopyArrayToVector(vPtr, (char *)byteArr);
982 break;
983
984 case FMT_UCHAR:
985 CopyArrayToVector(vPtr, (unsigned char *)byteArr);
986 break;
987
988 case FMT_INT:
989 CopyArrayToVector(vPtr, (int *)byteArr);
990 break;
991
992 case FMT_UINT:
993 CopyArrayToVector(vPtr, (unsigned int *)byteArr);
994 break;
995
996 case FMT_LONG:
997 CopyArrayToVector(vPtr, (long *)byteArr);
998 break;
999
1000 case FMT_ULONG:
1001 CopyArrayToVector(vPtr, (unsigned long *)byteArr);
1002 break;
1003
1004 case FMT_SHORT:
1005 CopyArrayToVector(vPtr, (short int *)byteArr);
1006 break;
1007
1008 case FMT_USHORT:
1009 CopyArrayToVector(vPtr, (unsigned short int *)byteArr);
1010 break;
1011
1012 case FMT_FLOAT:
1013 CopyArrayToVector(vPtr, (float *)byteArr);
1014 break;
1015
1016 case FMT_DOUBLE:
1017 CopyArrayToVector(vPtr, (double *)byteArr);
1018 break;
1019
1020 case FMT_UNKNOWN:
1021 break;
1022 }
1023 *indexPtr += length;
1024 return TCL_OK;
1025}
1026
1027/*
1028 * -----------------------------------------------------------------------
1029 *
1030 * BinreadOp --
1031 *
1032 * Reads binary values from a Tcl channel. Values are either appended
1033 * to the end of the vector or placed at a given index (using the
1034 * "-at" option), overwriting existing values. Data is read until EOF
1035 * is found on the channel or a specified number of values are read.
1036 * (note that this is not necessarily the same as the number of bytes).
1037 *
1038 * The following flags are supported:
1039 * -swap Swap bytes
1040 * -at index Start writing data at the index.
1041 * -format fmt Specifies the format of the data.
1042 *
1043 * This binary reader was created by Harald Kirsch (kir@iitb.fhg.de).
1044 *
1045 * Results:
1046 * Returns a standard Tcl result. The interpreter result will contain
1047 * the number of values (not the number of bytes) read.
1048 *
1049 * Caveats:
1050 * Channel reads must end on an element boundary.
1051 *
1052 * -----------------------------------------------------------------------
1053 */
1054/*ARGSUSED*/
1055static int
1056BinreadOp(vPtr, interp, argc, argv)
1057 VectorObject *vPtr;
1058 Tcl_Interp *interp;
1059 int argc;
1060 char **argv;
1061{
1062 char *byteArr;
1063 enum NativeFormats fmt;
1064 int size, length, mode;
1065 Tcl_Channel channel;
1066 int arraySize, bytesRead;
1067 int count, total;
1068 int first;
1069 int swap;
1070 register int i;
1071
1072 channel = Tcl_GetChannel(interp, argv[2], &mode);
1073 if (channel == NULL) {
1074 return TCL_ERROR;
1075 }
1076 if ((mode & TCL_READABLE) == 0) {
1077 Tcl_AppendResult(interp, "channel \"", argv[2],
1078 "\" wasn't opened for reading", (char *)NULL);
1079 return TCL_ERROR;
1080 }
1081 first = vPtr->length;
1082 fmt = FMT_DOUBLE;
1083 size = sizeof(double);
1084 swap = FALSE;
1085 count = 0;
1086
1087 if ((argc > 3) && (argv[3][0] != '-')) {
1088 long int value;
1089 /* Get the number of values to read. */
1090 if (Tcl_ExprLong(interp, argv[3], &value) != TCL_OK) {
1091 return TCL_ERROR;
1092 }
1093 if (value < 0) {
1094 Tcl_AppendResult(interp, "count can't be negative", (char *)NULL);
1095 return TCL_ERROR;
1096 }
1097 count = (int)value;
1098 argc--, argv++;
1099 }
1100 /* Process any option-value pairs that remain. */
1101 for (i = 3; i < argc; i++) {
1102 if (strcmp(argv[i], "-swap") == 0) {
1103 swap = TRUE;
1104 } else if (strcmp(argv[i], "-format") == 0) {
1105 i += 1;
1106 if (i >= argc) {
1107 Tcl_AppendResult(interp, "missing arg after \"", argv[i - 1],
1108 "\"", (char *)NULL);
1109 return TCL_ERROR;
1110 }
1111 fmt = GetBinaryFormat(interp, argv[i], &size);
1112 if (fmt == FMT_UNKNOWN) {
1113 return TCL_ERROR;
1114 }
1115 } else if (strcmp(argv[i], "-at") == 0) {
1116 i += 1;
1117 if (i >= argc) {
1118 Tcl_AppendResult(interp, "missing arg after \"", argv[i - 1],
1119 "\"", (char *)NULL);
1120 return TCL_ERROR;
1121 }
1122 if (Blt_VectorGetIndex(interp, vPtr, argv[i], &first, 0,
1123 (Blt_VectorIndexProc **)NULL) != TCL_OK) {
1124 return TCL_ERROR;
1125 }
1126 if (first > vPtr->length) {
1127 Tcl_AppendResult(interp, "index \"", argv[i],
1128 "\" is out of range", (char *)NULL);
1129 return TCL_ERROR;
1130 }
1131 }
1132 }
1133
1134#define BUFFER_SIZE 1024
1135 if (count == 0) {
1136 arraySize = BUFFER_SIZE * size;
1137 } else {
1138 arraySize = count * size;
1139 }
1140
1141 byteArr = Blt_Malloc(arraySize);
1142 assert(byteArr);
1143
1144 /* FIXME: restore old channel translation later? */
1145 if (Tcl_SetChannelOption(interp, channel, "-translation",
1146 "binary") != TCL_OK) {
1147 return TCL_ERROR;
1148 }
1149 total = 0;
1150 while (!Tcl_Eof(channel)) {
1151 bytesRead = Tcl_Read(channel, byteArr, arraySize);
1152 if (bytesRead < 0) {
1153 Tcl_AppendResult(interp, "error reading channel: ",
1154 Tcl_PosixError(interp), (char *)NULL);
1155 return TCL_ERROR;
1156 }
1157 if ((bytesRead % size) != 0) {
1158 Tcl_AppendResult(interp, "error reading channel: short read",
1159 (char *)NULL);
1160 return TCL_ERROR;
1161 }
1162 length = bytesRead / size;
1163 if (CopyValues(vPtr, byteArr, fmt, size, length, swap, &first)
1164 != TCL_OK) {
1165 return TCL_ERROR;
1166 }
1167 total += length;
1168 if (count > 0) {
1169 break;
1170 }
1171 }
1172 Blt_Free(byteArr);
1173
1174 if (vPtr->flush) {
1175 Blt_VectorFlushCache(vPtr);
1176 }
1177 Blt_VectorUpdateClients(vPtr);
1178
1179 /* Set the result as the number of values read. */
1180 Tcl_SetResult(interp, Blt_Itoa(total), TCL_VOLATILE);
1181 return TCL_OK;
1182}
1183
1184/*
1185 * -----------------------------------------------------------------------
1186 *
1187 * SearchOp --
1188 *
1189 * Searchs for a value in the vector. Returns the indices of all
1190 * vector elements matching a particular value.
1191 *
1192 * Results:
1193 * Always returns TCL_OK. interp->result will contain a list of
1194 * the indices of array elements matching value. If no elements
1195 * match, interp->result will contain the empty string.
1196 *
1197 * -----------------------------------------------------------------------
1198 */
1199/*ARGSUSED*/
1200static int
1201SearchOp(vPtr, interp, argc, argv)
1202 VectorObject *vPtr;
1203 Tcl_Interp *interp;
1204 int argc; /* Not used. */
1205 char **argv;
1206{
1207 double min, max;
1208 register int i;
1209 int wantValue;
1210
1211 wantValue = FALSE;
1212 if ((argv[2][0] == '-') && (strcmp(argv[2], "-value") == 0)) {
1213 wantValue = TRUE;
1214 argv++, argc--;
1215 }
1216 if (Tcl_ExprDouble(interp, argv[2], &min) != TCL_OK) {
1217 return TCL_ERROR;
1218 }
1219 max = min;
1220 if ((argc > 3) && (Tcl_ExprDouble(interp, argv[3], &max) != TCL_OK)) {
1221 return TCL_ERROR;
1222 }
1223 if ((min - max) >= DBL_EPSILON) {
1224 return TCL_OK; /* Bogus range. Don't bother looking. */
1225 }
1226 if (wantValue) {
1227 for (i = 0; i < vPtr->length; i++) {
1228 if (InRange(vPtr->valueArr[i], min, max)) {
1229 Tcl_AppendElement(interp, Blt_Dtoa(interp, vPtr->valueArr[i]));
1230 }
1231 }
1232 } else {
1233 for (i = 0; i < vPtr->length; i++) {
1234 if (InRange(vPtr->valueArr[i], min, max)) {
1235 Tcl_AppendElement(interp, Blt_Itoa(i + vPtr->offset));
1236 }
1237 }
1238 }
1239 return TCL_OK;
1240}
1241
1242/*
1243 * -----------------------------------------------------------------------
1244 *
1245 * OffsetOp --
1246 *
1247 * Queries or sets the offset of the array index from the base
1248 * address of the data array of values.
1249 *
1250 * Results:
1251 * A standard Tcl result. If the source vector doesn't exist
1252 * or the source list is not a valid list of numbers, TCL_ERROR
1253 * returned. Otherwise TCL_OK is returned.
1254 *
1255 * -----------------------------------------------------------------------
1256 */
1257/*ARGSUSED*/
1258static int
1259OffsetOp(vPtr, interp, argc, argv)
1260 VectorObject *vPtr;
1261 Tcl_Interp *interp;
1262 int argc; /* Not used. */
1263 char **argv;
1264{
1265 if (argc == 3) {
1266 int newOffset;
1267
1268 if (Tcl_GetInt(interp, argv[2], &newOffset) != TCL_OK) {
1269 return TCL_ERROR;
1270 }
1271 vPtr->offset = newOffset;
1272 }
1273 Tcl_SetResult(interp, Blt_Itoa(vPtr->offset), TCL_VOLATILE);
1274 return TCL_OK;
1275}
1276
1277/*
1278 * -----------------------------------------------------------------------
1279 *
1280 * RandomOp --
1281 *
1282 * Generates random values for the length of the vector.
1283 *
1284 * Results:
1285 * A standard Tcl result.
1286 *
1287 * -----------------------------------------------------------------------
1288 */
1289/*ARGSUSED*/
1290static int
1291RandomOp(vPtr, interp, argc, argv)
1292 VectorObject *vPtr;
1293 Tcl_Interp *interp;
1294 int argc; /* Not used. */
1295 char **argv;
1296{
1297#ifdef HAVE_DRAND48
1298 register int i;
1299
1300 for (i = 0; i < vPtr->length; i++) {
1301 vPtr->valueArr[i] = drand48();
1302 }
1303#endif /* HAVE_DRAND48 */
1304 if (vPtr->flush) {
1305 Blt_VectorFlushCache(vPtr);
1306 }
1307 Blt_VectorUpdateClients(vPtr);
1308 return TCL_OK;
1309}
1310
1311/*
1312 * -----------------------------------------------------------------------
1313 *
1314 * SeqOp --
1315 *
1316 * Generates a sequence of values in the vector.
1317 *
1318 * Results:
1319 * A standard Tcl result.
1320 *
1321 * -----------------------------------------------------------------------
1322 */
1323/*ARGSUSED*/
1324static int
1325SeqOp(vPtr, interp, argc, argv)
1326 VectorObject *vPtr;
1327 Tcl_Interp *interp;
1328 int argc; /* Not used. */
1329 char **argv;
1330{
1331 register int i;
1332 double start, finish, step;
1333 int fillVector;
1334 int nSteps;
1335
1336 if (Tcl_ExprDouble(interp, argv[2], &start) != TCL_OK) {
1337 return TCL_ERROR;
1338 }
1339 fillVector = FALSE;
1340 if ((argv[3][0] == 'e') && (strcmp(argv[3], "end") == 0)) {
1341 fillVector = TRUE;
1342 } else if (Tcl_ExprDouble(interp, argv[3], &finish) != TCL_OK) {
1343 return TCL_ERROR;
1344 }
1345 step = 1.0;
1346 if ((argc > 4) && (Tcl_ExprDouble(interp, argv[4], &step) != TCL_OK)) {
1347 return TCL_ERROR;
1348 }
1349 if (fillVector) {
1350 nSteps = vPtr->length;
1351 } else {
1352 nSteps = (int)((finish - start) / step) + 1;
1353 }
1354 if (nSteps > 0) {
1355 if (Blt_VectorChangeLength(vPtr, nSteps) != TCL_OK) {
1356 return TCL_ERROR;
1357 }
1358 for (i = 0; i < nSteps; i++) {
1359 vPtr->valueArr[i] = start + (step * (double)i);
1360 }
1361 if (vPtr->flush) {
1362 Blt_VectorFlushCache(vPtr);
1363 }
1364 Blt_VectorUpdateClients(vPtr);
1365 }
1366 return TCL_OK;
1367}
1368
1369/*
1370 * -----------------------------------------------------------------------
1371 *
1372 * SetOp --
1373 *
1374 * Sets the data of the vector object from a list of values.
1375 *
1376 * Results:
1377 * A standard Tcl result. If the source vector doesn't exist
1378 * or the source list is not a valid list of numbers, TCL_ERROR
1379 * returned. Otherwise TCL_OK is returned.
1380 *
1381 * Side Effects:
1382 * The vector data is reset. Clients of the vector are notified.
1383 * Any cached array indices are flushed.
1384 *
1385 * -----------------------------------------------------------------------
1386 */
1387/*ARGSUSED*/
1388static int
1389SetOp(vPtr, interp, argc, argv)
1390 VectorObject *vPtr;
1391 Tcl_Interp *interp;
1392 int argc; /* Not used. */
1393 char **argv;
1394{
1395 int result;
1396 VectorObject *v2Ptr;
1397 int nElem;
1398 char **elemArr;
1399
1400 /* The source can be either a list of expressions of another
1401 * vector. */
1402 if (Tcl_SplitList(interp, argv[2], &nElem, &elemArr) != TCL_OK) {
1403 return TCL_ERROR;
1404 }
1405 /* If there's only one element, see whether it's the name of a
1406 * vector. Otherwise, treat it as a single numeric expression. */
1407
1408 if ((nElem == 1) && ((v2Ptr = Blt_VectorParseElement((Tcl_Interp *)NULL,
1409 vPtr->dataPtr, argv[2], (char **)NULL, NS_SEARCH_BOTH)) != NULL)) {
1410 if (vPtr == v2Ptr) {
1411 VectorObject *tmpPtr;
1412
1413 /*
1414 * Source and destination vectors are the same. Copy the
1415 * source first into a temporary vector to avoid memory
1416 * overlaps.
1417 */
1418 tmpPtr = Blt_VectorNew(vPtr->dataPtr);
1419 result = Blt_VectorDuplicate(tmpPtr, v2Ptr);
1420 if (result == TCL_OK) {
1421 result = Blt_VectorDuplicate(vPtr, tmpPtr);
1422 }
1423 Blt_VectorFree(tmpPtr);
1424 } else {
1425 result = Blt_VectorDuplicate(vPtr, v2Ptr);
1426 }
1427 } else {
1428 result = CopyList(vPtr, nElem, elemArr);
1429 }
1430 Blt_Free(elemArr);
1431
1432 if (result == TCL_OK) {
1433 /*
1434 * The vector has changed; so flush the array indices (they're
1435 * wrong now), find the new range of the data, and notify
1436 * the vector's clients that it's been modified.
1437 */
1438 if (vPtr->flush) {
1439 Blt_VectorFlushCache(vPtr);
1440 }
1441 Blt_VectorUpdateClients(vPtr);
1442 }
1443 return result;
1444}
1445
1446static VectorObject **sortVectorArr; /* Pointer to the array of values currently
1447 * being sorted. */
1448static int nSortVectors;
1449static int reverse; /* Indicates the ordering of the sort. If
1450 * non-zero, the vectors are sorted in
1451 * decreasing order */
1452
1453static int
1454CompareVectors(a, b)
1455 void *a;
1456 void *b;
1457{
1458 double delta;
1459 int i;
1460 int sign;
1461 register VectorObject *vPtr;
1462
1463 sign = (reverse) ? -1 : 1;
1464 for (i = 0; i < nSortVectors; i++) {
1465 vPtr = sortVectorArr[i];
1466 delta = vPtr->valueArr[*(int *)a] - vPtr->valueArr[*(int *)b];
1467 if (delta < 0.0) {
1468 return (-1 * sign);
1469 } else if (delta > 0.0) {
1470 return (1 * sign);
1471 }
1472 }
1473 return 0;
1474}
1475
1476int *
1477Blt_VectorSortIndex(vPtrPtr, nVectors)
1478 VectorObject **vPtrPtr;
1479 int nVectors;
1480{
1481 int *indexArr;
1482 register int i;
1483 VectorObject *vPtr = *vPtrPtr;
1484
1485 indexArr = Blt_Malloc(sizeof(int) * vPtr->length);
1486 assert(indexArr);
1487 for (i = 0; i < vPtr->length; i++) {
1488 indexArr[i] = i;
1489 }
1490 sortVectorArr = vPtrPtr;
1491 nSortVectors = nVectors;
1492 qsort((char *)indexArr, vPtr->length, sizeof(int),
1493 (QSortCompareProc *)CompareVectors);
1494 return indexArr;
1495}
1496
1497static int *
1498SortVectors(vPtr, interp, argc, argv)
1499 VectorObject *vPtr;
1500 Tcl_Interp *interp;
1501 int argc;
1502 char **argv;
1503{
1504 VectorObject **vPtrArray, *v2Ptr;
1505 int *iArr;
1506 register int i;
1507
1508 vPtrArray = Blt_Malloc(sizeof(VectorObject *) * (argc + 1));
1509 assert(vPtrArray);
1510 vPtrArray[0] = vPtr;
1511 iArr = NULL;
1512 for (i = 0; i < argc; i++) {
1513 if (Blt_VectorLookupName(vPtr->dataPtr, argv[i], &v2Ptr) != TCL_OK) {
1514 goto error;
1515 }
1516 if (v2Ptr->length != vPtr->length) {
1517 Tcl_AppendResult(interp, "vector \"", v2Ptr->name,
1518 "\" is not the same size as \"", vPtr->name, "\"",
1519 (char *)NULL);
1520 goto error;
1521 }
1522 vPtrArray[i + 1] = v2Ptr;
1523 }
1524 iArr = Blt_VectorSortIndex(vPtrArray, argc + 1);
1525 error:
1526 Blt_Free(vPtrArray);
1527 return iArr;
1528}
1529
1530
1531/*
1532 * -----------------------------------------------------------------------
1533 *
1534 * SortOp --
1535 *
1536 * Sorts the vector object and any other vectors according to
1537 * sorting order of the vector object.
1538 *
1539 * Results:
1540 * A standard Tcl result. If any of the auxiliary vectors are
1541 * a different size than the sorted vector object, TCL_ERROR is
1542 * returned. Otherwise TCL_OK is returned.
1543 *
1544 * Side Effects:
1545 * The vectors are sorted.
1546 *
1547 * -----------------------------------------------------------------------
1548 */
1549
1550static int
1551SortOp(vPtr, interp, argc, argv)
1552 VectorObject *vPtr;
1553 Tcl_Interp *interp;
1554 int argc;
1555 char **argv;
1556{
1557 int *iArr;
1558 double *mergeArr;
1559 VectorObject *v2Ptr;
1560 int refSize, nBytes;
1561 int result;
1562 register int i, n;
1563
1564 reverse = FALSE;
1565 if ((argc > 2) && (argv[2][0] == '-')) {
1566 int length;
1567
1568 length = strlen(argv[2]);
1569 if ((length > 1) && (strncmp(argv[2], "-reverse", length) == 0)) {
1570 reverse = TRUE;
1571 } else {
1572 Tcl_AppendResult(interp, "unknown flag \"", argv[2],
1573 "\": should be \"-reverse\"", (char *)NULL);
1574 return TCL_ERROR;
1575 }
1576 argc--, argv++;
1577 }
1578 if (argc > 2) {
1579 iArr = SortVectors(vPtr, interp, argc - 2, argv + 2);
1580 } else {
1581 iArr = Blt_VectorSortIndex(&vPtr, 1);
1582 }
1583 if (iArr == NULL) {
1584 return TCL_ERROR;
1585 }
1586 refSize = vPtr->length;
1587
1588 /*
1589 * Create an array to store a copy of the current values of the
1590 * vector. We'll merge the values back into the vector based upon
1591 * the indices found in the index array.
1592 */
1593 nBytes = sizeof(double) * refSize;
1594 mergeArr = Blt_Malloc(nBytes);
1595 assert(mergeArr);
1596 memcpy((char *)mergeArr, (char *)vPtr->valueArr, nBytes);
1597 for (n = 0; n < refSize; n++) {
1598 vPtr->valueArr[n] = mergeArr[iArr[n]];
1599 }
1600 if (vPtr->flush) {
1601 Blt_VectorFlushCache(vPtr);
1602 }
1603 Blt_VectorUpdateClients(vPtr);
1604
1605 /* Now sort any other vectors in the same fashion. The vectors
1606 * must be the same size as the iArr though. */
1607 result = TCL_ERROR;
1608 for (i = 2; i < argc; i++) {
1609 if (Blt_VectorLookupName(vPtr->dataPtr, argv[i], &v2Ptr) != TCL_OK) {
1610 goto error;
1611 }
1612 if (v2Ptr->length != refSize) {
1613 Tcl_AppendResult(interp, "vector \"", v2Ptr->name,
1614 "\" is not the same size as \"", vPtr->name, "\"",
1615 (char *)NULL);
1616 goto error;
1617 }
1618 memcpy((char *)mergeArr, (char *)v2Ptr->valueArr, nBytes);
1619 for (n = 0; n < refSize; n++) {
1620 v2Ptr->valueArr[n] = mergeArr[iArr[n]];
1621 }
1622 Blt_VectorUpdateClients(v2Ptr);
1623 if (v2Ptr->flush) {
1624 Blt_VectorFlushCache(v2Ptr);
1625 }
1626 }
1627 result = TCL_OK;
1628 error:
1629 Blt_Free(mergeArr);
1630 Blt_Free(iArr);
1631 return result;
1632}
1633
1634/*
1635 *----------------------------------------------------------------------
1636 *
1637 * InstExprOp --
1638 *
1639 * Computes the result of the expression which may be
1640 * either a scalar (single value) or vector (list of values).
1641 *
1642 * Results:
1643 * A standard Tcl result.
1644 *
1645 *----------------------------------------------------------------------
1646 */
1647/*ARGSUSED*/
1648static int
1649InstExprOp(vPtr, interp, argc, argv)
1650 VectorObject *vPtr;
1651 Tcl_Interp *interp;
1652 int argc;
1653 char **argv;
1654{
1655 if (Blt_ExprVector(interp, argv[2], (Blt_Vector *) vPtr) != TCL_OK) {
1656 return TCL_ERROR;
1657 }
1658 if (vPtr->flush) {
1659 Blt_VectorFlushCache(vPtr);
1660 }
1661 Blt_VectorUpdateClients(vPtr);
1662 return TCL_OK;
1663}
1664
1665/*
1666 * -----------------------------------------------------------------------
1667 *
1668 * ArithOp --
1669 *
1670 * Results:
1671 * A standard Tcl result. If the source vector doesn't exist
1672 * or the source list is not a valid list of numbers, TCL_ERROR
1673 * returned. Otherwise TCL_OK is returned.
1674 *
1675 * Side Effects:
1676 * The vector data is reset. Clients of the vector are notified.
1677 * Any cached array indices are flushed.
1678 *
1679 * -----------------------------------------------------------------------
1680 */
1681/*ARGSUSED*/
1682static int
1683ArithOp(vPtr, interp, argc, argv)
1684 VectorObject *vPtr;
1685 Tcl_Interp *interp;
1686 int argc; /* Not used. */
1687 char **argv;
1688{
1689 register double value;
1690 register int i;
1691 VectorObject *v2Ptr;
1692
1693 v2Ptr = Blt_VectorParseElement((Tcl_Interp *)NULL, vPtr->dataPtr, argv[2],
1694 (char **)NULL, NS_SEARCH_BOTH);
1695 if (v2Ptr != NULL) {
1696 register int j;
1697 int length;
1698
1699 length = v2Ptr->last - v2Ptr->first + 1;
1700 if (length != vPtr->length) {
1701 Tcl_AppendResult(interp, "vectors \"", argv[0], "\" and \"",
1702 argv[2], "\" are not the same length", (char *)NULL);
1703 return TCL_ERROR;
1704 }
1705 switch (argv[1][0]) {
1706 case '*':
1707 for (i = 0, j = v2Ptr->first; i < vPtr->length; i++, j++) {
1708 value = vPtr->valueArr[i] * v2Ptr->valueArr[j];
1709 Tcl_AppendElement(interp, Blt_Dtoa(interp, value));
1710 }
1711 break;
1712
1713 case '/':
1714 for (i = 0, j = v2Ptr->first; i < vPtr->length; i++, j++) {
1715 value = vPtr->valueArr[i] / v2Ptr->valueArr[j];
1716 Tcl_AppendElement(interp, Blt_Dtoa(interp, value));
1717 }
1718 break;
1719
1720 case '-':
1721 for (i = 0, j = v2Ptr->first; i < vPtr->length; i++, j++) {
1722 value = vPtr->valueArr[i] - v2Ptr->valueArr[j];
1723 Tcl_AppendElement(interp, Blt_Dtoa(interp, value));
1724 }
1725 break;
1726
1727 case '+':
1728 for (i = 0, j = v2Ptr->first; i < vPtr->length; i++, j++) {
1729 value = vPtr->valueArr[i] + v2Ptr->valueArr[j];
1730 Tcl_AppendElement(interp, Blt_Dtoa(interp, value));
1731 }
1732 break;
1733 }
1734 } else {
1735 double scalar;
1736
1737 if (Tcl_ExprDouble(interp, argv[2], &scalar) != TCL_OK) {
1738 return TCL_ERROR;
1739 }
1740 switch (argv[1][0]) {
1741 case '*':
1742 for (i = 0; i < vPtr->length; i++) {
1743 value = vPtr->valueArr[i] * scalar;
1744 Tcl_AppendElement(interp, Blt_Dtoa(interp, value));
1745 }
1746 break;
1747
1748 case '/':
1749 for (i = 0; i < vPtr->length; i++) {
1750 value = vPtr->valueArr[i] / scalar;
1751 Tcl_AppendElement(interp, Blt_Dtoa(interp, value));
1752 }
1753 break;
1754
1755 case '-':
1756 for (i = 0; i < vPtr->length; i++) {
1757 value = vPtr->valueArr[i] - scalar;
1758 Tcl_AppendElement(interp, Blt_Dtoa(interp, value));
1759 }
1760 break;
1761
1762 case '+':
1763 for (i = 0; i < vPtr->length; i++) {
1764 value = vPtr->valueArr[i] + scalar;
1765 Tcl_AppendElement(interp, Blt_Dtoa(interp, value));
1766 }
1767 break;
1768 }
1769 }
1770 return TCL_OK;
1771}
1772
1773/*
1774 *----------------------------------------------------------------------
1775 *
1776 * VectorInstCmd --
1777 *
1778 * Parses and invokes the appropriate vector instance command
1779 * option.
1780 *
1781 * Results:
1782 * A standard Tcl result.
1783 *
1784 *----------------------------------------------------------------------
1785 */
1786static Blt_OpSpec vectorInstOps[] =
1787{
1788 {"*", 1, (Blt_Op)ArithOp, 3, 3, "item",}, /*Deprecated*/
1789 {"+", 1, (Blt_Op)ArithOp, 3, 3, "item",}, /*Deprecated*/
1790 {"-", 1, (Blt_Op)ArithOp, 3, 3, "item",}, /*Deprecated*/
1791 {"/", 1, (Blt_Op)ArithOp, 3, 3, "item",}, /*Deprecated*/
1792 {"append", 1, (Blt_Op)AppendOp, 3, 0, "item ?item...?",},
1793 {"binread", 1, (Blt_Op)BinreadOp, 3, 0, "channel ?numValues? ?flags?",},
1794 {"clear", 1, (Blt_Op)ClearOp, 2, 2, "",},
1795 {"delete", 2, (Blt_Op)DeleteOp, 2, 0, "index ?index...?",},
1796 {"dup", 2, (Blt_Op)DupOp, 3, 0, "vecName",},
1797 {"expr", 1, (Blt_Op)InstExprOp, 3, 3, "expression",},
1798 {"index", 1, (Blt_Op)IndexOp, 3, 4, "index ?value?",},
1799 {"length", 1, (Blt_Op)LengthOp, 2, 3, "?newSize?",},
1800 {"merge", 1, (Blt_Op)MergeOp, 3, 0, "vecName ?vecName...?",},
1801 {"normalize", 3, (Blt_Op)NormalizeOp, 2, 3, "?vecName?",}, /*Deprecated*/
1802 {"notify", 3, (Blt_Op)NotifyOp, 3, 3, "keyword",},
1803 {"offset", 2, (Blt_Op)OffsetOp, 2, 3, "?offset?",},
1804 {"populate", 1, (Blt_Op)PopulateOp, 4, 4, "vecName density",},
1805 {"random", 4, (Blt_Op)RandomOp, 2, 2, "",}, /*Deprecated*/
1806 {"range", 4, (Blt_Op)RangeOp, 4, 4, "first last",},
1807 {"search", 3, (Blt_Op)SearchOp, 3, 4, "?-value? value ?value?",},
1808 {"seq", 3, (Blt_Op)SeqOp, 4, 5, "start end ?step?",},
1809 {"set", 3, (Blt_Op)SetOp, 3, 3, "list",},
1810 {"sort", 2, (Blt_Op)SortOp, 2, 0, "?-reverse? ?vecName...?",},
1811 {"variable", 1, (Blt_Op)MapOp, 2, 3, "?varName?",},
1812};
1813
1814static int nInstOps = sizeof(vectorInstOps) / sizeof(Blt_OpSpec);
1815
1816int
1817Blt_VectorInstCmd(clientData, interp, argc, argv)
1818 ClientData clientData;
1819 Tcl_Interp *interp;
1820 int argc;
1821 char **argv;
1822{
1823 Blt_Op proc;
1824 VectorObject *vPtr = clientData;
1825
1826 vPtr->first = 0;
1827 vPtr->last = vPtr->length - 1;
1828 proc = Blt_GetOp(interp, nInstOps, vectorInstOps, BLT_OP_ARG1, argc, argv,
1829 0);
1830 if (proc == NULL) {
1831 return TCL_ERROR;
1832 }
1833 return (*proc) (vPtr, interp, argc, argv);
1834}
1835
1836
1837
1838/*
1839 * ----------------------------------------------------------------------
1840 *
1841 * Blt_VectorVarTrace --
1842 *
1843 * Results:
1844 * Returns NULL on success. Only called from a variable trace.
1845 *
1846 * Side effects:
1847 *
1848 * ----------------------------------------------------------------------
1849 */
1850char *
1851Blt_VectorVarTrace(clientData, interp, part1, part2, flags)
1852 ClientData clientData; /* File output information. */
1853 Tcl_Interp *interp;
1854 char *part1, *part2;
1855 int flags;
1856{
1857 VectorObject *vPtr = clientData;
1858 char string[TCL_DOUBLE_SPACE + 1];
1859#define MAX_ERR_MSG 1023
1860 static char message[MAX_ERR_MSG + 1];
1861 Blt_VectorIndexProc *indexProc;
1862 int varFlags;
1863 int first, last;
1864
1865 if (part2 == NULL) {
1866 if (flags & TCL_TRACE_UNSETS) {
1867 Blt_Free(vPtr->arrayName);
1868 vPtr->arrayName = NULL;
1869 vPtr->varNsPtr = NULL;
1870 if (vPtr->freeOnUnset) {
1871 Blt_VectorFree(vPtr);
1872 }
1873 }
1874 return NULL;
1875 }
1876 if (Blt_VectorGetIndexRange(interp, vPtr, part2, INDEX_ALL_FLAGS,
1877 &indexProc) != TCL_OK) {
1878 goto error;
1879 }
1880 first = vPtr->first, last = vPtr->last;
1881 varFlags = TCL_LEAVE_ERR_MSG | (TCL_GLOBAL_ONLY & flags);
1882 if (flags & TCL_TRACE_WRITES) {
1883 double value;
1884 char *newValue;
1885
1886 if (first == SPECIAL_INDEX) { /* Tried to set "min" or "max" */
1887 return "read-only index";
1888 }
1889 newValue = Tcl_GetVar2(interp, part1, part2, varFlags);
1890 if (newValue == NULL) {
1891 goto error;
1892 }
1893 if (Tcl_ExprDouble(interp, newValue, &value) != TCL_OK) {
1894 if ((last == first) && (first >= 0)) {
1895 /* Single numeric index. Reset the array element to
1896 * its old value on errors */
1897 Tcl_PrintDouble(interp, vPtr->valueArr[first], string);
1898 Tcl_SetVar2(interp, part1, part2, string, varFlags);
1899 }
1900 goto error;
1901 }
1902 if (first == vPtr->length) {
1903 if (Blt_VectorChangeLength(vPtr, vPtr->length + 1) != TCL_OK) {
1904 return "error resizing vector";
1905 }
1906 }
1907 /* Set possibly an entire range of values */
1908 ReplicateValue(vPtr, first, last, value);
1909 } else if (flags & TCL_TRACE_READS) {
1910 double value;
1911
1912 if (vPtr->length == 0) {
1913 if (Tcl_SetVar2(interp, part1, part2, "", varFlags) == NULL) {
1914 goto error;
1915 }
1916 return NULL;
1917 }
1918 if (first == vPtr->length) {
1919 return "write-only index";
1920 }
1921 if (first == last) {
1922 if (first >= 0) {
1923 value = vPtr->valueArr[first];
1924 } else {
1925 vPtr->first = 0, vPtr->last = vPtr->length - 1;
1926 value = (*indexProc) ((Blt_Vector *) vPtr);
1927 }
1928 Tcl_PrintDouble(interp, value, string);
1929 if (Tcl_SetVar2(interp, part1, part2, string, varFlags)
1930 == NULL) {
1931 goto error;
1932 }
1933 } else {
1934 Tcl_DString dString;
1935 char *result;
1936
1937 Tcl_DStringInit(&dString);
1938 GetValues(vPtr, first, last, &dString);
1939 result = Tcl_SetVar2(interp, part1, part2,
1940 Tcl_DStringValue(&dString), varFlags);
1941 Tcl_DStringFree(&dString);
1942 if (result == NULL) {
1943 goto error;
1944 }
1945 }
1946 } else if (flags & TCL_TRACE_UNSETS) {
1947 register int i, j;
1948
1949 if ((first == vPtr->length) || (first == SPECIAL_INDEX)) {
1950 return "special vector index";
1951 }
1952 /*
1953 * Collapse the vector from the point of the first unset element.
1954 * Also flush any array variable entries so that the shift is
1955 * reflected when the array variable is read.
1956 */
1957 for (i = first, j = last + 1; j < vPtr->length; i++, j++) {
1958 vPtr->valueArr[i] = vPtr->valueArr[j];
1959 }
1960 vPtr->length -= ((last - first) + 1);
1961 if (vPtr->flush) {
1962 Blt_VectorFlushCache(vPtr);
1963 }
1964 } else {
1965 return "unknown variable trace flag";
1966 }
1967 if (flags & (TCL_TRACE_UNSETS | TCL_TRACE_WRITES)) {
1968 Blt_VectorUpdateClients(vPtr);
1969 }
1970 Tcl_ResetResult(interp);
1971 return NULL;
1972
1973 error:
1974 strncpy(message, Tcl_GetStringResult(interp), MAX_ERR_MSG);
1975 message[MAX_ERR_MSG] = '\0';
1976 return message;
1977}
1978
1979#endif /* TCL_MAJOR_VERSION == 7 */
Note: See TracBrowser for help on using the repository browser.