-
Notifications
You must be signed in to change notification settings - Fork 0
/
search26.scr
336 lines (256 loc) · 9.54 KB
/
search26.scr
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
\ Electron Drift Instrument 11:28 01-10-91
(
Source Files
WELCOME TO EDI CASS TEAM
DRIVERS FOR HIGH VOLTAGE SYSTEM FOR EDI OPTICS
BY JOE RITTER AND SLOBODAN BEROS AND SCOTT WEISMAN
SEARCH26.SCR
AUTOMATED SEARCHES ARE SUPPORTED
)
\ 14:14 01-16-91
: TEST-MID@ ( I --- N ) 4* TEST-MID[] + @ ;
: TEST-MID! ( N I --- ) 4* TEST-MID[] + ! ;
: TEST-RANGE@ ( I --- N ) 4* TEST-RANGE[] + @ ;
: TEST-RANGE! ( N I --- ) 4* TEST-RANGE[] + ! ;
: TEST-INC@ ( I --- N ) 4* TEST-INC[] + @ ;
: TEST-INC! ( N I --- ) 4* TEST-INC[] + ! ;
: MIN-INC@ ( I --- N ) 4* MIN-INC[] + @ ;
: MIN-INC! ( N I --- ) 4* MIN-INC[] + ! ;
: TEST-CHAN@ ( I --- N ) 4* TEST-CHAN[] + @ ;
: TEST-CHAN! ( N I --- ) 4* TEST-CHAN[] + ! ;
\ 14:15 01-16-91
: PAIR-CHAN@ ( I --- N ) 4* PAIR-CHAN[] + @ ;
: PAIR-CHAN! ( N I --- ) 4* PAIR-CHAN[] + ! ;
: PAIR-VAL@ ( I --- N ) 4* PAIR-VAL[] + @ ;
: PAIR-VAL! ( N I --- ) 4* PAIR-VAL[] + ! ;
: PAIR-RANGE@ ( I --- N ) 4* PAIR-RANGE[] + @ ;
: PAIR-RANGE! ( N I --- ) 4* PAIR-RANGE[] + ! ;
: PAIR-HI@ ( I --- N ) FPSIZE * PAIR-HI[] + F@ ;
: PAIR-HI! ( N I --- ) FPSIZE * PAIR-HI[] + F! ;
\ 09:37 01-07-91
: CALC-SEARCH-LOOPS
0 TOTAL-SEARCH-LOOPS !
15 1 DO
I TEST-CHAN@ DUP 0= IF DROP LEAVE ELSE 1 LOOP-CHAN! THEN
I TEST-RANGE@ 1 RANGE! I TEST-INC@ 1 INC! I TEST-MID@ 1 MID!
BEGIN
FALSE FINER? !
CALC-TOTAL-LOOPS TOTAL-LOOPS @ TOTAL-SEARCH-LOOPS +!
1 INC@ I MIN-INC@ > IF
1 INC@ DUP 1 RANGE! 2/ 1 INC! TRUE FINER? !
THEN
FINER? @ NOT UNTIL
LOOP
TOTAL-SEARCH-LOOPS @ PAIR-FUNCTION-SEARCH? @ IF 3 * THEN
TOTAL-LOOPS ! ;
\ 17:39 01-22-91
: DISP-AUTO-MENU2 ( --- ) \ DISPLAYS AUTO-MENU2
61 13 GOTOXY ." B Areas "
61 14 GOTOXY ." C Convolutions "
61 15 GOTOXY ." R Reset index "
61 16 GOTOXY ." H Print Header "
61 17 GOTOXY ." P Print sums,volts "
61 18 GOTOXY ." S Set accum params "
61 19 GOTOXY ." L Search-auto-accum "
61 20 GOTOXY ." Z Exit Auto Menu 2 " ;
: DISP-AUTO-MENU2-VALS
REVERSE
76 13 GOTOXY DO-AREA @ IF ." YES" ELSE ." NO" THEN
76 14 GOTOXY DO-AZIM-CONV @ IF ." YES" ELSE ." NO" THEN
REVERSE
74 15 GOTOXY REC-INDEX @ 5 .R ;
\ 17:34 01-22-91
\ 13:36 01-07-91
: MAX-TEST ( --- T/F ) \ RETURNS CURRENT>MAX?
\ CRITERION
PEAK-CRITERION @ REC-INDEX @ REC@ \
PEAK-CRITERION @ MAX-INDEX @ REC@ > IF \ F> ???
REC-INDEX @ MAX-INDEX ! TRUE ELSE FALSE THEN
; \ RETURN TRUE IF CURRENT>MAX
\ ELSE FALSE
: RESTORE-PEAK-FROM-RUNS
0 MAX-INDEX !
REC-INDEX @ 1+ SEARCH-BASE-INDEX @ DO
I REC-INDEX ! MAX-TEST DROP \ DROP FLAG FROM MAX-TEST
LOOP
MAX-INDEX @ LOAD-REC OUTPUT-DATA TRODE-UPDATE-ALL
;
\ 11:51 01-10-91
: AUTO-ACCUM-LOOP2-INNER
1 LOOP-LIMITS DO
I S>F 1 LOOP-CHAN@ V! DISP-LOOPS
74 15 GOTOXY REC-INDEX @ 5 .R
2NDARY-CALC OUTPUT-DATA TRODE-UPDATE-ALL
CASE-ACCUM-TO-FILE
REC-INDEX @ SAVE-REC MAX-TEST IF I 1 MID! THEN
1 REC-INDEX +!
1 INC@ +LOOP
;
\ 12:34 01-14-91
: AUTO-ACCUM-LOOP2 \ SAME AS 1 W/CRITERIA TEST & HOMES IN ON MAX
CURRENT-TEST-CHAN @ DUP DUP DUP
TEST-CHAN@ 1 LOOP-CHAN!
TEST-MID@ DUP 10000 >= \ IF MID>=10000,USE CURRENT VAL AS MID
IF DROP 1 LOOP-CHAN@ V@ F>S THEN 1 MID!
TEST-RANGE@ 1 RANGE! TEST-INC@ 1 INC!
BEGIN 0 MAX-INDEX !
AUTO-ACCUM-LOOP2-INNER
CURRENT-TEST-CHAN @ MIN-INC@ 1 INC@ < DUP IF
1 INC@ DUP 1 RANGE! 2/ 1 INC!
THEN
NOT UNTIL ;
\ 11:53 01-10-91
: SINGLE-SEARCH
15 1 DO
I TEST-CHAN@ DUP 0= IF DROP LEAVE THEN
I CURRENT-TEST-CHAN !
REC-INDEX @ SEARCH-BASE-INDEX !
AUTO-ACCUM-LOOP2
RESTORE-PEAK-FROM-RUNS \ RESTORE PEAK VALUE FROM SET OF
LOOP \ SUBRUNS
1 SEARCH-BASE-INDEX ! \ RESTORE MAX FROM ALL SEARCHES
RESTORE-PEAK-FROM-RUNS
;
\ 10:16 01-07-91
: CALC-PARAMS ( --- F N ) \ CALCS MULT(FLT) & OFFSET(INT)
2 PAIR-HI@ 0 PAIR-HI@ F-
CURRENT-TEST-CHAN @ PAIR-RANGE@ 2* S>F F/ FDUP
CURRENT-TEST-CHAN @ PAIR-VAL@ S>F F*
2 PAIR-HI@ 0 PAIR-HI@ F- FSWAP F- F>S
;
\ THIS ROUTINE CALCS THE MULT. AND OFFSET FOR A PAIR-FUNCTION
\ SEARCH, GIVEN Y(X), Y(X-C), Y(X+C), AND Y MAXIMIZED FOR EACH
\ X. THE MULT. F THE INDIVIDUAL POINT PAIRS. THE FORMULA THUS
\ SIMPLIFIED IS SAME AS A LINE, Y=MX+B.
\ M={Y(X+C)-Y(X-C)}/2C
\ THE Y-INTERCEPT IS CALCULATED FROM
\ B=Y-MX
\ M IS FLOATING POINT, B IS INTEGER
\ 11:54 01-10-91
: PAIR-FUNCTION-SEARCH ( --- ) \ LEAVES MULT & OFFSET FOR EA.
15 1 DO \ PAIR IN CORR. ENTRIES IN C1 & C2 ARRAYS
I TEST-CHAN@ DUP 0= IF DROP LEAVE THEN
I CURRENT-TEST-CHAN !
2 -1 DO
J PAIR-VAL@ I J PAIR-RANGE@ * + S>F J PAIR-CHAN@ V!
REC-INDEX @ SEARCH-BASE-INDEX ! AUTO-ACCUM-LOOP2
RESTORE-PEAK-FROM-RUNS J TEST-CHAN@ V@ I 1+ PAIR-HI!
LOOP
CALC-PARAMS I C2! I C1! \ FIND MULT & OFFSET, STORE
I PAIR-VAL@ S>F FDUP I PAIR-CHAN@ V! \ SAVE INDEP CH VOLT
I C1@ F* I C2@ S>F F+ I TEST-CHAN@ V! \ AND PAIR VALUE
I TEST-MID@ S>F I TEST-CHAN@ V!
I PAIR-VAL@ S>F I PAIR-CHAN@ V!
LOOP ;
\ 10:16 01-02-91
: GET-PAIR-PARAMS ( N --- ) \ N IS INDEX TO STORE VALS TO
." INDEPENDENT CHANNEL? " #IN L OVER PAIR-CHAN!
." MIDPOINT? " #IN L OVER PAIR-VAL!
." +/- RANGE? " #IN L OVER PAIR-RANGE!
DROP
;
\ 11:55 01-10-91
: GET-SEARCH-PARAMS
15 1 DO
BEGIN
." FOR TEST " I . ." VARY CHANNEL #? " #IN L
DUP 0= IF DROP LEAVE THEN
DUP 14 = IF 7 EMIT L DROP FALSE ELSE TRUE THEN
UNTIL
I TEST-CHAN!
." MIDPOINT(10000 FOR EXISTING VALUE)? " #IN I TEST-MID! L
." +/- RANGE? " #IN I TEST-RANGE! L
." INCREMENT? " #IN I TEST-INC! L
." MINIMUM INCREMENT(CR IF SAME)? " #IN DUP 0= IF
DROP I TEST-INC@ THEN I MIN-INC! L L
PAIR-FUNCTION-SEARCH? @ IF I GET-PAIR-PARAMS THEN
LOOP ;
\ 15:16 01-02-91
: SETUP-SEARCH
1 CURRENT-LOOP !
0 0 GOTOXY 32 SPACES 0 0 GOTOXY
." IS THIS A PAIR FUNCTION SEARCH(1=YES,0=NO)? " #IN CR
IF TRUE ELSE FALSE THEN PAIR-FUNCTION-SEARCH? !
." FILENAME.EXT ? " FNAME 20 GETSTRING L
." OUTPUT TO PRINTER ALSO(1=YES,0=NO)? " #IN L
IF TRUE PRINTER-ON ! ELSE FALSE PRINTER-ON ! THEN
15 1 DO 0 I TEST-CHAN! LOOP
." ENTER TEST LOOP PARAMS IN SEQUENCE; ENTER 0 TO EXIT " L
GET-SEARCH-PARAMS
PAIR-FUNCTION-SEARCH? NOT IF 2NDARY-SETUP THEN
GET-BEGIN-COMMENT ;
\ 16:06 01-08-91
: RUN-SEARCH
FNAME ~>>FILE OUTPUT-HEADER1
PRINT-HEADER1
CONSOLE
0 3 GOTOXY CLS ." RUNNING UNDER AUTOMATED CONTROL"
RIGHT-MENU1 PAIR-FUNCTION-SEARCH? @ IF
PAIR-FUNCTION-SEARCH ELSE SINGLE-SEARCH THEN
FNAME ~>>FILE QUOTE .TIME QUOTE CR
PRINTER-ON @ IF PRINTER .TIME CR THEN
CONSOLE 7 EMIT
;
\ 19:23 12-13-90
: DISP-SEARCH-VALS
PRINTER CR
15 1 DO
I TEST-CHAN@ DUP 0= IF DROP LEAVE THEN
I PAIR-CHAN@
." FOR IND. CHANNEL " . ." AND DEP. CHANNEL " . ." :" CR
." C1=" I C1@ F. ." C2=" I C2@ . CR
LOOP
CONSOLE
;
\ 16:07 01-08-91
: SEARCH-AUTO-ACCUM
SETUP-DONE @ NOT IF 62 29 GOTOXY ." PLEASE SETUP"
7 EMIT 7 EMIT 7 EMIT 62 29 GOTOXY 15 SPACES EXIT THEN
SETUP-SEARCH
CALC-SEARCH-LOOPS
RUN-SEARCH
PAIR-FUNCTION-SEARCH? @ IF DISP-SEARCH-VALS THEN
CLS 0 0 GOTOXY GET-END-COMMENT CLS
RIGHT-MENU1 TRODE-UPDATE-ALL DISP-AUTO-MENU2 ;
\ 16:49 01-21-91
: SEARCH ( ^STR * CHAN MID RANGE INC MIN-INC --- )
15 0 DO 0 I TEST-CHAN! 0 I PRIMARY! LOOP 1 CURRENT-TEST-CHAN !
1 MIN-INC! 1 TEST-INC! 1 TEST-RANGE! 1 TEST-MID! 1 TEST-CHAN!
FALSE PAIR-FUNCTION-SEARCH? ! FALSE PRINTER-ON !
DEPTH 4 = IF \ PAIR SEARCH, *=2NDARY-CHAN C1(FLT) C2
1 TEST-CHAN@ 1 PRIMARY! 1 C2! 1 C1! 1 SECONDARY!
ELSE \ PAIR-FUNC-SEARCH, *=PAIR-CHAN MID RANGE
DEPTH 3 = IF \ PAIR-FUNC-SEARCH, HAS ADDITIONAL ON STK
1 PAIR-RANGE! 1 PAIR-VAL! 1 PAIR-CHAN!
TRUE PAIR-FUNCTION-SEARCH? !
THEN
THEN
FNAME STRCPY \ COPY FILENAME TO STRING
RUN-SEARCH
;
\ 17:40 01-22-91
: AUTO-MENU-INPUT2 ( --- ) \ PROCESS AUTO MENU 1 SELECTIONS
BEGIN
BEGIN ?TERMINAL UNTIL KEY \ WAIT FOR KEY
DUP 67 = IF DO-AZIM-CONV @ NOT DO-AZIM-CONV ! THEN \ 'C
DUP 66 = IF DO-AREA @ NOT DO-AREA ! THEN
DUP 82 = IF 1 REC-INDEX ! THEN \ 'R
DUP 76 = IF SEARCH-AUTO-ACCUM THEN \ 'L
DUP 80 = IF PRINT-LINE THEN \ 'P
DUP 65 = IF AUTO-ACCUM-PRINT THEN \ 'A
DUP 83 = IF SET-ACCUM-PARAMS IMG-CLEAR 0 0 GOTOXY
." SETUP IS COMPLETE " THEN \ 'S
DUP 72 = IF PRINT-HEADER1 THEN \ 'H
DUP 90 = IF DROP EXIT THEN CLRSTK \ 'Z
DISP-AUTO-MENU2 DISP-AUTO-MENU2-VALS DROP
AGAIN ;
\ 17:42 01-22-91
: AUTO-CONTROL2
SAVE-RASTER-PARAMS
RMCLEAR RIGHT-MENU1 TRODE-UPDATE-ALL
DISP-AUTO-MENU2 DISP-AUTO-MENU2-VALS
AUTO-MENU-INPUT2
FALSE RASTER-ON !
CLS MENU TRODE-UPDATE-ALL
RESTORE-RASTER-PARAMS
;