![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fay.p CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / pascal / tstpx / src|
Return to fay.p CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / ucb / pascal / tstpx / src |
1.1 root 1: { AN OPEN CHALLENGE TO ALL PASCAL COMPILERS: Compile this program
2: correctly and produce the correct output.
3:
4: Send responses, counter-challenges, etc., to:
5: Tom Pennello
6: Computer and Information Sciences
7: University of California
8: Santa Cruz, CA. 95064
9: }
10:
11: program p(output);
12: type integer = -32767..32768; node = 0..4500;
13: var Debug: boolean;
14:
15: procedure EachUSCC( { of relation R }
16: { Pass in an iterator to generate the nodes to be searched,
17: the relation on the nodes, a procedure to do information
18: propagation when V R W is discovered, a procedure
19: to take each SCC found, and a procedure to yield each
20: node in the graph.
21: We require that the nodes be of a scalar type so that
22: an array may be indexed by them. Also passed in is the
23: upper bound of the node type. }
24: procedure EachUnode(procedure P(T:node)); { Yields each node in graph }
25: procedure EachUnodeUtoUsearch(procedure SearchU(V:node));
26: procedure R(V:node; procedure DoUsuccessor(W:node));
27: procedure Propagate(V,W:node); { called when V R W is discovered }
28: procedure TakeUSCC(Root:node; procedure Each(procedure P(T:node)));
29: LastUnode: integer
30: );
31:
32: type
33: A = array[node] of integer; { range 0..Infinity (below) }
34: var N: ^A; SP: integer;
35: Stack: array[node {1..LastUnode}] of node;
36: Infinity: integer; { LastUnode+1 }
37:
38: procedure P(T:node); begin N^[T] := 0; end;
39:
40: procedure Search(V:node);
41: var I,T:integer;
42: procedure DoUsuccessor(W:node);
43: begin
44: Search(W);
45: if N^[W] < N^[V] then N^[V] := N^[W];
46: Propagate(V,W);
47: end;
48:
49: { EachUmember is yielded by EachUSCC when an SCC has been found. }
50: procedure EachUmember(procedure P(TU:node));
51: var I:integer;
52: begin { yield each member of current SCC }
53: for I := SP downto T do P(Stack[I]);
54: end;
55:
56: procedure YieldUSCC;
57: begin
58: if Debug then writeln('YieldUSCC passes',V,' to TakeUSCC');
59: TakeUSCC(V,EachUmember);
60: end;
61:
62: begin
63: if N^[V] = 0 then begin { stack the node }
64: if Debug then writeln('stacking ',V);
65: SP := SP+1;
66: Stack[SP] := V; N^[V] := SP;
67: if Debug then writeln('Doing successors of ',V);
68: R(V,DoUsuccessor);
69: if Debug then writeln('Now checking if ',V,' is an SCC root');
70: if V = Stack[N^[V]] then begin { V is root of an SCC }
71: T := N^[V];
72: if Debug then writeln(V,' is an SCC root; SP=',SP,' T=',T);
73: for I := SP downto T do N^[Stack[I]] := Infinity;
74: if SP <> T then begin
75: if Debug then writeln('Yield SCC should pass ',V,' out to TakeUSCC');
76: YieldUSCC;
77: end;
78: SP := T-1;
79: end;
80: end;
81: end;
82: begin
83: Infinity := LastUnode+1;
84: new(N); EachUnode(P);
85: SP := 0;
86: EachUnodeUtoUsearch(Search);
87: dispose(N);
88: end;
89:
90: procedure Outer; { needed to produce bug in Berkeley Pascal compiler }
91: procedure q;
92: procedure EachUnodeUtoUsearch(procedure Search(T:node));
93: begin
94: Search(1);
95: end;
96: procedure EachUnode(procedure P(T:node));
97: begin P(1); P(2);
98: end;
99: procedure R(V:node; procedure P(W:node));
100: begin
101: { Defines graph with edges 1->2 and 2->1 }
102: { Thus, the graph contains one SCC: [1,2] }
103: case V of
104: 1: P(2);
105: 2: P(1);
106: end;
107: end;
108: procedure Propagate(V,W:node); begin end;
109: procedure TakeUSCC(Root:node; procedure Each(procedure P(T:node)));
110: procedure P(T:node); begin write(T); end;
111: begin
112: writeln('TakeUSCC receives V=',Root,' from YieldUSCC');
113: writeln('The SCC''s constituents are:');
114: Each(P); writeln;
115: end;
116: begin
117: EachUSCC(EachUnode,EachUnodeUtoUsearch,R,Propagate,TakeUSCC,2);
118: end;
119:
120: procedure Doit;
121: begin
122: q;
123: end;
124:
125: begin
126: Doit;
127: end;
128:
129: begin
130: Debug := true;
131: Outer;
132: end.
133:
134: {----------------------------------------------------------------
135: An alternate version of this program, written in a language
136: supporting iterators, iterators as parameters, iterators
137: as yielded results of iterators, and the ability to yield more
138: than one thing, might be as follows:
139: ----------------------------------------------------------------
140:
141: iterator EachUSCC(
142: iterator EachUnode:node;
143: iterator EachUnodeUtoUsearch:node;
144: iterator R(V:node):node;
145: procedure Propagate(V,W:node);
146: LastUnode:node
147: ):
148: (Root:node; iterator EachUnodeUinUSCC:node);
149: # EachUSCC yields two results: the Root of the SCC,
150: # and an iterator that yields each member of that SCC.
151:
152: type A = aray[node] of integer;
153: var N: ^A; SP: integer;
154: Stack: array[node] of node;
155: Infinity: integer;
156:
157: procedure Search(V);
158: var T: integer;
159: iterator EachUmember:node;
160: begin
161: for I := SP downto T do P(Stack[I]);
162: end;
163: begin
164: if N^[V] = 0 then begin
165: SP := SP+1; Stack[SP] := V; N^[V] := SP;
166: for W in R(V) do begin # Search successors of V.
167: Search(W);
168: if N^[W] < N^[V] then N^[V] := N^[W];
169: Propagate(V,W);
170: end;
171: if V = Stack[N^[V]] then begin
172: T := N^[V]; # V is an SCC root.
173: for I := SP downto T do N^[Stack[I]] := Infinity;
174: if SP <> T then # Non-trivial SCC.
175: yield(V,EachUmember);
176: SP := T-1;
177: end;
178: end;
179: end;
180:
181: begin
182: Infinity := LastUnode+1;
183: new(N);
184: for T in EachUnode() do N^[T] := 0; # for loops declare their
185: SP := 0; # control variable as a constant.
186: for V in EachUnodeUtoUsearch() do Search(V);
187: dispose(N);
188: end;
189:
190: # Sample use of EachUSCC:
191:
192: iterator EachUnodeUtoUsearch:node;
193: begin
194: yield(1);
195: end;
196: iterator EachUnode:node;
197: begin
198: yield(1); yield(2);
199: end;
200: iterator R(V:node):node;
201: begin
202: if V = 1 then yield(2) else yield(1);
203: end;
204: procedure Propagate(V,W:node); begin end;
205:
206: procedure UseUEachUSCC;
207: begin
208: for (Root,EachUmember) in
209: EachUSCC(EachUnode,EachUnodeUtoUsearch,R,Propagate,TakeUSCC,2) do
210: begin
211: writeln('Root of received SCC is ',Root);
212: writeln('Constituents of the SCC are:');
213: for I in EachUmember() do write(I);
214: writeln;
215: end;
216: end;
217: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.