![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to insan.p CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSDReno / pgrm / pascal / tstpx / src|
Return to insan.p CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / pascal / tstpx / src |
1.1 root 1: program insane(input, output);
2: label
3: 1;
4: type
5: alfa = packed array[1..10] of char;
6: metaface = (notaface, front, back, top, bottom, left, right);
7: face = front .. right;
8: metapair = (notapair, one2, three4, five6);
9: pair = one2 .. five6;
10: metacolor = (notacolor, red, blue, green, white);
11: color = red .. white;
12: blockno = 1..4;
13: var
14: nosolutions: Boolean;
15: index, halfindex: integer;
16: pointr: integer;
17: datas: array[blockno, face] of alfa;
18: sum: array[blockno, pair, color] of integer;
19: halfsolution: array[blockno, 1..30] of pair;
20:
21: function word(alf: alfa): color;
22: begin
23: if alf = 'red' then
24: word := red else
25: if alf = 'blue' then
26: word := blue else
27: if alf = 'green' then
28: word := green else
29: word := white;
30: end;
31:
32: procedure readin;
33: var
34: hue: alfa;
35: ch: char;
36: cube: blockno;
37: position: face;
38:
39: procedure tone;
40: begin
41: case ch of
42: 'r': hue := 'red';
43: 'w': hue := 'white';
44: 'g': hue := 'green';
45: 'b': hue := 'blue';
46: end;
47: end;
48:
49: begin
50: for cube := 1 to 4 do
51: begin
52: for position := front to right do
53: begin
54: read(ch);
55: tone;
56: datas[cube, position] := hue;
57: end;
58: readln;
59: end;
60: end;
61:
62: procedure sumcolors;
63: var
64: cube: blockno;
65: side: face;
66: function facepair(aface: face): pair;
67: begin
68: case aface of
69: front, back: facepair := one2;
70: top, bottom: facepair := three4;
71: left, right: facepair := five6
72: end;
73: end;
74:
75: procedure initializesum;
76: var
77: cube: blockno;
78: side: face;
79: technicolor: color;
80: begin
81: for cube := 1 to 4 do
82: for side := front to right do
83: for technicolor := red to white do
84: sum[cube, facepair(side), technicolor] := 0;
85: end;
86:
87: begin
88: initializesum;
89: for cube := 1 to 4 do
90: for side := front to right do
91: sum[cube, facepair(side), word(datas[cube,side])] :=
92: sum[cube, facepair(side), word(datas[cube,side])] + 1;
93: end;
94:
95: procedure find2222;
96: var
97: subtotals: array[red..white] of integer;
98: pair1, pair2, pair3, pair4: pair;
99:
100: function two222(pair1, pair2, pair3, pair4: pair): Boolean;
101: var
102: hue: color;
103: begin
104: for hue := red to white do
105: subtotals[hue] :=
106: sum[1, pair1, hue]+
107: sum[2, pair2, hue]+
108: sum[3, pair3, hue]+
109: sum[4, pair4, hue];
110: if (subtotals[red]=2) and
111: (subtotals[blue]=2) and
112: (subtotals[green]=2) and
113: (subtotals[white]=2) then
114: two222 := true else
115: two222 := false;
116: end;
117:
118: procedure listsolution;
119: begin
120: halfsolution[1, halfindex] := pair1;
121: halfsolution[2, halfindex] := pair2;
122: halfsolution[3, halfindex] := pair3;
123: halfsolution[4, halfindex] := pair4;
124: halfindex := halfindex + 1;
125: end;
126:
127: begin
128: halfindex := 1;
129: for pair1 := one2 to five6 do
130: for pair2 := one2 to five6 do
131: for pair3 := one2 to five6 do
132: for pair4 := one2 to five6 do
133: if two222(pair1, pair2, pair3, pair4) then
134: listsolution;
135: if halfindex <= 2 then
136: begin
137: nosolutions := true;
138: goto 1;
139: end;
140: end;
141:
142: procedure simultaneous;
143: var
144: done: Boolean;
145: begin
146: nosolutions := false;
147: pointr := 0;
148: done := false;
149: repeat
150: pointr := pointr + 1;
151: repeat
152: index := succ(pointr);
153: if (halfsolution[1, pointr]<>halfsolution[1,index]) and
154: (halfsolution[2, pointr]<>halfsolution[2,index]) and
155: (halfsolution[3, pointr]<>halfsolution[3,index]) and
156: (halfsolution[4, pointr]<>halfsolution[4,index]) then
157: done := true else
158: index := index + 1;
159: until done or (index = pred(halfindex));
160: until done or (pointr = halfindex);
161: if pointr = halfindex then
162: begin
163: nosolutions := true;
164: goto 1;
165: end;
166: end;
167:
168: procedure rearrange;
169: var
170: box: blockno;
171: a, b: pair;
172:
173: procedure put(a, b: pair);
174: var
175: old1, new1, old2, new2: face;
176: save1, save2: alfa;
177:
178: procedure oldpair(c: pair);
179: begin
180: case c of
181: one2:
182: begin
183: old1 := front;
184: old2 := back;
185: end;
186: three4:
187: begin
188: old1 := top;
189: old2 := bottom;
190: end;
191: five6:
192: begin
193: old1 := left;
194: old2 := right;
195: end
196: end;
197: end;
198: procedure newpair(d: pair);
199: begin
200: oldpair(b);
201: new1 := old1;
202: new2 := old2;
203: end;
204:
205: begin
206: newpair(b);
207: oldpair(a);
208: save1 := datas[box, new1];
209: datas[box, new1] := datas[box, old1];
210: datas[box, old1] := save1;
211: save2 := datas[box, new2];
212: datas[box, new2] := datas[box, old2];
213: datas[box, old2] := save2;
214: end;
215:
216: begin
217: for box := 1 to 4 do
218: begin
219: a := halfsolution[box, pointr];
220: b := halfsolution[box, index];
221: if (a=one2) and (b=five6) then
222: put(five6, three4) else
223: begin
224: if a = three4 then
225: begin
226: if b = one2 then
227: begin
228: put(one2, five6);
229: put(three4, one2);
230: put(five6, three4);
231: end else
232: begin
233: put(three4, one2);
234: put(five6, three4);
235: end
236: end else
237: if b = one2 then
238: begin
239: put(one2, three4);
240: put(five6, one2);
241: end else
242: put(five6, one2);
243: end;
244: end;
245: end;
246:
247: procedure correct;
248: var
249: list: array[1..8] of integer;
250: done: Boolean;
251: side: face;
252: counter: integer;
253:
254: procedure check;
255: var
256: delux: array[red..white] of integer;
257: kolor: color;
258: counter: integer;
259: begin
260: done := true;
261: for kolor := red to white do
262: for counter := 1 to 4 do
263: delux[kolor] := 0;
264: for counter := 1 to 4 do
265: begin
266: delux[word(datas[counter,side])] :=
267: delux[word(datas[counter,side])] + 1;
268: if delux[word(datas[counter,side])] >= 2 then
269: done := false;
270: end;
271: end;
272:
273: procedure rotate;
274: var
275: save: alfa;
276: opposite: face;
277: begin
278: if side = back then
279: opposite := front else
280: if side = front then
281: opposite := back else
282: if side = top then
283: opposite := bottom else
284: if side = bottom then
285: opposite := top;
286: save := datas[list[counter], side];
287: datas[list[counter], side] := datas[list[counter], opposite];
288: datas[list[counter], opposite] := save;
289: end;
290:
291: begin
292: list[1] := 4;
293: list[2] := 3;
294: list[3] := 4;
295: list[4] := 2;
296: list[5] := 4;
297: list[6] := 3;
298: list[7] := 4;
299: list[8] := 3;
300: for side := back to top do
301: begin
302: counter := 0;
303: check;
304: while not done do
305: begin
306: counter := counter + 1;
307: rotate;
308: check;
309: end;
310: end
311: end;
312:
313: procedure printout;
314: var
315: space: integer;
316: cube: integer;
317: side: face;
318: begin
319: if nosolutions then
320: writeln('no solutions') else
321: begin
322: writeln('solution to instant insanity');
323: for cube := 1 to 4 do
324: begin
325: write(cube, ' ');
326: for side := front to bottom do
327: write(datas[cube, side]);
328: writeln;
329: end;
330: end;
331: end;
332:
333: begin
334: reset(input);
335: readin;
336: sumcolors;
337: find2222;
338: simultaneous;
339: rearrange;
340: correct;
341: 1:
342: printout;
343: end.
344: {
345: wbggrb
346: wbrgrr
347: wbgwrg
348: wrgwbr
349: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.