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
}