Forgot your password?
Document Actions
TST: SET test library.
TST: SET test library. stltst.opl
1 .=member intro
2$ ssssssss eeeeeeeeee tttttttttt ll
3$ ssssssssss eeeeeeeeee tttttttttt ll
4$ ss ss ee tt ll
5$ ss ee tt ll
6$ sssssssss eeeeee tt ll
7$ sssssssss eeeeee tt ll
8$ ss ee tt ll
9$ ss ss ee tt ll
10$ ssssssssss eeeeeeeee tt llllllllll
11$ ssssssss eeeeeeeee tt llllllllll
12$
13$
14$ tttttttttt ssssssss tttttttttt
15$ tttttttttt ssssssssss tttttttttt
16$ tt ss ss tt
17$ tt ss tt
18$ tt sssssssss tt
19$ tt sssssssss tt
20$ tt ss tt
21$ tt ss ss tt
22$ tt ssssssssss tt
23$ tt ssssssss tt
24$
25$
26$ t h e s e t l t e s t l i b r a r y
27$
28$ this software is part of the setl programming system
29$ address queries and comments to
30$
31$ setl project
32$ department of computer science
33$ new york university
34$ courant institute of mathematical sciences
35$ 251 mercer street
36$ new york, ny 10012
37$
38
39
1 .=member macros
2 macro maxsi;
3 131071 $ maximum short integer on cdc 6600
4 endm;
5
6
7 macro prog_level;
smff 1 'tst(85007)'
9 endm;
10
11
12 macro nullset;
13 <>
14 endm;
15
16 macro nulltup;
17 (//)
18 endm;
19
20 macro nullstring;
21 ''
22 endm;
23
24 macro card;
25 #
26 endm;
27
28
29$ the print_xxxx - macros presumably should become utility routines.
30$ for now, it is easier to implement it in two steps: first introduce
31$ the macros for the source statement sequences, and later replace the
32$ macros by procs.
33
34
35 macro print_head(text); $ print test identification header
36
37 print('start execution of', text);
38 print
39
40 endm;
41
42
43 macro print_line(text); $ print a line as a function of print_mode
44
45 if print_mode >= print_full then
46 print; print;
47 print(text);
48 print;
49 end if
50
51 endm;
52
53
54 macro print_tail(text); $ print test termination message
55
56 print; print;
57 print('terminate execution of', text);
58
59 if print_mode >= print_full then eject; else print; end if
60
61 endm;
62
63
64$ the print modes of the test library correspond to the assert modes
65$ of the run-time library. the following macros define this corres-
66$ pondence.
67
68 macro print_off; 0 endm;
69 macro print_part; 1 endm;
70 macro print_full; 2 endm;
71 macro print_debug; 3 endm;
72
73
1 .=member opttst6
2library optimiser_test_6;
3
4 $ nyu program id
5 $ author - s. freudenberger
6
7 exports
8 bug_6;
9
10 const x;
11
12 init f := <>;
13
14 repr
15 base b: string;
16 f: local smap(elmt b) integer;
17 end repr;
18
19
20 procedure bug_6;
21
22 f(x) := 1;
23
24 assert f = << (/ 'x', 1 /) >>;
25 assert x = 'x';
26
27 end procedure bug_6;
28
29end library optimiser_test_6;
30
31
1 .=member opttst7
2
3
4library optimiser_test_7;
5
6 $ nyu program id
7 $ author - s. freudenberger
8
9 exports
10 bug_7;
11
12 init f := <>;
13
14 repr
15 base b1: string;
16 base b2: integer;
17 f: local smap(elmt b1) elmt b2;
18 end repr;
19
20
21 procedure bug_7;
22
23 x := 1.0;
24 g1 := << (/ x, 1 /) >>;
25 g2 := << (/ x, 'elmt' /) >>;
26
27 assert g1 = << (/ 1.0, 1 /) >>;
28 assert g2 = << (/ 1.0, 'elmt' /) >>;
29 assert x = 1.0;
30
31 f(g2(x)) := g1(x);
32
33 assert f = << (/ 'elmt', 1 /) >>;
34 assert g1 = << (/ 1.0, 1 /) >>;
35 assert g2 = << (/ 1.0, 'elmt' /) >>;
36 assert x = 1.0;
37
38 end procedure bug_7;
39
40end library optimiser_test_7;
41
42
1 .=member opttst13
2
3
4library optimiser_test_13;
5
6 $ nyu program id
7 $ author - d. shields (nyu-cims) 15-oct-1981
8 $ fixed with v82060:
9 $ - s. freudenberger (nyu-cims) 1-mar-1982
10
11 exports
12 bug_13;
13$
14$ this program is erroneous in that 'yes' should be 'true'. as it
15$ stands, the program terminates with an error message complaining
16$ about bad type, 'atom expected'.
17$
18$ the problem is due to the implicit repr which occurs in the init
19$ statement: input_available has been repr'ed to have the mode atom,
20$ while yes, being undeclared, has the mode general. the type check
21$ required in this context is postponed until run-time.
22$
23$ note however that the original problem then should produce an error
24$ message when input_available is tested in getinp: 'expect boolean
25$ in test', since omega is not boolean. the version below has been
26$ modified to test input_available for true, to avoid this problem.
27$
28 init input_available := false;
29
30 procedure bug_13;
31
32 getinp; assert input_available = om;
33 getinp; assert input_available = om;
34
35 end procedure bug_13;
36
37
38 procedure getinp;
39
40 assert input_available = om or input_available = false;
41$$--if input_available then return; end if;
42 if input_available = true then return; end if;
43
44 input_available := yes; assert input_available = om;
45
46 end procedure getinp;
47
48end library optimiser_test_13;
49
50
1 .=member opttst14
2
3
4library optimiser_test_14;
5
6 $ nyu program id
7 $ author - s. freudenberger
8
9 exports
10 bug_14;
11
12 var s1, s2, t1, t2;
13
14 repr
15 base b: integer;
16 s1, s2: local set(elmt b);
17 t1, t2: tuple(elmt b);
18 end repr;
19
20
21 procedure bug_14;
22
23 s := << 1, 4, 9, 16, 25 >>;
24 s1 := s;
25 s2 := << 1, 8, 27, 64, 125 >>;
26 t := (/ 1, 4, 9, 16, 25 /);
27 t1 := t;
28 t2 := (/ 1, 8, 27, 64, 125 /);
29
30 assert s = s;
31 assert t1 = t;
32 assert forall x in s1 + s2 st x in t1 + t2;
33 assert s1 = s;
34 assert t1 = t;
35
36 end procedure bug_14;
37
38end library optimiser_test_14;
39
40
1 .=member opttst16
2
3
4library optimiser_test_16;
5
6 $ nyu program id
7 $ author - s. freudenberger
8
9 exports
10 bug_16;
11
12 var l1, l2, l3;
13
14 repr
15 base b: integer;
16 l1, l2, l3: local set(elmt b);
17 end repr;
18
19
20 procedure bug_16;
21$
22$ the following test was first logged as opt bug 16 on 80-08-11
23$ by s. m. freudenberger. it was extended to its current form
24$ on 80-11-28, and ran successful on opt setl v80333.
25$
26 l2 := << 1, 2, 3 >>; l3 := << 4, 5, 6 >>;
27
28 assert l1 = om;
29 assert l2 = << 1, 2, 3 >>;
30 assert l3 = << 4, 5, 6 >>;
31
32 l1 := l2 + l3;
33
34 assert l1 = << 1, 2, 3, 4, 5, 6 >>;
35 assert l2 = << 1, 2, 3 >>;
36 assert l3 = << 4, 5, 6 >>;
37
38 end procedure bug_16;
39
40end library optimiser_test_16;
41
42
1 .=member opttst35
2
3
4library optimiser_test_35;
5
6 $ nyu program id
7 $ author - s. freudenberger
8
9 exports
10 bug_35;
11
12 var f, g, s, x, y;
13
14 init f := <>, g := <>, s := <>;
15
16 repr
17 plex base b;
18 f: local smap(elmt b) integer;
19 g: sparse smap(elmt b) integer;
20 s: local set(elmt b);
21 x, y: elmt b;
22 end repr;
23
24
25 procedure bug_35;
26
27$ this procedure does a short test to see whether plex bases are
28$ implemented.
29
30 loop forall i in <<1 .. 10>> do
31 x := newat; f(x) := i*i; g(x) := i; s with:= x;
32 end loop forall;
33
34 (forall i = g(y))
35 assert f(y) = i * g(y); assert y in s;
36 end forall;
37
38 end procedure bug_35;
39
40end library optimiser_test_35;
41
42
1 .=member opttsts
2
3
4library optimiser_tests;
5
6 $ nyu program id
7 $ author - s. freudenberger
8
9 libraries
10 optimiser_test_6,
11 optimiser_test_7,
12 optimiser_test_13,
13 optimiser_test_14,
14 optimiser_test_16,
15 optimiser_test_35;
16 exports
17 opt_tests;
18
19
20 var
21 error_mode, $ setl run-time error mode
22 error_limit, $ setl run-time error limit
23 print_mode; $ cims.setl.tst print mode
24
25
26 procedure opt_tests;
27
28 title('cims.setl.' + prog_level);
29
30 getem(error_mode, error_limit);
31
32 print_mode := getipp('assert=1/2');
33 if getipp('tdebug=0/1') = 1 then print_mode := print_debug; end;
34
35 print_head('optimiser regression tests');
36
37 bug_1; bug_2; bug_3; bug_4; bug_5;
38 bug_6; bug_7; bug_8; bug_9; bug_10;
39 bug_11; bug_12; bug_13; bug_14; bug_15;
40 bug_16; bug_17; bug_18; bug_19; bug_20;
41 bug_21; bug_22; bug_23; bug_24; bug_25;
42 bug_26; bug_27; bug_28; bug_29; bug_30;
43 bug_31; bug_32; bug_33; bug_34; bug_35;
smfd 2 bug_36; bug_37; bug_38;
44
45 print_tail('optimiser regression tests');
46
47 end procedure opt_tests;
48
49
50 procedure bug_1;
51$
52$ this test showed inconsistency in iterations over tuples between the
53$ interpreter and the general library routine w.r.t. omegas embedded in
54$ tuples.
55$
56 repr
57 t2: tuple(integer);
58 end repr;
59
60
smff 2 t := (/ 1, 2, 3, 4, 5, 6 /); t(3) := om; t(5) := om;
smff 3
smff 4 t3 := t2 := t1 := t;
62
63 assert (/ x : x in t1 /) = (/ x : x in t2 /);
64 assert (/ x : x in t2 /) = t3;
smff 5 assert t1 = t;
smff 6 assert t2 = t;
smff 7 assert t3 = t;
68
69 end procedure bug_1;
70
71
72 procedure bug_2;
73$
74$ this example showed that the conversion on a with-operation was done
75$ at the wrong place: the conversion should be done before, not after,
76$ the with operation.
77$
78 repr
79 base b: integer;
80 x: elmt b;
81 t1, t2: tuple(elmt b);
82 end repr;
83
84
85 t1 := (/ 1, 2, 3 /); x := 4;
86
87 assert (/1, 2, 3/) with x = (/ 1, 2, 3, 4 /);
88 assert t1 with x = (/ 1, 2, 3, 4 /);
89 assert (t2:=(/1,2,3/)) with x = (/ 1, 2, 3, 4 /);
90
91 end procedure bug_2;
92
93
94 procedure bug_3;
95$
96$ this example showed that the omega test for a base element was
97$ not always done correctly.
98$
99 repr
100 base b: string;
101 x: elmt b;
102 y: string;
103 end repr;
104
105
106 x := om; assert x = om;
107 y := om; x := y; assert y = om; assert x = om;
108
109 end procedure bug_3;
110
111
112 procedure bug_4;
113$
114$ test example 2 dealt with mixed tuples. the same holds true,
115$ of course, for set/map types.
116$
117 repr
118 f: smap(general) general;
119 s: set(general);
120 x: general;
121 end repr;
122
123
124 f := << (/ 1, 1 /), (/ 2, 4 /), (/ 3, 9 /) >>;
125 x := 2;
126 s := <>;
127
128 assert f = << (/ 1, 1 /), (/ 2, 4 /), (/ 3, 9 /) >>;
129 assert s = <>;
130 assert x = 2;
131
132 s := f with x;
133
134 assert f = << (/ 1, 1 /), (/ 2, 4 /), (/ 3, 9 /) >>;
135 assert s = << (/ 1, 1 /), (/ 2, 4 /), (/ 3, 9 /), 2 >>;
136 assert x = 2;
137
138 end procedure bug_4;
139
140
141 procedure bug_5;
142$
143$ the two maps f and g have the same hash code (at least in one
144$ particular implementation at a particular time): it showed a
145$ bug in the equality routine for map cases, where a branch was
146$ done under the negated condition.
147$
148 repr
149 base b: integer;
150 f, g: remote smap(elmt b) integer;
151 end repr;
152
153
154 f := << (/ 2, 1 /), (/ 1, 0 /) >>;
155 g := << (/ 3, 1 /), (/ 0, 0 /) >>;
156
157 assert f /= g;
158
159 end procedure bug_5;
160
161
162 procedure bug_8;
163
164 const x;
165
166 repr
167 base b: string;
168 x: elmt b;
169 end repr;
170
171
172 assert x = 'x';
173 assert type x = 'string';
174 assert is_string x = true;
175 assert is_atom x = false;
176
177 end procedure bug_8;
178
179
180 procedure bug_9;
181
182 f := << (/ 1, 1 /), (/ 2, 4 /), (/ 3, 9 /) >>;
183 assert f = << (/ 1, 1 /), (/ 2, 4 /), (/ 3, 9 /) >>;
184
185 f less:= (/1, 2/);
186 assert f = << (/ 1, 1 /), (/ 2, 4 /), (/ 3, 9 /) >>;
187
188 f less:= 2;
189 assert f = << (/ 1, 1 /), (/ 2, 4 /), (/ 3, 9 /) >>;
190
191 end procedure bug_9;
192
193
194 procedure bug_10;
195
196 s1 := << 1, 2, 3, 4, 5, 6, 7 >>;
197 s2 := << x : x in s1 >>;
198
199 assert s1 = << 1 .. 7 >>;
200 assert s2 = << 1 .. 7 >>;
201
202 end procedure bug_10;
203
204
205 procedure bug_11;
206
207 repr
208 s1, s2: set(integer);
209 end repr;
210
211
212 s1 := << 1, 2, 3, 4 >>;
213
214 if s1 = <> then
215 assert false;
216 else
217 s2 := <>;
218 end if;
219
220 assert s1 = << 1 .. 4 >>;
221 assert s2 = <>;
222
223 end procedure bug_11;
224
225
226 procedure bug_12;
227$
228$ this example shows a mode propagation bug in cod.fixasn. this has
229$ been fixed with v82060.
230$
231 t := (/ <> /) .dis/
232 (/tp : tp in <<(/<<'t_set'>>, (/<<'t_om'>>/), false/)>>/);
233
234 assert t = (/<<'t_set'>>, (/<<'t_om'>>/), false/);
235
236 end procedure bug_12;
237
238
239 operator .dis(t1, t2);
240
241 if t1 = (/ <> /) then return t2; end if;
242
243 end operator .dis;
244
245
246 procedure bug_15;
247
248 repr
249 f: mmap<> smap(integer) integer;
250 end repr;
251
252
253 f := <>; f<<1>><<2>> with:= 3;
254
255 assert f = << (/ 1, (/ 2, 3 /) /) >>;
256 assert f<<1>> = << (/ 2, 3 /) >>;
257 assert f<<1>><<2>> = << 3 >>;
258 assert f<<1>>(2) = 3;
259
260 end procedure bug_15;
261
262
263 procedure bug_17;
264$
265$ the following test was first logged as opt bug 17 on 80-10-08
266$ by s. m. freudenberger. it was extended to its current form
267$ on 80-11-28, and ran successful on opt setl v80333.
268$
269 repr
270 s: set(general);
271 end repr;
272
273
274 s := <>; assert s = <>;
275 s(10) := 'a'; assert s = << (/ 10, 'a' /) >>;
276
277 s with:= (/ 5, 'c' /);
278 assert s = << (/ 5, 'c' /), (/ 10, 'a' /) >>;
279
280 x := s(5);
281 assert s = << (/ 5, 'c' /), (/ 10, 'a' /) >>;
282
283 assert x = 'c';
284 s lessf:= 10; assert s = << (/ 5, 'c' /) >>;
285 s with:= 'x'; assert s = << (/ 5, 'c' /), 'x' >>;
286 s less:= (/ 5, 'c' /); assert s = << 'x' >>;
287
288
289 end procedure bug_17;
290
291
292 procedure bug_18;
293$
294$ the following was first logged as opt bug 18 on 80-10-16
295$ by s. m. freudenberger. it was extended to its current form
296$ on 80-11-28, and ran successful on opt setl v80333.
297$
298 repr
299 base b: integer;
300 f1, f2, f3: remote mmap<> set(integer);
301 x: elmt b;
302 end repr;
303
304
305 f1 := << (/ i, i*i /) : i in (/ 1 .. 10 /) >>; f2 := f1;
306 f1(x := 11) := 121; f3 := f1;
307
308 assert f1 = f3;
309 assert x = 11;
310
311 f1 lessf:= x;
312
313 assert f1<> = <>;
314 assert f1<> /= om;
315 assert arb f1<> = om;
316 assert f1(x) = om;
317
318 assert f1 = << (/ i, i*i /) : i in (/ 1 .. 10 /) >>;
319 assert f2 = << (/ i, i*i /) : i in (/ 1 .. 10 /) >>;
320 assert f3 = << (/ i, i*i /) : i in (/ 1 .. 11 /) >>;
321
322
323 end procedure bug_18;
324
325
326 procedure bug_19;
327$
328$ the following test was first logged as opt bug 19 on 80-10-14
329$ by s. m. freudenberger. it was extended to its current form
330$ on 80-11-28, and ran successful on opt setl v80333.
331$
332 repr
333 f: set(general);
334 i: integer;
335 j: string;
336 y: real;
337 end repr;
338
339
340 i := 5; j := 'a'; y := 10.0; f := <>;
341
342 f<><> with:= y;
343
344 assert f = << (/ 5, (/ 'a', 10.0 /) /) >>;
345 assert i = 5;
346 assert j = 'a';
347 assert y = 10.0;
348
349
350 end procedure bug_19;
351
352
353 procedure bug_20;
354$
355$ the following test was first logged as opt bug 20 on 80-10-15
356$ by s. m. freudenberger. it was extended to its current form
357$ on 80-11-28, and ran successful on opt setl v80333.
358$
359 repr
360 f1, g1: mmap(integer) integer;
361 f2, g2: smap(integer) integer;
362 end repr;
363
364 f1 := << (/ 1, 1 /), (/ 2, 4 /), (/ 3, 9 /), (/ 4, 16 /) >>;
365 f2 := f1;
366
367 assert f1<<3>> = << 9 >>;
368 assert f2(3) = 9;
369
370 g2 := << (/ 1, 1 /), (/ 2, 4 /), (/ 3, 9 /), (/ 4, 16 /) >>;
371 g1 := g2;
372
373 assert g1<<3>> = << 9 >>;
374 assert g2(3) = 9;
375
376 end procedure bug_20;
377
378
379 procedure bug_21;
380$
381$ the following test was first logged as opt bug 21 on 80-10-27
382$ by s. m. freudenberger. it was extended to its current form
383$ on 80-11-28, and ran successful on opt setl v80333.
384$ (this test originally produced a bad goto index in the equality
385$ routine.)
386$
387 repr
388 base b1: string;
389 base b2: remote mmap<>
390 sparse set(elmt b1);
391
392 f1, f2: elmt b2;
393 end repr;
394
395
396 f1 := << (/ 'a', 'b' /) >>; f2 := << (/ 'c', 'd' /) >>;
397
398 assert f1 /= f2;
399 assert f1 = << (/ 'a', 'b' /) >>;
400 assert f2 = << (/ 'c', 'd' /) >>;
401
402
403 end procedure bug_21;
404
405
406 procedure bug_22;
407$
408$ the following test was first logged as opt bug 22 on 80-11-13.
409$ by s. m. freudenberger. it was extended to its current form
410$ on 81-01-26, and ran successful under opt setl v81021.
411$
412 repr
413 base b1: integer;
414 base b2: tuple(elmt b1, string);
415
416 f: sparse smap(elmt b1) string;
417 x: elmt b2;
418 end repr;
419
420 x := (/ 3, 'a' /);
421 f := << (/ 3, 'a' /) >>;
422
423 assert x in f;
424 assert f = << (/ 3, 'a' /) >>;
425 assert x = (/ 3, 'a' /);
426
427 end procedure bug_22;
428
429
430 procedure bug_23;
431$
432$ the following test was first logged as opt bug 23 on 81-01-21
433$ by s. m. freudenberger. it was extended to its current form
434$ on 81-01-26, and ran successful on opt setl v81021.
435$ (this test originally uncovered a bug in lib.moregen: the
436$ conversion from s1 to s2 was not done correctly.)
437$
438 repr
439 base b1: tuple(string, integer);
440 base b2: elmt b1;
441
442 s1: remote set(elmt b1);
443 s2: remote set(elmt b2);
444 x1: elmt b1;
445 x2: elmt b2;
446 end repr;
447
448
449 s1 := << (/ 'x', 1 /), (/ 'y', 2 /) >>;
450 assert forall x1 in s1 st is_string x1(1) and is_integer x1(2);
451
452 s2 := s1;
453 assert forall x2 in s2 st is_string x2(1) and is_integer x2(2);
454
455
456 end procedure bug_23;
457
458
459 procedure bug_24;
460$
461$ the following test checks whether a modification to the code
462$ generator produces correct results. it improves membership
463$ tests, so that based tests are done whenever possible.
464$
465 repr
466 base b1: integer;
467 base b2: elmt b1;
468 base b3: elmt b2;
469 base b4: elmt b3;
470 base b5: remote set(elmt b1);
471
472 s1: remote set(elmt b1);
473 x1: elmt b1;
474 x2: elmt b2;
475 x3: elmt b3;
476 x4: elmt b4;
477 s5: elmt b5;
478 end repr;
479
480
481 s1 := s5 := << 1 .. 20 >>; x1 := x2 := x3 := x4 := 5;
482
483 assert x1 in s1; assert x1 in s5;
484 assert x2 in s1; assert x2 in s5;
485 assert x3 in s1; assert x3 in s5;
486 assert x4 in s1; assert x4 in s5;
487
488 end procedure bug_24;
489
490
491 procedure bug_25;
492$
493$ the following test was first logged as opt bug 25 on 81-01-29
494$ by s. m. freudenberger. it was included in its current form
495$ on 81-02-06, and ran successful under opt setl v81029.
496$
497 b := << 1, 3 .. 100 >>; c := << 1, 2 .. 10 >>;
498
499 b := b * c;
500
501 assert b = << 1, 3 .. 10 >>;
502 assert c = << 1, 2 .. 10 >>;
503
504 end procedure bug_25;
505
506
507 procedure bug_26;
508$
509$ this program shows an error in the conversion routine w.r.t.
510$ the range check on short integers.
511$
512 init
513 loser := (/ 1, 2, 3 /),
514 q := 1,
515 t := 3;
516
517 (/ loser(t), q /) := (/ q, loser(t) /);
518
519 assert loser = (/ 1, 2, 1 /);
520 assert q = 3;
521 assert t = 3;
522
523
524 end procedure bug_26;
525
526
527 procedure bug_27;
528$
529$ this procedure shows a code generator problem w.r.t. mode
530$ mode propagation on map retrievals: setl permits the index
531$ to be outside the map domain, which means that the index mode
532$ need not be convertable to the map domain mode. (it is, of
533$ course, a somewhat redundant operation then, which explains
534$ the original choice.)
535$
536 var f, x;
537
538 repr
539 f: smap(integer) integer;
540 x: string;
541 end repr;
542
543
544 f := << (/ i, i*i /) : i in << 1 .. 5 >> >>; x := 'a';
545
546 assert f(x) = om;
547 assert f<> = <>;
548
549 end procedure bug_27;
550
551
552 procedure bug_28;
553$
554$ in these examples, the else clause of the if-expression is an
555$ expression for which we like to back-propagate the result mode,
556$ but which cannot be converted to the result mode of the then-
557$ clause. this means that the result of the if-expression must
558$ yield a mode general, and we must reset it accordingly.
559$
560 var f, s, x;
561
562 repr
563 f: smap(string) string;
564 s: set(integer);
565 x: general;
566 end repr;
567
568
569 f := << (/ 'a', 'b' /), (/ 'b', 'b' /) >>;
570 s := << 1 .. 10 >>;
571 x := 'a';
572
573 assert if false then s else << x : i in s >> end = << 'a' >>;
574 assert if false then s else (/ x /) end = (/ 'a' /);
575 assert if false then s else domain f end = << 'a', 'b' >>;
576 assert if false then s else range f end = << 'b' >>;
577
578
579 end procedure bug_28;
580
581
582 procedure bug_29;
583$
584$ this program checks the modification to the representation of the
585$ case map
586$
587 const
588 b1 = << 1, 2, 3, 4, 5, 6, 7, 8, 9 >>;
589 var
590 x, y, z;
591 repr
592 base b1: integer;
593 base b2: string;
594 f: remote smap(elmt b2) elmt b1;
595 x: elmt b1;
596 y: elmt b2;
597 z: general;
598 end repr;
599
600
601 f := << (/ 'a', 1 /), (/ 'b', 2 /), (/ 'c', 3 /) >>;
602 x := 2; y := 'a'; z := 'c';
603
604 case x of
605 (1): assert false;
606 (2): assert true;
607 (3): assert false;
608 (4): assert false;
609 end case;
610
611 case y of
612 ('a'): assert true;
613 ('b'): assert false;
614 ('c'): assert false;
615 ('d'): assert false;
616 end case;
617
618 case z of
619 ('a'): assert false;
620 ('b'): assert false;
621 ('c'): assert true;
622 ('d'): assert false;
623 end case;
624
625 assert case x of
626 (1): false,
627 (2): true,
628 (3): false,
629 (4): false
630 else false
631 end;
632
633 assert case y of
634 ('a'): true,
635 ('b'): false,
636 ('c'): false,
637 ('d'): false
638 else false
639 end;
640
641 assert case z of
642 ('a'): false,
643 ('b'): false,
644 ('c'): true,
645 ('d'): false
646 else false
647 end;
648
649 case x of
650 (6): assert false;
651 (7): assert false;
652 (8): assert false;
653 else assert true;
654 end case;
655
656 case y of
657 ('x'): assert false;
658 ('y'): assert false;
659 ('z'): assert false;
660 else assert true;
661 end case;
662
663 case z of
664 ('x'): assert false;
665 ('y'): assert false;
666 ('z'): assert false;
667 else assert true;
668 end case;
669
670 assert case x of
671 (6): false,
672 (7): false,
673 (8): false
674 else true
675 end;
676
677 assert case y of
678 ('x'): false,
679 ('y'): false,
680 ('z'): false
681 else true
682 end;
683
684 assert case z of
685 ('x'): false,
686 ('y'): false,
687 ('z'): false
688 else true
689 end;
690
691 end procedure bug_29;
692
693
694 procedure bug_30;
695$
696$ this program shows an error in the code generator routine which emits
697$ conversions: if both a dereference operation and a conversion to a
698$ primitive mode is required, it should not fail.
699$
700 var x, y;
701
702 repr
703 base b: general;
704 x: elmt b;
705 y: integer;
706 end repr;
707
708 x := 1; y := x;
709
710 assert x = 1;
711 assert y = 1;
712 assert x = y;
713
714 end procedure bug_30;
715
716
717 procedure bug_31;
718$
719$ this procedure checks the modification to the operator precedences for
720$ binary compound operators.
721$
722 assert 2 * 3 +/ (/2/) = 8;
723 assert +/(/2/) = 2;
724
725 end procedure bug_31;
726
727
728 procedure bug_32;
729$
730$ this procedure checks the modification to the grammar w.r.t. what can
731$ indexed: the new definition allows a factor to be a parenthesised
732$ expression followed by an index.
733$
734 assert (if true then (/1/) else (/2/) end)(1) = 1;
735
736 end procedure bug_32;
737
738
739 procedure bug_33;
740$
741$ this procedure tests whether the ofcl and sofcl inline code sequences
742$ work properly.
743$
744 var s1, s2, s3; repr s1, s2, s3: string; end repr;
745
746 s1 := 'abc'; s2 := 'xyz'; s3 := s1;
747
748 assert s1 = 'abc';
749 assert s2 = 'xyz';
750 assert s3 = 'abc';
751
752 s1(2) := s2(2);
753
754 assert s1 = 'ayc';
755 assert s2 = 'xyz';
756 assert s3 = 'abc';
757
758 s1(2) := s2;
759
760 assert s1 = 'axyzc';
761 assert s2 = 'xyz';
762 assert s3 = 'abc';
763
764 end procedure bug_33;
765
766
767 procedure bug_34;
768$
769$ this procedure checks whether the correct code is generated to prevent
770$ loops to become infinite.
771$
772 assert card (/3, 4 .. 4/) = 2;
773 assert card (/3, 4 .. 3/) = 1;
774 assert card (/3, 4 .. 2/) = 0;
775
776 assert card (/3, 3 .. 4/) = 0;
777 assert card (/3, 3 .. 3/) = 0;
778 assert card (/3, 3 .. 2/) = 0;
779
780 assert card (/3, 2 .. 4/) = 0;
781 assert card (/3, 2 .. 3/) = 1;
782 assert card (/3, 2 .. 2/) = 2;
783
784 i := 3;
785
786 assert card (/i, i+1..4/) = 2;
787 assert card (/i, i+1..3/) = 1;
788 assert card (/i, i+1..2/) = 0;
789
790 assert card (/i, i .. 4/) = 0;
791 assert card (/i, i .. 3/) = 0;
792 assert card (/i, i .. 2/) = 0;
793
794 assert card (/i, i-1..4/) = 0;
795 assert card (/i, i-1..3/) = 1;
796 assert card (/i, i-1..2/) = 2;
797
798 j := 4;
799
800 assert card (/i, j .. 4/) = 2;
801 assert card (/i, j .. 3/) = 1;
802 assert card (/i, j .. 2/) = 0;
803
804 j := 3;
805
806 assert card (/i, j .. 4/) = 0;
807 assert card (/i, j .. 3/) = 0;
808 assert card (/i, j .. 2/) = 0;
809
810 j := 2;
811
812 assert card (/i, j .. 4/) = 0;
813 assert card (/i, j .. 3/) = 1;
814 assert card (/i, j .. 2/) = 2;
815
816 end procedure bug_34;
smfd 3
smfd 4
smfd 5 procedure bug_36;
smfd 6$
smfd 7$ version: v27 = 83073
smfd 8$ systems: all
smfd 9$ reported 21-mar-1983 by s. freudenberger
smfd 10$ fixed 21-mar-1983 by s. freudenberger
smfd 11$
smfd 12$ problem: stllib stores the symbol table index instead of the sample
smfd 13$ value when modifying mixed tuples.
smfd 14$
smfd 15 var t1, t2, t3, t4, t5, t6;
smfd 16
smfd 17 repr
smfd 18 t1, t4: tuple;
smfd 19 t2, t5: tuple(general, integer, integer 1..10, integer);
smfd 20 t3, t6: tuple(untyped integer);
smfd 21 end repr;
smfd 22
smfd 23 t1 := (//); t1(1) := 1; t1(4) := 4;
smfd 24 t6 := t5 := t4 := t3 := t2 := t1;
smfd 25
smfd 26 x frome t1; x frome t2; x frome t3;
smfd 27 t4(#t4) := om; t5(#t5) := om; t6(#t6) := om;
smfd 28
smfd 29 assert t1 = t2 and t2 = t3 and t3 = t4 and t4 = t5 and t5 = t6;
smfd 30 assert t1 = t2 and t1 = t3 and t1 = t4 and t1 = t5 and t1 = t6;
smfd 31
smfd 32 end procedure bug_36;
smfd 33
smfd 34
smfd 35 procedure bug_37;
smfd 36$
smfd 37$ version: v27 = 83077
smfd 38$ systems: all
smfd 39$ reported 22-mar-1983 by s. freudenberger
smfd 40$ fixed 23-mar-1983 by s. freudenberger
smfd 41$
smfd 42$ problem: cod inhibits the result of domain to be a map; however,
smfd 43$ the optimiser treats all sets of pairs as maps.
smfd 44$
smfd 45 var f, s;
smfd 46 var i;
smfd 47
smfd 48 repr
smfd 49 base b: tuple(integer 0..65536, integer 0..65536);
smfd 50 f: remote mmap<> set(boolean);
smfd 51 s: mmap<> set(integer 0..65536);
smfd 52 i: integer 0..65536;
smfd 53 end repr;
smfd 54
smfd 55 f := <<(/(/i, i*i/), even i/) : i in (/1..5/)>>;
smfd 56 s := domain f;
smfd 57
smfd 58 assert f = <<(/(/i, i*i/), even i/) : i in (/1..5/)>>;
smfd 59 assert s = <<(/i, i*i/) : i in (/1..5/)>>;
smfd 60
smfd 61 end procedure bug_37;
smfd 62
smfd 63
smfd 64 procedure bug_38;
smfd 65$
smfd 66$ version: v28 = 83244
smfd 67$ systems: all
smfd 68$ reported 4-sep-1983 by s. freudenberger
smfd 69$ fixed 5-sep-1983 by s. freudenberger (no new version number)
smfd 70$
smfd 71$ problem: cod generates a conversion that can cause run-time error;
smfd 72$ in the particular context, a conversion may only be
smfd 73$ emitted if no run-time error can result.
smfd 74$
smfd 75 var f, x;
smfd 76
smfd 77 repr
smfd 78 base b1: integer;
smfd 79 base b2: tuple(elmt b1, tuple(elmt b1), integer);
smfd 80 f: remote smap(elmt b2) tuple(integer, integer);
smfd 81 x: tuple(integer, general, integer);
smfd 82 end repr;
smfd 83
smfd 84 f := <<(/(/1, (/2, 3, 4/), 2/), (/2, 3/)/)>>;
smfd 85 x := (/6, 'a', 1/);
smfd 86 assert f(x) = om;
smfd 87
smfd 88 end procedure bug_38;
817
818
819end library optimiser_tests;
820
821
1 .=member directory
2 directory test;
3
4 var
5 error_mode, $ setl run-time error mode
6 error_limit, $ setl run-time error limit
7 print_mode; $ cims.setl.tst print mode
8
9
10 program test - main:
11
12 imports
13 binary_ops,
14 unary_ops,
15 string_primitive_test,
16 parse_test,
17 heap_sort_test,
18 prime_factorization_test,
19 set_identity_test,
20 union_test_2,
21 power_set_test,
smfc 2 map_identity_test,
22 circularity_test,
23 quantifier_test,
24 recursion_test,
25 median_test,
26 huffman_coding_test,
27 tarjan_test,
28 iterator_test_1,
29 iterator_test_2,
30 tree_print,
31 opt_tests;
32 writes
33 error_mode,
34 error_limit,
35 print_mode;
36
37
38 module test - binary_operators:
39
40 $ author - s. freudenberger (nyu-cims) (15-dec-78)
41
42 exports
43 binary_ops;
44 reads
45 print_mode,
46 error_mode;
47 writes
48 error_limit;
49
50
51 module test - unary_operators:
52
53 $ author - s. freudenberger (nyu-cims) (15-aug-81)
54
55 exports
56 unary_ops;
57 reads
58 print_mode,
59 error_mode;
60 writes
61 error_limit;
62
63
64 module test - string_primitives:
65
66 $ authors - s. freudenberger (nyu-cims) (15-dec-78)
67 $ - j. schwartz (nyu-cims) (16-feb-79)
68
69 exports
70 string_primitive_test,
71 parse_test;
72 reads
73 error_mode,
74 print_mode;
75 writes
76 error_limit;
77
78
79 module test - heapsort:
80
81 $ author - d. shields (nyu-cims) (15-dec-78)
82
83 exports
84 heap_sort_test;
85 reads
86 print_mode;
87
88
89 module test - prime_factorization:
90
91 $ author - j. schwartz (nyu-cims) (25-jan-79)
92
93 exports
94 prime_factorization_test;
95 reads
96 print_mode;
97
98
99 module test - set_identities:
100
101 $ author - e. weixelbaum (nyu-cims) (25-jan-79)
102
103 exports
104 set_identity_test;
105 reads
106 print_mode;
107
108
109 module test - union_2:
110
111 $ author - c. goss (nyu-cims) (25-jan-79)
112
113 exports
114 union_test_2;
115 reads
116 print_mode;
117
118
119 module test - power_set:
120
121 $ author h. lewis (nyu-cims) (02-feb-79)
122
123 exports
124 power_set_test;
125 reads
126 print_mode;
127
smfc 3
smfc 4 module test - map_identities:
smfc 5
smfc 6 $ author - larry rudolph (nyu-cims)
smfc 7 $ completed by s. freudenberger (nyu-cims) (29-aug-83)
smfc 8
smfc 9 exports
smfc 10 map_identity_test;
smfc 11 reads
smfc 12 print_mode;
smfc 13
128
129 module test - circularity:
130
131 $ author - r. lee (nyu-cims) (02-feb-79)
132
133 exports
134 circularity_test;
135 reads
136 print_mode;
137
138
139 module test - quantifiers:
140
141 $ author - r. lee (nyu-cims)
142
143 exports
144 quantifier_test;
145 reads
146 print_mode;
147
148
149 module test - recursion:
150
151 $ author - j. schwartz (nyu-cims) (02-feb-79)
152
153 exports
154 recursion_test;
155 reads
156 print_mode;
157
158
159 module test - median_finder:
160
161 $ author - henry warren (nyu-cims) (20-feb-79)
162
163 exports
164 median_test;
165 reads
166 print_mode;
167
168
169 module test - huffman_coding:
170
171 $ author - j. schwartz (nyu-cims) (19-feb-79)
172
173 exports
174 huffman_coding_test;
175 reads
176 print_mode;
177
178
179 module test - tarjan:
180
181 $ tarjan-s fast interval finder.
182 $ (see setl newsletter no. 204 for details) (15-dec-78)
183
184 exports
185 tarjan_test;
186 reads
187 print_mode;
188
189
190 module test - iterators_1:
191
192 $ author - r. lee (nyu-cims) (15-dec-78)
193
194 exports
195 iterator_test_1;
196 reads
197 print_mode;
198
199
200 module test - iterators_2:
201
202 $ author - r. lee (nyu-cims) (15-dec-78)
203
204 exports
205 iterator_test_2;
206 reads
207 print_mode;
208
209
210 module test - input_output:
211
212 $ author - j. schwartz (nyu-cims) (20-feb-79)
213
214 exports
215 tree_print;
216 reads
217 print_mode;
218
219
220 end directory test;
1 .=member setlmain
2 program test - main;
3
4 title('cims.setl.' + prog_level);
5
6 getem(error_mode, error_limit);
7
8 print_mode := getipp('assert=1/2');
9 if getipp('tdebug=0/1') = 1 then print_mode := print_debug; end;
10
11 binary_ops;
12 unary_ops;
13 string_primitive_test;
14 parse_test;
15
16 heap_sort_test;
17 prime_factorization_test;
18
19 set_identity_test; $ test 5
20 union_test_2; $ test 6
21 power_set_test; $ test 8
smfc 14 map_identity_test; $ test 9
22 circularity_test; $ test 16
23 quantifier_test; $ test 24
24 recursion_test; $ test 28
25
26 median_test;
27 huffman_coding_test;
28 tarjan_test;
29
30 iterator_test_1;
31 iterator_test_2;
32
33 tree_print;
34 opt_tests;
35
36 end program test - main;
37
38
39
40
1 .=member binops
2 module test - binary_operators;
3
4 $ nyu test id
5 $ author - s. freudenberger (nyu-cims)
6
7 exports
8 binary_ops; $ tests binary operators
9 reads
10 print_mode,
11 error_mode;
12 writes
13 error_limit;
14
15
16 const
17 eps = 0.1e-04,
18
19 ptupb = <<13, 14, 15>>,
20 lsetb = <<5, 6, 7, 8, 9>>,
suna 2 rsetb = <<10, 11, 12, 13, 14>>;
suna 3
suna 4 init
suna 5 sivar := 3,
suna 6 simax := maxsi,
suna 7 livar := -3,
suna 8 revar := 3.0,
suna 9 lcvar := 'abc',
suna 10
suna 11 sttup := (/1, 2, 3/),
suna 12 uitup := (/4, 5, 6/),
suna 13 urtup := (/7.0, 8.0, 9.0/),
suna 14 pitup := (/10, 11, 12/),
suna 15 pbtup := (/13, 14, 15/),
suna 16
suna 17 uset1 := << 1, 2, 3>>,
suna 18 uset2 := << 0, 2, 4>>,
suna 19 lset1 := << 6, 7, 8>>,
suna 20 lset2 := << 5, 7, 9>>,
suna 21 rset1 := <<11, 12, 13>>,
suna 22 rset2 := <<10, 12, 14>>;
43
44 repr
45 sivar, simax, livar: integer;
46 eps, revar: real;
47 lcvar: string;
48
49 base ptupb: integer;
50 uitup: tuple(untyped integer);
51 urtup: tuple(untyped real);
52 pitup: packed tuple(integer 10...12);
53 pbtup: packed tuple(elmt ptupb);
54
55 base lsetb: integer;
56 lset1, lset2: local set(elmt lsetb);
57
58 base rsetb: integer;
59 rset1, rset2: remote set(elmt rsetb);
60
61 end repr;
62
63
64 proc binary_ops;
65
66 print_head('binary operator test');
67
70 if print_mode = print_debug then
71 print;
72
73 print('short integer = ', sivar);
74 print('max short int = ', simax);
75 print('long integer = ', livar);
76 print('epsilon = ', eps );
77 print('real = ', revar);
78 print('long char string =', lcvar);
79
80 print('standard tuple = ', sttup);
81 print('untyped int tup = ', uitup);
82 print('untyped real tup =', urtup);
83 print('packed int tup = ', pitup);
84 print('packed based tup =', pbtup);
85
86 print('unbased set 1 = ', uset1);
87 print('unbased set 2 = ', uset2);
88 print('local set 1 = ', lset1);
89 print('local set 2 = ', lset2);
90 print('remote set 1 = ', rset1);
91 print('remote set 2 = ', rset2);
92 end if;
93
94 add_test; $ tests -add- routine
95 diff_test; $ tests -diff- routine
96 div_test; $ tests -div- routine
97 slash_test; $ tests -slash- routine
98 smod_test; $ tests -smod- routine
99 mult_test; $ tests -mult- routine
100 sexp_test; $ tests -sexp- routine
101 with_test; $ tests -with- routine
102$ less_test; $ tests -less- routine
103$ from_test; $ tests -from- routine
104 incs_test; $ tests -incs- routine
105 npow_test; $ tests -npow- routine
suna 23
suna 24 assert sivar = 3;
suna 25 assert simax = maxsi;
suna 26 assert livar = -3;
suna 27 assert lcvar = 'abc';
suna 28
suna 29 assert abs(revar - 3.0) < eps;
suna 30
suna 31 assert sttup = (/1, 2, 3/);
suna 32 assert uitup = (/4, 5, 6/);
suna 33 assert urtup = (/7.0, 8.0, 9.0/);
null 1$$$--- first need to fix ltlasm...
null 2$$-- assert pitup = (/10, 11, 12/);
null 3$$-- assert pbtup = (/13, 14, 15/);
suna 36
suna 37 assert uset1 = << 1, 2, 3>>;
suna 38 assert uset2 = << 0, 2, 4>>;
suna 39 assert lset1 = << 6, 7, 8>>;
suna 40 assert lset2 = << 5, 7, 9>>;
suna 41 assert rset1 = <<11, 12, 13>>;
suna 42 assert rset2 = <<10, 12, 14>>;
106
107 print_tail('binary operator test');
108
109 end proc binary_ops;
110
111
112 proc add_test;
113
114 print_head('addition test');
115
116 assert sivar + sivar = 6 ;
117 assert sivar + livar = 0 ;
118 assert simax + simax = 262142 ;
119 assert livar + sivar = 0 ;
120 assert livar + livar = -6 ;
121 assert abs( (revar + revar) - 6.0 ) < eps;
122 assert lcvar + lcvar = 'abcabc' ;
123 assert sttup + sttup = (/1, 2, 3, 1, 2, 3/) ;
124 assert sttup + uitup = (/1, 2, 3, 4, 5, 6/) ;
125 assert uitup + sttup = (/4, 5, 6, 1, 2, 3/) ;
126 assert uitup + uitup = (/4, 5, 6, 4, 5, 6/) ;
127 assert uset1 + uset2 = <<0, 1, 2, 3, 4>> ;
128 assert uset1 + lset1 = <<1, 2, 3, 6, 7, 8>> ;
129 assert uset1 + rset1 = <<1, 2, 3, 11, 12, 13>> ;
130 assert lset1 + uset1 = <<1, 2, 3, 6, 7, 8>> ;
131 assert lset1 + lset2 = <<5, 6, 7, 8, 9>> ;
132 assert lset1 + rset1 = <<6, 7, 8, 11, 12, 13>> ;
133 assert rset1 + uset1 = <<1, 2, 3, 11, 12, 13>> ;
134 assert rset1 + lset1 = <<6, 7, 8, 11, 12, 13>> ;
135 assert rset1 + rset2 = <<10, 11, 12, 13, 14>> ;
136
137 print;
138 error_limit +:= 9; setem(error_mode, error_limit);
139 print ( 'error messages om.13 and type.02',
140 'should follow this line.' );
141 echeck( om + om );
142 print ( 'error message type.03 should follow this line.' );
143 echeck( sivar + om );
144 print ( 'error message type.03 should follow this line.' );
145 echeck( livar + om );
146 print ( 'error message type.03 should follow this line.' );
147 echeck( lcvar + om );
148 print ( 'error message type.03 should follow this line.' );
149 echeck( revar + om );
150 print ( 'error message type.03 should follow this line.' );
151 echeck( sttup + om );
152 print ( 'error message type.03 should follow this line.' );
153 echeck( uitup + om );
154 print ( 'error message type.03 should follow this line.' );
155 echeck( uset1 + om );
156
157 print_tail('addition test');
158
159 end proc add_test;
160
161
162 proc diff_test;
163
164 print_head('difference test');
165
166 assert sivar - sivar = 0 ;
167 assert sivar - simax = -131068 ;
168 assert sivar - livar = 6 ;
169 assert livar - sivar = -6 ;
170 assert livar - livar = 0 ;
171 assert abs( (revar - revar) - 0.0 ) < eps;
172 assert uset1 - uset2 = <<1, 3>> ;
173 assert lset1 - lset2 = <<6, 8>> ;
174 assert rset1 - rset2 = <<11, 13>> ;
175
176 print;
177 error_limit +:= 9; setem(error_mode, error_limit);
178 print ( 'error messages om.13 and type.04',
179 'should follow this line.' );
180 echeck( om - om );
181 print ( 'error message type.04 should follow this line.' );
182 echeck( lcvar - om );
183 print ( 'error message type.04 should follow this line.' );
184 echeck( sttup - om );
185 print ( 'error message type.04 should follow this line.' );
186 echeck( uitup - om );
187 print ( 'error message type.05 should follow this line.' );
188 echeck( sivar - om );
189 print ( 'error message type.05 should follow this line.' );
190 echeck( livar - om );
191 print ( 'error message type.05 should follow this line.' );
192 echeck( revar - om );
193 print ( 'error message type.05 should follow this line.' );
194 echeck( uset1 - om );
195
196 print_tail('difference test');
197
198 end proc diff_test;
199
200
201 proc div_test;
202 var temp; repr temp: general; end repr;
203
204 print_head('integer division test');
205
206 assert sivar div sivar = 1 ;
207 assert sivar div livar = -1 ;
208 assert simax div sivar = 43690 ;
209 assert simax div livar = -43690 ;
210 assert livar div sivar = -1 ;
211 assert livar div livar = 1 ;
212
213 print;
214 error_limit +:= 8; setem(error_mode, error_limit);
215 print ( 'error message type.06 should follow this line.' );
216 echeck( om div om );
217 print ( 'error message type.06 should follow this line.' );
218 temp := revar;
219 echeck( temp div om );
220 print ( 'error message type.06 should follow this line.' );
221 temp := lcvar;
222 echeck( temp div om );
223 print ( 'error message type.06 should follow this line.' );
224 temp := sttup;
225 echeck( temp div om );
226 print ( 'error message type.06 should follow this line.' );
227 temp := uitup;
228 echeck( temp div om );
229 print ( 'error message type.06 should follow this line.' );
230 temp := uset1;
231 echeck( temp div om );
232 print ( 'error message type.07 should follow this line.' );
233 echeck( sivar div om );
234 print ( 'error message type.07 should follow this line.' );
235 echeck( livar div om );
236
237 print_tail('integer division test');
238
239 end proc div_test;
240
241
242 proc slash_test;
243
244 print_head('real division test');
245
246 assert abs( (sivar / sivar) - 1.0 ) < eps;
247 assert abs( (sivar / livar) - -1.0 ) < eps;
248 assert abs( (livar / sivar) - -1.0 ) < eps;
249 assert abs( (livar / livar) - 1.0 ) < eps;
250 assert abs( (revar / revar) - 1.0 ) < eps;
251
252 print;
253 error_limit +:= 8; setem(error_mode, error_limit);
254 print ( 'error message type.08 should follow this line.' );
255 echeck( om / om );
256 print ( 'error message type.08 should follow this line.' );
257 echeck( lcvar / om );
258 print ( 'error message type.08 should follow this line.' );
259 echeck( sttup / om );
260 print ( 'error message type.08 should follow this line.' );
261 echeck( uitup / om );
262 print ( 'error message type.08 should follow this line.' );
263 echeck( uset1 / om );
264 print ( 'error message type.09 should follow this line.' );
265 echeck( sivar / om );
266 print ( 'error message type.09 should follow this line.' );
267 echeck( livar / om );
268 print ( 'error message type.09 should follow this line.' );
269 echeck( revar / om );
270
271 print_tail('real division test');
272
273 end proc slash_test;
274
275
276 proc smod_test;
277
278 print_head('modulo test');
279
280 assert sivar mod sivar = 0 ;
281 assert sivar mod livar = 0 ;
282 assert simax mod sivar = 1 ;
283 assert simax mod livar = 1 ;
284 assert livar mod sivar = 0 ;
285 assert livar mod livar = 0 ;
286 assert uset1 mod uset2 = <<0, 1, 3, 4>> ;
287 assert lset1 mod lset2 = <<5, 6, 8, 9>> ;
288 assert rset1 mod rset2 = <<10, 11, 13, 14>> ;
289
290 print;
291 error_limit +:= 8; setem(error_mode, error_limit);
292 print ( 'error message type.10 should follow this line.' );
293 echeck( om mod om );
294 print ( 'error message type.10 should follow this line.' );
295 echeck( lcvar mod om );
296 print ( 'error message type.10 should follow this line.' );
297 echeck( revar mod om );
298 print ( 'error message type.10 should follow this line.' );
299 echeck( sttup mod om );
300 print ( 'error message type.10 should follow this line.' );
301 echeck( uitup mod om );
302 print ( 'error message type.11 should follow this line.' );
303 echeck( sivar mod om );
304 print ( 'error message type.11 should follow this line.' );
305 echeck( livar mod om );
306 print ( 'error message type.11 should follow this line.' );
307 echeck( uset1 mod om );
308
309 print_tail('modulo test');
310
311 end proc smod_test;
312
313
314 proc mult_test;
315
316 const one = 1, zero = 0;
317
318 var uset3; init uset3 := <<2, 5>>;
319
320 print_head('multiplication test');
321
322 assert sivar * sivar = 9 ;
323 assert sivar * livar = -9 ;
324 assert sivar * lcvar = 'abcabcabc' ;
325 assert sivar * sttup = (/1, 2, 3, 1, 2, 3, 1, 2, 3/) ;
326 assert sivar * uitup = (/4, 5, 6, 4, 5, 6, 4, 5, 6/) ;
327 assert simax * sivar = 393213 ;
328 assert simax * livar = -393213 ;
329 assert livar * sivar = -9 ;
330 assert livar * livar = 9 ;
331 assert abs( (revar * revar) - 9.0 ) < eps;
332 assert lcvar * sivar = 'abcabcabc' ;
333 assert lcvar * one = 'abc' ;
334 assert lcvar * zero = '' ;
335 assert sttup * sivar = (/1, 2, 3, 1, 2, 3, 1, 2, 3/) ;
336 assert sttup * one = (/1, 2, 3/) ;
337 assert sttup * zero = (//) ;
338 assert uitup * sivar = (/4, 5, 6, 4, 5, 6, 4, 5, 6/) ;
339 assert uitup * one = (/4, 5, 6/) ;
340 assert uitup * zero = (//) ;
341 assert uset1 * uset2 = <<2>> ;
342 assert uset1 * uset3 = <<2>> ;
343 assert uset3 = <<2, 5>> ;
344 assert lset1 * lset2 = <<7>> ;
345 assert rset1 * rset2 = <<12>> ;
346
347 print;
348 error_limit +:= 9; setem(error_mode, error_limit);
349 print ( 'error messages om.13 and type.12',
350 'should follow this line.' );
351 echeck( om * om );
352 print ( 'error message type.13 should follow this line.' );
353 echeck( sivar * om );
354 print ( 'error message type.13 should follow this line.' );
355 echeck( livar * om );
356 print ( 'error message type.13 should follow this line.' );
357 echeck( lcvar * om );
358 print ( 'error message type.13 should follow this line.' );
359 echeck( revar * om );
360 print ( 'error message type.13 should follow this line.' );
361 echeck( sttup * om );
362 print ( 'error message type.13 should follow this line.' );
363 echeck( uitup * om );
364 print ( 'error message type.13 should follow this line.' );
365 echeck( uset1 * om );
366
367 print_tail('multiplication test');
368
369 end proc mult_test;
370
371
372 proc sexp_test;
373
374 print_head('exponentation test');
375
376 assert abs( ( 5.0 ** 2.0) - 25.0 ) < eps;
377 assert abs( ( 5.0 ** 0.0) - 1.0 ) < eps;
378 assert abs( ( 5.0 ** -1.0) - 0.2 ) < eps;
379 echeck( 0.0 ** 2.0 );
380 echeck( 0.0 ** 0.0 );
381 echeck( 0.0 ** -2.0 );
382 echeck( -3.0 ** 2.0 );
383 echeck( -3.0 ** 0.0 );
384 echeck( -3.0 ** -2.0 );
385 assert abs( ( 5.0 ** 2) - 25.0 ) < eps;
386 assert abs( ( 5.0 ** 0) - 1.0 ) < eps;
387 assert abs( ( 2.0 ** -2) - 0.25 ) < eps;
388 assert abs( ( 0.0 ** 2) - 0.0 ) < eps;
389 echeck( 0.0 ** 0 );
390 echeck( 0.0 ** -2 );
391 assert abs( ( -2.0 ** 3) - -8.0 ) < eps;
392 assert abs( ( -2.0 ** 2) - 4.0 ) < eps;
393 assert abs( ( -2.0 ** 0) - 1.0 ) < eps;
394 assert abs( ( -2.0 ** -2) - 0.25 ) < eps;
395 assert abs( ( -2.0 ** -3) - -0.125 ) < eps;
396 assert 2 ** 2 = 4 ;
397 assert 2 ** 0 = 1 ;
398 assert abs( ( 2 ** -2) - 0.25 ) < eps;
399 assert 0 ** 2 = 0 ;
400 echeck( 0 ** 0 );
401 echeck( 0 ** -2 );
402 assert -2 ** 3 = -8 ;
403 assert -2 ** 2 = 4 ;
404 assert -2 ** 0 = 1 ;
405 assert abs( ( -2 ** -2) - 0.25 ) < eps;
406 assert abs( ( -2 ** -3) - -0.125 ) < eps;
407
408 print;
409 error_limit +:= 5; setem(error_mode, error_limit);
410 print ( 'error message om.22 should follow this line.' );
411 echeck( om ** 2.0 );
412 print ( 'error message om.23 should follow this line.' );
413 echeck( 2.0 ** om );
414 print ( 'error message type.52 should follow this line.' );
415 echeck( 'a' ** 2.0 );
416 print ( 'error message type.53 should follow this line.' );
417 echeck( 2.0 ** 'a' );
418 print ( 'error message type.53 should follow this line.' );
419 echeck( 2 ** 5.0 );
420
421 print_tail('exponentation test');
422
423 end proc sexp_test;
424
425
426 proc with_test;
427
428 var s;
429 init s := <<1>>;
430
431 print_head('with routine test');
432
433 s with:= s;
434 s with:= s;
435 assert s = <<1, <<1>>, <<1, <<1>>>> >>;
436
437 s := om;
438
439 print_tail('with routine test');
440
441 end proc with_test;
442
443
444 proc incs_test;
445
446 print_head('set inclusion test');
447
448 temp1 := <<1, 2, 3, 4>>;
449
450 assert temp1 incs uset1 = true ;
451 assert uset1 incs uset1 = true ;
452 assert uset1 incs temp1 = false ;
453 assert temp1 incs uset2 = false ;
454 assert uset2 incs temp1 = false ;
455 assert uset1 incs <> = true ;
456
457 print;
458 error_limit +:= 2; setem(error_mode, error_limit);
459 print ( 'error message type.46 should follow this line.' );
460 assert om incs uset1 = false ;
461 print ( 'error message type.47 should follow this line.' );
462 assert uset1 incs om = false ;
463
464 print_tail('set inclusion test');
465
466 end proc incs_test;
467
468
469 proc npow_test;
470
471 print_head('k-subset test');
472
473 echeck( -1 npow uset1 );
474 assert 0 npow uset1 = <<<>>> ;
475 assert 1 npow uset1 = <<<<1>>, <<2>>, <<3>>>> ;
476 assert 2 npow uset1 = <<<<1, 2>>, <<1, 3>>, <<2, 3>>>> ;
477 assert 3 npow uset1 = <<<<1, 2, 3>>>> ;
478 assert 4 npow uset1 = <> ;
479 assert uset1 npow sivar = <<<<1, 2, 3>>>> ;
480
481 print;
482 error_limit +:= 2; setem(error_mode, error_limit);
483 print ( 'error message type.49 should follow this line.' );
484 echeck( om npow om );
485 print ( 'error message type.01 should follow this line.' );
486 echeck( uset1 npow uset2 );
487
488 print_tail('k-subset test');
489
490 end proc npow_test;
491
492
493 proc echeck(rd a);
494
495 if error_mode = 4 then
496 print(a);
497
498 elseif a /= om then
499 print;
500 print(25 * '*');
501 print('incorrect error value:', a);
502 print;
503
504 end if;
505
506 end proc echeck;
507
508
509 end module test - binary_operators;
510
511
512
513
1 .=member unops
2
3
4module test - unary_operators;
5
6 $ nyu test id
7 $ author - s. freudenberger (nyu-cims)
8
9 exports
10 unary_ops; $ tests unary operators
11 reads
12 print_mode,
13 error_mode;
14 writes
15 error_limit;
16
17
18 const
19 s = << 1, 3, 5 >>,
20 d1 = << 1, 9, 25 >>,
21 d2 = << 1, 27, 125 >>,
22 d3 = << 1, 81, 625 >>,
23 r1 = << 1, 9, 25 >>,
24 r2 = << 1, 27, 125 >>,
25 r3 = << 1, 81, 625 >>,
26 r4 = << 1, 3, 5, 9, 25 >>,
27 r5 = << 1, 3, 5, 27, 125 >>,
28 r6 = << 1, 3, 5, 81, 625 >>;
29
30 var
31 s1, s2, s3,
32 f1, f2, f3, f4, f5, f6,
33 lset, rset, sset,
34 lsm1, rsm1, ssm1, lmm1, rmm1, smm1,
35 lsm2, rsm2, ssm2, lmm2, rmm2, smm2,
36 lsm3, rsm3, ssm3, lmm3, rmm3, smm3;
37
38 repr
39 base b1: integer;
40 base b2: integer;
41 base b3: elmt b2;
42
43 s1: general;
44 s2: set(general);
45 s3: set(integer);
46
47 lset: local set(elmt b1);
48 rset: remote set(elmt b1);
49 sset: sparse set(elmt b1);
50
51 f1: general;
52 f2: smap(general) integer;
53 f3: smap(integer) integer;
54
55 lsm1: local smap(elmt b1) elmt b1;
56 rsm1: remote smap(elmt b1) elmt b1;
57 ssm1: sparse smap(elmt b1) elmt b1;
58
59 lsm2: local smap(elmt b2) elmt b2;
60 rsm2: remote smap(elmt b2) elmt b2;
61 ssm2: sparse smap(elmt b2) elmt b2;
62
63 lsm3: local smap(elmt b3) elmt b3;
64 rsm3: remote smap(elmt b3) elmt b3;
65 ssm3: sparse smap(elmt b3) elmt b3;
66
67 f4: general;
68 f5: mmap<> set(general);
69 f6: mmap<> set(integer);
70
71 lmm1: local mmap<> sparse set(elmt b1);
72 rmm1: remote mmap<> sparse set(elmt b1);
73 smm1: sparse mmap<> sparse set(elmt b1);
74
75 lmm2: local mmap<> sparse set(elmt b2);
76 rmm2: remote mmap<> sparse set(elmt b2);
77 smm2: sparse mmap<> sparse set(elmt b2);
78
79 lmm3: local mmap<> sparse set(elmt b3);
80 rmm3: remote mmap<> sparse set(elmt b3);
81 smm3: sparse mmap<> sparse set(elmt b3);
82 end repr;
83
84
85 procedure unary_ops;
86
87 print_head('unary operator tests');
88
89 dom_test; $ tests -domain- operator
90 range_test; $ tests -range- operator
91
92 print_tail('unary operator tests');
93
94 end procedure unary_ops;
95
96
97 procedure dom_test;
98
99
100 print_head('domain test');
101
102 f1 := << (/ x**2, x /) : x in s >>;
103 f2 := << (/ x**3, x /) : x in s >>;
104 f3 := << (/ x**4, x /) : x in s >>;
105
106 lsm1 := lmm1 := rsm1 := rmm1 := ssm1 := smm1 := f1;
107 lsm2 := lmm2 := rsm2 := rmm2 := ssm2 := smm2 := f2;
108 lsm3 := lmm3 := rsm3 := rmm3 := ssm3 := smm3 := f3;
109
110 unbased_cases;
111 based_cases;
112
113 assert f1 = lsm1; assert f1 = rsm1; assert f1 = ssm1;
114 assert f2 = lsm2; assert f2 = rsm2; assert f2 = ssm2;
115 assert f3 = lsm3; assert f3 = rsm3; assert f3 = ssm3;
116 assert f1 = lmm1; assert f1 = rmm1; assert f1 = smm1;
117 assert f2 = lmm2; assert f2 = rmm2; assert f2 = smm2;
118 assert f3 = lmm3; assert f3 = rmm3; assert f3 = smm3;
119
120 assert f1 = << (/ x**2, x /) : x in s >>;
121 assert f2 = << (/ x**3, x /) : x in s >>;
122 assert f3 = << (/ x**4, x /) : x in s >>;
123
124 print_tail('domain test');
125
126
127 end procedure dom_test;
128
129
130 procedure unbased_cases;
131
132 s1 := domain f1; assert s1 = d1;
133 s2 := domain f1; assert s2 = d1;
134 s3 := domain f1; assert s3 = d1;
135
136 s1 := domain f2; assert s1 = d2;
137 s2 := domain f2; assert s2 = d2;
138 s3 := domain f2; assert s3 = d2;
139
140 s1 := domain f3; assert s1 = d3;
141 s2 := domain f3; assert s2 = d3;
142 s3 := domain f3; assert s3 = d3;
143
144 s1 := domain lsm1; assert s1 = d1;
145 s2 := domain lsm1; assert s2 = d1;
146 s3 := domain lsm1; assert s3 = d1;
147
148 s1 := domain lsm2; assert s1 = d2;
149 s2 := domain lsm2; assert s2 = d2;
150 s3 := domain lsm2; assert s3 = d2;
151
152 s1 := domain lsm3; assert s1 = d3;
153 s2 := domain lsm3; assert s2 = d3;
154 s3 := domain lsm3; assert s3 = d3;
155
156 s1 := domain lmm1; assert s1 = d1;
157 s2 := domain lmm1; assert s2 = d1;
158 s3 := domain lmm1; assert s3 = d1;
159
160 s1 := domain lmm2; assert s1 = d2;
161 s2 := domain lmm2; assert s2 = d2;
162 s3 := domain lmm2; assert s3 = d2;
163
164 s1 := domain lmm3; assert s1 = d3;
165 s2 := domain lmm3; assert s2 = d3;
166 s3 := domain lmm3; assert s3 = d3;
167
168 s1 := domain rsm1; assert s1 = d1;
169 s2 := domain rsm1; assert s2 = d1;
170 s3 := domain rsm1; assert s3 = d1;
171
172 s1 := domain rsm2; assert s1 = d2;
173 s2 := domain rsm2; assert s2 = d2;
174 s3 := domain rsm2; assert s3 = d2;
175
176 s1 := domain rsm3; assert s1 = d3;
177 s2 := domain rsm3; assert s2 = d3;
178 s3 := domain rsm3; assert s3 = d3;
179
180 s1 := domain rmm1; assert s1 = d1;
181 s2 := domain rmm1; assert s2 = d1;
182 s3 := domain rmm1; assert s3 = d1;
183
184 s1 := domain rmm2; assert s1 = d2;
185 s2 := domain rmm2; assert s2 = d2;
186 s3 := domain rmm2; assert s3 = d2;
187
188 s1 := domain rmm3; assert s1 = d3;
189 s2 := domain rmm3; assert s2 = d3;
190 s3 := domain rmm3; assert s3 = d3;
191
192 s1 := domain ssm1; assert s1 = d1;
193 s2 := domain ssm1; assert s2 = d1;
194 s3 := domain ssm1; assert s3 = d1;
195
196 s1 := domain ssm2; assert s1 = d2;
197 s2 := domain ssm2; assert s2 = d2;
198 s3 := domain ssm2; assert s3 = d2;
199
200 s1 := domain ssm3; assert s1 = d3;
201 s2 := domain ssm3; assert s2 = d3;
202 s3 := domain ssm3; assert s3 = d3;
203
204 s1 := domain smm1; assert s1 = d1;
205 s2 := domain smm1; assert s2 = d1;
206 s3 := domain smm1; assert s3 = d1;
207
208 s1 := domain smm2; assert s1 = d2;
209 s2 := domain smm2; assert s2 = d2;
210 s3 := domain smm2; assert s3 = d2;
211
212 s1 := domain smm3; assert s1 = d3;
213 s2 := domain smm3; assert s2 = d3;
214 s3 := domain smm3; assert s3 = d3;
215
216
217 end procedure unbased_cases;
218
219
220 procedure based_cases;
221
222 lset := domain f1; assert lset = d1;
223 rset := domain f1; assert rset = d1;
224 sset := domain f1; assert sset = d1;
225
226 lset := domain f2; assert lset = d2;
227 rset := domain f2; assert rset = d2;
228 sset := domain f2; assert sset = d2;
229
230 lset := domain f3; assert lset = d3;
231 rset := domain f3; assert rset = d3;
232 sset := domain f3; assert sset = d3;
233
234 lset := domain lsm1; assert lset = d1;
235 rset := domain lsm1; assert rset = d1;
236 sset := domain lsm1; assert sset = d1;
237
238 lset := domain lsm2; assert lset = d2;
239 rset := domain lsm2; assert rset = d2;
240 sset := domain lsm2; assert sset = d2;
241
242 lset := domain lsm3; assert lset = d3;
243 rset := domain lsm3; assert rset = d3;
244 sset := domain lsm3; assert sset = d3;
245
246 lset := domain lmm1; assert lset = d1;
247 rset := domain lmm1; assert rset = d1;
248 sset := domain lmm1; assert sset = d1;
249
250 lset := domain lmm2; assert lset = d2;
251 rset := domain lmm2; assert rset = d2;
252 sset := domain lmm2; assert sset = d2;
253
254 lset := domain lmm3; assert lset = d3;
255 rset := domain lmm3; assert rset = d3;
256 sset := domain lmm3; assert sset = d3;
257
258 lset := domain rsm1; assert lset = d1;
259 rset := domain rsm1; assert rset = d1;
260 sset := domain rsm1; assert sset = d1;
261
262 lset := domain rsm2; assert lset = d2;
263 rset := domain rsm2; assert rset = d2;
264 sset := domain rsm2; assert sset = d2;
265
266 lset := domain rsm3; assert lset = d3;
267 rset := domain rsm3; assert rset = d3;
268 sset := domain rsm3; assert sset = d3;
269
270 lset := domain rmm1; assert lset = d1;
271 rset := domain rmm1; assert rset = d1;
272 sset := domain rmm1; assert sset = d1;
273
274 lset := domain rmm2; assert lset = d2;
275 rset := domain rmm2; assert rset = d2;
276 sset := domain rmm2; assert sset = d2;
277
278 lset := domain rmm3; assert lset = d3;
279 rset := domain rmm3; assert rset = d3;
280 sset := domain rmm3; assert sset = d3;
281
282 lset := domain ssm1; assert lset = d1;
283 rset := domain ssm1; assert rset = d1;
284 sset := domain ssm1; assert sset = d1;
285
286 lset := domain ssm2; assert lset = d2;
287 rset := domain ssm2; assert rset = d2;
288 sset := domain ssm2; assert sset = d2;
289
290 lset := domain ssm3; assert lset = d3;
291 rset := domain ssm3; assert rset = d3;
292 sset := domain ssm3; assert sset = d3;
293
294 lset := domain smm1; assert lset = d1;
295 rset := domain smm1; assert rset = d1;
296 sset := domain smm1; assert sset = d1;
297
298 lset := domain smm2; assert lset = d2;
299 rset := domain smm2; assert rset = d2;
300 sset := domain smm2; assert sset = d2;
301
302 lset := domain smm3; assert lset = d3;
303 rset := domain smm3; assert rset = d3;
304 sset := domain smm3; assert sset = d3;
305
306
307 end procedure based_cases;
308
309
310 procedure range_test;
311
312 print_head('range test');
313
314
315 f1 := << (/ x, x**2 /) : x in s >>;
316 f2 := << (/ x, x**3 /) : x in s >>;
317 f3 := << (/ x, x**4 /) : x in s >>;
318
319 lsm1 := rsm1 := ssm1 := f1;
320 lsm2 := rsm2 := ssm2 := f2;
321 lsm3 := rsm3 := ssm3 := f3;
322
323 unbased_smap_cases;
324 based_smap_cases;
325
326 assert f2 = lsm2; assert f2 = rsm2; assert f2 = ssm2;
327 assert f3 = lsm3; assert f3 = rsm3; assert f3 = ssm3;
328 assert f1 = lsm1; assert f1 = rsm1; assert f1 = ssm1;
329
330 assert f1 = << (/ x, x**2 /) : x in s >>;
331 assert f2 = << (/ x, x**3 /) : x in s >>;
332 assert f3 = << (/ x, x**4 /) : x in s >>;
333
334
335 f4 := f1 + << (/ x, x /) : x in s >>;
336 f5 := f2 + << (/ x, x /) : x in s >>;
337 f6 := f3 + << (/ x, x /) : x in s >>;
338
339 lmm1 := rmm1 := smm1 := f4;
340 lmm2 := rmm2 := smm2 := f5;
341 lmm3 := rmm3 := smm3 := f6;
342
343 unbased_mmap_cases;
344 based_mmap_cases;
345
346 assert f4 = lmm1; assert f4 = rmm1; assert f4 = smm1;
347 assert f5 = lmm2; assert f5 = rmm2; assert f5 = smm2;
348 assert f6 = lmm3; assert f6 = rmm3; assert f6 = smm3;
349
350 assert f1 = << (/ x, x**2 /) : x in s >>;
351 assert f2 = << (/ x, x**3 /) : x in s >>;
352 assert f3 = << (/ x, x**4 /) : x in s >>;
353
354 assert f4 = << (/ x, x**2 /) : x in s >>
355 + << (/ x, x /) : x in s >>;
356 assert f5 = << (/ x, x**3 /) : x in s >>
357 + << (/ x, x /) : x in s >>;
358 assert f6 = << (/ x, x**4 /) : x in s >>
359 + << (/ x, x /) : x in s >>;
360
361 print_tail('range test');
362
363
364 end procedure range_test;
365
366
367 procedure unbased_smap_cases;
368
369 s1 := range f1; assert s1 = r1;
370 s2 := range f1; assert s2 = r1;
371 s3 := range f1; assert s3 = r1;
372
373 s1 := range f2; assert s1 = r2;
374 s2 := range f2; assert s2 = r2;
375 s3 := range f2; assert s3 = r2;
376
377 s1 := range f3; assert s1 = r3;
378 s2 := range f3; assert s2 = r3;
379 s3 := range f3; assert s3 = r3;
380
381 s1 := range lsm1; assert s1 = r1;
382 s2 := range lsm1; assert s2 = r1;
383 s3 := range lsm1; assert s3 = r1;
384
385 s1 := range lsm2; assert s1 = r2;
386 s2 := range lsm2; assert s2 = r2;
387 s3 := range lsm2; assert s3 = r2;
388
389 s1 := range lsm3; assert s1 = r3;
390 s2 := range lsm3; assert s2 = r3;
391 s3 := range lsm3; assert s3 = r3;
392
393 s1 := range rsm1; assert s1 = r1;
394 s2 := range rsm1; assert s2 = r1;
395 s3 := range rsm1; assert s3 = r1;
396
397 s1 := range rsm2; assert s1 = r2;
398 s2 := range rsm2; assert s2 = r2;
399 s3 := range rsm2; assert s3 = r2;
400
401 s1 := range rsm3; assert s1 = r3;
402 s2 := range rsm3; assert s2 = r3;
403 s3 := range rsm3; assert s3 = r3;
404
405 s1 := range ssm1; assert s1 = r1;
406 s2 := range ssm1; assert s2 = r1;
407 s3 := range ssm1; assert s3 = r1;
408
409 s1 := range ssm2; assert s1 = r2;
410 s2 := range ssm2; assert s2 = r2;
411 s3 := range ssm2; assert s3 = r2;
412
413 s1 := range ssm3; assert s1 = r3;
414 s2 := range ssm3; assert s2 = r3;
415 s3 := range ssm3; assert s3 = r3;
416
417 end procedure unbased_smap_cases;
418
419
420 procedure based_smap_cases;
421
422 lset := range f1; assert lset = r1;
423 rset := range f1; assert rset = r1;
424 sset := range f1; assert sset = r1;
425
426 lset := range f2; assert lset = r2;
427 rset := range f2; assert rset = r2;
428 sset := range f2; assert sset = r2;
429
430 lset := range f3; assert lset = r3;
431 rset := range f3; assert rset = r3;
432 sset := range f3; assert sset = r3;
433
434 lset := range lsm1; assert lset = r1;
435 rset := range lsm1; assert rset = r1;
436 sset := range lsm1; assert sset = r1;
437
438 lset := range lsm2; assert lset = r2;
439 rset := range lsm2; assert rset = r2;
440 sset := range lsm2; assert sset = r2;
441
442 lset := range lsm3; assert lset = r3;
443 rset := range lsm3; assert rset = r3;
444 sset := range lsm3; assert sset = r3;
445
446 lset := range rsm1; assert lset = r1;
447 rset := range rsm1; assert rset = r1;
448 sset := range rsm1; assert sset = r1;
449
450 lset := range rsm2; assert lset = r2;
451 rset := range rsm2; assert rset = r2;
452 sset := range rsm2; assert sset = r2;
453
454 lset := range rsm3; assert lset = r3;
455 rset := range rsm3; assert rset = r3;
456 sset := range rsm3; assert sset = r3;
457
458 lset := range ssm1; assert lset = r1;
459 rset := range ssm1; assert rset = r1;
460 sset := range ssm1; assert sset = r1;
461
462 lset := range ssm2; assert lset = r2;
463 rset := range ssm2; assert rset = r2;
464 sset := range ssm2; assert sset = r2;
465
466 lset := range ssm3; assert lset = r3;
467 rset := range ssm3; assert rset = r3;
468 sset := range ssm3; assert sset = r3;
469
470 end procedure based_smap_cases;
471
472
473 procedure unbased_mmap_cases;
474
475 s1 := range f4; assert s1 = r4;
476 s2 := range f4; assert s2 = r4;
477 s3 := range f4; assert s3 = r4;
478
479 s1 := range f5; assert s1 = r5;
480 s2 := range f5; assert s2 = r5;
481 s3 := range f5; assert s3 = r5;
482
483 s1 := range f6; assert s1 = r6;
484 s2 := range f6; assert s2 = r6;
485 s3 := range f6; assert s3 = r6;
486
487 s1 := range lmm1; assert s1 = r4;
488 s2 := range lmm1; assert s2 = r4;
489 s3 := range lmm1; assert s3 = r4;
490
491 s1 := range lmm2; assert s1 = r5;
492 s2 := range lmm2; assert s2 = r5;
493 s3 := range lmm2; assert s3 = r5;
494
495 s1 := range lmm3; assert s1 = r6;
496 s2 := range lmm3; assert s2 = r6;
497 s3 := range lmm3; assert s3 = r6;
498
499 s1 := range rmm1; assert s1 = r4;
500 s2 := range rmm1; assert s2 = r4;
501 s3 := range rmm1; assert s3 = r4;
502
503 s1 := range rmm2; assert s1 = r5;
504 s2 := range rmm2; assert s2 = r5;
505 s3 := range rmm2; assert s3 = r5;
506
507 s1 := range rmm3; assert s1 = r6;
508 s2 := range rmm3; assert s2 = r6;
509 s3 := range rmm3; assert s3 = r6;
510
511 s1 := range smm1; assert s1 = r4;
512 s2 := range smm1; assert s2 = r4;
513 s3 := range smm1; assert s3 = r4;
514
515 s1 := range smm2; assert s1 = r5;
516 s2 := range smm2; assert s2 = r5;
517 s3 := range smm2; assert s3 = r5;
518
519 s1 := range smm3; assert s1 = r6;
520 s2 := range smm3; assert s2 = r6;
521 s3 := range smm3; assert s3 = r6;
522
523 end procedure unbased_mmap_cases;
524
525
526 procedure based_mmap_cases;
527
528 lset := range f4; assert lset = r4;
529 rset := range f4; assert rset = r4;
530 sset := range f4; assert sset = r4;
531
532 lset := range f5; assert lset = r5;
533 rset := range f5; assert rset = r5;
534 sset := range f5; assert sset = r5;
535
536 lset := range f6; assert lset = r6;
537 rset := range f6; assert rset = r6;
538 sset := range f6; assert sset = r6;
539
540 lset := range lmm1; assert lset = r4;
541 rset := range lmm1; assert rset = r4;
542 sset := range lmm1; assert sset = r4;
543
544 lset := range lmm2; assert lset = r5;
545 rset := range lmm2; assert rset = r5;
546 sset := range lmm2; assert sset = r5;
547
548 lset := range lmm3; assert lset = r6;
549 rset := range lmm3; assert rset = r6;
550 sset := range lmm3; assert sset = r6;
551
552 lset := range rmm1; assert lset = r4;
553 rset := range rmm1; assert rset = r4;
554 sset := range rmm1; assert sset = r4;
555
556 lset := range rmm2; assert lset = r5;
557 rset := range rmm2; assert rset = r5;
558 sset := range rmm2; assert sset = r5;
559
560 lset := range rmm3; assert lset = r6;
561 rset := range rmm3; assert rset = r6;
562 sset := range rmm3; assert sset = r6;
563
564 lset := range smm1; assert lset = r4;
565 rset := range smm1; assert rset = r4;
566 sset := range smm1; assert sset = r4;
567
568 lset := range smm2; assert lset = r5;
569 rset := range smm2; assert rset = r5;
570 sset := range smm2; assert sset = r5;
571
572 lset := range smm3; assert lset = r6;
573 rset := range smm3; assert rset = r6;
574 sset := range smm3; assert sset = r6;
575
576 end procedure based_mmap_cases;
577
578
579end module test - unary_operators;
1 .=member strprim
2 module test - string_primitives;
3
4 $ nyu test id
5 $ authors - s. freudenberger (nyu-cims) (15-dec-78)
6 $ - j. schwartz (nyu-cims) (16-feb-79)
7
8 exports
9 string_primitive_test,
10 parse_test;
11
12 reads
13 error_mode,
14 print_mode;
15
16 writes
17 error_limit;
18
19
20 const
21 $ constants for proc string_primitive_test
22 text = 'hier steh ich nun, ich armer tor.',
23 alpha = ' abcdefghijklmnopqrstuvwxyz',
24 character = ' abcdefghijklmnopqrstuvwxyz,.',
25
26 $ constants for proc parse_test
27 opsigns = '+-*/()_='; $ operator signs
28
29 var
30 $ variables for string_primitive_test
31 temp,
32
33 $ variables for parse_test
34 lp, $ left precedences
35 rp; $ right precedences
36
37
38 repr
39 temp, text, alpha, character: string;
40 opsigns: string;
41 end repr;
42
43
44 proc string_primitive_test;
45
46
47 print_head('string primitive test');
48
49 temp := text;
50 assert break(temp, ',') = 'hier steh ich nun';
51 assert temp = ', ich armer tor.';
52
53 temp := text;
54 assert break(temp, 'h') = '';
55 assert temp = text;
56
57 temp := text;
58 assert break(temp, '$') = om;
59 assert temp = text;
60
61
62 temp := text;
63 assert span(temp, alpha) = 'hier steh ich nun';
64 assert temp = ', ich armer tor.';
65
66 temp := text;
67 assert span(temp, character) = text;
68 assert temp = '';
69
70 temp := text;
71 assert span(temp, '$') = om;
72 assert temp = text;
73
74
75 temp := text;
76 assert match(temp, 'hier') = 'hier';
77 assert temp = ' steh ich nun, ich armer tor.';
78
79 temp := text;
80 assert match(temp, text) = text;
81 assert temp = '';
82
83 temp := 'hier';
84 assert match(temp, text) = om;
85 assert temp = 'hier';
86
87 temp := text;
88 assert match(temp, 'hello') = om;
89 assert temp = text;
90
91 temp := text;
92 assert match(temp, 'tor.') = om;
93 assert temp = text;
94
95
96 assert lpad('abc', 10) = ' abc';
97 assert lpad(text, 5) = text;
98
99
100 temp := text;
101 assert any(temp, alpha) = 'h';
102 assert temp = 'ier steh ich nun, ich armer tor.';
103
104 temp := text;
105 assert any(temp, '$') = om;
106 assert temp = text;
107
108
109 temp := text;
110 assert notany(temp, ',') = 'h';
111 assert temp = 'ier steh ich nun, ich armer tor.';
112
113 temp := text;
114 assert notany(temp, alpha) = om;
115 assert temp = text;
116
117
118 temp := text;
119 assert rbreak(temp, ',') = ' ich armer tor.';
120 assert temp = 'hier steh ich nun,';
121
122 temp := text;
123 assert rbreak(temp, '.') = '';
124 assert temp = text;
125
126 temp := text;
127 assert rbreak(temp, '$') = om;
128 assert temp = text;
129
130
131 temp := text;
132 assert rspan(temp, '.') = '.';
133 assert temp = 'hier steh ich nun, ich armer tor';
134
135 temp := text;
136 assert rspan(temp, character) = text;
137 assert temp = '';
138
139 temp := text;
140 assert rspan(temp, '$') = om;
141 assert temp = text;
142
143
144 temp := text;
145 assert rmatch(temp, 'tor.') = 'tor.';
146 assert temp = 'hier steh ich nun, ich armer ';
147
148 temp := text;
149 assert rmatch(temp, text) = text;
150 assert temp = '';
151
152 temp := 'tor.';
153 assert rmatch(temp, text) = om;
154 assert temp = 'tor.';
155
156 temp := text;
157 assert rmatch(temp, 'hello') = om;
158 assert temp = text;
159
160 temp := text;
161 assert rmatch(temp, 'hier') = om;
162 assert temp = text;
163
164
165 assert rpad('abc', 10) = 'abc ';
166 assert rpad(text, 5) = text;
167
168
169 temp := text;
170 assert rany(temp, '.') = '.';
171 assert temp = 'hier steh ich nun, ich armer tor';
172
173 temp := text;
174 assert rany(temp, '$') = om;
175 assert temp = text;
176
177
178 temp := text;
179 assert rnotany(temp, alpha) = '.';
180 assert temp = 'hier steh ich nun, ich armer tor';
181
182 temp := text;
183 assert rnotany(temp, '.') = om;
184 assert temp = text;
185
186
187 print_tail('string primitive test');
188
189
190 end proc string_primitive_test;
191
192
193 proc parse_test; $ test of string primitives by parsing
194
195 $ nyu test id
196 $ author - j. schwartz (nyu-cims)
197 $ logged in as jts13
198 $ included into ststpl 16-feb-79
199
200
201 $ the operators we allow are +-*/= and assignment (to the right).
202 $ this will allow us to test using a mini - interpreter.
203
204
205 print_head('parse test');
206
207 lp:=(/1, 1, 2, 2, 4, 0, 0, 0/); lp:=<<(/c,lp(i)/):c=opsigns(i)>>;
208 rp:=(/1, 1, 2, 2,-1, 3, 3, 0/); rp:=<<(/c,rp(i)/):c=opsigns(i)>>;
209
210 print (t:=lexscan('a+b*(c*(d+e))'));
211 print(parse(t));
212
213 print(t:=lexscan('a23+b14*(11.1*(d3+105))'));
214 print(parse(t));
215
216 assert eval('1+2+3+4')=10;
217 assert eval('1+2+3+4=10')=1;
218
219 assert eval('1+1_a+a_a+a_a')=8;
220 assert eval('(1_a+2_b*0)+(a+b*b)/b+1=4')=1;
221
222 print_tail('parse test');
223
224 end proc parse_test;
225
226
227 proc lexscan(s); $ lexical scanner using string primitives
228
229 sx:=s; tokens:=nulltup;
230
231 (while sx /= nullstring)
232 if span(sx,' ') /= om then continue;end;
233
234 tokens with:= any(sx,opsigns);
235 tokens with:= span(sx,'abcdefghijklmnopqrstuvwxyz0123456789.');
236 end while;
237
238 return tokens;
239
240 end proc lexscan;
241
242
243 proc parse(toks); $ operator precedence parse
244
245 polish := nulltup;
246 opstack := (/'('/);
247 tokss := toks;
248 tokss with:= ')';
249
250 (forall tok = tokss(i))
251
252 if lp(tok)=om then $ operand
253 polish with:= tok;
254
255 else
256 (while rp(opstack(card opstack))>=lp(tok))
257 opp frome opstack;
258 polish with:= opp;
259 end while;
260
261 if tok=')' then
262 opp frome opstack; $ should be '('
263 else
264 opstack with:= tok;
265 end if;
266 end if;
267 end forall;
268
269 return polish;
270
271 end proc parse;
272
273 proc eval(stringg);
274
275 pol:= $ convert string to polish tuple
276 parse(lexscan(stringg));
277
278 vars := <>;
279 consts := <>;
281
282 vall:=<<(/c,cval(c)/): c in consts>>;
283 vstack:=nulltup; $ storage stack for evaluation
284
285 (forall vop = pol(i))
286 if vop in vars then
287 vstack with:= (if not ((v:=vall(vop)) = om) then v else 0 end);
288
289 else
290 x frome vstack; y frome vstack;
291
292 case vop of
293
294 ('+'): vstack with:= y+x;
295 ('-'): vstack with:= y-x;
296
297 ('*'): vstack with:= y*x;
298 ('/'): vstack with:= y div x;
299
300 ('='): vstack with:= (if x=y then 1 else 0 end);
301 ('_'): vall(pol(i-1)) := y; vstack with:= y;
302
303 end case;
304 end if;
305 end forall;
306
307 assert card vstack=1;
308
309 return vstack(1);
310
311 end proc eval;
312
313
314 proc cval(c); $ evaluates integer constant
315
316 n := 0;
317 (forall j in (/1...card c/))
318 digits:= 'x0123456789';
319 n := n * 10 + card break(digits,c(j))-1;
320 end forall;
321
322 return n;
323
324 end proc cval;
325
326
327 end module test - string_primitives;
328
329
330
331
1 .=member heapsort
2 module test - heapsort;
3
4 $ nyu test id
5 $ author - d. shields (nyu-cims)
6
7 exports
8 heap_sort_test;
9
10 reads
11 print_mode;
12
13 macro swap(a,b);
14 temp := seq(a); seq(a) := seq(b); seq(b) := temp
15 endm;
16
17 const
18
19 $ rand not yet implemented.
20 $ read(seqlen);
21 $ testseq := nulltup;
22 $ (forall i := 1...seqlen)
23 $ testseq(i) := random(seqlen);
24 $ end for;
25
26 seqlen = 50,
27
28 testseq = (/ 01, 78, 56, 23, 17, 88, 05, 85, 65, 43,
29 43, 32, 78, 90, 31, 16, 10, 54, 99, 32,
30 38, 55, 99, 02, 25, 07, 54, 88, 77, 66,
31 55, 44, 57, 78, 83, 06, 16, 12, 18, 92,
32 93, 54, 33, 10, 19, 20, 21, 23, 13, 10 /),
33
34 nstodo = 10;
35
36 var
37 sortseq, $ sorted sequence
38
39 timeon;
40
41 repr
42 testseq: tuple(integer 1...100);
43 sortseq: tuple(integer 1...100);
44 timeon: integer;
45 seqlen: integer 1 .. 100;
46
47 heap_sort: procedure(
48 tuple(integer 1 .. 100),
49 integer 1 .. 100,
50 integer 1 .. 100
51 );
52 end repr;
53
54
55 proc heap_sort_test;
56
57 print_head('heap sort test');
58
59 timeon := time;
60
61 (forall tmp in (/1...nstodo/))
62 sortseq := heap_sort(testseq, 1, seqlen);
63 end forall;
64
65 if print_mode >= print_full then
66 print; print;
67 print('sorted', seqlen, 'items',
68 nstodo, 'times in',
69 time - timeon, 'milliseconds.');
70 print('unsorted sequence =', testseq);
71 print('sorted sequence = ', sortseq);
72 end if;
73
74 print_tail('heap sort test');
75
76 end proc heap_sort_test;
77 proc heap_sort(tseq, lo, hi);
78
79 $ sort seq(lo...hi) using heapsort
80
81 repr
82 seq, tseq: tuple(integer 1...100);
83 m, i, lo, hi, seqtop,
84 targ, temp: integer 1...100;
85 end repr;
86
87 seq := tseq;
88
89 $ build initial heap; i is parent
90 (forall i in (/ lo + 1...hi/))
91
92 $ promote large children
93 loop
94 init
95 m := i;
96 while
97 m > lo and seq(m div 2) < seq(m)
98 do
99 swap(m, m div 2);
100 m := m div 2;
101 end loop init;
102 end forall;
103
104 $ sort subtrees in turn
105 (forall seqtop in (/ hi, hi-1...lo+1/))
106 swap(lo, seqtop); $ extract largest element
107
108 $ force remaining subtree to be heap
109 loop
110 init
111 m := lo;
112 doing
113 targ := if (m*2+1) < seqtop and seq(m*2) < seq(m*2+1)
114 then m*2+1
115 else m*2
116 end;
117 while
118 m*2 < seqtop and seq(m) < seq(targ)
119 do
120 swap(m, targ); $ child too big, so exchange
121 m := targ; $ move to subtree of largest child
122 end loop init;
123 end forall;
124
125 return seq;
126
127 end proc heap_sort;
128
129
130 drop
131 swap;
132
133
134 end module test - heapsort;
135
136
137
138
1 .=member primfac
2 module test - prime_factorization;
3
4 $ nyu test id
5 $ author - j. schwartz (nyu-cims) 02-jan-79
6 $ logged in as jts10
7
8 exports
9 prime_factorization_test;
10
11 reads
12 print_mode;
13
14
15 proc prime_factorization_test;
16
17 print_head('prime factorization test');
18
19 (forall n in (/ 2, 13...100/)) assert n = */facts(n); end;
20
21 print_tail('prime factorization test');
22
23 end proc prime_factorization_test;
24
25
26 proc facts(n); $ prime factorisation procedure
27 nn := n;
28 k:=2; $ lowest prime
29 factup:= nulltup; $ tuple of factors
30
31 loop while exists k in (/k..nn/) st (nn mod k)=0 until (k*k>nn) do
32
33 nn := nn div k;
34 factup with:= k;
35
36 end loop;
37
38 if nn > 1 then factup with:= nn; end if;
39 return factup;
40 end proc facts;
41
42
43 end module test - prime_factorization;
44
45
46
47
1 .=member test5
2 module test - set_identities;
3
4 $ nyu test id
5 $ author - e. weixelbaum (nyu-cims)
6 $ logged in as smf04
7
8 exports
9 set_identity_test;
10
11 reads
12 print_mode;
13
14
15 $ author - elia weixelbaum (nyu)
16 $ program -- test case 5 of setl tests
17 $
18 $ 12 set identities are checked on both sets and maps. in
19 $ certain identities, the complement of a set is desired.
20 $ therefore, there is a universe set and the sets are subsets
21 $ of the universe. the sets are a, b and c, the universe is u,
22 $ and the maps are f and g. a is repred as aloc, arem, aspa
23 $ which are local, remote, and sparse sets, resp. similar
24 $ reprs are used for b, c, u, f and g. the identities are
25 $ checked on as many combinations of reprs as is reasonably
26 $ possible.
27 $ assert statements are used to verify these identities.
28 $
29 $ the identities are as follows:
30 $
31 $ 0: x * y subset x + y
32 $
33 $ 1: x * y = x + y - (x - y) - (y - x)
34 $
35 $ 2: card (x + y) = card x + card y - card (x * y)
36 $
37 $ 3: x = (x - y) + (x * y)
38 $
39 $ 4: complement(x) + complement(y) = complement(x * y)
40 $ this is done as:
41 $ (u - x) + (u - y) = u - (x * y)
42 $
43 $ 5: card (u - x) = card u - card x
44 $
45 $ 6: card (x + something not in x) = card x + 1
46 $
47 $ 7: empty set * x = empty set
48 $
49 $ 8: empty set + x = x
50 $
51 $ 9: u + x = u
52 $
53 $ 10: u * x = x
54 $
55 $ 11: x1 + y1 = x2 + y2 where
56 $ x1 and y1 are sets, x2 and y2 are corresponding tuples,
57 $ i.e. x1 = x2 and y1 = y2. also x1 * y1 = <>.
58 $
59 $ this last identity checks that set union of 2 disjoint sets
60 $ is the same as tuple concatenation where the tuples are the
61 $ two sets written as tuples.
62
63
64 macro ident11 (aset, cset, atpl, ctpl, msg);
65 assert (forall x in aset + cset st x in atpl + ctpl)
66 and card (aset + cset) = card (atpl + ctpl)
67 endm;
68
69
70 var
71
72 x,
73
74 uloc,
75 urem,
76 uspa,
77
78 aloc,
79 arem,
80 aspa,
81
82 bloc,
83 brem,
84 bspa,
85
86 cloc,
87 crem,
88 cspa,
89
90 atup,
91 ctup,
92
93 floc,
94 frem,
95 fspa,
96
97 gloc,
98 grem,
99 gspa;
100
101
102 const
103
104 u = <<1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20>>,
105 a = <<1,2,5,7,14,17,19>>,
106 b = <<3,6,7,11,12,15,16,17,19,20>>,
107 c = <<20,15,8,3,0>>,
108
109 aaa = (/7,17,19,1,5,2,14/),
110 ccc = (/15,3,0,8,20/),
111
112 arba = 17,
113 arbb = 11,
114 arbf = (/3,9/),
115 arbg = (/8,62/),
116
117 f = <<(/1,1/),(/2,4/),(/3,9/),(/4,16/),(/5,25/),(/6,36/)>>,
118 g = <<(/2,7/),(/4,16/),(/5,40/),(/8,62/)>>;
119
120
121 init
122
123 uloc := u,
124 urem := u,
125 uspa := u;
126
127
128 repr
129 base intb: integer;
130
131 uloc: local set (elmt intb);
132 urem: remote set (elmt intb);
133 uspa: sparse set (elmt intb);
134
135 aloc: local set (elmt intb);
136 arem: remote set (elmt intb);
137 aspa: sparse set (elmt intb);
138
139 bloc: local set (elmt intb);
140 brem: remote set (elmt intb);
141 bspa: sparse set (elmt intb);
142
143 cloc: local set (elmt intb);
144 crem: remote set (elmt intb);
145 cspa: sparse set (elmt intb);
146
147 atup: tuple (elmt intb);
148 ctup: tuple (elmt intb);
149
150 floc: local smap (elmt intb) integer;
151 frem: remote smap (elmt intb) integer;
152 fspa: sparse smap (elmt intb) integer;
153
154 gloc: local smap (elmt intb) integer;
155 grem: remote smap (elmt intb) integer;
156 gspa: sparse smap (elmt intb) integer;
157
158 end repr;
159
160
161 proc set_identity_test;
162
163 print_head('test 5 - set identity test');
164
165 $ test1 uses the different reprs of a, b, f and g in testing
166 $ identities 0 - 4. test1 is called 4 times:
167
168 $ call 1 - all reprs of a, b, f and g are assigned the
169 $ constants a, b, f and g respectively.
170
171 $ call 2 - all reprs of a and f are assigned the
172 $ constants a and f, resp., and all reprs of b
173 $ and g are assigned null- or unit sets.
174
175 $ call 3 - all reprs of a and f are assigned null- or
176 $ unit sets, and all reprs of b and g are
177 $ assigned the constants b and g respectively.
178
179 $ call 4 - all reprs of a, b, f and g are assigned null-
180 $ or unit sets.
181
182 $ note: all reprs of u are used but are always assigned the
183 $ constant u.
184
185 loop
186 forall
187 (/ aloc, arem, aspa, bloc, brem, bspa,
188 floc, frem, fspa, gloc, grem, gspa /)
189 in
190 (/ (/ a, a, a, b, b, b,
191 f, f, f, g, g, g /),
192
193 (/ a, a, a, <>, <>, <>,
194 f, f, f, <>, <>, <> /),
195
196 (/ <>, <>, <>, b, b, b,
197 <>, <>, <>, g, g, g /),
198
199 (/ <>, <>, <>, <>, <>, <>,
200 <>, <>, <>, <>, <>, <> /)
201 /)
202 do
203
204 test1;
205
206 end loop forall;
207
208
209 $ test2 uses the different reprs of a and f in testing identities
210 $ 5 - 10. test2 is called 3 times:
211
212 $ call 1 - all reprs of a and f are assigned the constants
213 $ a and f respectively.
214
215 $ call 2 - all reprs of a and f are assigned <>.
216
217 $ call 3 - all reprs of a and f are assigned unit sets.
218
219 $ note: all reprs of u are used but are always assigned the
220 $ constant u.
221
222 loop
223 forall
224 (/ aloc, arem, aspa, floc, frem, fspa /)
225 in
226 (/ (/ a, a, a, f, f, f /),
227 (/ <>, <>, <>, <>, <>, <> /),
228 (/ <>,<>,<>,<>,<>,<> /)
229 /)
230 do
231
232 test2;
233
234 end loop forall;
235
236 $ test3 calls identity 11 with different combinations of reprs
237 $ of a, c, a tuple
238 $ version of a and a tuple version of c. test3
239 $ is called 3 times:
240 $
241 $ call 1 - all reprs of a and c are assigned the constants
242 $
243 $ a and c respectively and atup and ctup are assigned
244 $ the constant tuples aaa and ccc respectively.
245 $
246 $ call 2 - all sets are assigned <> and all tuples are
247 $ assigned (//).
248 $
249 $ call 3 - the a sets and tuple are assigned unit sets and
250 $
251 $ unit tuple respectively and the b sets and tuple
252 $ are assigned <> and (//) respectively.
253
254 (forall (/aloc, arem, aspa,
255 cloc, crem, cspa,
256 atup, ctup/)
257
258 in (/ (/ a, a, a, c, c, c,
259 aaa, ccc/),
260
261 (/ <>, <>, <>, <>, <>, <>,
262 (//), (//)/),
263
264 (/<>,<>,<>, <>,<>,<>,
265 (/arba/), (//)/)/))
266
267
268 test3;
269
270 end forall;
271
272 print_tail('test 5 - set identity test');
273
274
275 end proc set_identity_test;
276 proc test1;
277
278 assert aloc * bloc subset aloc + bloc;
279 assert aloc * brem subset aloc + brem;
280 assert aloc * bspa subset aloc + bspa;
281 assert arem * bloc subset arem + bloc;
282 assert arem * brem subset arem + brem;
283 assert arem * bspa subset arem + bspa;
284 assert aspa * bloc subset aspa + bloc;
285 assert aspa * brem subset aspa + brem;
286 assert aspa * bspa subset aspa + bspa;
287
288 assert floc * gloc subset floc + gloc;
289 assert floc * grem subset floc + grem;
290 assert floc * gspa subset floc + gspa;
291 assert frem * gloc subset frem + gloc;
292 assert frem * grem subset frem + grem;
293 assert frem * gspa subset frem + gspa;
294 assert fspa * gloc subset fspa + gloc;
295 assert fspa * grem subset fspa + grem;
296 assert fspa * gspa subset fspa + gspa;
297
298
299 assert aloc * bloc = aloc + bloc - (aloc - bloc) - (bloc - aloc);
300 assert aloc * brem = aloc + brem - (aloc - brem) - (brem - aloc);
301 assert aloc * bspa = aloc + bspa - (aloc - bspa) - (bspa - aloc);
302 assert arem * bloc = arem + bloc - (arem - bloc) - (bloc - arem);
303 assert arem * brem = arem + brem - (arem - brem) - (brem - arem);
304 assert arem * bspa = arem + bspa - (arem - bspa) - (bspa - arem);
305 assert aspa * bloc = aspa + bloc - (aspa - bloc) - (bloc - aspa);
306 assert aspa * brem = aspa + brem - (aspa - brem) - (brem - aspa);
307 assert aspa * bspa = aspa + bspa - (aspa - bspa) - (bspa - aspa);
308
309 assert floc * gloc = floc + gloc - (floc - gloc) - (gloc - floc);
310 assert floc * grem = floc + grem - (floc - grem) - (grem - floc);
311 assert floc * gspa = floc + gspa - (floc - gspa) - (gspa - floc);
312 assert frem * gloc = frem + gloc - (frem - gloc) - (gloc - frem);
313 assert frem * grem = frem + grem - (frem - grem) - (grem - frem);
314 assert frem * gspa = frem + gspa - (frem - gspa) - (gspa - frem);
315 assert fspa * gloc = fspa + gloc - (fspa - gloc) - (gloc - fspa);
316 assert fspa * grem = fspa + grem - (fspa - grem) - (grem - fspa);
317 assert fspa * gspa = fspa + gspa - (fspa - gspa) - (gspa - fspa);
318
319
320 assert card(aloc+bloc) = card aloc + card bloc - card(aloc*bloc);
321 assert card(aloc+brem) = card aloc + card brem - card(aloc*brem);
322 assert card(aloc+bspa) = card aloc + card bspa - card(aloc*bspa);
323 assert card(arem+bloc) = card arem + card bloc - card(arem*bloc);
324 assert card(arem+brem) = card arem + card brem - card(arem*brem);
325 assert card(arem+bspa) = card arem + card bspa - card(arem*bspa);
326 assert card(aspa+bloc) = card aspa + card bloc - card(aspa*bloc);
327 assert card(aspa+brem) = card aspa + card brem - card(aspa*brem);
328 assert card(aspa+bspa) = card aspa + card bspa - card(aspa*bspa);
329
330 assert card(floc+gloc) = card floc + card gloc - card(floc*gloc);
331 assert card(floc+grem) = card floc + card grem - card(floc*grem);
332 assert card(floc+gspa) = card floc + card gspa - card(floc*gspa);
333 assert card(frem+gloc) = card frem + card gloc - card(frem*gloc);
334 assert card(frem+grem) = card frem + card grem - card(frem*grem);
335 assert card(frem+gspa) = card frem + card gspa - card(frem*gspa);
336 assert card(fspa+gloc) = card fspa + card gloc - card(fspa*gloc);
337 assert card(fspa+grem) = card fspa + card grem - card(fspa*grem);
338 assert card(fspa+gspa) = card fspa + card gspa - card(fspa*gspa);
339
340
341 assert aloc = (aloc - bloc) + (aloc * bloc);
342 assert aloc = (aloc - brem) + (aloc * brem);
343 assert aloc = (aloc - bspa) + (aloc * bspa);
344 assert arem = (arem - bloc) + (arem * bloc);
345 assert arem = (arem - brem) + (arem * brem);
346 assert arem = (arem - bspa) + (arem * bspa);
347 assert aspa = (aspa - bloc) + (aspa * bloc);
348 assert aspa = (aspa - brem) + (aspa * brem);
349 assert aspa = (aspa - bspa) + (aspa * bspa);
350
351 assert floc = (floc - gloc) + (floc * gloc);
352 assert floc = (floc - grem) + (floc * grem);
353 assert floc = (floc - gspa) + (floc * gspa);
354 assert frem = (frem - gloc) + (frem * gloc);
355 assert frem = (frem - grem) + (frem * grem);
356 assert frem = (frem - gspa) + (frem * gspa);
357 assert fspa = (fspa - gloc) + (fspa * gloc);
358 assert fspa = (fspa - grem) + (fspa * grem);
359 assert fspa = (fspa - gspa) + (fspa * gspa);
360
361
362 assert (uloc - aloc) + (uloc - bloc) = uloc - (aloc * bloc);
363 assert (urem - arem) + (urem - brem) = urem - (arem * brem);
364 assert (uspa - aspa) + (uspa - bspa) = uspa - (aspa * bspa);
365 assert (uspa - aloc) + (uspa - brem) = uspa - (aloc * brem);
366
367 end proc test1;
368 proc test2;
369
370
371
372 assert card (uloc - aloc) = card uloc - card aloc;
373 assert card (uloc - arem) = card uloc - card arem;
374 assert card (uloc - aspa) = card uloc - card aspa;
375 assert card (urem - aloc) = card urem - card aloc;
376 assert card (urem - arem) = card urem - card arem;
377 assert card (urem - aspa) = card urem - card aspa;
378 assert card (uspa - aloc) = card uspa - card aloc;
379 assert card (uspa - arem) = card uspa - card arem;
380 assert card (uspa - aspa) = card uspa - card aspa;
381
382
383 assert card (aloc + << arb (uloc - aloc) >> ) = card aloc + 1;
384 assert card (aloc + << arb (urem - aloc) >> ) = card aloc + 1;
385 assert card (aloc + << arb (uspa - aloc) >> ) = card aloc + 1;
386 assert card (arem + << arb (uloc - arem) >> ) = card arem + 1;
387 assert card (arem + << arb (urem - arem) >> ) = card arem + 1;
388 assert card (arem + << arb (uspa - arem) >> ) = card arem + 1;
389 assert card (aspa + << arb (uloc - aspa) >> ) = card aspa + 1;
390 assert card (aspa + << arb (urem - aspa) >> ) = card aspa + 1;
391 assert card (aspa + << arb (uspa - aspa) >> ) = card aspa + 1;
392
393
394 assert nullset * aloc = nullset;
395 assert nullset * arem = nullset;
396 assert nullset * aspa = nullset;
397
398 assert aloc * nullset = nullset;
399 assert arem * nullset = nullset;
400 assert aspa * nullset = nullset;
401
402 assert nullset * floc = nullset;
403 assert nullset * frem = nullset;
404 assert nullset * fspa = nullset;
405
406 assert floc * nullset = nullset;
407 assert frem * nullset = nullset;
408 assert fspa * nullset = nullset;
409
410
411 assert nullset + aloc = aloc;
412 assert nullset + arem = arem;
413 assert nullset + aspa = aspa;
414
415 assert aloc + nullset = aloc;
416 assert arem + nullset = arem;
417 assert aspa + nullset = aspa;
418
419 assert nullset + floc = floc;
420 assert nullset + frem = frem;
421 assert nullset + fspa = fspa;
422
423 assert floc + nullset = floc;
424 assert frem + nullset = frem;
425 assert fspa + nullset = fspa;
426
427
428 assert uloc + aloc = uloc;
429 assert uloc + arem = uloc;
430 assert uloc + aspa = uloc;
431 assert urem + aloc = urem;
432 assert urem + arem = urem;
433 assert urem + aspa = urem;
434 assert uspa + aloc = uspa;
435 assert uspa + arem = uspa;
436 assert uspa + aspa = uspa;
437
438 assert aloc + uloc = uloc;
439 assert arem + uloc = uloc;
440 assert aspa + uloc = uloc;
441 assert aloc + urem = urem;
442 assert arem + urem = urem;
443 assert aspa + urem = urem;
444 assert aloc + uspa = uspa;
445 assert arem + uspa = uspa;
446 assert aspa + uspa = uspa;
447
448
449 assert aloc * uloc = aloc;
450 assert aloc * urem = aloc;
451 assert aloc * uspa = aloc;
452 assert arem * uloc = arem;
453 assert arem * urem = arem;
454 assert arem * uspa = arem;
455 assert aspa * uloc = aspa;
456 assert aspa * urem = aspa;
457 assert aspa * uspa = aspa;
458
459 assert uloc * aloc = aloc;
460 assert urem * aloc = aloc;
461 assert uspa * aloc = aloc;
462 assert uloc * arem = arem;
463 assert urem * arem = arem;
464 assert uspa * arem = arem;
465 assert uloc * aspa = aspa;
466 assert urem * aspa = aspa;
467 assert uspa * aspa = aspa;
468
469 end proc test2;
470 proc test3;
471
472
473
474 ident11(aloc, cloc, atup, ctup, 'local sets ');
475 ident11(arem, crem, atup, ctup, 'remote sets ');
476 ident11(aspa, cspa, atup, ctup, 'sparse sets ');
477 ident11(aloc, crem, atup, ctup, 'local and remote sets ');
478 ident11(aloc, cspa, atup, ctup, 'local and sparse sets ');
479 ident11(arem, cspa, atup, ctup, 'remote and sparse sets');
480
481 end proc test3;
482
483
484 drop
485 ident11;
486
487
488 end module test - set_identities;
489
490
491
1 .=member test6
2 module test - union_2;
3
4 $ nyu test id
5 $ author - c. goss (nyu-cims)
6
7 exports
8 union_test_2;
9
10 reads
11 print_mode;
12
13
14$ this test consists of a set of 'bag' manipulation routines which
15$ bags as represented by both tuples and maps. (conceptually,
16$ a 'bag' is a set which allows duplicate members.) with each pair
17$ of test bags we perform union, intersection, and difference
18$ operations for each representation and ensure that the results
19$ are identical.
20
21
22 const
23 test_tup1 = << (/01, (/'a', 'b', 'c'/)/),
24 (/02, (/ 1, 2, 3/)/),
25 (/03, (/1.0, 2.0, 3.0/)/) >>,
26
27 test_tup2 = << (/01, (/'a', 'd', 'e'/)/),
28 (/02, (/ 2, 5, 6, 7, 8, 1, 576/)/),
29 (/03, (/2.0, 5.0, 6.0, 7.0, 8.0, 1.0, 576.0/)/) >>;
30
31 var
32 failnum; $ number of unsuccessful tests
33
34 init
35 failnum := 0;
36
37
38 procedure union_test_2;
39
40 print_head('test 6 - bag manipulation test');
41
42 loop
43 init
44 i:=1;
45 print;
46 print('test program 6 clint goss');
47 doing $ simulate the reading of input
48 tup1 := test_tup1(i);
49 tup2 := test_tup2(i);
50 while
51 test_tup1(i) /= om $ <===> not eof
52 step
53 i := i + 1;
54 term $ print final statistics about test 6
55 print;
56 print(i-1, 'pairs of bags tested.');
57 if failnum /= 0 then
58 print(failnum, 'test(s) failed.');
59 else
60 print('all tests passed.');
61 end if;
62 do
63 formmaps; $ form maps for each tuple bag
64 echodata; $ echo data depending on print mode
65 applytsests; $ finally, perform tests
66
67 end loop;
68
69
70 print_tail('test 6 - bag manipulation test');
71
72formmaps::
73 $ maps corresponding to the tuples.
74
75 if print_mode = print_debug then
76 print;
77 print('forming maps');
78 end if;
79
80 t := tup1; $ start with first tuple
81 m := nullset; $ initialize map bag to empty.
82 jj := 1;
83
84setmap:
85 loop
86 forall j in (/ 1...card t /)
87 do
88 if t(j) in domain m then
89 $ replace the old pair by a new pair
90 $ with an incremented image.
91 v := m(t(j));
92 m less:= (/t(j), v/);
93 m with:= (/t(j), v+1/);
94
95 else $ add new pair with image = 1.
96 m with:= (/t(j), 1/);
97 end if;
98 end loop forall j;
99
100 if jj = 1 then
101 map1 := m;
102
103 m := nullset;
104 t := tup2;
105 jj := 2;
106 goto setmap;
107
108 else
109 map2 := m;
110 end if;
111
112echodata::
113
114 if print_mode = print_debug then
115 print;
116 print('test', i);
117 print('tuple 1 =', tup1);
118 print('tuple 2 =', tup2);
119 print('map 1 = ', map1);
120 print('map 2 = ', map2);
121 end if;
122
123applytsests:: $ here we test the tuple results of
124 $ the tuple bag operations are
125 $ identical to the map results of the
126 $ map bag operations.
127
128 eqtest(tup1 .ti tup2, map1 .mi map2, 'intersection');
129 eqtest(tup1 .tu tup2, map1 .mu map2, 'union' );
130 eqtest(tup1 .td tup2, map1 .md map2, 'difference' );
131
132 end procedure union_test_2;
133
134
135 procedure eqtest(tup, mapp, msg);
136 $
137 $ this routine tests for equality between a tuple bag and
138 $ a map bag.
139 $
140 if print_mode >= print_full then
141 print; print;
142 print('testing equlity after', msg);
143 print;
144 end if;
145
146 m := mapp; $ start with the full map
147 loop
148 forall i in (/ 1...card tup /)
149 do
150 assert tup(i) in domain m;
151 v := m(tup(i)); $ decrement image of tuple element in map
152 m with:= (/tup(i), v-1/);
153 m less:= (/tup(i), v/);
154 end loop forall i;
155 $
156 $ ensure final map has the singleton range <<0>>.
157 $
158 (forall i in domain m) assert m(i) = 0; end forall;
159
160 end procedure eqtest;
161
162
163 op .ti(a, b); $ tuple bag intersection
164
165 if print_mode = print_debug then
166 print;
167 print('ti.01: a = ', a);
168 print('ti.02: b = ', b);
169 print('ti.03: result =', (/x in a st x in b/));
170 end if;
171
172 return (/x in a st x in b/);
173
174 end op .ti;
175
176
177 op .tu(a, b); $ tuple bag union
178
179 if print_mode = print_debug then
180 print;
181 print('tu.01: a = ', a);
182 print('tu.02: b = ', b);
183 print('tu.03: result =', a + b);
184 end if;
185
186 return a + b;
187
188 end op .tu;
189
190
191 op .td(a, b); $ tuple bag difference
192
193 if print_mode = print_debug then
194 print;
195 print('td.01: a = ', a);
196 print('td.02: b = ', b);
197 print('td.03: result =', (/x in a st x notin b/));
198 end if;
199
200 return (/x in a st x notin b/);
201
202 end op .td;
203
204
205 op .mi(a, b); $ map bag intersection
206
207 r := nullset;
208 loop
209 forall elem in domain a st elem in domain b
210 do
211 if a(elem) > b(elem) then
212 r with:= (/elem, b(elem)/);
213 else
214 r with:= (/elem, a(elem)/);
215 end if;
216 end loop;
217 if print_mode = print_debug then
218 print;
219 print('mi.01: a = ', a);
220 print('mi.02: b = ', b);
221 print('mi.03: result =', r);
222 end if;
223
224 return r;
225
226 end op .mi;
227
228
229 op .mu(a, b); $ map bag union
230
231 r := a + b;
232 loop
233 forall elem in (domain a) * (domain b)
234 do
235 r less:= (/elem, a(elem)/);
236 r less:= (/elem, b(elem)/);
237 r with:= (/elem, a(elem)+b(elem)/);
238 end loop;
239 if print_mode = print_debug then
240 print;
241 print('mu.01: a = ', a);
242 print('mu.02: b = ', b);
243 print('mu.03: result =', r);
244 end if;
245
246 return r;
247
248 end op .mu;
249
250
251 op .md(a, b); $ map bag difference
252
253 r := a;
254 loop
255 forall x in (domain a) * (domain b)
256 do
257 r less:= (/x, a(x)/);
258 if a(x) > b(x) then r with:= (/x, a(x) - b(x)/); end;
259 end loop;
260 if print_mode = print_debug then
261 print;
262 print('md.01: a = ', a);
263 print('md.02: b = ', b);
264 print('md.03: result =', r);
265 end if;
266
267 return r;
268
269 end op .md;
270
271
272 end module test - union_2;
273
274
275
276
1 .=member test8
2 module test - power_set;
3
4 $ nyu test id
5 $ author - h. lewis (nyu-cims)
6 $ logged in as jts10
7 $ submitted as file ds01 (22 jan 79)
8
9 exports
10 power_set_test;
11
12 reads
13 print_mode;
14
15
16 $ test routine for pow and npow operators
17 $
18 $ henry m. lewis
19 $
20 $ this program exercises the built-in setl operators pow s and
21 $ n npow s , verifying thier results by comparison with those
22 $ of a program function powr(s) , by verifying cardinalities,
23 $ and by application of the following identities for various small
24 $ sets of integers:
25
26 $ pow (set + << singleton >> ) =
27 $ (pow set) + << y with singleton : y elmt pow set >>
28
29 $ pow (s + t) = << y + z : y elmt pow s, z elmt pow t >>
30
31 $ n npow (set + << singleton >> ) =
32 $ (n npow set) + << y with singleton :
33 $ y elmt (n - 1) npow set >> $ n >= 1
34
35 $ n npow (s + t) =
36 $ << y + z :
37 $ nn:=0...n, y elmt nn npow s, z elmt (n-nn) npow t >>
38
39 $ the size of the sets tested and their contents may be altered by
40 $ adjustment to the macros 'inititems' , 'newitem' ,
41 $ 'singl_iterator' , and 'sets_iterator' .
42
43
44 var $ globals for messages.
45 recursion_,
46 singl_identity,
47 set_identity,
48 n_recursion,
49 n_single_identity,
50 n_set_identity;
51
52 macro newitem;
53 (item +:= 1) endm;
54 macro singl_iterator;
55 (/1...lim1/) endm;
56
57 macro sets_iterator;
58 (/1...lim2/) endm;
59
60
61
62 $ variable declarations
63
64 var
65 test_status, $ set to 'fail if one or more tests fail
66
67 n, nn, $ cardinality for npow tests
68
69 x, $ singleton
70
71 $ set arguments for pow and npow tests
72
73 slocal, tlocal,
74 sremote, tremote,
75 ssparse, tsparse,
76
77 $ power sets
78
79 spowlocal, tpowlocal,
80 spowremote, tpowremote,
81 spowsparse, tpowsparse,
82
83 $ elements of a power set
84
85 ylocal, zlocal,
86 yremote, zremote,
87 ysparse, zsparse;
88
89
90 repr
91 base items: *;
92
93 base sets : set( elmt items );
94
95 x : elmt items;
96
97 slocal, tlocal : local set( elmt items );
98 sremote, tremote : remote set( elmt items );
99 ssparse, tsparse : sparse set( elmt items );
100
101 spowlocal, tpowlocal : local set( elmt sets );
102 spowremote, tpowremote : remote set( elmt sets );
103 spowsparse, tpowsparse : sparse set( elmt sets );
104
105 ylocal, zlocal : local set( elmt items );
106 yremote, zremote : remote set( elmt items );
107 ysparse, zsparse : sparse set( elmt items );
108
109 n : integer;
110 end repr;
111
112
113 proc power_set_test;
114
115 print_head('test 8 - power set test');
116
117 item := 0;
118
119 lim1 := 3; lim2 := 3;
120 recursion_ :=
121 'pow s = powr(s) $ powr is a program function ';
122
123 singl_identity :=
124 'pow (set + << singleton >> ) = (pow set) '
125 ' << y with singleton : y in pow set >>';
126
127 set_identity :=
128 'pow (s + t) = << y + z : y in pow s, z in pow t >>';
129
130 n_recursion :=
131 'n npow s = << x in powr(s) st card s = n >> '
132 ' $ powr is a program function ';
133 n_singl_identity :=
134 'n npow (set + << singleton >> ) '
135 '= (n npow set) + << y with singleton '
136 ': y in (n - 1) npow set >>';
137
138 n_set_identity :=
139 'n npow (s + t) '
140 '= << y + z : nn:=0...n, y in nn npow s, '
141 'z in (n - nn) npow t >>';
142
143 item := 0;
144
145 slocal := sremote := ssparse := << >>;
146
147 loop forall i in singl_iterator
148 do
149
150 spowlocal := pow slocal;
151 spowremote := pow sremote;
152 spowsparse := pow ssparse;
153
154 tpowlocal := powr(slocal);
155 tpowremote := powr(sremote);
156 tpowsparse := powr(ssparse);
157
158 $ verify the identity card pow s = 2**card s
159
160 assert card spowlocal = 2 ** (card slocal);
161 assert card spowremote = 2 ** (card sremote);
162 assert card spowsparse = 2 ** (card ssparse);
163
164 $ compare the result of pow s with that of powr(s)
165
166 rec_test;
167
168 (forall n in (/0...2**i/)) $ test power sets of all sizes
169
170 spowlocal := n npow slocal;
171 spowremote := n npow sremote;
172 spowsparse := n npow ssparse;
173
174 $ verify the identity n npow s = << x in powr(s) st card x = n >>
175
176 n_rec_test;
177
178 end forall n;
179
180 x := newitem;
181
182 $ verify the identity:
183
184 $ pow (set + << singleton >> ) =
185 $ (pow set) + << y with singleton : y in pow set >>
186
187 singl_ident_test;
188
189 (forall n in (/0...2**i/)) $ test power sets of all sizes
190
191 $ verify the identity:
192
193 $ n npow (set + << singleton >> )
194 $ = <>
196
197 n_singl_ident_test;
198
199 end forall n;
200
201 slocal with:= newitem;
202 sremote with:= newitem;
203 ssparse with:= newitem;
204
205 end loop forall i;
206
207 tpowlocal := powr(slocal);
208 tpowremote := powr(sremote);
209 tpowsparse := powr(ssparse);
210
211 tlocal := tremote := tsparse := << >>;
212 slocal := sremote := ssparse := << >>;
213
214 loop forall i in sets_iterator
215 do
216 loop forall tmp in (/ 1... if i=1 then 1 else 2 end /)
217 do
218
219 $ verify the identity:
220
221 $ pow (s + t) = << y + z : y in pow s, z in pow t >>
222
223 set_ident_test;
224
225 (forall n in (/0...2**i/)) $ test power sets of all sizes
226
227 $ verify the identity:
228
229 $ n npow (s + t) =
230 $ << y + z : nn:=0...n, y in nn npow s,
231 $ z in (n-nn) npow t >>
232
233 n_set_ident_test;
234
235 end forall n;
236 tlocal from tpowlocal;
237 tremote from tpowremote;
238 tsparse from tpowsparse;
239
240 end loop forall tmp;
241 slocal with:= newitem;
242 sremote with:= newitem;
243 ssparse with:= newitem;
244
245 end loop forall i;
246
247 if test_status /= 'fail' $ so set by cardtest or eqtest
248 then
249 print;
250 print_line('all tests passed');
251 end if;
252
253 print_tail('test 8 - power set test');
254
255 end proc power_set_test;
256
257
258 proc powr(s);
259
260 if s = << >>
261 then
262 return << << >> >>;
263 else
264 singleton := arb s;
265 return powr(s - << singleton >> ) + << subset_ with singleton
266 : subset_ in powr(s - << singleton >> ) >>;
267 end if;
268
269 end proc powr;
270
271
272 proc rec_test;
273
274 eqtest(
275 spowlocal,
276 tpowlocal,
277 slocal,
278 om,
279 recursion_,
280 's',
281 om,
282 'local',
283 om);
284 eqtest(
285 spowremote,
286 tpowremote,
287 sremote,
288 om,
289 recursion_,
290 's',
291 om,
292 'remote',
293 om);
294 eqtest(
295 spowsparse,
296 tpowsparse,
297 ssparse,
298 om,
299 recursion_,
300 's',
301 om,
302 'sparse',
303 om);
304
305 end proc rec_test;
306
307 proc n_rec_test;
308
309 eqtest(
310 spowlocal,
311 << ylocal in tpowlocal st card ylocal = n >>,
312 slocal,
313 om,
314 n_recursion,
315 's',
316 om,
317 'local',
318 n);
319 eqtest(
320 spowremote,
321 << yremote in tpowremote st card yremote = n >>,
322 sremote,
323 om,
324 n_recursion,
325 's',
326 om,
327 'remote',
328 n);
329 eqtest(
330 spowsparse,
331 << ysparse in tpowsparse st card ysparse = n >>,
332 ssparse,
333 om,
334 n_recursion,
335 's',
336 om,
337 'sparse',
338 n);
339
340 end proc n_rec_test;
341
342 proc singl_ident_test;
343
344 eqtest(
345 pow (slocal + << x >> ),
346 (pow slocal) + << ylocal with x
347 : ylocal in pow slocal >>,
348 slocal,
349 x,
350 singl_identity,
351 'set',
352 'singleton',
353 'local',
354 om);
355 eqtest(
356 pow (sremote + << x >> ),
357 (pow sremote) + << yremote with x
358 : yremote in pow sremote >>,
359 sremote,
360 x,
361 singl_identity,
362 'set',
363 'singleton',
364 'remote',
365 om);
366 eqtest(
367 pow (ssparse + << x >> ),
368 (pow ssparse) + << ysparse with x
369 : ysparse in pow ssparse >>,
370 ssparse,
371 x,
372 singl_identity,
373 'set',
374 'singleton',
375 'sparse',
376 om);
377
378 end proc singl_ident_test;
379
380 proc n_singl_ident_test;
381
382 eqtest(
383 n npow (slocal + << x >> ),
384 (n npow slocal) + if n<=0 then << >> else << ylocal
385 with x : ylocal in (n - 1) npow slocal >> end,
386 slocal,
387 x,
388 n_singl_identity,
389 'set',
390 'singleton',
391 'local',
392 n);
393 eqtest(
394 n npow (sremote + << x >> ),
395 (n npow sremote) + if n<=0 then << >> else << yremote
396 with x : yremote in (n - 1) npow sremote >> end,
397 sremote,
398 x,
399 n_singl_identity,
400 'set',
401 'singleton',
402 'remote',
403 n);
404 eqtest(
405 n npow (ssparse + << x >> ),
406 (n npow ssparse) + if n<=0 then << >> else << ysparse
407 with x : ysparse in (n - 1) npow ssparse >> end,
408 ssparse,
409 x,
410 n_singl_identity,
411 'set',
412 'singleton',
413 'sparse',
414 n);
415
416 end proc n_singl_ident_test;
417
418 proc set_ident_test;
419
420 eqtest(
421 pow (slocal + tlocal),
422 << ylocal + zlocal
423 : ylocal in pow slocal, zlocal in pow tlocal >>,
424 slocal,
425 tlocal,
426 set_identity,
427 's',
428 't',
429 'local',
430 om);
431 eqtest(
432 pow (sremote + tremote),
433 << yremote + zremote
434 : yremote in pow sremote, zremote in pow tremote >>,
435 sremote,
436 tremote,
437 set_identity,
438 's',
439 't',
440 'remote',
441 om);
442 eqtest(
443 pow (ssparse + tsparse),
444 << ysparse + zsparse
445 : ysparse in pow ssparse, zsparse in pow tsparse >>,
446 ssparse,
447 tsparse,
448 set_identity,
449 's',
450 't',
451 'sparse',
452 om);
453
454 end proc set_ident_test;
455
456 proc n_set_ident_test;
457
458 eqtest(
459 n npow (slocal + tlocal),
460 << ylocal + zlocal : nn in (/0...n/),
461 ylocal in nn npow slocal,
462 zlocal in (n - nn) npow tlocal >>,
463 slocal,
464 tlocal,
465 n_set_identity,
466 's',
467 't',
468 'local',
469 n);
470 eqtest(
471 n npow (sremote + tremote),
472 << yremote + zremote : nn in (/0...n/),
473 yremote in nn npow sremote,
474 zremote in (n - nn) npow tremote >>,
475 sremote,
476 tremote,
477 n_set_identity,
478 's',
479 't',
480 'remote',
481 n);
482 eqtest(
483 n npow (ssparse + tsparse),
484 << ysparse + zsparse : nn in (/0...n/),
485 ysparse in nn npow ssparse,
486 zsparse in (n - nn) npow tsparse >>,
487 ssparse,
488 tsparse,
489 n_set_identity,
490 's',
491 't',
492 'sparse',
493 n);
494
495 end proc n_set_ident_test;
496
497 proc eqtest(pow1,pow2,s1,s2,test_,nams1,nams2,base_,npowsize);
498
499 if print_mode = print_debug then
500 print; print;
501 print('test the identity', test_,
502 'using', base_, 'data representation.');
503 print(' ',nams1,' = ',s1);
504 if s2 /= om then print(' ', nams2, '=', s2); end if;
505 if npowsize /= om then print(' n = ', npowsize); end if;
506 print(' lhs identity = ',pow1);
507 print(' rhs identity = ',pow2);
508 end if;
509
510 assert pow1 = pow2;
511
512 end proc eqtest;
513
514
515 drop
516 newitem,
517 singl_iterator,
518 sets_iterator;
519
520
521 end module test - power_set;
522
523
524
525
1 .=member test9
2 module test - map_identities;
3
4 $ nyu test id
5 $ author - larry rudolph (nyu-cims)
6
7 exports
8 map_identity_test;
9 reads
10 print_mode;
11
12$ this program tests the following identies:
13$
14$ 1. cardinality of <> = cardinality of a * domain f
15$
16$ 2. the set <> = range <<(/x, f(x)/) : x in a>>
17$
18$ 3. the set <> = the set <>
19$
20$ the map f and the set a have the following restrictions:
21$
22$ 1. f must be one-to-one.
23$
24$ 2. a must be a subset of the domain of f.
25$
26$
27$ single parameter maps are tested via the proceedure 'svmtest'.
28$ these maps have variable names begining with the letter 'f'. two
29$ parameter maps are tested in proceedure 'mpmtest' and all two
30$ parameter maps begin with the letter 'g'.
31$
32$ the program runs in two modes: brief and verbose. the brief
33$ mode only signals test failures; in the verbose mode, a running
34$ comentary is supplied along with the results of all tests.
35$
36$ n.b. the statement of the assignment contained a error.
37$ the set <> does not equal the
38$ set <>.
39$ (see number 3 above for the correct equalities.)
40
41 var
42 flsm, frsm, fssm, flbsm, frbsm, fsbsm,
43 flm, frm, fsm, flbm, frbm, fsbm,
44 glm, grm, gsm, glbm, grbm, gsbm,
45 glmm, grmm, gsmm, glbmm, grbmm, gsbmm,
46 als, ars, ass,
47 bls, brs, bss;
48
49 const
50 setofsets =
51 << <<3,4,5>>, <<4,5>>, <<3>>, <> >>;
52
53
54 repr
55 base intb: integer;
56 base rng: integer;
57 base pairs: tuple(elmt rng, elmt rng);
58 mode remote_smap: remote smap(elmt rng) integer;
59 mode remote_set: remote set(elmt pairs);
60
61 flm: local map (elmt intb) integer;
62 frm: remote map (elmt intb) integer;
63 fsm: sparse map (elmt intb) integer;
64 flbm: local map (elmt intb) elmt rng;
65 frbm: remote map (elmt intb) elmt rng;
66 fsbm: sparse map (elmt intb) elmt rng;
67
68 flsm: local smap(elmt intb) integer;
69 frsm: remote smap(elmt intb) integer;
70 fssm: sparse smap(elmt intb) integer;
71 flbsm: local smap(elmt intb) elmt rng;
72 frbsm: remote smap(elmt intb) elmt rng;
73 fsbsm: sparse smap(elmt intb) elmt rng;
74
75 glm: local map (elmt intb) tuple(elmt rng, integer);
76 grm: remote map (elmt intb) tuple(elmt rng, integer);
77 gsm: sparse map (elmt intb) tuple(elmt rng, integer);
78 glbm: local map (elmt intb) elmt pairs;
79 grbm: remote map (elmt intb) elmt pairs;
80 gsbm: sparse map (elmt intb) elmt pairs;
81
82 glmm: local mmap<> remote_smap;
83 grmm: remote mmap<> remote_smap;
84 gsmm: sparse mmap<> remote_smap;
85 glbmm: local mmap<> remote_set;
86 grbmm: remote mmap<> remote_set;
87 gsbmm: sparse mmap<> remote_set;
88
89 als, bls: local set(elmt intb);
90 ars, brs: remote set(elmt intb);
91 ass, bss: sparse set(elmt intb);
92 end repr;
93
94 procedure map_identity_test;
95
96 print_head('test 9 - map identity test');
97
98 if print_mode = print_debug then
99 print('note: f indicates a 1-parameter map');
100 print(' g indicates a 2-parameter map');
101 end if;
102
103
104 svmtest( <<(/-55, 33/)>>,
105 <<-55>>,
106 'a and f both contain only one element');
107
108 svmtest( <<(/x, x+x/) : x in (/1..10/)>>,
109 <<1..10>>,
110 'a is identical to domain f');
111
112 svmtest( <<(/x, x/) : x in (/1..10/)>>,
113 <<2, 10>>,
114 'a is a proper subset of domain f');
115
116 svmtest( <<(/x+x+2, x/) : x in (/17..23/)>>,
117 <<36>>,
118 'a contains only one element');
119
120 svmtest( <<(/x, x/) : x in (/1..5/)>>,
121 <>,
122 'a is the empty set');
123
124
125 $ test two parameter maps
126 (forall a in setofsets, b in setofsets)
127 mpmtest(
128 <<(/x, (/y, 2**x * 3**y/)/) : x in a, y in b>>,
129 a,
130 b
131 );
132 end forall a;
133
134 print_tail('test 9 - map identity tests');
135
136 end procedure map_identity_test;
137
138
139 procedure svmtest(fmap, aset, heading);
140
141 $ test one parameter maps.
142
143 if print_mode = print_debug then
144 print; print(heading); print;
145 end if;
146
147 svmtest_1(fmap, aset, heading);
148 svmtest_2(fmap, aset, heading);
149
150 end procedure svmtest;
151
152
153 procedure svmtest_1(fmap, aset, heading);
154
155 if print_mode = print_debug then
156 print;
157 print(' test single-valued map representation');
158 print;
159 end if;
160
161 als := ars := ass := aset;
162 flsm := frsm := fssm := fmap;
163 flbsm := frbsm := fsbsm := fmap;
164
165
166 $ test unbased map
167 assert <> =
168 range <<(/x, fmap(x)/) : x in aset>>
169 and range <<(/x, fmap(x)/) : x in aset>> =
170 <>
171 and # <> =
172 # (aset * domain fmap);
173
174 $ test local smap
175 assert <> =
176 range <<(/x, flsm(x)/) : x in als>>
177 and range <<(/x, flsm(x)/) : x in ars>> =
178 <>
179 and # <> =
180 # (als * domain flsm);
181
182 $ test remote smap
183 assert <> =
184 range <<(/x, frsm(x)/) : x in ars>>
185 and range <<(/x, frsm(x)/) : x in ass>> =
186 <>
187 and # <> =
188 # (ars * domain frsm);
189
190 $ test sparse smap
191 assert <> =
192 range <<(/x, fssm(x)/) : x in ass>>
193 and range <<(/x, fssm(x)/) : x in aset>> =
194 <>
195 and # <> =
196 # (ass * domain fssm);
197
198
199 $ test local smap
200 assert <> =
201 range <<(/x, flbsm(x)/) : x in aset>>
202 and range <<(/x, flbsm(x)/) : x in als>> =
203 <>
204 and # <> =
205 # (aset * domain flbsm);
206
207 $ test remote smap
208 assert <> =
209 range <<(/x, frbsm(x)/) : x in ars>>
210 and range <<(/x, frbsm(x)/) : x in ass>> =
211 <>
212 and # <> =
213 # (ars * domain frbsm);
214
215 $ test sparse smap
216 assert <> =
217 range <<(/x, fsbsm(x)/) : x in ass>>
218 and range <<(/x, fsbsm(x)/) : x in als>> =
219 <>
220 and # <> =
221 # (ass * domain fsbsm);
222
223
224 end procedure svmtest_1;
225
226
227 procedure svmtest_2(fmap, aset, heading);
228
229 if print_mode = print_debug then
230 print;
231 print(' test ambiguous map representation');
232 print;
233 end if;
234
235 als := ars := ass := aset;
236 flm := frm := fsm := fmap;
237 flbm := frbm := fsbm := fmap;
238
239
240 $ test local map
241 assert <> =
242 range <<(/x, flm(x)/) : x in ass>>
243 and range <<(/x, flm(x)/) : x in als>> =
244 <>
245 and # <> =
246 # (ass * domain flm);
247
248 $ test remote map
249 assert <> =
250 range <<(/x, frm(x)/) : x in als>>
251 and range <<(/x, frm(x)/) : x in aset>> =
252 <>
253 and # <> =
254 # (als * domain frm);
255
256 $ test sparse map
257 assert <> =
258 range <<(/x, fsm(x)/) : x in aset>>
259 and range <<(/x, fsm(x)/) : x in ars>> =
260 <>
261 and # <> =
262 # (aset * domain fsm);
263
264
265 $ test local map
266 assert <> =
267 range <<(/x, flbm(x)/) : x in als>>
268 and range <<(/x, flbm(x)/) : x in ass>> =
269 <>
270 and # <> =
271 # (ass * domain flbm);
272
273 $ test remote map
274 assert <> =
275 range <<(/x, frbm(x)/) : x in ass>>
276 and range <<(/x, frbm(x)/) : x in ars>> =
277 <>
278 and # <> =
279 # (ars * domain frbm);
280
281 $ test sparse map
282 assert <> =
283 range <<(/x, fsbm(x)/) : x in ars>>
284 and range <<(/x, fsbm(x)/) : x in als>> =
285 <>
286 and # <> =
287 # (als * domain fsbm);
288
289
290 end procedure svmtest_2;
291
292 procedure mpmtest(g, aset, bset);
293
294 $ test 2-parameter maps (nameed g).
295
296 if print_mode = print_debug then
297 print;
298 print('two parameter map test');
299 print;
300 end if;
301
302 mpmtest_1(g, aset, bset);
303 mpmtest_2(g, aset, bset);
304 mpmtest_3(g, aset, bset);
305 mpmtest_4(g, aset, bset);
306
307 end procedure mpmtest;
308 procedure mpmtest_1(g, aset, bset);
309
310 if print_mode = print_debug then
311 print; print(' range is unbased pair'); print;
312 end if;
313
314 als := ars := ass := aset;
315 bls := brs := bss := bset;
316 glm := grm := gsm := g;
317
318
319 $ test unbased map
320 assert <<>(y) : x in ars, y in bss>> =
321 range range
322 <<(/x, (/y, g<>(y)/)/) : x in als, y in bss>>
323 and range range
324 <<(/x, (/y, g<>(y)/)/) : x in als, y in bss>> =
325 <>
326 and # <> =
327 # aset * # bset;
328
329 $ test local map
330 assert <<>(y) : x in ars, y in bss>> =
331 range range
332 <<(/x, (/y, glm<>(y)/)/) : x in als, y in bss>>
333 and range range
334 <<(/x, (/y, glm<>(y)/)/) : x in als, y in bss>> =
335 <>
336 and # <> =
337 # aset * # bset;
338
339 $ test remote map
340 assert <<>(y) : x in ars, y in bss>> =
341 range range
342 <<(/x, (/y, grm<>(y)/)/) : x in als, y in bss>>
343 and range range
344 <<(/x, (/y, grm<>(y)/)/) : x in als, y in bss>> =
345 <>
346 and # <> =
347 # aset * # bset;
348
349 $ test sparse map
350 assert <<>(y) : x in ars, y in bss>> =
351 range range
352 <<(/x, (/y, gsm<>(y)/)/) : x in als, y in bss>>
353 and range range
354 <<(/x, (/y, gsm<>(y)/)/) : x in als, y in bss>> =
355 <>
356 and # <> =
357 # aset * # bset;
358
359
360 end procedure mpmtest_1;
361
362
363 procedure mpmtest_2(gmap, aset, bset);
364
365 if print_mode = print_debug then
366 print; print(' range is element-of-base'); print;
367 end if;
368
369 als := ars := ass := aset;
370 bls := brs := bss := bset;
371 glbm := grbm := gsbm := gmap;
372
373
374 $ test local map
375 assert <<>(y) : x in ars, y in bss>> =
376 range range
377 <<(/x, (/y, glbm<>(y)/)/) : x in als, y in bss>>
378 and range range
379 <<(/x, (/y, glbm<>(y)/)/) : x in als, y in bss>> =
380 <>
381 and # <> =
382 # aset * # bset;
383
384 $ test remote map
385 assert <<>(y) : x in ars, y in bss>> =
386 range range
387 <<(/x, (/y, grbm<>(y)/)/) : x in als, y in bss>>
388 and range range
389 <<(/x, (/y, grbm<>(y)/)/) : x in als, y in bss>> =
390 <>
391 and # <> =
392 # aset * # bset;
393
394 $ test sparse map
395 assert <<>(y) : x in ars, y in bss>> =
396 range range
397 <<(/x, (/y, gsbm<>(y)/)/) : x in als, y in bss>>
398 and range range
399 <<(/x, (/y, gsbm<>(y)/)/) : x in als, y in bss>> =
400 <>
401 and # <> =
402 # aset * # bset;
403
404
405 end procedure mpmtest_2;
406
407
408 procedure mpmtest_3(gmap, aset, bset);
409
410 if print_mode = print_debug then
411 print; print(' map is multi-valued by declaration'); print;
412 end if;
413
414 als := ars := ass := aset;
415 bls := brs := bss := bset;
416 glmm:= grmm:= gsmm:= gmap;
417
418
419 $ test local mmap
420 assert <<>(y) : x in ars, y in bss>> =
421 range range
422 <<(/x, (/y, glmm<>(y)/)/) : x in als, y in bss>>
423 and range range
424 <<(/x, (/y, glmm<>(y)/)/) : x in als, y in bss>> =
425 <>
426 and # <> =
427 # aset * # bset;
428
429 $ test remote mmap
430 assert <<>(y) : x in ars, y in bss>> =
431 range range
432 <<(/x, (/y, grmm<>(y)/)/) : x in als, y in bss>>
433 and range range
434 <<(/x, (/y, grmm<>(y)/)/) : x in als, y in bss>> =
435 <>
436 and # <> =
437 # aset * # bset;
438
439 $ test sparse mmap
440 assert <<>(y) : x in ars, y in bss>> =
441 range range
442 <<(/x, (/y, gsmm<>(y)/)/) : x in als, y in bss>>
443 and range range
444 <<(/x, (/y, gsmm<>(y)/)/) : x in als, y in bss>> =
445 <>
446 and # <> =
447 # aset * # bset;
448
449
450 end procedure mpmtest_3;
451
452
453 procedure mpmtest_4(gmap, aset, bset);
454
455 if print_mode = print_debug then
456 print; print(' range is remote smap'); print;
457 end if;
458
459 als := ars := ass := aset;
460 bls := brs := bss := bset;
461 glbmm := grbmm := gsbmm := gmap;
462
463
464 $ test local mmap
465 assert <<>(y) : x in ars, y in bss>>
466 = range range
467 <<(/x, (/y, glbmm<>(y)/)/) : x in als, y in bss>>
468 and range range
469 <<(/x, (/y, glbmm<>(y)/)/) : x in als, y in bss>>
470 = <>
471 and # <>
472 = # aset * # bset;
473
474 $ test remote mmap
475 assert <<>(y) : x in ars, y in bss>>
476 = range range
477 <<(/x, (/y, grbmm<>(y)/)/) : x in als, y in bss>>
478 and range range
479 <<(/x, (/y, grbmm<>(y)/)/) : x in als, y in bss>>
480 = <>
481 and # <>
482 = # aset * # bset;
483
484 $ test sparse mmap
485 assert <<>(y) : x in ars, y in bss>>
486 = range range
487 <<(/x, (/y, gsbmm<>(y)/)/) : x in als, y in bss>>
488 and range range
489 <<(/x, (/y, gsbmm<>(y)/)/) : x in als, y in bss>>
490 = <>
491 and # <>
492 = # aset * # bset;
493
494
495 end procedure mpmtest_4;
496
497
498 end module test - map_identities;
499
500
501
502
1 .=member test16
2 module test - circularity;
3
4 $ nyu test id
5 $ author - r. lee (nyu-cims)
6 $ logged in as lee16
7
8 exports
9 circularity_test;
10
11 reads
12 print_mode;
13
14 $ circularity test (by richard lee)
15 $
16 $ in this test we build various circular structures
17 $ and subject these structures to equality tests with
18 $ equivalent ones built explicitly which are not
19 $ self-referent.
20
21 macro unitset;
22 <<1>> endm;
23
24
25 var
26 sibase, $ set of based integers
27 srbase, $ set of based reals
28 sloc, $ local set of integers
29 srem, $ remote set of integers
30 stint, $ set of tuples of integers
31 stibase, $ set of tuples of based integers
32 ssbase, $ set of based sets
33 sm, $ single valued map
34 mm, $ multivalued map
35 mmr, $ remote multivalued map
36 mml, $ local multivalued map
37 mmlr; $ multivalued local map of remote map
38
39 repr
40
41 base ibase : integer;
42 base rbase : real;
43 base tint : tuple( integer);
44 base tibase : tuple(elmt ibase);
45 base sbase : set( integer);
46
47 sibase : set(elmt ibase);
48 srbase : set(elmt rbase);
49 stint : set(elmt tint);
50 stibase: set(elmt tibase);
51 sloc : local set(elmt ibase);
52 srem : remote set(elmt ibase);
53 ssbase : set(elmt sbase);
54 sm : smap(elmt ibase)
55 elmt ibase;
56 mm : mmap <>
57 set(elmt ibase);
58 mmr : remote mmap <>
59 set(elmt ibase);
60 mml : local mmap <>
61 set(elmt ibase);
62 mmlr : local mmap <>
63 remote mmap <>
64 set(elmt ibase);
65
66 end repr;
67
68
69 proc circularity_test;
70
71 print_head('test 16 - circular structure test');
72
73
74 si := satom := gmap := sr := nullset;
75
76 loop forall i in (/ 1... 10 /) do $ build
77 si +:= <>; $ set of integers,
78 sr +:= << float(i)+0.5>>; $ set of reals,
79 satom with:= newat; $ set of atoms,
80 gmap(i) := 2*i+1; $ single valued map
81 end loop; $ respectively
82
83 sm := gmap; $ force into new repr
84
85 sibase := si; $ force into new repr
86
87 srbase := sr; $ force into new repr
88
89 sloc := si; $ force into new repr
90 srem := sloc; $ force into new repr
91 sspar := srem; $ force into default repr
92
93 stup := nullset; $ build set of tuples of varying
94 tup := nulltup; $ lengths
95 sett := sset := nullset; $ and set of sets
96 loop forall i in (/ 1...10 /) do
97 tup with:= i;
98 stup with:= tup;
99 sett with:= i;
100 sset with:= sett;
101 end;
102
103 stint := stup; $ force into new repr
104 stibase := stint; $ force into new repr
105
106 ssbase := sset; $ force into new repr
107
108 mm := gmap; $ build multivalued map
109 (forall x in sm)
110 mm<> +:= <>;
111 end forall;
112
113 mml := mm ; $ force into new repr
114 mmr := mml; $ force into new repr
115
116 mmlr := << (/i,(/i+j,2*j/)/) : i in (/1...10/), j in (/1...5/) >>;
117 $ doubly indexed map
118
119
120 sgen := << 3, (/10,4/), 2.5, 'abcd' >>; $ mixed set
121 sgen with:= sgen;
122
123 sch := << 'a', 'b', 'c', 'dd', 'zzz', 'set of characters' >>;
124 $ set of character strings
125
126 setnc := <>; $ set of null character
127
128 setns := <>; $ set of empty set
129
130 setnt := <>; $ set of null tuple
131
132
133 circtest(nullset, 'empty set' );
134 circtest(unitset, 'unit set' );
135
136 circtest(setnc, 'set of null character' );
137 circtest(setns, 'set of null set' );
138 circtest(setnt, 'set of null tuple' );
139
140 circtest(satom, 'set of atoms' );
141
142 circtest(stup, 'set of tuples' );
143 circtest(stint, 'set of based tuples' );
144 circtest(stibase, 'set of tuples of based integers' );
145
146 circtest(si, 'set of integers' );
147 circtest(sibase, 'set of based integers' );
148
149 circtest(sr, 'set of reals' );
150 circtest(srbase, 'set of based reals' );
151
152 circtest(sloc, 'local set of integers' );
153 circtest(srem, 'remote set of integers' );
154 circtest(sspar, 'sparse set of integers' );
155
156 circtest(sgen, 'general set' );
157
158 circtest(sch, 'set of character strings' );
159
160 circtest(sset, 'set of sets' );
161 circtest(ssbase, 'set of based sets' );
162
163 circtest(gmap, 'general map' );
164 circtest(sm, 'single valued map' );
165 circtest(mm, 'multi-valued map' );
166 circtest(mmr, 'multi-valued remote map' );
167 circtest(mml, 'multi-valued local map' );
168 circtest(mmlr, 'multi-valued local/remote map' );
169
170
171 print_tail('test 16 - circular structure test');
172
173 end proc circularity_test;
174
175
176 proc circtest(sinit, mesg);
177
178 $ build circular sets
179 loop init $ base step
180 simp:=sexp:=sinit;
181 simp with:= simp;
182 temp := sexp;
183 sexp with:= temp;
184 if print_mode = print_debug then
185 print('++++ building circular',mesg);
186 print('++ step = 1 implicit set =',simp);
187 print('++ explicit set =',sexp);
188 end if;
189 i := card sinit div 2 + 1;
190 j := i;
191 while ( i <= card sinit )
192 step j+:= 1;
193 until j > i + 1
194 do $ i th step
195 simp with:= simp;
196 temp :=sexp;
197 sexp with:= temp;
198 if print_mode = print_debug then
199 print('++ step =',j,' implicit set =',simp);
200 print('++ explicit set =',sexp);
201 end if;
202 end;
203 $ circular equality test
204 assert simp = sexp;
205
206 end proc circtest;
207
208
209 drop
210 unitset;
211
212
213 end module test - circularity;
214
215
216
217
1 .=member test24
2 module test - quantifiers;
3
4 $ nyu program identification
5 $ author - richard lee
6 $ entered in as file lee24a in tstbag/un=shwrtzj
7 $ renamed as rtl24a 24 jan 79
8
9 exports
10 quantifier_test;
11
12 reads
13 print_mode;
14
15
16 $ this is first of a series of quantifier tests
17 $ in this test we build sets and tuples of integers
18 $ and reals.
19 $ in particular three of each repr is built such
20 $ that the first is always false on p(x), the
21 $ second is partially true and partially false on
22 $ p(x), and the third is always true on p(x) where
23 $ p(x) is a chosen predicate of one variable.
24
25 macro p(x);
26 x > zero(x) endm;
27
28 var
29
30 teststatus,
31
32 sibase, $ based integer sets
33 srbase, $ based real sets
34 tibase, $ based integer tuples
35 trbase, $ based real tuples
36 sirem; $ remote integer sets
37
38 repr
39
40 base ibase : integer;
41 base rbase : real;
42
43 sibase : tuple( set(elmt ibase) );
44 srbase : tuple( set(elmt rbase) );
45 tibase : tuple( tuple(elmt ibase) );
46 trbase : tuple( tuple(elmt rbase) );
47 sirem : tuple( remote set(elmt ibase) );
48
49 end repr;
50
51
52 proc quantifier_test;
53
54 print_head('quantifier test');
55
56 $ build our basic sets and tuples
57 rsets := isets := (/nullset,nullset,nullset/);
58 rtups := itups := (/nulltup,nulltup,nulltup/);
59 lims := (/(/-10,-1/),(/-5,5/),(/1,10/)/);
60 loop forall (/lwb, upb/) = lims(j) do
61 loop forall i in (/ lwb...upb /)do
62 isets(j) with:= i;
63 rsets(j) with:= float(i);
64 itups(j) with:= i;
65 rtups(j) with:= float(i);
66 end;
67 end;
68
69 $ now try some different reprs
70 srbase := rsets;
71 sibase := isets;
72 siloc := sibase;
73 sirem := siloc;
74 trbase := rtups;
75 tibase := itups;
76
77 loop forall i in (/ 1...3 /) do
78 qtest1(isets(i), 'sparse integer set ' + str(i));
79 qtest1(rsets(i), 'sparse real set ' + str(i));
80 qtest1(sibase(i), 'based integer set ' + str(i));
81 qtest1(srbase(i), 'based real set ' + str(i));
82 qtest1(siloc(i), 'local set ' + str(i));
83 qtest1(sirem(i), 'remote set ' + str(i));
84 qtest1(tibase(i), 'based integer tuple ' + str(i));
85 qtest1(trbase(i), 'based real tuple ' + str(i));
86 end;
87
88 print_tail('quantifier test');
89
90
91 end proc quantifier_test;
92
93
94 proc qtest1(s,mesg2);
95
96 $ checks some fundamental properties of quantifiers
97
98 tracecheck(s,'entering qtest1',mesg2);
99
100 mesg1 := '++ semantic test of universal quantifier - part a';
101 tracecheck(s,mesg1,mesg2);
102
103 if (forall x in s st p(x)) then
104 if +/(/1 : x in s st p(x)/) = card s then
105 tracecheck(s,mesg1+' passed',mesg2);
106 else failed_(s,mesg1,mesg2); end;
107 else tracecheck(s,mesg1+' passed',mesg2);
108 end if;
109
110 mesg1 := '++ semantic test of universal quantifier - part b';
111 tracecheck(s,mesg1,mesg2);
112
113 if +/(/1 : x in s st p(x)/) = card s then
114 if (forall x in s st p(x)) then
115 tracecheck(s,mesg1+' passed',mesg2);
116 else failed_(s,mesg1,mesg2); end;
117 else tracecheck(s,mesg1+' passed',mesg2);
118 end if;
119
120 mesg1 := '++ semantic test of existential quantifier - part a';
121 tracecheck(s,mesg1,mesg2);
122
123 if (exists x in s st p(x)) then
124 if +/(/ 1 : x in s st p(x) /) /= om then
125 tracecheck(s,mesg1+' passed',mesg2);
126 else failed_(s,mesg1,mesg2); end;
127 else tracecheck(s,mesg1+' passed',mesg2);
128 end if;
129
130 mesg1 := '++ semantic test of existential quantifier - part b';
131 tracecheck(s,mesg1,mesg2);
132
133 if not (+/(/1 : x in s st p(x)/) = om) then
134 if (exists x in s st p(x)) then
135 tracecheck(s,mesg1+' passed',mesg2);
136 else failed_(s,mesg1,mesg2); end;
137 else tracecheck(s,mesg1+' passed',mesg2);
138 end if;
139
140 passall(s,'semantic tests',mesg2);
141
142 tracecheck(s,'leaving qtest1',mesg2);
143
144 end proc qtest1;
145
146
147 proc passall(s,mesg1,mesg2);
148
149 $ prints success messages
150
151 if teststatus = 'failed' then teststatus := ''; return;
152 else teststatus := 'passed';
153 end if;
154
155 if print_mode >= print_full then
156 print(mesg1,'with',mesg2,'all passed');
157 end if;
158
159 end proc passall;
160
161
162 proc failed_(s,mesg1,mesg2);
163
164 $ failure diagnostic dump
165
166 teststatus := 'failed';
167 print(60*'-');
168 print(mesg1,'with',mesg2,'failed');
169 print('s =',s);
170 print(60*'-');
171
172 end proc failed_;
173
174 proc tracecheck(s,mesg1,mesg2);
175
176 $ print trace messages
177
178 if print_mode = print_debug then
179 print('*trace*',mesg1,'with',mesg2);
180 end;
181
182 end proc tracecheck;
183
184
185 proc zero(x);
186 return(x-x);
187 end proc zero;
188
189
190 drop
191 p;
192
193
194 end module test - quantifiers;
195
196
197
198
1 .=member test28
2 module test - recursion;
3
4 $ nyu test id
5 $ author - j. schwartz (nyu-cims)
6 $ logged in as jts14
7 $ passed xsetl 30 jan 79
8 $ forward to stefan as file ds05
9
10 exports
11 recursion_test;
12
13 reads
14 print_mode;
15
16 var
17 have; $ memo function map
18
19
20 proc recursion_test; $ tests recursive routines
21
22 print_head('recursion test');
23
24 (forall n in (/ 1...6/)) assert factorial(n) = */(/1...n/); end;
25
26 have:=nullset;
27 (forall n in (/ 1...10/)) assert fib(n) = fib2(n)
28 and fib2(n) = fib3(n); end;
29
30 have:=nullset;
31 (forall n in (/ 10, 9...1 /)) assert fib(n) = fib2(n)
32 and fib2(n) = fib3(n); end;
33
34 $ recursive sorting test
35 tupa := (/1,3,2/); tupb := (/1,4,3/);
36 tup := tupa + tupb + tupa; tup := tup + tup;
37 tups := tupa + tupa + tupb; tups := tups + tups;
38
39 assert bsort(tup) = msort(tups);
40
41 print_tail('recursion test');
42
43 end proc recursion_test;
44
45
46 proc factorial(n);
47
48 return if n=1 then 1 else n*factorial (n-1) end;
49
50 end proc factorial;
51
52
53 proc fib(n);
54
55 return if n=1 or n=2 then 1 else
56 fib(n-1)+fib(n-2) end;
57
58 end proc fib;
59
60
61 proc fib2(n);
62
63 if have(n) = om then
64
65 have(n):= if n=1 or n=2 then 1 else
66 fib(n-1)+fib(n-2) end;
67
68 end if;
69
70 return have(n);
71
72 end proc fib2;
73
74
75 proc fib3(m);
76
77 fibmap :=<<(/1,1/),(/2,1/)>>;
78
79 (forall n in (/ 3...m /))
80
81 fibmap(n) := fibmap(n-1)+fibmap(n-2);
82 fibmap(n-2):=om;
83
84 end forall;
85
86 return fibmap(m);
87
88
89 end proc fib3;
90
91
92 proc bsort(tup);
93
94 return if(card tup)=1 then tup else
95 putin(tup(1), bsort(tup(2..))) end ;
96
97 end proc bsort;
98
99
100 proc putin (x,tup);
101
102 return if x <= tup(1) then (/x/)+ tup
103 elseif (card tup)=1 then tup+(/x/) else
104 (/tup(1)/)+putin(x,tup(2..)) end ;
105
106 end proc putin;
107
108
109 proc msort (tups);
110
111 return if(card tups)=1 then tups else
112 merge(msort(tups(1...(card tups)div 2)),
113 bsort(tups((card tups)div 2 + 1..))) end ;
114
115 end proc msort;
116
117
118 proc merge(t1,t2);
119
120 return if t1=(//) then t2
121
122 elseif t2=(//) then t1
123
124 elseif t1(1)<< random(100): 1...cases(i) >>;
36 $ random not implemented, fake it.
37 testset := << 1...cases(i) >>;
38
39 print; print; print;
40 print('case number', i, ', test set is', testset);
41
42 median := kthone((card testset+1) div 2, testset);
43 print('the median of the test set is', median);
44 end forall;
45
46 print_tail('median test');
47
48 end proc median_test;
49
50
51 proc kthone(kparam, setparam);
52
53 $ the value of this function is the kparam'th number, in
54 $ ascending order, of the given set 'setparam' of numbers. if
55 $ kparam is out of range, the result is undefined.
56 $ this is the algorithm discovered by floyd, et al, in late
57 $ 1971, that runs in linear time.
58
59 $ 'kthonebl' is a global variable (to prevent stacking on
60 $ recursion). user must initialize it to null char. string.
61
62 if setparam = nullset then return om; end if;
63
64 $ save parameters - this routine does not alter them.
65 k := kparam;
66 sett := setparam;
67
68 kthonebl +:= ' '; $ change print identing level
69
70 (while (card sett)>= 3) $ number of comparisons
71 $ build set 'midpts', the set of middle values from
72 $ 'set', taking the numbers three at a time.
73 i := 2;
74 midpts := <>;
75 (forall x in sett)
76 i := (i+1) mod 3;
77
78 if i = 0 then u := x;
79 elseif i = 1 then v := x;
80 elseif i = 2 then
81 $ put median of u, v, and the current x into set
82 $ midpts. requires 3 comparisons (worst case).
83
84 if x < v then
85 cas := 1;
86 else
87 cas := 0;
88 end;
89
90 if u < x then
91 cas := cas + 2;
92 end;
93
94 if v < u then
95 cas := 3 - cas;
96 end;
97 $ now cas must be 1, 2, or 3.
98 tmp:=(/u, v, x/);
99 midpts with:= tmp(cas);
100 end if i ;
101 end forall x;
102
103 $ print number of comparisons, indented.
104 print(kthonebl, (card sett div 3)*3);
105 $ as many as two members of -sett- have not been considered
106 $ for placement in -midpts-. but the error is not sufficient
107 $ to prevent this algorithm from working in linear time.
108 $ note that card midpts ge. 1, because card set ge. 3.
109 $ now find the (exact) median of 'midpts', in linear time.
110 $ this algorithm chooses on the low side if card midpts is eve
111 median := kthone((card midpts+1) div 2, midpts);
112 $ note that 'median' is somewhere in the middle third of
113 $ -sett-.
114 $ precisely, the number of members of -sett- that
115 $ are less than 'median' is at least (n/3-1)/2 + (n/3+1)/2,
116 $ and the number of members that are greater is at least
117 $ n/6 + (n/3+2)/2, where n = card set.
118
119 $ now divide -sett- into two piles;members of 'smalpile'
120 $ are le. median, and members of 'bigpile' are gt. median.
121 smalpile := nullset ;
122 bigpile := nullset ;
123 (forall x in sett)
124 if x <= median then
125 smalpile with:= x;
126 else
127 bigpile with:= x;
128 end if;
129 end forall x;
130 $ print number of comparisons.
131 print(kthonebl, card sett);
132 $ since card set ge. 3, and we have thrown the median into
133 $ 'smalpile', we have card smalpile ge. 2 and card bigpile ge.
134 $ iterate to find the appropriate member of the appropriate
135 $ pile.
136
137 if k <= card smalpile then
138 sett := smalpile;
139 else
140 sett := bigpile;
141 k := k - card smalpile;
142 end if;
143 end while;
144 $ go back with new set and possibly new k.
145 kthonebl := if card kthonebl > 3 then
146 kthonebl(1...card kthonebl-3) else '' end;
147 $ now card set is 1 or 2 (it can't be zero). k may be out of
148 $ range if the original call had kparam out of range.
149
150 if (card sett) = 1 then
151 if k = 1 then
152 return arb sett;
153 else
154 return om ;
155 end if k;
156
157 else
158 $ card set must be 2.
159 if k = 1 then
160 return min/sett;
161 elseif k = 2 then
162 return max/sett;
163 else
164 return om ;
165 end if;
166 end if;
167
168 end proc kthone;
169
170
171 end module test - median_finder;
172
173
174
175
1 .=member huff
2 module test - huffman_coding;
3
4 $ nyu program identification
5 $ huffman encode and decode
6 $ author - j. schwartz (nyu-cims)
7 $ entered as file huff in tstbag/un=jts
8 $ conversion of setla program deck huff on t880 stestpl
9 $ passed xsetl 14-feb-79
10 $ forward for inclusion in standard tests 14-feb-79
11
12 exports
13 huffman_coding_test;
14
15 reads
16 print_mode;
17
18 const
19 csq = 'etaionshrdlubcfgjkmpqvwxyz .,',
20 fseq = (/ 10, 8, 7, 6, 5, 4, 4, 4, 4, 4,
21 3, 3, 3, 3, 3, 2, 2, 2, 2, 2,
22 1, 1, 1, 1, 1, 1, 10, 1, 1 /);
23
24 var
25 cseq,
26 code,
27 seq,
28 l,
29 r,
30 wfreq,
31 work;
32
33
34 proc huffman_coding_test;
35
36 print_head('huffman coding test');
37
38 cseq := (/csq(n): n in (/ 1...card csq /)/);
39 chs := nullset; $ character set
40
41 frq := nullset; $ frequency mapping
42 (forall n in (/ 1...card cseq/))
43 chs with:= cseq(n);
44 frq(cseq(n)) := fseq(n);
45 end forall;
46
47 huftabs := huftabl(chs, frq);
48 (/code, l, r, tp/) := huftabs;
49
50 strng := 'if you can read this, the huffman test has passed.';
51
52 coded := +/(/code(strng(n)): n in (/1...card strng/)/);
53 print( (decode := codsq(huftabs, coded)) );
54
55 assert decode = strng;
56
57 print_tail('huffman coding test');
58
59 end proc huffman_coding_test;
60
61
62 op .getmin (s); $
63
64 keep := arb s;
65 least := wfreq(keep);
66
67 (forall x in s)
68 if wfreq(x) < least then
69 keep := x;
70 least := wfreq(x);
71 end if;
72 end forall;
73
74 work less:= keep;
75
76 return keep;
77
78 end op .getmin;
79
80
81 $ routine to produce huffman tree and code table.
82 proc huftabl (chars, freq);
83 work := chars;
84 wfreq := freq;
85 l := nullset;
86 r := nullset;
87
88 (while (card work) > 1)
89 c1 := .getmin work;
90 c2 := .getmin work;
91 n := newat;
92 l(n) := c1;
93 r(n) := c2;
94 wfreq(n) := wfreq(c1)+wfreq(c2);
95 work with:= n;
96 end while;
97
98 code := nullset;
99 seq := nullstring;
100
101 if print_mode = print_debug then
102 print; print;
103 print('work =', work);
104 print('l = ', l );
105 print('r = ', r );
106 print;
107 end if;
108
109 tp := arb work;
110 walk(tp);
111 return (/code, l, r, tp/);
112
113 end proc huftabl;
114
115 proc walk(tp); $ recursive tree-walker
116 $ builds-up address of each twig
117
118 if l(tp) /= om then
119 seq := seq + '0';
120 walk(l(tp));
121 seq := seq + '1';
122 walk(r(tp));
123 else $ at twig
124 code(tp) := seq;
125 end if;
126
127 if(card seq) > 1 then
128 seq := seq(1...card seq-1);
129 else
130 seq := nullstring;
131 end;
132
133 end proc walk;
134
135
136 proc codsq(huftabs, sq); $ huffman decoding routine
137
138 (/jk, l, r, tp/) := huftabs;
139
140 outpu := nullstring;
141 node := tp;
142 n := 1;
143
144 (while n <= card sq step n := n+1;)
145 if l(node) = om then $ so that we are at twig
146 outpu := outpu + node;
147 node := tp;
148 n := n-1;
149 else
150 node := if sq(n) = '0' then l(node) else r(node) end;
151 end if;
152 end while;
153
154 return outpu + node;
155
156 end proc codsq;
157
158
159 end module test - huffman_coding;
160
161
162
163
1 .=member tarjan
2
3
4 module test - tarjan;
5
6 $ tarjan's fast interval finder.
7 $ (see setl newsletter no. 204 for details)
8
9 exports
10 tarjan_test;
11
12 reads
13 print_mode;
14
15
16 $ this example analyses the following graph:
17
18 $ [301]
19 $ ?
20 $ [302] ---------<---------
21 $ ? '
22 $ [303] --------<-------- '
23 $ ? ' '
24 $ [304] -------<------- ' '
25 $ ? ' ' '
26 $ [305] ------<------ ' ' '
27 $ ? ' ' ' '
28 $ [306] -----<----- ' ' ' '
29 $ ? ' ' ' ' '
30 $ [307] ----<---- ' ' ' ' '
31 $ ? ' ' ' ' ' '
32 $ [308] ---<--- ' ' ' ' ' '
33 $ ? ' ' ' ' ' ' '
34 $ [309] --<-- ' ' ' ' ' ' '
35 $ ? ' ' ' ' ' ' ' '
36 $ [310] -->-- ' ' ' ' ' ' '
37 $ ? ' ' ' ' ' ' '
38 $ [311] --->--- ' ' ' ' ' '
39 $ ? ' ' ' ' ' '
40 $ [312] ---->---- ' ' ' ' '
41 $ ? ' ' ' ' '
42 $ [313] ----->----- ' ' ' '
43 $ ? ' ' ' '
44 $ [314] ------>------ ' ' '
45 $ ? ' ' '
46 $ [315] ------->------- ' '
47 $ ? ' '
48 $ [316] -------->-------- '
49 $ ? '
50 $ [317] --------->---------
51 $ ?
52 $ [318]
53
54
55 const
56 int_graph = << (/301, 302/), (/302, 303/), (/303, 304/),
57 (/304, 305/), (/305, 306/), (/306, 307/),
58 (/307, 308/), (/308, 309/), (/309, 310/),
59 (/310, 311/), (/311, 312/), (/312, 313/),
60 (/313, 314/), (/314, 315/), (/315, 316/),
61 (/316, 317/), (/317, 318/),
62 (/310, 309/), (/311, 308/), (/312, 307/),
63 (/313, 306/), (/314, 305/), (/315, 304/),
64 (/316, 303/), (/317, 302/) >>,
65
66 int_root = 301,
67
68 int_intervals = << (/301, (/301, 302, 318/) /),
69 (/302, (/302, 303, 317/) /),
70 (/303, (/303, 304, 316/) /),
71 (/304, (/304, 305, 315/) /),
72 (/305, (/305, 306, 314/) /),
73 (/306, (/306, 307, 313/) /),
74 (/307, (/307, 308, 312/) /),
75 (/308, (/308, 309, 311/) /),
76 (/309, (/309, 310/) /) >>;
77
78
79 $ evaluate head lim x using virtual tree
80
81 macro headlim(x); vreps(vheadlim(x)) endm;
82
83 var
84 head, $ maps each node to its interval head
85 vpar, $ parent mapping in virtual tree
86 vndescs, $ number of descendants in virtual tree
87 vreps; $ node represented by virtual tree head
88
89
90 repr
91 base nodebase: integer;
92 $ base for graph nodes
93
94 $ reprs for all procedures
95
96 intsof: proc( remote mmap <>
97 set(elmt nodebase) ,
98 elmt nodebase )
99 smap(elmt nodebase) tuple(elmt nodebase);
100 initvt: proc( remote set(elmt nodebase) );
101 collapse: proc( elmt nodebase, elmt nodebase );
102 vheadlim: proc( elmt nodebase )
103 elmt nodebase;
104 dfst: proc( remote mmap <>
105 set(elmt nodebase),
106 elmt nodebase )
107 tuple( remote smap(elmt nodebase)
108 elmt nodebase,
109 remote smap(elmt nodebase) integer,
110 remote smap(elmt nodebase) integer,
111 remote smap(elmt nodebase) integer );
112
113 $ reprs for global variables
114
115 head: local smap(elmt nodebase)
116 elmt nodebase;
117 $ maps each node to its interval head
118 vpar: local smap(elmt nodebase)
119 elmt nodebase;
120 $ parent mapping in virtual tree
121 vndescs: local smap(elmt nodebase) integer;
122 $ number of descendants in virtual tree
123 vreps: local smap(elmt nodebase)
124 elmt nodebase;
125 $ node represented by virtual tree root
126
127 $ reprs for examples
128
129 int_graph: remote mmap <>
130 set(elmt nodebase);
131 int_root: elmt nodebase;
132 int_intervals: smap(elmt nodebase) tuple(elmt nodebase);
133
134 end repr;
135
136
137 proc tarjan_test;
138
139 print_head('tarjan-s interval finder');
140
141 assert intsof(int_graph, int_root) = int_intervals;
142$ assert intsof(str_graph, str_root) = str_intervals;
143
144 print_tail('tarjan-s interval finder (based version)');
145
146 end proc tarjan_test;
147
148
149 proc intsof(graph, root); $ tarjan-s interval finder
150
151
152 repr
153 intervals: smap(elmt nodebase) tuple( elmt nodebase);
154 $ maps each interval head into its interva
155 nodes: remote set(elmt nodebase);
156 $ set of all graph nodes
157 inverse: remote mmap <>
158 set(elmt nodebase);
159 $ the inverse graph
160 parent: remote smap(elmt nodebase)
161 elmt nodebase;
162 $ parent mapping in depth first tree
163 nodeno,
164 postno: remote smap(elmt nodebase) integer;
165 $ pre- and postorder node numbers
166 ndescs: remote smap(elmt nodebase) integer;
167 $ number of descendants in depth first tre
168 nodevect: smap(integer) elmt nodebase;
169 $ vector of nodes in nodeno order
170 backedgesinv: remote mmap <>
171 set(elmt nodebase);
172 $ set of all inverse back edges
173 targbackedges: remote set(elmt nodebase);
174 $ set of all back edge targets
175 n: integer;
176 $ do-loop counter
177 x, y, z: elmt nodebase;
178 $ particular nodes
179 reachunder,
180 newreachunder,
181 newmorereachunder:
182 set(elmt nodebase);
183 $ growing 'reachunder' set and its parts
184 rleftvec: smap(integer) elmt nodebase;
185 $ nodes in right-to-left top-down order
186
187 end repr;
188
189 nodes := domain graph + range graph; $ the nodes of the graph
190
191 $ compute the inverse of the graph
192 inverse := << (/y,x/) : (/x,y/) in graph >>;
193
194 $ call depth first spanning tree routine, to return:
195 $ parent := parent map in tree,
196 $ nodeno := node number map in preorder,
197 $ ndescs := number of descendants,
198 $ postno := postorder number map of nodes.
199 (/parent, nodeno, ndescs, postno/) := dfst(graph, root);
200
201 $ -nodevect- is the inverse of -nodeno-
202 nodevect := << (/n,x/) : (/x,n/) in nodeno>>;
203
204 $ -backedgesinv- is the set of all inverse back edges
205 backedgesinv := << (/y,x/) : (/x,y/) in graph st
206 nodeno(y) <= nodeno(x)
207 and nodeno(x) <= nodeno(y) + ndescs(y)>>;
208
209 targbackedges := domain backedgesinv; $ back edge targets
210
211 head := <>; $ will map nodes to their interval heads
212 initvt(nodes); $ initialize virtual forest
213
214 $ process back edge targets right-to-left, bottom-up
215 (forall n in (/ card nodevect, card nodevect-1...2 /) st
216 (x := nodevect(n)) in targbackedges)
217
218 reachunder := <>;
219 newreachunder := << headlim(y) : y in backedgesinv<>>>;
220 newreachunder less:= x;
221
222 $ start reachunder set, extend along reversed edges
223 (while newreachunder /= <>)
224 y from newreachunder;
225 reachunder with:= y;
226
227 head(y) := x; $ identify interval head
228 collapse(y, x); $ collapse y into x
229
230 if root in (morereachunder :=
231 <<>>>-reachunder) then
232 print('the graph is irreducible.');
233 stop;
234 else
235 newreachunder := newreachunder + morereachunder;
236 end if;
237
238 end while;
239 end forall;
240
241
242 $ the remaining nodes form the last acyclic interval.
243 $ its head is root. extend the 'head' mapping to these nodes.
244 (forall y in nodes st head(y) = om)
245 head(y) := root;
246 end forall;
247
248
249 $ next we walk the tree in right-to-left, top-down order
250 $ to build the intervals
251 rleftvec := << (/card nodes+1-n, x/) : (/x,n/) in postno>>;
252 intervals := << (/x, (/x/)/) : x in range head>>;
253
254 (forall n in (/ 2...card rleftvec/))
255 $ note that root is bypassed in this loop, as head(root)
256 $ currently points to root, whereas it should be undefined.
257 y := rleftvec(n);
258 intervals(head(y)) with:= y;
259 end forall;
260
261 return intervals;
262
263 end proc intsof;
264
265 proc initvt(nodes); $ initialize virtual forest mappings
266
267
268 repr
269 x : elmt nodebase; $ a particular node
270 end repr;
271
272 vpar := <>; $ virtual parent map
273 vndescs := << (/x, 1/) : x in nodes >>;
274 $ number of descendants
275 vreps := << (/x, x/) : x in nodes >>;
276 $ node represented by virtual node
277
278 end proc initvt;
279
280
281 proc collapse(y, x); $ collapse y into x.
282
283 $ perform logical collapse of y into x, but use virtual
284 $ tree and maintain its balance.
285
286
287 repr
288 rx, ry : elmt nodebase; $ virtual roots of x, y
289 end repr;
290
291 $ get roots for x and y
292 rx := vheadlim(x);
293 ry := vheadlim(y);
294
295 if vndescs(rx) < vndescs(ry) then $ subordinate y to x
296 vpar(rx) := ry;
297 vndescs(ry) := vndescs(rx) + vndescs(ry);
298 vreps(ry) := x;
299 else $ subordinate x to y (reversed assignment)
300 vpar(ry) := rx;
301 vndescs(rx) := vndescs(rx) + vndescs(ry);
302 vreps(rx) := x;
303 end if;
304
305 end proc collapse;
306
307
308 proc vheadlim(x);
309
310 $ locate virtual subtree root and compress path
311
312
313 repr
314 nd,
315 par1,
316 par2,
317 par3: elmt nodebase;
318 $ nodes on the path to top
319 pathnodes: set(elmt nodebase);
320 $ set of path nodes
321 end repr;
322
323
324 if (par1 := vpar(x)) = om then $ top of tree
325 return x;
326 elseif (par2 := vpar(par1)) = om then $ no need to compress
327 return par1;
328 else $ climb to top and compress path
329 pathnodes := <>;
330 (while (par3 := vpar(par2)) /= om)
331 $ pathnodes contains all but
332 $ the last two nodes on the path
333 pathnodes with:= par1;
334 par1 := par2;
335 par2 := par3;
336 end while;
337
338 (forall nd in pathnodes) $ compress path
339 vpar(nd) := par2;
340 end forall;
341
342 return par2;
343 end if;
344
345 end proc vheadlim;
346
347
348 proc dfst(graph, root); $ depth first spanning tree
349
350 $ builds depth first spanning tree and several auxiliary mappings
351
352
353 repr
354 x, y: elmt nodebase;
355 parent: remote smap(elmt nodebase)
356 elmt nodebase;
357 nodeno,
358 ndescs,
359 postno: remote smap(elmt nodebase) integer;
360 descs: set(elmt nodebase);
361 seen: remote set(elmt nodebase);
362 stk: tuple(elmt nodebase);
363 end repr;
364
365 parent := <>; $ parent map in spanning tree
366 nodeno := <>; $ preorder node number
367 ndescs := <>; $ number of descendants
368 postno := <>; $ postorder node number
369
370 seen := <>; $ nodes processed
371 stk := (//); $ stack of ancestors
372 x := root;
373
374 loop do
375 if x notin seen then $ a new node
376 nodeno(x) := card nodeno + 1; $ preorder number
377 ndescs(x) := 0; $ initialize descendant count
378 seen with:= x;
379 end if;
380
381
382 if (descs := graph<> - seen) /= <> then
383 y := arb descs; $ descend in search to y
384 stk with:= x; $ stacking x
385 x := y;
386 else $ ascend in stack
387 postno(x) := card postno + 1;
388 if stk = (//) then
389 quit loop; $ last time at the root
390 else $ ascend to the parent of x
391 y frome stk;
392 parent(x) := y;
393 $ update parent map
394 ndescs(y) := ndescs(y) + ndescs(x) + 1;
395 $ update descendant count
396 x := y;
397 end if;
398 end if;
399 end loop;
400
401 return (/parent, nodeno, ndescs, postno/);
402
403 end proc dfst;
404
405 drop headlim;
406
407 end module test - tarjan;
408
409
1 .=member iter1
2 module test - iterators_1;
3
4 $ nyu test id
5 $ author - r. lee (nyu-cims)
6
7 exports
8 iterator_test_1;
9
10 reads
11 print_mode;
12
13 const
14 lim = 5,
15 bfact = 300000;
16
17
18 var
19 sum, $ accumulate sum
20
21 std_set, $ unbased set of small integers
22 big_set, $ unbased set of large integers
23 neg_set, $ unbased set of small negative integers
24 bneg_set, $ unbased set of large negative integers
25
26 tup, $ unbased tuple of small integers
27 tup_neg, $ unbased tuple of small negative integers
28 tup_big, $ unbased tuple of large integers
29 tup_bneg, $ unbased tuple of large negative integers
30
31 locset, $ local set of small integers
32 remset, $ remote set of small integers
33 locbset, $ local set of large integers
34 rembset, $ remote set of large integers
35 locnset, $ local set of small negative integers
36 remnset, $ remote set of small negative integers
37 locbnset, $ local set of large negative integers
38 rembnset, $ remote set of large negative integers
39
40 locset2, $ copies of the above sets
41 remset2,
42 locbset2,
43 rembset2,
44 locnset2,
45 remnset2,
46 locbnset2,
47 rembnset2,
48
49 etup, $ tuple of small positive based integers
50 utup, $ tuple of small positive untyped integers
51 etup_big, $ tuple of large positive based integers
52 utup_big, $ tuple of large positive untyped integers
53 etup_neg, $ tuple of small negative based integers
54 utup_neg, $ tuple of small negative untyped integers
55 etup_bneg, $ tuple of large negative based integers
56 utup_bneg; $ tuple of large negative untyped integers
57
58
59 repr
60
61 base intb: integer; $ base for all integers, etc.
62
63 locset: local set(elmt intb);
64 remset: remote set(elmt intb);
65 locbset: local set(elmt intb);
66 rembset: remote set(elmt intb);
67
68 locnset: local set(elmt intb);
69 remnset: remote set(elmt intb);
70 locbnset: local set(elmt intb);
71 rembnset: remote set(elmt intb);
72
73 locset2: local set(elmt intb);
74 remset2: remote set(elmt intb);
75 locbset2: local set(elmt intb);
76 rembset2: remote set(elmt intb);
77 locnset2: local set(elmt intb);
78 remnset2: remote set(elmt intb);
79 locbnset2: local set(elmt intb);
80 rembnset2: remote set(elmt intb);
81
82 etup: tuple(elmt intb);
83 utup: tuple(untyped integer);
84 etup_big: tuple(elmt intb);
85 utup_big: tuple(untyped integer);
86 etup_neg: tuple(elmt intb);
87 utup_neg: tuple(untyped integer);
88 etup_bneg: tuple(elmt intb);
89 utup_bneg: tuple(untyped integer);
90
91 end repr;
92
93
94 proc iterator_test_1;
95
96 print_head('iterator tests');
97 print_head('iterator test 1');
98 print;
99
100 if print_mode >= print_full then
101 print;
102 print('commencing aritmetic tests with limit =', lim,
103 ', bfact =', bfact, '.');
104 end if;
105
106 sum := 0; $ accumulate sum
107 sum_big := 0; $ accumulate sum of large integers
108 sum_neg := 0; $ accumulate sum of negatives
109 sum_bneg := 0; $ accumulate sum of large negatives
110 sum_nbig := 0; $ large negatives by subtraction
111
112 std_set := nullset; $ set of integers
113 big_set := nullset; $ set of big integers
114 neg_set := nullset; $ set of negatives
115 bneg_set := nullset; $ set of big negatives
116
117 tup := nulltup; $ tuple of integers
118 tup_neg := nulltup; $ tuple of negatives
119 tup_big := nulltup; $ tuple of big integers
120 tup_neg := nulltup; $ tuple of negatives
121 tup_bneg := nulltup; $ tuple of big negatives
122
123 (forall k in (/1...lim/)) $ iterative addition loop
124
125 kbig := k * bfact; $ calculate big integers
126
127 sum +:= k; $ calculate total in various ways
128 sum_big +:= kbig;
129 sum_neg +:= - k;
130 sum_bneg +:= - kbig;
131 sum_nbig -:= kbig; $ calculate by subtraction
132
133 std_set with:= k;
134 big_set with:= kbig;
135 neg_set with:= - k;
136 bneg_set with:= - kbig;
137
138 tup with:= k;
139 tup_big with:= kbig;
140 tup_neg with:= - k;
141 tup_bneg with:= - kbig;
142
143 end forall;
144
145 print_line('test the (unbased) sums.');
146
147 assert sum = sum_big div bfact; $ long int
148 assert sum = -sum_neg; $ neg arithmetic
149 assert sum = -sum_bneg div bfact; $ long neg arithmetic
150 assert sum = +/std_set; $ set member add
151 assert sum = (+/big_set) div bfact; $ long member add
152 assert sum = -(+/neg_set); $ neg member add
153 assert sum = (+/bneg_set)div -bfact; $ long neg member add
154 assert sum = +/tup; $ component add
155 assert sum = (+/tup_big) div bfact; $ long component add
156 assert sum = -(+/tup_neg); $ neg component add
157 assert sum = (+/tup_bneg) div -bfact;$ long neg component add
158
159 print_line('repeat the tests after conversion to based cases.');
160
161 locset := std_set; $ local basing
162 remset := std_set; $ remote basing
163 locbset := big_set; $ local based,big set
164 rembset := big_set; $ remote based,big set
165 locnset := neg_set; $ local neg set
166 remnset := neg_set; $ remote neg set
167 locbnset := bneg_set; $ local long neg set
168 rembnset := bneg_set; $ remote long neg set
169
170 assert std_set = locset; $ local integer basing
171 assert std_set = remset; $ remote integer basing
172 assert big_set = locbset; $ local long integer basing
173 assert big_set = rembset; $ remote long integer basing
174 assert neg_set = locnset; $ local negint basing
175 assert neg_set = remnset; $ remote negint basing
176 assert bneg_set = locbnset; $ local long negint basing
177 assert bneg_set = rembnset; $ remote long negint basing
178
179 assert sum = +/locset; $ loc int sum
180 assert sum = +/remset; $ rem int sum
181 assert sum = (+/locbset) div bfact; $ loc long int sum
182 assert sum = (+/rembset) div bfact; $ rem long int sum
183 assert sum = -(+/locnset); $ loc neg sum
184 assert sum = -(+/remnset); $ rem neg sum
185 assert sum = (+/locbnset)div -bfact; $ loc long neg int sum
186 assert sum = (+/rembnset)div -bfact; $ rem long neg int sum
187
188
189 print_line('copy the sets, and remove an element.');
190 print_line('check proper observance of the copy semantic.');
191
192 set2 := std_set; std_set := std_set less n;
193 big_set2 := big_set; big_set := big_set less n;
194 neg_set2 := neg_set; neg_set := neg_set less n;
195 bneg_set2 := bneg_set; bneg_set := bneg_set less n;
196 locset2 := locset; locset := locset less n;
197 remset2 := remset; remset := remset less n;
198 locbset2 := locbset; locbset := locbset less n;
199 rembset2 := rembset; rembset := rembset less n;
200 locnset2 := locnset; locnset := locnset less n;
201 remnset2 := remnset; remnset := remnset less n;
202 locbnset2 := locbnset; locbnset := locbnset less n;
203 rembnset2 := rembnset; rembnset := rembnset less n;
204
205 assert set2 = locset2; $ local set deletion
206 assert set2 = remset2; $ remote set deletion
207 assert big_set2 = locbset2; $ loc long int set deletion
208 assert big_set2 = rembset2; $ rem long int set deletion
209 assert neg_set2 = locnset2; $ loc neg int set deletion
210 assert neg_set2 = remnset2; $ rem neg int set deletion
211 assert bneg_set2 = locbnset2; $ loc long neg set deletion
212 assert bneg_set2 = rembnset2; $ rem long neg set deletion
213
214 assert sum = +/set2; $ sum after deletion
215 assert sum = (+/big_set2) div bfact; $ long sum after deletion
216 assert sum = -(+/neg_set2); $ neg sum after deletion
217 assert sum = (+/bneg_set)div -bfact; $ long neg after deletion
218
219 print_line('repeat the sequence of copy tests for tuples.');
220
221 tup2 := tup; tup with:= 1;
222 tup2_big := tup_big; tup_big with:= 1;
223 tup2_neg := tup_neg; tup_neg with:= 1;
224 tup2_bneg := tup_bneg; tup_bneg with:= 1;
225
226 assert sum = +/tup2; $ tup sum extension
227 assert sum = (+/tup2_big) div bfact; $ tup long sum extension
228 assert sum = -(+/tup2_neg); $ tup neg sum extension
229 assert sum = (+/tup2_bneg) div -bfact; $ long neg sum ext
230
231 print_line('perform a series of explicit loop tests.');
232
233 assert sum = sumof(set2); $ sum maniter
234 assert sum = sumof(locset2); $ loc sum maniter
235 assert sum = sumof(remset2); $ rem sum maniter
236 assert sum = sumof(big_set2) div bfact; $ long sum maniter
237 assert sum = sumof(locbset2) div bfact; $ loc long sum maniter
238 assert sum = sumof(rembset2) div bfact; $ rem long sum maniter
239 assert sum = -sumof(neg_set2); $ neg sum maniter
240 assert sum = -sumof(locnset2); $ loc neg sum maniter
241 assert sum = -sumof(remnset2); $ rem neg sum maniter
242 assert sum = sumof(bneg_set2) div -bfact; $ long neg sum maniter
243 assert sum = sumof(locbnset2) div -bfact; $ loc long neg sum man
244 assert sum = sumof(rembnset2) div -bfact; $ rem long neg sum man
245
246 print_line('perform a series of tests on based tuples.');
247
248 etup := tup2;
249 utup := tup2;
250 etup_big := tup2_big;
251 utup_big := tup2_big;
252 etup_neg := tup2_neg;
253 utup_neg := tup2_neg;
254 etup_bneg := tup2_bneg;
255 utup_bneg := tup2_bneg;
256
257 assert sum = tupsum(etup); $ tupsum maniter elements
258 assert sum = tupsum(utup); $ tupsum maniter untyped
259 assert sum = tupsum(etup_big) div bfact; $
260 assert sum = tupsum(utup_big) div bfact; $
261 assert sum = -tupsum(etup_neg); $ neg tupsum maniter elements
262 assert sum = -tupsum(utup_neg); $ neg tupsum maniter untyped
263 assert sum = -tupsum(etup_bneg) div bfact; $
264 assert sum = -tupsum(utup_bneg) div bfact; $
265
266 print_tail('iterator test 1');
267
268
269 end proc iterator_test_1;
270
271
272 proc sumof(rw setup); $ calculates sum by manual iteration
273
274 sum1 := 0;
275
276 loop do
277
278 x from setup;
279 if x=om then quit; end;
280 sum1 +:= x;
281
282 end;
283
284 return sum1;
285
286 end proc sumof;
287
288
289 procedure tupsum(x); $ calculates sum by manual iteration
290
291 y := 0;
292
293 loop do
294
295 z frome x;
296 if z = om then quit; end;
297 y +:= z;
298
299 end;
300
301 return y;
302
303 end procedure tupsum;
304
305
306 end module test - iterators_1;
307
308
309
310
1 .=member iter2
2 module test - iterators_2;
3
4 exports
5 iterator_test_2;
6
7 reads
8 print_mode;
9
10
11 var
12 i, j, k, n,
13
14 unbased_set_1,
15 unbased_set_2,
16 unbased_set_3,
17 unbased_set_4,
18 unbased_set_6,
19 unbased_set_8,
20
21 unbased_map_1,
22 unbased_map_2,
23 unbased_map_3,
24 unbased_map_4,
25 unbased_map_5,
26 unbased_map_6,
27
28 unbased_mmap_1,
29 unbased_mmap_2,
30 unbased_mmap_3,
31 unbased_mmap_4,
32
33 unbased_tup_1,
34 unbased_tup_2,
35 unbased_tup_3,
36 unbased_tup_4,
37
38 loc_set_1,
39 loc_set_5,
40
41 rem_set_1,
42 rem_set_7,
43
44 rem_mmap_1,
45 rem_mmap_2,
46 loc_mmap_1,
47
48 packed_int_tup_1,
49 untyped_real_tup,
50 untyped_int_tup_1,
51 untyped_int_tup_2;
52
53
54 repr
55 i, j, k, n: integer 1...100;
56
57 base ibase: integer;
58 base tint: tuple(integer);
59 base tibase: tuple(elmt ibase);
60
61 loc_set_1: local set(elmt ibase);
62 loc_set_5: local set(elmt tint);
63 rem_set_1: remote set(elmt ibase);
64 rem_set_7: remote set(elmt tibase);
65
66 rem_mmap_1: remote mmap <>
67 set(elmt ibase);
68 loc_mmap_1: local mmap <>
69 remote set(elmt ibase);
70 rem_mmap_2: remote mmap <>
71 mmap <<*>>
72 remote smap (elmt ibase)
73 integer;
74
75 packed_int_tup_1: packed tuple(integer 1...66);
76 untyped_real_tup: tuple(untyped real);
77 untyped_int_tup_1: tuple(untyped integer);
78 untyped_int_tup_2: tuple(untyped integer);
79
80 end repr;
81
82
83 $ iterator tests
84
85 $ in this series of tests we iterate over
86 $ a variety of sets and tuples, using the
87 $ iteration to rebuild them, and then checking
88 $ equality between the original and the rebuilt
89 $ object.
90
91 $ we build up a set of objects
92 $ having a variety of forms to which the
93 $ iterator routines are sensitive, and then
94 $ test the iterators by rebuilding the sets
95 $ iteratively and testing for equality after rebuild
96
97
98 proc iterator_test_2;
99
100 print_head('iterator test 2');
101
102 $ build a general (unbased) tuple, set, and map
103 unbased_set_1 := nullset;
104 unbased_map_1 := nullset;
105 unbased_tup_1 := nulltup;
106
107 (forall n in (/ 1...10 /))
108 unbased_tup_1 with:= n;
109 unbased_set_1 with:= n;
110 unbased_map_1(n) := 2*n + 1;
111 end forall;
112
smff 8 $ -unbased_tup_2- is undefined for various indices
114 unbased_tup_2 := unbased_tup_1;
115 unbased_tup_2(2) := unbased_tup_2(4) := unbased_tup_2(10) := om;
116
117 $ -unbased_tup_3- has an undefined initial segment
118 unbased_tup_3 := unbased_tup_2;
119 unbased_tup_3(1) := om;
120
121 $ unbased_tup_4 will be totally undefined since the initial
122 $ segement of -unbased_tup_3- is undefined.
123 unbased_tup_4 := unbased_tup_3(1...2);
124
125 $ check conversions between different representations
126 packed_int_tup_1 := unbased_tup_1;
127 untyped_int_tup_1 := unbased_tup_1;
128
129 $ build tuples of untyped values
130 untyped_real_tup := (/ float j : j in (/1...10/) /);
131 untyped_int_tup_2 := (/1...10/);
132
133 loc_set_1 := unbased_set_1 - <<1, 3, 5, 6>>;
134
135 $ build a general (unbased) multi-valued map
136 unbased_mmap_1 := unbased_map_1;
137 (forall x in unbased_map_1 st x(1) > 5)
138 unbased_mmap_1<> with:= x(2)+1;
139 end forall;
140
141 $ build a general (unbased) map with both single- and multi-
142 $ valued points
143 unbased_map_2 := unbased_mmap_1;
144 (forall n in (/ 1...5 /))
145 unbased_map_2(n) := 2*n;
146 end forall;
147
148 $ now we build up a variety of multiparameter
149 $ maps to test the more complex iterator cases
150
151 $ doubly indexed map
152 unbased_mmap_2 := << (/i, (/j, i+j/) /) :
153 i in (/1...10/),
154 j in (/1...5/) >>;
155
156 $ delete some points from -unbased_mmap_2-
157 unbased_mmap_3 := unbased_mmap_2;
158 (forall i in (/ 1...5 /))
159 unbased_mmap_3(i, i) := om;
160 end forall;
161
162 $ delete all points from -unbased_mmap_3-
163 unbased_map_3 := unbased_mmap_3;
164 (forall i in (/ 1...10 /), j in (/ 1...5 /))
165 unbased_map_3(i, j) := om;
166 end forall;
167
168 rem_mmap_1 := << (/i, 2*i/) : i in (/1...10/) >>
169 + <<(/i, 3*i/): i in (/1...5/)>>;
170 loc_mmap_1 := rem_mmap_1;
171
172 $ build a triply indexed map
173 unbased_mmap_4 := << (/i, (/j, (/k, 3*k - 1/) /) /) :
174 i in (/1...5/),
175 j in (/1...4/),
176 k in (/1...3/) >>;
177
178 rem_mmap_2 := unbased_mmap_4;
179
180 $ build a set of tuples
181 unbased_set_4 := << (/i, i+1/) : i in (/1...10/) >>;
182
183 $ check conversions between different representations
184 loc_set_5 := unbased_set_4;
185 rem_set_7 := loc_set_5;
186
187 $ create a set of strings
188 unbased_set_8 := << i*'a' + 'b'*j + k*'c' :
189 i in (/1...3/),
190 j in (/1...3/),
191 k in (/1...3/) >>;
192
193 $ build a set of unit tuples
194 unbased_set_6 := << (/i/) : i in (/1...10/) >>;
195
196 $ remove several elements from -unbased_mmap_1-
197 unbased_map_4 := unbased_mmap_1;
198 unbased_map_4 lessf:= 3;
199 unbased_map_4(10) := om;
200 unbased_map_4<<1>> := nullset;
201
202 $ extend and restrict -unbased_mmap_1-
203 unbased_map_5 := unbased_mmap_1
204 + << (/i, i*i/) : i in (/1...5/) >>
205 - <<(/5, 11/), (/6, 14/), (/1, 1/)>>;
206
207 unbased_map_6 := << (/x, x + x*10 /) : x in unbased_set_1 >>;
208
209 rem_set_1 := unbased_set_1;
210
211 unbased_set_2 := unbased_set_1;
212 unbased_set_2 with:= 20;
213 unbased_set_2 with:= 100;
214 unbased_set_2 with:= -5;
215
216 unbased_set_2 less:= 2;
217 unbased_set_2 less:= 4;
218 unbased_set_2 less:= 10;
219
220
221 print_line('start execution of iteration test 2.');
222
223 rebtestt(unbased_tup_1, 'tuple of integers');
224 rebtests(unbased_map_1, 'integer-valued map');
225 rebtests(loc_set_1, 'local set of integers');
226
227 rebtests(<>, 'null set');
228 rebtestt((//), 'null tuple');
229 rebtests(<<1>>, 'unit set');
230 rebtestt((/1/), 'unit tuple');
231
smff 9 tup_denot_2 := [];
smff 10 tup_denot_2(1) := 1; tup_denot_2(3) := 3;
smff 11 tup_denot_2(5..9) := [ 5, 6, 7, 8, 9 ];
smff 12 assert unbased_tup_2 = tup_denot_2;
smff 13
smff 14 tup_denot_3 := [];
smff 15 tup_denot_3(3) := 3;
smff 16 tup_denot_3(5..9) := [ 5, 6, 7, 8, 9 ];
smff 17 assert unbased_tup_3 = tup_denot_3;
smff 18
234 rebtestt(unbased_tup_4, 'generated null tuple');
235
236 rebtestc('abcde', 'long string');
237
238 rebtests(unbased_set_4, 'set of tuples');
239 rebtests(loc_set_5, 'local set of tuples');
240 rebtests(rem_set_7, 'remote set of tuples');
241 rebtests(unbased_set_6, 'set of unit tuples');
242 rebtests(unbased_set_8, 'set of character strings');
243
244 rebtestt(packed_int_tup_1, 'packed tuple');
245 rebtestt(untyped_real_tup, 'real tuple');
246 rebtestt(untyped_int_tup_1, 'integer tuple');
247 rebtestt(untyped_int_tup_2, 'integer tuple');
248
249 rebtests(unbased_mmap_1, 'multi-valued map');
250 rebtests(unbased_map_2, 'multi-map with some sval elts');
251 rebtests(unbased_mmap_2, 'double indexed map');
252 rebtests(unbased_mmap_3, 'double indexed map with degen locs');
253
254 rebtests(unbased_map_3, 'multi-valued nullmap');
255 rebtests(rem_mmap_1, 'remote map with set range');
256 rebtests(loc_mmap_1, 'local map with remote range');
257 rebtests(unbased_mmap_4, 'triply indexed map');
258 rebtests(rem_mmap_2, 'triply indexed map');
259
260 rebtests(unbased_map_4, 'map with deleted elements');
261 rebtests(unbased_map_5, 'map after expansion and deletion');
262 rebtests(unbased_map_6, 'set after conversion to map');
263 rebtests(rem_set_1, 'remote set of integers');
264 rebtests(unbased_set_2, 'set after expansion and deletion');
265
266
267 print_tail('iterator test 2');
268
269 end proc iterator_test_2;
270
271
272 proc rebtests(rd sett, rd mesg);
273
274 $ this iterates over a set to rebuild it and
275 $ then tests for equality between the original
276 $ and the rebuilt copy
277
278 news := nullset;
279
280 (forall x in sett)
281 news with:= x;
282 end forall;
283
284 assert sett = news;
285
286 end proc rebtests;
287
288
289 proc rebtestt(rd tup, rd mesg);
290
291 $ this is the tuple analog of rebtests
292
293 newt:=nulltup;
294
295 (forall x = tup(j))
296 newt with:= x;
297 end forall;
298
299 assert tup = newt;
300
301 end proc rebtestt;
302
303
304 proc rebtestc(rd cstr, rd mesg);
305
306 $ this is the string analog of rebtests
307
308 newc:= nullstring;
309
310 (forall n in (/ 1...card cstr /))
311 newc +:= cstr(n);
312 end forall;
313
314 assert cstr = newc;
315
316 end proc rebtestc;
317
318
319 end module test - iterators_2;
320
321
322
323
1 .=member testio
2 module test - input_output;
3
4 $ nyu test id
5 $ author - j. schwartz
6 $ logged in as jts15 (20 jan 79)
7 $ passed xsetl 30 jan 79
8
9 exports
10 tree_print;
11
12 reads
13 print_mode;
14
15 var
16 left_child,
17 right_child,
18 value,
19 blanks;
20
21
22 proc tree_print; $ indenting tree print program
23
24 print_head('tree print');
25
smff 19 l := []; l(1) := 2; l(2) := 4; l(5) := 6; l(6) := 7;
smff 20 r := []; r(1) := 3; r(3) := 5; r(5) := 9; r(6) := 8; r(9) := 10;
28
29 l := << (/i,n/) : n = l(i) st n /= om >>;
30 r := << (/i,n/) : n = r(i) st n /= om >>;
31
32 vall := << (/i,i/) : i in (/1...10/) >>;
33
34 print('the following should be aligned:'
35 ' 1, 2-3, 4-5, 6-9, 7-8-10');
36 tprint(l, r, vall, 1);
37
38 print_tail('tree print');
39
40 end proc tree_print;
41
42
43 proc tprint(l, r, vall, topp); $ binary tree print routine
44
45 $ n.b. left_child,right_child,value,blanks must be global
46 left_child := l; right_child := r; value := vall;
47 blanks := 44 * ' ';
48
49 tp(topp, 1);
50
51 end proc tprint;
52
53
54 proc tp(node,level);
55
56 if node=om then return; end;
57
58 print(blanks(1..4*(level mod 12)), value(node));
59
60 tp(left_child(node), level+1);
61 tp(right_child(node), level+1);
62
63 end proc tp;
64
65
66 end module test - input_output;
67
68
69
70