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