BSD 1 development

[unix-history] / tests / insan.p

program insane(input, output);
label
	1;
type
	alfa = packed array[1..10] of char;
	face = (front, back, top, bottom, left, right);
	pair = (one2, three4, five6);
	color = (red, blue, green, white);
	blockno = 1..4;
var
	nosolutions: Boolean;
	index, halfindex: integer;
	pointr: integer;
	data: array[blockno, face] of alfa;
	sum: array[blockno, pair, color] of integer;
	halfsolution: array[blockno, 1..30] of pair;

function word(alf: alfa): color;
begin
	if alf = 'red' then
		word := red else
	if alf = 'blue' then
		word := blue else
	if alf = 'green' then
		word := green else
		word := white;
end;

procedure readin;
var
	hue: alfa;
	ch: char;
	cube: blockno;
	position: face;

procedure tone;
begin
	case ch of
	'r': hue := 'red';
	'w': hue := 'white';
	'g': hue := 'green';
	'b': hue := 'blue';
	end;
end;

begin
	for cube := 1 to 4 do
	begin
		for position := front to right do
		begin
			read(ch);
			tone;
			data[cube, position] := hue;
		end;
		readln;
	end;
end;

procedure sumcolors;
var
	cube: blockno;
	side: face;
function facepair(aface: face): pair;
begin
	case aface of
	front, back: facepair := one2;
	top, bottom: facepair := three4;
	left, right: facepair := five6
	end;
end;

procedure initializesum;
var
	cube: blockno;
	side: face;
	technicolor: color;
begin
	for cube := 1 to 4 do
		for side :=  front to right do
			for technicolor := red to white do
				sum[cube, facepair(side), technicolor] := 0;
end;

begin
	initializesum;
	for cube := 1 to 4 do
		for side := front to right do
			sum[cube, facepair(side), word(data[cube,side])] :=
			sum[cube, facepair(side), word(data[cube,side])] + 1;
end;

procedure find2222;
var
	subtotals: array[red..white] of integer;
	pair1, pair2, pair3, pair4: pair;

function two222(pair1, pair2, pair3, pair4: pair): Boolean;
var
	hue: color;
begin
	for hue := red to white do
		subtotals[hue] :=
			sum[1, pair1, hue]+
			sum[2, pair2, hue]+
			sum[3, pair3, hue]+
			sum[4, pair4, hue];
	if (subtotals[red]=2) and
	   (subtotals[blue]=2) and
	   (subtotals[green]=2) and
	   (subtotals[white]=2) then
		two222 := true else
		two222 := false;
end;

procedure listsolution;
begin
	halfsolution[1, halfindex] := pair1;
	halfsolution[2, halfindex] := pair2;
	halfsolution[3, halfindex] := pair3;
	halfsolution[4, halfindex] := pair4;
	halfindex := halfindex + 1;
end;

begin
	halfindex := 1;
	for pair1 := one2 to five6 do
	for pair2 := one2 to five6 do
	for pair3 := one2 to five6 do
	for pair4 := one2 to five6 do
		if two222(pair1, pair2, pair3, pair4) then
			listsolution;
	if halfindex <= 2 then
	begin
		nosolutions := true;
		goto 1;
	end;
end;

procedure simultaneous;
var
	done: Boolean;
begin
	nosolutions := false;
	pointr := 0;
	done := false;
	repeat
		pointr := pointr + 1;
		repeat
			index := succ(pointr);
			if (halfsolution[1, pointr]<>halfsolution[1,index]) and
			   (halfsolution[2, pointr]<>halfsolution[2,index]) and
			   (halfsolution[3, pointr]<>halfsolution[3,index]) and
			   (halfsolution[4, pointr]<>halfsolution[4,index]) then
				done := true else
				index := index + 1;
		until done or (index = pred(halfindex));
	until done or (pointr = halfindex);
	if pointr = halfindex then
	begin
		nosolutions := true;
		goto 1;
	end;
end;

procedure rearrange;
var
	box: blockno;
	a, b: pair;

procedure put(a, b: pair);
var
	old1, new1, old2, new2: face;
	save1, save2: alfa;

procedure oldpair(c: pair);
begin
	case c of
	one2:
		begin
			old1 := front;
			old2 := back;
		end;
	three4:
		begin
			old1 := top;
			old2 := bottom;
		end;
	five6:
		begin
			old1 := left;
			old2 := right;
		end
	end;
end;
procedure newpair(d: pair);
begin
	oldpair(b);
	new1 := old1;
	new2 := old2;
end;

begin
	newpair(b);
	oldpair(a);
	save1 := data[box, new1];
	data[box, new1] := data[box, old1];
	data[box, old1] := save1;
	save2 := data[box, new2];
	data[box, new2] := data[box, old2];
	data[box, old2] := save2;
end;

begin
	for box := 1 to 4 do
	begin
		a := halfsolution[box, pointr];
		b := halfsolution[box, index];
		if (a=one2) and (b=five6) then
			put(five6, three4) else
		begin
			if a = three4 then
			begin
				if b = one2 then
				begin
					put(one2, five6);
					put(three4, one2);
					put(five6, three4);
				end else
				begin
					put(three4, one2);
					put(five6, three4);
				end
			end else
			if b = one2 then
			begin
				put(one2, three4);
				put(five6, one2);
			end else
				put(five6, one2);
		end;
	end;
end;

procedure correct;
var
	list: array[1..8] of integer;
	done: Boolean;
	side: face;
	counter: integer;

procedure check;
var
	delux: array[red..white] of integer;
	kolor: color;
	counter: integer;
begin
	done := true;
	for kolor := red to white do
		for counter := 1 to 4 do
			delux[kolor] := 0;
	for counter := 1 to 4 do
	begin
		delux[word(data[counter,side])] :=
		delux[word(data[counter,side])] + 1;
		if delux[word(data[counter,side])] >= 2 then
			done := false;
	end;
end;

procedure rotate;
var
	save: alfa;
	opposite: face;
begin
	if side = back then
		opposite := front else
	if side = front then
		opposite := back else
	if side = top then
		opposite := bottom else
	if side = bottom then
		opposite := top;
	save := data[list[counter], side];
	data[list[counter], side] := data[list[counter], opposite];
	data[list[counter], opposite] := save;
end;

begin
	list[1] := 4;
	list[2] := 3;
	list[3] := 4;
	list[4] := 2;
	list[5] := 4;
	list[6] := 3;
	list[7] := 4;
	list[8] := 3;
	for side := back to top do
	begin
		counter := 0;
		check;
		while not done do
		begin
			counter := counter + 1;
			rotate;
			check;
		end;
	end
end;

procedure printout;
var
	space: integer;
	cube: integer;
	side: face;
begin
	if nosolutions then
		writeln('no solutions') else
	begin
		writeln('solution to instant insanity');
		for cube := 1 to 4 do
		begin
			write(cube, '   ');
			for side := front to bottom do
				write(data[cube, side]);
			writeln;
		end;
	end;
end;

begin
	reset(input, 'insan.d');
	readin;
	sumcolors;
	find2222;
	simultaneous;
	rearrange;
	correct;
1:
	printout;
end.
{
wbggrb
wbrgrr
wbgwrg
wrgwbr
}