minnie.tuhs.org/unixen.tar/unixen/PDP-11/Distributions/ucb/spencer_2bsd.tar.gz/2bsd.tar/src/pascal/tests/insan.p

Text File | 1980-02-17 | 6KB | 347 lines

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
}