program Puzzle;
{ -- Project Name: Puzzle.Pas
-- Author: Douglas E. Woolley
-- Date Started: 8/15/88
-- Last Update: 9/27/88
-- This program will accept the appearance of the Rubik's Cube as input,
-- and output a step-by-step text/graphical solution to restore the puzzle.
}
type
String1 = String[1]; { -- Stores Side to be moved, eg. F, R, B }
String3 = String[3]; { -- Stores 1 move of solution 'F+ ' }
String30 = String[30]; { -- Stores Title for Border }
String60 = String[60]; { -- Stores Set of Moves (at most 20) }
Array6 = Array [1..6] of Integer;
MenuType = Array [1..6] of String[20];
const
RowForSide: Array6 = (3, 10, 10, 10, 10, 17);
ColForSide: Array6 = (3, 3, 12, 21, 30, 3);
MenuOption: MenuType = ( { -- 1 } 'Graphic Solution',
{ -- 2 } 'Text Solution',
{ -- 3 } 'Instructions',
{ -- 4 } 'Set Valid Colors',
{ -- 5 } 'Test Program',
{ -- 6 } 'Exit');
LastOption = 6;
var
A: Array [1..54] of Char; { -- Has current color of square. }
AInit: Array [1..54] of Char; { -- Has initial color of square. }
Option: Integer;
ValidColor: Array [1..6] of Char;
CorrectInput: Boolean;
Solution: Array [1..200] of String3; { -- Has all moves to make. }
LastSolIndex: Integer; { -- Has last index of Sol. }
MoveError: Boolean; { -- Detects if an error occurs during moves. }
{ --INCLUDE DISPLAYS.INC: DisplayBorder, DisplayTitlePage, DisplayMenu, Beep }
{$I DISPLAYS.INC}
{ -- DISPLAYS.INC }
procedure DisplayBorder ({using} Title: String30; TM: Integer);
{ -- This procedure will display special characters around the perimeter
-- and centers the Title on the top line; TM=0 is width 80, = 1 width 40. }
const
TopLtCor = 201;
TopRtCor = 187;
BotLtCor = 200;
BotRtCor = 188;
Down = 186;
Across = 205;
var
I: Integer;
begin
if TM = 0 then { -- Width is 80 }
TextMode (C80)
else TextMode (C40); { -- Width is 40 }
TextBackground (Blue); TextColor (LightGreen); ClrScr;
Write (Chr(TopLtCor));
for I := 2 to 79-TM*40 do Write (Chr(Across));
Write (Chr(TopRtCor));
for I := 2 to 23 do begin
GotoXY (1, I); Write (Chr(Down));
GotoXY( 80-TM*40, I); Write (Chr(Down));
end;
GotoXY (1, 24);
Write (Chr(BotLtCor));
for I := 2 to 79-TM*40 do Write (Chr(Across));
Write (Chr(BotRtCor));
{ -- Center title on 1st line. }
TextColor (White);
GotoXY (39 -TM*20 - (Length(Title) div 2), 1); Write (' ', Title, ' ');
end;
procedure DisplayTitlePage;
{ -- This procedure will display program name, author, date, etc. }
var
Ch: Char;
begin
DisplayBorder ('COMPUTER ORIENTED SOLUTIONS', 0);
TextColor (White);
GotoXY (39, 2); Write ('TO');
GotoXY (32, 3); Write ('THE RUBIK''S CUBE');
TextColor (LightCyan);
GotoXY (33, 6); Write ('IBM Version 1.0');
TextColor (White);
GotoXY (31, 12); Write ('Douglas E. Woolley');
TextColor (Yellow);
GotoXY (26, 13); Write ('University of South Florida');
TextColor (LightRed);
GotoXY (34, 20); Write ('September 1988');
TextColor (LightBlue);
GotoXY (34, 23); Write ('Press any key');
Read (Kbd, Ch);
end;
procedure DisplayMenu ({giving} var Option: Integer);
{ -- This procedure will display Menu and accept valid option. }
var
I: Integer;
Ch: Char;
begin
DisplayBorder ('COMPUTER ORIENTED SOLUTIONS', 0);
TextColor (White);
GotoXY (39, 2); Write ('TO');
GotoXY (32, 3); Write ('THE RUBIK''S CUBE');
for I := 1 to LastOption do begin
TextColor (White);
GotoXY (30, 4 + I*2); Write (I, '. ');
TextColor (Yellow);
Write (MenuOption[I]);
end;
GotoXY (30, 4 + (LastOption+1)*2);
Write ('Choose:');
repeat
Read (Kbd, Ch);
Option := Ord(Ch) - Ord('0');
until Option in [1 .. LastOption];
end;
procedure Beep;
{ -- This procedure makes a beep for errors. }
begin
Sound (440);
Delay (150);
NoSound;
end;
{ -- INCLUDE VALIDCOL.INC: InitValidColors, GetValidColors }
{$I VALIDCOL.INC}
procedure InitValidColors;
{ -- This procedure will assign 6 common colors on the Rubik's Cube
-- to the captial global variable ValidColor. }
begin
ValidColor[1] := 'B';
ValidColor[2] := 'G';
ValidColor[3] := 'O';
ValidColor[4] := 'R';
ValidColor[5] := 'W';
ValidColor[6] := 'Y';
end;
procedure GetValidColors;
{ -- This procedure will accept 6 valid colors to use for the cube. }
var
Side, I: Integer;
Ch: Char;
Valid: Boolean;
begin
DisplayBorder (MenuOption[Option], 1);
{ -- Display Instructions on entering colors. }
TextColor (LightGreen);
GotoXY (3, 5);
Write('Enter 6 unique color symbols used on');
GotoXY (3, 6);
Write ('your puzzle (');
TextColor (Yellow); Write ('Enter');
TextColor (LightGreen); Write (' key for default):');
{ -- Display default values. }
for Side := 1 to 6 do begin
TextColor (Yellow);
GotoXY (15, 7+Side); Write ('Color ', Side, ': ');
TextColor (LightGray);
Write (ValidColor[Side]);
end;
{ -- Get 6 uniuqe color values; (If Enter is pressed, then default) }
for Side := 1 to 6 do begin
GotoXY (15+9, 7+Side);
TextColor (White);
repeat
Read (Kbd, Ch);
Ch := UpCase(Ch);
if (Ch in ['A' .. 'Z']) or (Ord(Ch) in [13]) then { -- maybe valid }
begin
Valid := True;
If Ord(Ch) = 13 then { -- Enter was pressed }
Ch := ValidColor[Side];
{ -- Check if symbol entered is a duplicate. }
for I := 1 to Side-1 do
if ValidColor[I] = Ch then
Valid := False;
end
else { -- Character was not a letter or an Enter key. }
Valid := False;
until Valid;
ValidColor[Side] := Ch;
Write (ValidColor[Side]);
end; { -- for Side }
GotoXY (14, 25); TextColor (Yellow);
Write ('Press any key');
Read (Kbd, Ch);
end;
procedure InitArrayOfColors; { -- output is global array of colors. }
{ -- This procedure will set all array items to spaces for color. }
var
I: Integer;
begin
for I := 1 to 54 do begin
AInit[I] := ' '; A[I] := ' ';
end;
end;
procedure DisplayBox ({using} Side: Integer);
{ -- This procedure displays a box for corresponding side at row,col. }
const
TopLtCor = 218;
TopRtCor = 191;
BotLtCor = 192;
BotRtCor = 217;
Down = 179;
Across = 196;
var
I, InitCol, InitRow: Integer;
begin
InitCol := ColForSide[Side];
InitRow := RowForSide[Side];
GotoXY (InitCol, InitRow); TextColor (Yellow);
{ -- Display Top line }
Write (Chr(TopLtCor));
for I := 1 to 7 do Write (Chr(Across));
Write (Chr(TopRtCor));
{ -- Display vertical lines }
for I := 1 to 5 do begin
GotoXY (InitCol, InitRow+I); Write (Chr(Down), ' ');
GotoXY (InitCol+8, InitRow+I); Write (Chr(Down));
end;
{ -- Display bottom line }
GotoXY (InitCol, InitRow+6);
Write (Chr(BotLtCor));
for I := 1 to 7 do Write (Chr(Across));
Write (Chr(BotRtCor));
end;
procedure DisplayColors ({using} Side: Integer);
{ -- This procedure displays the color contents of squares on the Side. }
var
Col, Row, InitCol, InitRow, Index: Integer;
begin
InitCol := ColForSide[Side];
InitRow := RowForSide[Side];
for Row := 1 to 3 do
for Col := 1 to 3 do begin
TextColor (White);
TextBackground (Black);
GotoXY (InitCol + Col*2, InitRow + Row*2 -1);
Index := (Side-1)*9 + (Row-1)*3 + Col;
Write (A[Index]);
end;
TextBackground (Blue); TextColor (Yellow);
end;
procedure DisplayTextInstr;
{ -- This procedure will display commands needed for displaying the solution.}
const
RtArrow = 26;
LtArrow = 27;
begin
{ -- First command }
TextColor (Green);
GotoXY (14, 4); Write ('Press: ');
TextColor (Yellow);
Write ('Space, ', Chr(RtArrow), ', ');
TextColor (Green); Write ('or ');
TextColor (Yellow); Write ('Enter');
{ -- 2nd line/ 1st command. }
GotoXY (14, 5); TextColor (LightGreen);
Write ('and perform move shown');
{ -- 3rd line/ 1st command. }
GotoXY (14, 6);
Write ('below then compare sides;');
{ -- Fourth line/ 2nd command }
TextColor (Green);
GotoXY (14, 7); Write ('or ');
TextColor (Yellow);
Write (Chr(LtArrow));
TextColor (Green);
Write (' for previous move;');
{ -- Fifth line/ 3rd command }
GotoXY (14, 8); Write ('or ');
TextColor (Yellow);
Write ('ESC ');
TextColor (Green);
Write ('to quit.');
end;
procedure DisplayInputInstr;
{ -- This procedure will display commands needed for inputting colors. }
const
RtArrow = 26;
LtArrow = 27;
var
I: Integer;
begin
{ -- First command }
TextColor (Green);
GotoXY (14, 4); Write ('Press: ');
TextColor (Yellow);
for I:= 1 to 5 do
Write (ValidColor[I], ', ');
Write (ValidColor[6]);
{ -- Second command }
TextColor (Green);
GotoXY (14, 5); Write ('or ');
TextColor (Yellow);
Write ('Space');
TextColor (Green);
Write (' to remove entry');
{ -- Third command }
TextColor (Green);
GotoXY (14, 6); Write ('or ');
TextColor (Yellow);
Write (Chr(RtArrow));
TextColor (Green);
Write (' for next square');
{ -- Fourth command }
GotoXY (14, 7); Write ('or ');
TextColor (Yellow);
Write (Chr(LtArrow));
TextColor (Green);
Write (' for previous square');
{ -- Fifth command }
GotoXY (14, 8); Write ('or ');
TextColor (Yellow);
Write ('ESC ');
TextColor (Green);
Write ('when finished.');
end;
procedure DisplayBoxes;
{ -- This procedure will display the 6 sides of the cube. }
var
Side: Integer;
begin
for Side := 1 to 6 do begin
DisplayBox (Side);
DisplayColors (Side);
end;
TextColor (LightRed);
GotoXY (2, 5); Write ('T');
GotoXY (2, 6); Write ('o');
GotoXY (2, 7); Write ('p');
GotoXY (2, 11); Write ('F');
GotoXY (2, 12); Write ('r');
GotoXY (2, 13); Write ('o');
GotoXY (2, 14); Write ('n');
GotoXY (2, 15); Write ('t');
GotoXY (2, 18); Write ('B');
GotoXY (2, 19); Write ('o');
GotoXY (2, 20); Write ('t');
GotoXY (2, 21); Write ('t');
GotoXY (2, 22); Write ('o');
GotoXY (2, 23); Write ('m');
GotoXY (13, 17); Write (' Right ', ' Back ', ' Left');
end;
{ -- INCLUDE GETINPUT.INC Match, InputCorrect, GetColors, GetRCInput }
{$I GETINPUT.INC}
{ -- GETINPUT.INC }
function Match({using} Cor: String3; A1, A2, A3: Char): {giving} Boolean;
{ -- This function returns True if Cor matches a permutation of A1,A2,A3. }
begin
if (A1+A2+A3 = Cor) or (A1+A3+A2 = Cor) or (A2+A1+A3 = Cor) or
(A2+A3+A1 = Cor) or (A3+A1+A2 = Cor) or (A3+A2+A1 = Cor) then
Match := True
else
Match := False;
end;
function InputCorrect: {giving} Boolean;
{ -- This function will output True if 12 unique edges and 8 unique corners
-- are entered with 6 unique middle squares on the 6 sides. }
var
Side, I, J: Integer;
Colr: Array[1..6] of Char;
Edge: Array[1..12] of String[2];
Corn: Array[1..8] of String3;
EdgeHere: Array[1..12] of Boolean;
CornHere: Array[1..8] of Boolean;
begin
InputCorrect := True;
for Side := 1 to 6 do
Colr[Side] := A[Side*9-4];
for I := 1 to 5 do
for J := I+1 to 6 do
if Colr[I] = Colr[J] then begin
InputCorrect := False;
Exit;
end;
{ -- All the possible Edge combinations with the unique mid squares. }
Edge[1] := Colr[1] + Colr[2]; Edge[2] := Colr[1] + Colr[3];
Edge[3] := Colr[1] + Colr[4]; Edge[4] := Colr[1] + Colr[5];
Edge[5] := Colr[2] + Colr[3]; Edge[6] := Colr[3] + Colr[4];
Edge[7] := Colr[4] + Colr[5]; Edge[8] := Colr[5] + Colr[2];
Edge[9] := Colr[2] + Colr[6]; Edge[10]:= Colr[3] + Colr[6];
Edge[11]:= Colr[4] + Colr[6]; Edge[12]:= Colr[5] + Colr[6];
{ -- All the possible Corner combinations with the unique mid squares. }
Corn[1] := Colr[1] + Colr[2] + Colr[3];
Corn[2] := Colr[1] + Colr[3] + Colr[4];
Corn[3] := Colr[1] + Colr[4] + Colr[5];
Corn[4] := Colr[1] + Colr[5] + Colr[2];
Corn[5] := Colr[6] + Colr[2] + Colr[3];
Corn[6] := Colr[6] + Colr[3] + Colr[4];
Corn[7] := Colr[6] + Colr[4] + Colr[5];
Corn[8] := Colr[6] + Colr[5] + Colr[2];
{ -- Check if any valid edge pieces are missing or duplicated. }
for I := 1 to 12 do begin
EdgeHere[I] := False;
if (A[8]+A[11] = Edge[I]) or (A[11]+A[8] = Edge[I]) then
if EdgeHere[I] then begin InputCorrect := False; Exit; end
else EdgeHere[I] := True;
if (A[6]+A[20] = Edge[I]) or (A[20]+A[6] = Edge[I]) then
if EdgeHere[I] then begin InputCorrect := False; Exit; end
else EdgeHere[I] := True;
if (A[2]+A[29] = Edge[I]) or (A[29]+A[2] = Edge[I]) then
If EdgeHere[I] then begin InputCorrect := False; Exit; end
else EdgeHere[I] := True;
if (A[4]+A[38] = Edge[I]) or (A[38]+A[4] = Edge[I]) then
If EdgeHere[I] then begin InputCorrect := False; Exit; end
else EdgeHere[I] := True;
if (A[15]+A[22] = Edge[I]) or (A[22]+A[15] = Edge[I]) then
If EdgeHere[I] then begin InputCorrect := False; Exit; end
else EdgeHere[I] := True;
if (A[24]+A[31] = Edge[I]) or (A[31]+A[24] = Edge[I]) then
If EdgeHere[I] then begin InputCorrect := False; Exit; end
else EdgeHere[I] := True;
if (A[33]+A[40] = Edge[I]) or (A[40]+A[33] = Edge[I]) then
If EdgeHere[I] then begin InputCorrect := False; Exit; end
else EdgeHere[I] := True;
if (A[13]+A[42] = Edge[I]) or (A[42]+A[13] = Edge[I]) then
If EdgeHere[I] then begin InputCorrect := False; Exit; end
else EdgeHere[I] := True;
if (A[17]+A[47] = Edge[I]) or (A[47]+A[17] = Edge[I]) then
If EdgeHere[I] then begin InputCorrect := False; Exit; end
else EdgeHere[I] := True;
if (A[26]+A[51] = Edge[I]) or (A[51]+A[26] = Edge[I]) then
If EdgeHere[I] then begin InputCorrect := False; Exit; end
else EdgeHere[I] := True;
if (A[35]+A[53] = Edge[I]) or (A[53]+A[35] = Edge[I]) then
If EdgeHere[I] then begin InputCorrect := False; Exit; end
else EdgeHere[I] := True;
if (A[44]+A[49] = Edge[I]) or (A[49]+A[44] = Edge[I]) then
If EdgeHere[I] then begin InputCorrect := False; Exit; end
else EdgeHere[I] := True;
If not EdgeHere[I] then { -- This Edge[I] does not exist. }
begin InputCorrect := False; Exit; end
end; { -- for I }
{ -- Check if any valid corner pieces are missing or duplicated. }
for I := 1 to 8 do begin
CornHere[I] := False;
if Match(Corn[I], A[9], A[12], A[19]) then
if CornHere[I] then begin InputCorrect := False; Exit; end
else CornHere[I] := True;
if Match(Corn[I], A[3], A[21], A[28]) then
if CornHere[I] then begin InputCorrect := False; Exit; end
else CornHere[I] := True;
if Match(Corn[I], A[1], A[30], A[37]) then
if CornHere[I] then begin InputCorrect := False; Exit; end
else CornHere[I] := True;
if Match(Corn[I], A[7], A[10], A[39]) then
if CornHere[I] then begin InputCorrect := False; Exit; end
else CornHere[I] := True;
if Match(Corn[I], A[18], A[25], A[48]) then
if CornHere[I] then begin InputCorrect := False; Exit; end
else CornHere[I] := True;
if Match(Corn[I], A[27], A[34], A[54]) then
if CornHere[I] then begin InputCorrect := False; Exit; end
else CornHere[I] := True;
if Match(Corn[I], A[36], A[43], A[52]) then
if CornHere[I] then begin InputCorrect := False; Exit; end
else CornHere[I] := True;
if Match(Corn[I], A[16], A[45], A[46]) then
if CornHere[I] then begin InputCorrect := False; Exit; end
else CornHere[I] := True;
If not CornHere[I] then { -- This Corn[I] does not exist. }
InputCorrect := False;
end; { -- for I }
end;
procedure GetColors;
{ -- This procedure gets the color of squares on each Side.
-- Output: AInit[1..54] are assigned; InputCorrect is True or False. }
const
ESC = 27;
LtArr = 75;
RtArr = 77;
LtArrSh = 52; { -- Shifted left arrow }
RtArrSh = 54; { -- Shifted right arrow }
Space = 32;
var
Col, Row, InitCol,
InitRow, Index, Side, I: Integer;
ColorIndex, Col2Index: Integer;
TotalNumOfCol: Integer;
Ch: Char;
ValidColr, ValidCommand: Boolean;
NumOfEachColor: Array [1..6] of Integer;
ColorSymbols: String[6];
ESCPressed: Boolean;
RightInput: Boolean;
begin
{ -- Initialize variables }
Side := 1; Row := 1; Col := 1; ColorSymbols := '';
for I := 1 to 6 do begin
NumOfEachColor[I] := 0;
ColorSymbols := ColorSymbols + ValidColor[I];
end;
repeat
InitCol := ColForSide[Side];
InitRow := RowForSide[Side];
TextColor (White);
TextBackground (Black);
GotoXY (InitCol + Col*2, InitRow + Row*2 -1);
{ -- Get valid command: Color, Space, ESC, Left Arrow, or Right Arrow. }
repeat
Read (Kbd, Ch);
Ch := UpCase(Ch);
ValidColr := False; { -- Initially not a Color symbol }
if keypressed then
Read (Kbd, Ch)
else begin
ColorIndex := Pos(Ch, ColorSymbols);
if ColorIndex > 0 then
if NumOfEachColor[ColorIndex] + 1 <= 9 then
{ -- No more than 9 squares for a unique color. }
ValidColr := True;
end;
ValidCommand:=(Ord(Ch) in [ESC, LtArr, RtArr, LtArrSh, RtArrSh, Space]);
if not (ValidColr or ValidCommand) then beep; { -- Make beep for error}
until ValidColr or ValidCommand;
If ValidColr or (Ord(Ch) = Space) then { -- Store Character color symbol}
begin
Index := (Side-1)*9 + (Row-1)*3 + Col;
Col2Index := Pos (AInit[Index], ColorSymbols);
if Col2Index > 0 then { -- Remove old color and replace with new }
NumOfEachColor[Col2Index] := NumOfEachColor[Col2Index] - 1;
AInit[Index] := Ch; A[Index] := Ch;
Write (AInit[Index]);
if ValidColr then
NumOfEachColor[ColorIndex] := NumOfEachColor[ColorIndex] + 1;
end
else if Ord(Ch) in [LtArr, LtArrSh] then { -- Move to previous space }
begin
Col := Col - 1;
If Col < 1 then begin
Col := 3;
Row := Row - 1;
if Row < 1 then begin
Row := 3;
Side := Side - 1;
if Side < 1 then Side := 6;
end;
end;
end;
{ -- Increment pointer to next square on cube. }
if ValidColr or (Ord(Ch) in [RtArr, RtArrSh, Space]) then begin
Col := Col + 1;
If Col > 3 then begin
Col := 1;
Row := Row + 1;
if Row > 3 then begin
Row := 1;
Side := Side + 1;
if Side > 6 then Side := 1;
end;
end;
end;
ESCPressed := Ord(Ch) = ESC;
if ESCPressed then begin { -- Quit if input correct, else re-try? }
TextBackground (Blue); TextColor (Yellow);
TotalNumOfCol := 0;
for I := 1 to 6 do
TotalNumOfCol := TotalNumOfCol + NumOfEachColor[I];
RightInput := InputCorrect; { -- Function checks for each edge/corn. }
if (TotalNumOfCol <> 6*9) { -- 54 colors were not entered. }
or not RightInput then begin
Beep;
GotoXY (2, 25);
if (TotalNumOfCol <> 6*9) then { -- not all colors entered. }
Write ('Input is incomplete. Try again? (Y/N)')
else { -- A corner or edge was missing or duplicated. }
Write ('A side is incorrect. Try again? (Y/N)');
repeat
Read (Kbd, Ch); Ch := UpCase (Ch);
until Ch in ['Y', 'N'];
if Ch = 'N' then
CorrectInput := False
else begin
GotoXY (2,25);
for I := 1 to 38 do Write (' ');
end;
end;
end;
until ESCPressed and (Ch <> 'Y');
end;
procedure GetRCInput;
{ -- This procedure will assign colors to array variables for Rubik's Cube. }
var
I: Integer;
begin
DisplayBorder ('Input Colors on Rubik''s Cube', 1);
InitArrayOfColors;
DisplayBoxes;
DisplayInputInstr;
CorrectInput := True; { -- Assume that colors gotten in input will be good}
GetColors; { -- CorrectInput will be False if colors were not input right.}
if CorrectInput then { -- Duplicate initial colors to current color array.}
for I := 1 to 54 do
A[I] := AInit[I];
end;
{ -- ************ Computer Coded Solution **************** }
procedure MoveSide ({given} SideToMove: String1; NumOfRot: Integer);
{ -- This procedure will turn Side a total of NumOfRot rotations clockwise. }
var
Side, RotNum: Integer;
I, X, Y: Integer;
Temp: Char;
begin
Side := Pos(SideToMove, 'TFRPLB');
for RotNum := 1 to NumOfRot do begin
I := (Side - 1) * 9;
Temp := A[I+7]; A[I+7] := A[I+9]; A[I+9] := A[I+3];
A[I+3] := A[I+1]; A[I+1] := Temp;
Temp := A[I+4]; A[I+4] := A[I+8]; A[I+8] := A[I+6];
A[I+6] := A[I+2]; A[I+2] := Temp;
end;
case SideToMove of
'T': for RotNum := 1 to NumOfRot do
for I := 0 to 2 do begin
Temp := A[30-I]; A[30-I] := A[39-I]; A[39-I] := A[12-I];
A[12-I] := A[21-I]; A[21-I] := Temp;
end;
'F': for RotNum := 1 to NumOfRot do begin
X := 0; Y := 0;
for I := 7 to 9 do begin
Temp := A[I]; A[I] := A[45-Y]; A[45-Y] := A[48-X];
A[48-X] := A[19+Y]; A[19+Y] := Temp;
X := X+1; Y := Y+3;
end;
end;
'R': for RotNum := 1 to NumOfRot do begin
X := 0;
for I := 0 to 2 do begin
X := X+3; Y := X-3;
Temp := A[X]; A[X] := A[12+Y]; A[12+Y] := A[48+Y];
A[48+Y] := A[34-Y]; A[34-Y] := Temp;
end;
end;
'L': for RotNum := 1 to NumOfRot do begin
X := 1; Y := 0;
for I := 0 to 2 do begin
Temp := A[X]; A[X] := A[36-Y]; A[36-Y] := A[46+Y];
A[46+Y] := A[10+Y]; A[10+Y] := Temp;
X := X+3; Y := Y+3;
end;
end;
'B': for RotNum := 1 to NumOfRot do
for I := 0 to 2 do begin
Temp := A[16+I]; A[16+I] := A[43+I]; A[43+I] := A[34+I];
A[34+I] := A[25+I]; A[25+I] := Temp;
end;
end; { -- case }
end;
procedure MakeMove ({using} NextMove: String3);
{ -- This procedure will process one move by swapping the A array
-- corresponding to the Side being moved. }
var
SideToMove: String1;
Rotation: String1;
MoveIsNotRC: Boolean;
NumOfRot, RotNum: Integer;
I, X, Y: Integer;
Temp: Char;
Side: Integer;
Ch: Char;
begin
SideToMove := Copy(NextMove, 1, 1);
Rotation := Copy(NextMove, 2, 1);
MoveIsNotRC := True;
if Rotation = 'C' then begin { -- Move is TurnCube + Rotation }
MoveIsNotRC := False;
Rotation := Copy (NextMove, 3, 1);
end;
NumOfRot := Pos(Rotation, '+2-'); { -- Rotation symbol translated to 1,2,3}
if MoveIsNotRC then { -- Move is T, F, R, L, or B followed by a +, 2, - }
MoveSide (SideToMove, NumOfRot)
else { -- Rotate Cube clockwise with respect to Top for each NumOfRot. }
begin
MoveSide ('T', NumOfRot); { -- Rotate Top Layer of Cube. }
MoveSide ('B', 4-NumOfRot); { -- Rotate Bottom Layer of Cube. }
{ -- Rotate middle layer of cube. }
for RotNum := 1 to NumOfRot do
for I := 0 to 2 do begin
Temp := A[13+I]; A[13+I] := A[22+I]; A[22+I] := A[31+I];
A[31+I] := A[40+I]; A[40+I] := Temp;
end;
end;
{ -- Display next move and display colors ONLY DURING DEBUGGING. }
{ TextColor (Yellow); GotoXY (30,20); Write (NextMove);
for Side := 1 to 6 do
DisplayColors (Side);
Read (Kbd, Ch); }
end;
procedure Combine ({using} FirstMove: String3);
{ -- This procedure will add the first move to the Solution array, compacting}
var
LastMove: String3;
SideToMove: String1;
Rotation: String1;
MoveIsNotRC: Boolean;
SideToMove2: String1;
Rotation2: String1;
Move2IsNotRC: Boolean;
NumOfRot, NumOfRot2: Integer;
RotNum, I: Integer;
begin
SideToMove := Copy(FirstMove, 1, 1);
Rotation := Copy(FirstMove, 2, 1);
MoveIsNotRC := True;
if Rotation = 'C' then begin { -- Move is TurnCube + Rotation }
MoveIsNotRC := False;
Rotation := Copy (FirstMove, 3, 1);
end;
NumOfRot := Pos(Rotation, '+2-'); { -- Rotation symbol translated 1,2,3}
LastMove := Solution[LastSolIndex];
SideToMove2 := Copy(LastMove, 1, 1);
Rotation2 := Copy(LastMove, 2, 1);
Move2IsNotRC:= True;
if Rotation2 = 'C' then begin { -- Move is TurnCube + Rotation }
Move2IsNotRC := False;
Rotation2 := Copy (LastMove, 3, 1);
end;
NumOfRot2 := Pos(Rotation2, '+2-'); {-- Rotation symbol becomes 1,2,3}
if (SideToMove = SideToMove2) and (MoveIsNotRC = Move2IsNotRC) then
{ -- Since last move = this move, combine rotations into 1 rotation. }
begin
RotNum := (NumOfRot + NumOfRot2) mod 4;
if RotNum = 0 then { -- 2 rotations combined is = no turn.}
LastSolIndex := LastSolIndex - 1
else begin { -- Change the rotation }
if MoveIsNotRC then I := 2
else I := 3;
Solution[LastSolIndex] := Copy(Solution[LastSolIndex], 1, I-1) +
Copy('+2-', RotNum, 1) + ' ';
end; { -- if RotNum else }
end { -- if SideToMove }
else begin { -- store unique next move. }
LastSolIndex := LastSolIndex + 1;
Solution[LastSolIndex] := FirstMove;
end; { -- else SideToMove }
end;
procedure AddToSolution ({using} SetOfMoves: String60);
{ -- This procedure will first internally move the cube as directed, then
-- Add the set of moves to the entire Solution array, with compacting. }
var
StartOfMove: Integer;
FirstMove, NextMove: String3;
begin
{ -- Get First move and process it. }
FirstMove := Copy(SetOfMoves, 1, 3);
MakeMove (FirstMove);
{ -- Add First move to Solution array: Combine if same as previous move. }
if LastSolIndex > 0 then { -- Check if last move = this move, and combine.}
Combine (FirstMove)
else begin { -- LastSolIndex = 0 so automatically store next move. }
LastSolIndex := LastSolIndex + 1;
Solution[LastSolIndex] := FirstMove;
end; { -- if else LastSolIndex > 0}
{ -- Partition and process each move in SetOfMoves after the first. }
StartOfMove := 4;
while StartOfMove < Length(SetOfMoves) do begin
NextMove := Copy(SetOfMoves, StartOfMove, 3);
LastSolIndex := LastSolIndex + 1;
Solution[LastSolIndex] := NextMove;
MakeMove (NextMove);
StartOfMove := StartOfMove + 3; { -- Starting position of next move. }
end;
end;
procedure ErrorInMoves;
{ -- This procedure will display an error message about the solution. }
var
Ch: Char;
begin
TextColor (LightGray); Beep;
GotoXY (13, 19); Write ('An error has been detected.');
GotoXY (13, 20); Write ('Possibly, you have an im-');
GotoXY (13, 21); Write ('possible cube.');
TextColor (Yellow);
GotoXY (13, 22); Write (' Press any key');
Read (Kbd, Ch);
Window (13, 19, 39, 23); ClrScr;
Window (1, 1, 80, 25);
end;
{ -- INCLUDE SOLUTION.INC SolveTopEdges, SolveTopCorners, SolveVerticalEdges,
SolveBottomCorners, SolveBottomEdges }
{$I SOLUTION.INC}
{ -- SOLUTION.INC}
procedure SolveTopEdges ({giving} var MoveError: Boolean);
{ -- This procedure will store the moves in Solution to restore top edges. }
{ -- Strategy: Work on front-top edge then rotate cube to next face. }
var
Face: Integer;
Tmid, Fmid: Char;
begin
for Face := 1 to 4 do begin
Tmid := A[5]; { -- Has Color symbol of Top middle square. }
Fmid := A[14]; { -- Has color symbol of Front middle square. }
if (A[8] = Fmid) and (A[11] = Tmid) then { -- Orient FT }
AddToSolution ('F+ T- R+ T+ ')
else if (A[6] = Fmid) and (A[20] = Tmid) then { -- Move RT to FT }
AddToSolution ('R- F- ')
else if (A[6] = Tmid) and (A[20] = Fmid) then { -- Move RT to FT }
AddToSolution ('R- T- R+ T+ ')
else if (A[2] = Fmid) and (A[29] = Tmid) then { -- Move PT to FT }
AddToSolution ('T+ R- T- F- ')
else if (A[2] = Tmid) and (A[29] = Fmid) then { -- Move PT to FT }
AddToSolution ('T+ R2 T- B- F2 ')
else if (A[4] = Fmid) and (A[38] = Tmid) then { -- Move LT to FT }
AddToSolution ('L+ F+ ')
else if (A[4] = Tmid) and (A[38] = Fmid) then { -- Move LT to FT }
AddToSolution ('L2 B+ F2 ')
else if (A[15] = Fmid) and (A[22] = Tmid) then { -- Move FR to FT }
AddToSolution ('F- ')
else if (A[15] = Tmid) and (A[22] = Fmid) then { -- Move FR to FT }
AddToSolution ('R- B- R+ F2 ')
else if (A[24] = Fmid) and (A[31] = Tmid) then { -- Move PR to FT }
AddToSolution ('R+ B- R- F2 ')
else if (A[24] = Tmid) and (A[31] = Fmid) then { -- Move PR to FT }
AddToSolution ('R2 F- R2 ')
else if (A[33] = Fmid) and (A[40] = Tmid) then { -- Move LP to FT }
AddToSolution ('L2 F+ L2 ')
else if (A[33] = Tmid) and (A[40] = Fmid) then { -- Move LP to FT }
AddToSolution ('L- B+ L+ F2 ')
else if (A[13] = Fmid) and (A[42] = Tmid) then { -- Move FL to FT }
AddToSolution ('F+ ')
else if (A[13] = Tmid) and (A[42] = Fmid) then { -- Move FL to FT }
AddToSolution ('T+ L- T- ')
else if (A[17] = Fmid) and (A[47] = Tmid) then { -- Move BF to FT }
AddToSolution ('F2 ')
else if (A[17] = Tmid) and (A[47] = Fmid) then { -- Move BF to FT }
AddToSolution ('F+ T+ L- T- ')
else if (A[26] = Fmid) and (A[51] = Tmid) then { -- Move BR to FT }
AddToSolution ('B- F2 ')
else if (A[26] = Tmid) and (A[51] = Fmid) then { -- Move BR to FT }
AddToSolution ('R+ F- R- ')
else if (A[35] = Fmid) and (A[53] = Tmid) then { -- Move BP to FT }
AddToSolution ('B2 F2 ')
else if (A[35] = Tmid) and (A[53] = Fmid) then { -- Move BP to FT }
AddToSolution ('B+ L- F+ L+ ')
else if (A[44] = Fmid) and (A[49] = Tmid) then { -- Move BL to FT }
AddToSolution ('B+ F2 ')
else if (A[44] = Tmid) and (A[49] = Fmid) then { -- Move BL to FT }
AddToSolution ('L- F+ L+ ');
if (A[8] = Tmid) and (A[11] = Fmid) and (Face < 4) then { --Rotate Cube }
AddToSolution ('RC+')
else If (A[8]<>Tmid) or (A[11]<>Fmid) then begin { -- Fatal error }
ErrorInMoves; MoveError := True; Exit; end;
end; { -- for Face }
end;
procedure SolveTopCorners ({giving} var MoveError: Boolean);
{ -- This procedure will store the moves in Solution to restore top corners. }
{ -- Strategy: Work on front-right-top corner then rotate cube to next face. }
var
Face: Integer;
Tmid, Fmid: Char;
begin
for Face := 1 to 4 do begin
Tmid := A[5]; { -- Has Color symbol of Top middle square. }
Fmid := A[14]; { -- Has color symbol of Front middle square. }
if (A[9] = Fmid) and (A[19] = Tmid) then { -- Orient FRT }
AddToSolution ('R- B2 R+ F+ B2 F- ')
else if (A[12] = Tmid) and (A[19] = Fmid) then { -- Orient FRT }
AddToSolution ('F+ B2 F- R- B2 R+ ')
else if (A[3] = Tmid) and (A[21] = Fmid) then { -- Move PRT to FRT }
AddToSolution ('R+ B+ R- F+ B2 F- ')
else if (A[3] = Fmid) and (A[28] = Tmid) then { -- Move PRT to FRT }
AddToSolution ('R+ B- R- F+ B- F- ')
else if (A[21] = Tmid) and (A[28] = Fmid) then { -- Move PRT to FRT }
AddToSolution ('R+ B2 R2 B+ R+ ')
else if (A[1] = Tmid) and (A[30] = Fmid) then { -- Move PLT to FRT }
AddToSolution ('L- B2 L+ B- R- B+ R+ ')
else if (A[30] = Tmid) and (A[37] = Fmid) then { -- Move PLT to FRT }
AddToSolution ('L- B+ L+ R- B2 R+ ')
else if (A[1] = Fmid) and (A[37] = Tmid) then { -- Move PLT to FRT }
AddToSolution ('L- B- L+ F+ B- F- ')
else if (A[7] = Tmid) and (A[39] = Fmid) then { -- Move FLT to FRT }
AddToSolution ('L+ B2 L- F+ B- F- ')
else if (A[10] = Fmid) and (A[39] = Tmid) then { -- Move FLT to FRT }
AddToSolution ('L+ R- B+ L- R+ ')
else if (A[7] = Fmid) and (A[10] = Tmid) then { -- Move FLT to FRT }
AddToSolution ('F- B2 F2 B- F- ')
else if (A[18] = Tmid) and (A[48] = Fmid) then { -- Move FRB to FRT }
AddToSolution ('F+ B+ F- ')
else if (A[25] = Fmid) and (A[48] = Tmid) then { -- Move FRB to FRT }
AddToSolution ('R- B+ R+ F+ B2 F- ')
else if (A[18] = Fmid) and (A[25] = Tmid) then { -- Move FRB to FRT }
AddToSolution ('R- B- R+ ')
else if (A[27] = Fmid) and (A[34] = Tmid) then { -- Move PRB to FRT }
AddToSolution ('F+ B- F- ')
else if (A[27] = Tmid) and (A[54] = Fmid) then { -- Move PRB to FRT }
AddToSolution ('B2 R- B+ R+ ')
else if (A[34] = Fmid) and (A[54] = Tmid) then { -- Move PRB to FRT }
AddToSolution ('B- R- B+ R+ F+ B2 F- ')
else if (A[36] = Tmid) and (A[52] = Fmid) then { -- Move PLB to FRT }
AddToSolution ('R- B2 R+ ')
else if (A[36] = Fmid) and (A[43] = Tmid) then { -- Move PLB to FRT }
AddToSolution ('F+ B2 F- ')
else if (A[43] = Fmid) and (A[52] = Tmid) then { -- Move PLB to FRT }
AddToSolution ('B2 R- B+ R+ F+ B2 F- ')
else if (A[45] = Tmid) and (A[46] = Fmid) then { -- Move FLB to FRT }
AddToSolution ('R- B+ R+ ')
else if (A[16] = Tmid) and (A[45] = Fmid) then { -- Move FLB to FRT }
AddToSolution ('B2 F+ B- F- ')
else if (A[16] = Fmid) and (A[46] = Tmid) then { -- Move FLB to FRT }
AddToSolution ('B+ R- B+ R+ F+ B2 F- ');
if (A[9] = Tmid) and (A[12] = Fmid) and (Face < 4) then { --Rotate Cube }
AddToSolution ('RC+')
else if (A[9]<>Tmid) or (A[12]<>Fmid) then begin { -- Fatal error }
ErrorInMoves; MoveError := True; Exit; end;
end; { -- for Face }
end;
procedure SolveVerticalEdges ({giving} var MoveError: Boolean);
{ -- This procedure will store the moves in Solution to restore vert. edges. }
{ -- Strategy: Work on front-right edge then rotate cube to next face. }
var
Face: Integer;
Fmid, Rmid: Char;
begin
for Face := 1 to 4 do begin
Fmid := A[14]; { -- Has color symbol of Front middle square. }
Rmid := A[23]; { -- Has color symbol of Right middle square. }
if (A[15] = Rmid) and (A[22] = Fmid) then { -- Orient FR }
AddToSolution ('R- B+ R+ B+ F+ B- F- B+ R- B+ R+ B+ F+ B- F- ')
else if (A[24] = Fmid) and (A[31] = Rmid) then { -- Move PR to FR }
AddToSolution ('RC+R- B+ R+ B+ F+ B- F- RC-B- F+ B- F- B- R- B+ R+ ')
else if (A[24] = Rmid) and (A[31] = Fmid) then { -- Move PR to FR }
AddToSolution ('RC+R- B+ R+ B+ F+ B- F- RC-R- B+ R+ B+ F+ B- F- ')
else if (A[33] = Fmid) and (A[40] = Rmid) then { -- Move PL to FR }
AddToSolution ('RC2R- B+ R+ B+ F+ B- F- RC2B2 F+ B- F- B- R- B+ R+ ')
else if (A[33] = Rmid) and (A[40] = Fmid) then { -- Move PL to FR }
AddToSolution ('RC2R- B+ R+ B+ F+ B- F- RC2B- R- B+ R+ B+ F+ B- F- ')
else if (A[13] = Fmid) and (A[42] = Rmid) then { -- Move FL to FR }
AddToSolution ('RC-R- B+ R+ B+ F+ B- F- RC+B2 R- B+ R+ B+ F+ B- F- ')
else if (A[13] = Rmid) and (A[42] = Fmid) then { -- Move FL to FR }
AddToSolution ('RC-R- B+ R+ B+ F+ B- F- RC+B+ F+ B- F- B- R- B+ R+ ')
else if (A[17] = Fmid) and (A[47] = Rmid) then { -- Move FB to FR }
AddToSolution ('B- R- B+ R+ B+ F+ B- F- ')
else if (A[17] = Rmid) and (A[47] = Fmid) then { -- Move FB to FR }
AddToSolution ('B2 F+ B- F- B- R- B+ R+ ')
else if (A[26] = Rmid) and (A[51] = Fmid) then { -- Move RB to FR }
AddToSolution ('B+ F+ B- F- B- R- B+ R+ ')
else if (A[26] = Fmid) and (A[51] = Rmid) then { -- Move RB to FR }
AddToSolution ('B2 R- B+ R+ B+ F+ B- F- ')
else if (A[35] = Fmid) and (A[53] = Rmid) then { -- Move PB to FR }
AddToSolution ('B+ R- B+ R+ B+ F+ B- F- ')
else if (A[35] = Rmid) and (A[53] = Fmid) then { -- Move PB to FR }
AddToSolution ('F+ B- F- B- R- B+ R+ ')
else if (A[44] = Fmid) and (A[49] = Rmid) then { -- Move LB to FR }
AddToSolution ('R- B+ R+ B+ F+ B- F- ')
else if (A[44] = Rmid) and (A[49] = Fmid) then { -- Move LB to FR }
AddToSolution ('B- F+ B- F- B- R- B+ R+ ');
if (A[15] = Fmid) and (A[22] = Rmid) and (Face < 4) then { --Rotate Cube }
AddToSolution ('RC+')
else if (A[15]<>Fmid) or (A[22]<>Rmid) then begin { -- Fatal error }
ErrorInMoves; MoveError := True; Exit; end;
end;
end;
procedure SolveBottomCorners ({giving} var MoveError: Boolean);
{ -- This procedure will store the moves in Solution to restore bot corners. }
{ -- Strategy: First "position" all 4 corners, then "orient" 4 corners. }
var
Face: Integer;
Fmid, Rmid, Pmid, Lmid, Bmid: Char;
BFL, BFR, BPR, BLP: Boolean; { -- True if this corner exists. }
All4Positioned, All4Oriented: Boolean;
begin
{ -- ****************** Position all 4 corners *************** }
Face := 1;
repeat
If Face > 4 then begin { -- Fatal error }
ErrorInMoves; MoveError := True; Exit; end;
Fmid := A[14]; Rmid := A[23]; Pmid := A[32]; Lmid := A[41];
{ -- Determine which of the 4 Bottom corners exist (= True). }
BFL := ((A[16] = Fmid) and (A[45] = Lmid)) or
((A[16] = Lmid) and (A[46] = Fmid)) or
((A[45] = Fmid) and (A[46] = Lmid));
BFR := ((A[18] = Fmid) and (A[25] = Rmid)) or
((A[18] = Rmid) and (A[48] = Fmid)) or
((A[25] = Fmid) and (A[48] = Rmid));
BPR := ((A[27] = Rmid) and (A[34] = Pmid)) or
((A[34] = Rmid) and (A[54] = Pmid)) or
((A[27] = Pmid) and (A[54] = Rmid));
BLP := ((A[36] = Pmid) and (A[43] = Lmid)) or
((A[36] = Lmid) and (A[52] = Pmid)) or
((A[43] = Pmid) and (A[52] = Lmid));
All4Positioned := True; { -- Will be after this set, unless no matches. }
if (BFL and BFR) or (BFR and BPR) or (BPR and BLP) or (BLP and BFL) then
{ -- Either all 4 match, or only 2 corners match. }
if not (BFL and BFR and BPR and BLP) then { -- only 2 corners match }
begin
if (BFL and BFR) then
AddToSolution ('RC2')
else if (BFR and BPR) then
AddToSolution ('RC-')
else if (BLP and BFL) then
AddToSolution ('RC+');
{ -- Exchange adjacent sides BFL and BFR, which are out of place. }
AddToSolution ('R- B- R+ F+ B+ F- R- B+ R+ B2 ');
end
else { -- null else- since all 4 match, skip to next section. }
else if (BFL and BPR) or (BFR and BLP) then {--Pair of diagonals match. }
begin
{ -- Exchange diagonals BFL and BPL}
AddToSolution ('F- B- R- B+ R+ F+ ');
{ -- Turn Bottom one rotation left or right to match all 4 corners. }
if (BFL and BPR) then
AddToSolution ('B- ')
else
AddToSolution ('B+ ');
end
else { -- No matches found with current Bottom rotation, try another. }
begin
AddToSolution ('B+ '); All4Positioned := False;
end;
Face := Face + 1;
until All4Positioned;
{ -- ****************** Orient 4 corners ****************** }
{ -- Rotate Cube until 1 of 7 patterns appear, or all 4 are oriented. }
{ -- Perform set of moves. If pattern is BC1 or BC2, cube is oriented. }
All4Oriented := False; Face := 1;
repeat
If Face > 4 then begin { -- Fatal error, Pattern not found after 4 turns.}
ErrorInMoves; MoveError := True; Exit; end;
Bmid := A[50];
if (A[46] = Bmid) and (A[48] = Bmid) and (A[52] = Bmid) and (A[54] = Bmid)
then All4Oriented := True
else
if (A[46] = Bmid) and (A[43] = Bmid) and (A[34] = Bmid) and (A[25] = Bmid)
then begin { -- BC2 pattern }
AddToSolution ('B2 R- B2 R+ B+ R- B+ R+ '); Face := 1;
end
else { -- 6 other patterns possible if the cube is at proper rotation. }
if (A[46] = Bmid) and (A[36] = Bmid) and (A[27] = Bmid) and (A[18] = Bmid)
or (A[45] = Bmid) and (A[36] = Bmid) and (A[34] = Bmid) and (A[25] = Bmid)
or (A[16] = Bmid) and (A[36] = Bmid) and (A[54] = Bmid) and (A[48] = Bmid)
or (A[16] = Bmid) and (A[52] = Bmid) and (A[54] = Bmid) and (A[18] = Bmid)
or (A[16] = Bmid) and (A[52] = Bmid) and (A[27] = Bmid) and (A[48] = Bmid)
or (A[45] = Bmid) and (A[43] = Bmid) and (A[27] = Bmid) and (A[25] = Bmid)
then begin { -- BC1 or BC3 or BC4 or BC5 or BC6 or BC7 pattern. }
AddToSolution ('R- B- R+ B- R- B2 R+ B2 '); Face := 1;
end
else begin { -- Cube is not yet at proper rotation to match a pattern. }
AddToSolution ('RC+'); Face := Face + 1;
end;
until All4Oriented;
end;
procedure SolveBottomEdges ({giving} var MoveError: Boolean);
{ -- This procedure will store the moves in Solution to restore bot edges. }
{ -- Strategy: First "position" all 4 edges, then "orient" the 4 edges. }
var
Face: Integer;
Fmid, Rmid, Pmid, Lmid, Bmid: Char;
BF, BR, BP, BL: Boolean; { -- True if this corner exists. }
All4Positioned, All4Oriented: Boolean;
Pattern1, Pattern2, Pattern3: Boolean;
begin
{ -- ****************** Position all 4 edges *************** }
All4Positioned := False; Face := 1;
repeat
If Face > 4 then begin { -- Fatal error }
ErrorInMoves; MoveError := True; Exit; end;
Fmid := A[14]; Rmid := A[23]; Pmid := A[32]; Lmid := A[41];
{ -- Determine which of the 4 Bottom edges are positioned (= True). }
BF := (A[17] = Fmid) or (A[47] = Fmid);
BR := (A[26] = Rmid) or (A[51] = Rmid);
BP := (A[35] = Pmid) or (A[53] = Pmid);
BL := (A[44] = Lmid) or (A[49] = Lmid);
if BF and BR and BP and BL then { -- All 4 edges are positioned. }
All4Positioned := True
else { -- 0 or 1 egde is positioned. There are 2 ways to position them.}
begin
if BR then AddToSolution ('RC+')
else if BP then AddToSolution ('RC2')
else if BL then AddToSolution ('RC-');
{ -- if 1 edge correctly positioned then it is in the BF position. }
Lmid := A[41]; { -- Cube may have rotated and changed colors. }
if (BF or BR or BP or BL) and ((A[51] = Lmid) or (A[26] = Lmid)) then
{ -- Permute 3 bottom edges: BR -> BL -> BP -> BR }
AddToSolution ('L- R+ F- L+ R- B2 L- R+ F- L+ R- ')
else { -- Either 0 edges positioned, or 3 non-positioned need this. }
{ -- Permute 3 bottom edges: BR -> BP -> BL -> BR }
AddToSolution ('L- R+ F+ L+ R- B2 L- R+ F+ L+ R- ');
end;
Face := Face + 1;
until All4Positioned;
{ -- ****************** Orient 4 edges ****************** }
{ -- Rotate Cube until 1 of 7 patterns appear, or all 4 are oriented. }
{ -- Perform set of moves. If pattern is BC1 or BC2, cube is oriented. }
Bmid := A[50];
{ -- Check if all edges are oriented. }
All4Oriented := (A[47] + A[49] + A[51] + A[53]) = (Bmid+ Bmid+ Bmid+ Bmid);
if not All4Oriented then begin { -- Edges will be in 1 of 3 patterns. }
Pattern1 := (A[47] <> Bmid) and (A[49] <> Bmid) and
(A[51] <> Bmid) and (A[53] <> Bmid);
Pattern2 := (A[47] = Bmid) and (A[53] = Bmid) or
(A[49] = Bmid) and (A[51] = Bmid);
Pattern3 := (A[47] = Bmid) and (A[49] = Bmid) or
(A[49] = Bmid) and (A[53] = Bmid) or
(A[51] = Bmid) and (A[53] = Bmid) or
(A[47] = Bmid) and (A[51] = Bmid);
if Pattern1 then { -- Permute each edge (swap the colors on each) }
AddToSolution('L- R+ F2 L+ R- B2 L- R+ F+ L+ R- B2 L- R+ F2 L+ R- B- ')
else if Pattern2 then begin { -- Permute edges across from each other. }
if (A[47] = Bmid) and (A[53] = Bmid) then { -- Rotate Cube }
AddToSolution ('RC+');
AddToSolution('L- R+ F+ L+ R- B+ L- R+ F+ L+ R- B+ L- R+ F2 L+ R- B+ ');
AddToSolution('L- R+ F+ L+ R- B+ L- R+ F+ L+ R- B2 ');
end
else if Pattern3 then begin { -- 4 possible orientations, Rotate cube. }
if (A[47] = Bmid) and (A[49] = Bmid) then
AddToSolution ('RC-')
else if (A[49] = Bmid) and (A[53] = Bmid) then
AddToSolution ('RC2')
else if (A[51] = Bmid) and (A[53] = Bmid) then
AddToSolution ('RC+');
{ -- Rotate BP -> BF -> BL -> BP, then orient 3 edges. }
AddToSolution ('L- R+ F+ L+ R- B- L- R+ F- L+ R- B- L- R+ F2 L+ R- ');
AddToSolution ('RC+L- R+ F+ L+ R- B2 L- R+ F+ L+ R- ');
end
else begin { -- Fatal error, none of the patterns were detected. }
ErrorInMoves; MoveError := True; Exit; end;
end; { -- If not All4Oriented }
end;
function CubeIsSolved: Boolean;
{ -- This function returns True if each side has 9 squares of the same color.}
var
Side, I: Integer;
begin
CubeIsSolved := True;
for Side := 1 to 6 do
for I := 1 to 8 do
if A[(Side-1)*9 + I] <> A[(Side-1)*9 + I+1] then
CubeIsSolved := False;
end;
procedure GetRCSolution ({using/giving} var MoveError: Boolean);
{ -- This procedure will store all the moves to restore the puzzle in the
-- array Solution[1..200] of string[3], with Solution[LastSolIndex]
-- having the last move of the solution. }
var
I: Integer;
Ch: Char;
begin
LastSolIndex := 0; { -- No solution has been stored yet. }
MoveError := False; { -- No errors in moves. }
SolveTopEdges (MoveError);
if MoveError then Exit;
SolveTopCorners (MoveError);
if MoveError then Exit;
SolveVerticalEdges (MoveError);
if MoveError then Exit;
SolveBottomCorners (MoveError);
if MoveError then Exit;
SolveBottomEdges (MoveError);
if MoveError then Exit;
if CubeIsSolved then
if Copy(Solution[LastSolIndex], 1, 2) = 'RC' then
{ -- Don't rotate cube. }
LastSolIndex := LastSolIndex - 1
else { -- null }
else { -- Do not display solution. }
begin { -- Fatal error, Program could not solve cube. }
ErrorInMoves; MoveError := True; Exit; end;
end;
procedure DisplayTextSolution ({using} Option1or2: Integer);
{ -- This procedure will display step-by-step the moves to restore the puzzle
-- in the array Solution[1..200] of string[3], with Solution[LastSolIndex]
-- having the last move of the solution.
-- If Option1or2 = 2 then display is text. }
const
Space = 32;
Enter = 13;
RtArr = 77;
LtArr = 75;
RtArrSh = 54;
LtArrSh = 52;
ESC = 27;
var
I, Index, Side, RotPos: Integer;
Ch, RotCh: Char;
Rotation: String1;
begin
DisplayBorder (MenuOption[Option1or2], 1);
DisplayBoxes;
for I := 1 to 54 do { -- Initialize A array with Initial input colors. }
A[I] := AInit[I];
for Side := 1 to 6 do { -- Display initial input colors }
DisplayColors (Side);
if LastSolIndex > 0 then
DisplayTextInstr;
Index := 0;
while Index < LastSolIndex do begin
{ -- Get valid command. }
repeat
Read (Kbd, Ch);
if Keypressed then Read (Kbd, Ch);
until (Ord(Ch) in [Space, Enter, RtArr, RtArrSh, ESC]) or
((Ord(Ch) in [LtArr, LtArrSh]) and (Index > 1));
if Index = 0 then begin { -- Display only the first time through. }
{ -- Display move, colors on sides, and number of moves. }
TextColor (LightGreen);
GotoXY (15,20); Write ('--> <--');
GotoXY (20,22);
Write (' move out of '); TextColor (LightCyan);
Write (LastSolIndex);
end;
if Ord(Ch) in [Space, Enter, RtArr, RtArrSh] then { -- Do next move. }
begin
Index := Index + 1;
MakeMove (Solution[Index]);
end
else if Ord(Ch) in [ESC] then { -- Quit and return to main menu. }
Exit
else if Ord(Ch) in [LtArr, LtArrSh] then { -- Do reverse move. }
begin
RotCh := Copy(Solution[Index], 2, 1);
if (RotCh in ['+', '2', '-']) then
RotPos := 2
else RotPos := 3; { -- Assume RC+, RC2, or RC- }
Rotation := Copy (Solution[Index], RotPos, 1);
if Rotation = '+' then
Rotation := '-'
else if Rotation = '-' then
Rotation := '+';
MakeMove (Copy(Solution[Index], 1, RotPos-1) + Rotation + ' ');
Index := Index - 1;
end; { -- if Ord (Ch) in LtArr }
{ -- Display move, colors on sides, and number of moves. }
TextColor (Yellow);
GotoXY (20, 20); Write (Solution[Index]); { -- 1 move of solution. }
TextColor (LightCyan);
GotoXY (20, 22); Write (Index:3); { -- Number of moves done. }
TextColor (LightGreen);
if Index = 1 then Write (' move ')
else Write (' moves');
for Side := 1 to 6 do
DisplayColors (Side);
GotoXY (20, 21);
end; { -- while }
{ -- ******** Cube is solved ******** }
{ -- Clear Top Instructions.}
Window (14, 3, 39, 8); ClrScr; Window (1, 1, 80, 25);
Delay (3000); { -- Wait 3 seconds for suspense }
if Keypressed then Read (Kbd, Ch); { -- Get impatient response. }
TextColor (Yellow); GotoXY (3, 25);
Write ('Congratulations!!! Press any key.');
Sound (500); Delay (500);
Sound (700); Delay (500);
Sound (900); Delay (500);
Sound (700); Delay (500);
Sound (500); Delay (500);
NoSound;
Read (Kbd, Ch);
end;
{ -- INCLUDE MagnifyLetter (L, M, X, Y, Co) }
{$I MAGNIFY.INC}
{ -- MAGNIFY.INC }
procedure MagnifyLetter (L: Char; {by} M: Integer; {at} X, Y: Integer;
{using} Co: Integer);
{ -- This procedure will magnify the letter L by M times at position X, Y.
-- If the character L is not available (such as a space), then no display. }
var
I, J, K: Integer;
Let: Array [1..7] of String[5];
begin
Case L of
{ -- Letter A }
'A': begin
Let [1] := '00100';
Let [2] := '01010';
Let [3] := '10001';
Let [4] := '10001';
Let [5] := '11111';
Let [6] := '10001';
Let [7] := '10001';
end;
{ -- Letter B }
'B': begin
Let [1] := '11110';
Let [2] := '10001';
Let [3] := '10001';
Let [4] := '11110';
Let [5] := '10001';
Let [6] := '10001';
Let [7] := '11110';
end;
{ -- Letter C }
'C': begin
Let [1] := '01110';
Let [2] := '10001';
Let [3] := '10000';
Let [4] := '10000';
Let [5] := '10000';
Let [6] := '10001';
Let [7] := '01110';
end;
{ -- Letter D }
'D': begin
Let [1] := '11100';
Let [2] := '10010';
Let [3] := '10001';
Let [4] := '10001';
Let [5] := '10001';
Let [6] := '10010';
Let [7] := '11100';
end;
{ -- Letter E }
'E': begin
Let [1] := '11111';
Let [2] := '10000';
Let [3] := '10000';
Let [4] := '11110';
Let [5] := '10000';
Let [6] := '10000';
Let [7] := '11111';
end;
{ -- Letter F }
'F': begin
Let [1] := '11111';
Let [2] := '10000';
Let [3] := '10000';
Let [4] := '11110';
Let [5] := '10000';
Let [6] := '10000';
Let [7] := '10000';
end;
{ -- Letter G }
'G': begin
Let [1] := '01110';
Let [2] := '10001';
Let [3] := '10000';
Let [4] := '10111';
Let [5] := '10001';
Let [6] := '10001';
Let [7] := '01110';
end;
{ -- Letter H }
'H': begin
Let [1] := '10001';
Let [2] := '10001';
Let [3] := '10001';
Let [4] := '11111';
Let [5] := '10001';
Let [6] := '10001';
Let [7] := '10001';
end;
{ -- Letter I }
'I': begin
Let [1] := '01110';
Let [2] := '00100';
Let [3] := '00100';
Let [4] := '00100';
Let [5] := '00100';
Let [6] := '00100';
Let [7] := '01110';
end;
{ -- Letter J }
'J': begin
Let [1] := '00111';
Let [2] := '00010';
Let [3] := '00010';
Let [4] := '00010';
Let [5] := '10010';
Let [6] := '10010';
Let [7] := '01100';
end;
{ -- Letter K }
'K': begin
Let [1] := '10001';
Let [2] := '10010';
Let [3] := '10100';
Let [4] := '11000';
Let [5] := '10100';
Let [6] := '10010';
Let [7] := '10001';
end;
{ -- Letter L }
'L': begin
Let [1] := '10000';
Let [2] := '10000';
Let [3] := '10000';
Let [4] := '10000';
Let [5] := '10000';
Let [6] := '10000';
Let [7] := '11111';
end;
{ -- Letter M }
'M': begin
Let [1] := '10001';
Let [2] := '11011';
Let [3] := '11111';
Let [4] := '10101';
Let [5] := '10001';
Let [6] := '10001';
Let [7] := '10001';
end;
{ -- Letter N }
'N': begin
Let [1] := '11001';
Let [2] := '11001';
Let [3] := '11101';
Let [4] := '10101';
Let [5] := '10111';
Let [6] := '10011';
Let [7] := '10011';
end;
{ -- Letter O }
'O': begin
Let [1] := '01110';
Let [2] := '10001';
Let [3] := '10001';
Let [4] := '10001';
Let [5] := '10001';
Let [6] := '10001';
Let [7] := '01110';
end;
{ -- Letter P }
'P': begin
Let [1] := '11110';
Let [2] := '10001';
Let [3] := '10001';
Let [4] := '11110';
Let [5] := '10000';
Let [6] := '10000';
Let [7] := '10000';
end;
{ -- Letter Q }
'Q': begin
Let [1] := '01110';
Let [2] := '10001';
Let [3] := '10001';
Let [4] := '10001';
Let [5] := '10101';
Let [6] := '10010';
Let [7] := '01101';
end;
{ -- Letter R }
'R': begin
Let [1] := '11110';
Let [2] := '10001';
Let [3] := '10001';
Let [4] := '11110';
Let [5] := '10100';
Let [6] := '10010';
Let [7] := '10001';
end;
{ -- Letter S }
'S': begin
Let [1] := '01111';
Let [2] := '10000';
Let [3] := '10000';
Let [4] := '01110';
Let [5] := '00001';
Let [6] := '00001';
Let [7] := '11110';
end;
{ -- Letter T }
'T': begin
Let [1] := '11111';
Let [2] := '00100';
Let [3] := '00100';
Let [4] := '00100';
Let [5] := '00100';
Let [6] := '00100';
Let [7] := '00100';
end;
{ -- Letter U }
'U': begin
Let [1] := '10001';
Let [2] := '10001';
Let [3] := '10001';
Let [4] := '10001';
Let [5] := '10001';
Let [6] := '10001';
Let [7] := '01110';
end;
{ -- Letter V }
'V': begin
Let [1] := '10001';
Let [2] := '10001';
Let [3] := '10001';
Let [4] := '10001';
Let [5] := '10001';
Let [6] := '01010';
Let [7] := '00100';
end;
{ -- Letter W }
'W': begin
Let [1] := '10001';
Let [2] := '10001';
Let [3] := '10001';
Let [4] := '10101';
Let [5] := '11111';
Let [6] := '11011';
Let [7] := '10001';
end;
{ -- Letter X }
'X': begin
Let [1] := '10001';
Let [2] := '10001';
Let [3] := '01010';
Let [4] := '00100';
Let [5] := '01010';
Let [6] := '10001';
Let [7] := '10001';
end;
{ -- Letter Y }
'Y': begin
Let [1] := '10001';
Let [2] := '10001';
Let [3] := '01010';
Let [4] := '00100';
Let [5] := '00100';
Let [6] := '00100';
Let [7] := '00100';
end;
{ -- Letter Z }
'Z': begin
Let [1] := '11111';
Let [2] := '00001';
Let [3] := '00010';
Let [4] := '00100';
Let [5] := '01000';
Let [6] := '10000';
Let [7] := '11111';
end;
{ -- Symbol + }
'+': begin
Let [1] := '00000';
Let [2] := '00100';
Let [3] := '00100';
Let [4] := '11111';
Let [5] := '00100';
Let [6] := '00100';
Let [7] := '00000';
end;
{ -- Symbol 2 }
'2': begin
Let [1] := '01110';
Let [2] := '10001';
Let [3] := '00001';
Let [4] := '00110';
Let [5] := '00100';
Let [6] := '01000';
Let [7] := '11111';
end;
{ -- Symbol - }
'-': begin
Let [1] := '00000';
Let [2] := '00000';
Let [3] := '00000';
Let [4] := '11111';
Let [5] := '00000';
Let [6] := '00000';
Let [7] := '00000';
end;
else Exit; { -- if symbol is not available. }
end; { -- case }
{ -- Draw Enlarged Pixels of Letter in Color Co. }
for I := 0 to 6 do
for J := 0 to 4 do
If Copy (Let[I+1], J+1, 1) = '1' then
for K := 0 to M-1 do
Draw (X +J*M,Y + I*M+K, X +J*M+M-1,Y +I*M+K, Co);
end; { procedure }
{ -- INCLUDE INSTR.INC DisplayInstr }
{$I INSTR.INC}
{ -- INSTR.INC }
procedure DisplayInstr;
{ -- This procedure will display a brief description of each menu option. }
const
ESC = 27;
var
Ch: Char;
Co, J: Integer;
Side: Integer;
begin
{ -- First Screen }
ClrScr; Window (10,1, 79,25); TextColor (Yellow); ClrScr;
Writeln ('INSTRUCTIONS'); TextColor (White);
Writeln; Writeln;
Writeln ('In order to obtain a solution (Graphical or Text), the user');
Writeln ('must describe the appearance of the puzzle to the computer.');
Writeln;
Writeln ('To begin, look at the six middle squares on each side.');
Writeln ('There should be six unique colors on these squares.');
Writeln ('If the colors are different from the following six colors,');
Writeln ('then you must first choose option 4 from the main menu to');
Writeln ('"set valid colors" for the cube: (B)lue, (G)reen, (O)range,');
Writeln ('(R)ed, (W)hite, and (Y)ellow.');
Writeln;
Writeln ('Before describing the different menu options, let''s take a');
Writeln ('look at the six different sides of the Rubik''s Cube.');
GotoXY (1, 24); TextColor (Yellow);
Write ('Press ESC to quit, any other key to continue.');
Read (Kbd, Ch); if Ch = Chr(ESC) then Exit;
{ -- Second Screen }
GraphColorMode;
GraphBackGround (Blue); Window (1,1, 80, 25);
Palette (3); { -- 4 colors available (Graphics and Text):
0 = Background, 1 = LightCyan, 2 = LightMagenta, 3 = White. }
Side := 1;
repeat
{ -- Display Title }
Co := 3; { Color = White }
TextColor (Co); GotoXY (15, 1); Writeln ('View 6 Sides');
if Side > 1 then { -- Clear cube picture and Side symbol. }
for J := 1 to 15 do
Writeln (' ': 28);
{ -- Draw Cube }
Draw (40,10, 100,10, Co); Draw (100,10, 70,40, Co);
Draw (70,40, 10,40, Co); Draw (10,40, 40,10, Co);
Draw (40,70, 100,70, Co); Draw (100,70, 70,100, Co);
Draw (70,100, 10,100, CO); Draw (10,100, 40,70, Co);
Draw (40,10, 40,70, Co); Draw (100,10, 100,70, Co);
Draw (70,40, 70,100, Co); Draw (10,40, 10,100, Co);
{ -- Draw line above instructions area. }
Draw (0,165, 315, 165, 3); TextColor (1);
GotoXY (1,22);
Write ('Press ESC to quit;');
GotoXY (1, 23); Write ('Press M for menu options;');
GotoXY (1, 24); Write ('Press any other key to continue.');
GotoXY (20, 15);
{ -- Fill in sides }
Case Side of
1: begin { -- Top Side }
for J := 40 to 100 do
Draw (J,10, J-30,40, Co);
MagnifyLetter ('T', 5, 124, 84, 3);
Write ('op ');
end;
2: begin { -- Front Side }
for J := 40 to 100 do
Draw (10,J, 70,J, Co);
MagnifyLetter ('F', 5, 124, 84, 3);
Write ('ront ');
end;
3: begin { -- Right Side }
for J := 40 to 100 do
Draw (70,J, 100,J-30, Co);
MagnifyLetter ('R', 5, 124, 84, 3);
Write ('ight ');
end;
4: begin { -- Back Side }
for J := 40 to 100 do
Draw (J,10, J,70, Co);
MagnifyLetter ('P', 5, 124, 84, 3);
Write ('osterior');
end;
5: begin { -- Left Side }
for J := 10 to 70 do
Draw (40,J, 10,J+30, Co);
MagnifyLetter ('L', 5, 124, 84, 3);
Write ('eft ');
end;
6: begin { -- Bottom Side }
for J := 40 to 100 do
Draw (J,70, J-30,100, Co);
MagnifyLetter ('B', 5, 124, 84, 3);
Write ('ottom ');
end;
end; { -- case }
Read (Kbd, Ch);
if Ch = Chr(ESC) then begin
TextMode; Exit; end;
Side := Side + 1;
until (Side > 6) or (Ch in ['m', 'M']); { -- for Side }
{ -- Third Screen }
TextMode; ClrScr; TextColor (Yellow); TextBackGround(Blue); ClrScr;
Window(10,1, 79,25); ClrScr;
Writeln ('Option 1. Graphical Solution'); TextColor (White);
Writeln;
Writeln ('In order to obtain the graphical solution, you must first');
Writeln ('enter the colors on the 54 squares into the computer.');
Writeln ('Choosing option 1 will allow you to enter the colors on the');
Writeln ('six sides of the cube: (T)op, (F)ront, (R)ight, (P)osterior,');
Writeln ('(L)eft, and (B)ottom.');
Writeln;
Writeln ('The colors on each side are to be input from top to bottom,');
Writeln ('left to right by pressing the valid color symbol associated');
Writeln ('with each square. If you make a mistake, press the left arrow');
Writeln ('and then press the correct color symbol.');
Writeln;
Writeln ('After entering the colors for the top, front, right, back, and');
Writeln ('left sides, then place the cube so that the front is facing');
Writeln ('you and the top side is facing up. To enter the color symbols');
Writeln ('on the bottom, tilt the cube so that the front becomes the top');
Writeln ('and the bottom becomes the front, temporarily. Now, enter the');
Writeln ('colors from top to bottom, left to right as you see them on the');
Writeln ('front. After doing so, tilt the cube back.');
Writeln; TextColor (Yellow); GotoXY (1, 24);
Write ('Press ESC to quit, any other key to continue.');
Read (Kbd, Ch); if Ch = Chr(ESC) then Exit;
{ -- fourth screen }
ClrScr; TextColor (Yellow);
Writeln ('Option 1. Graphical Solution (cont.)'); TextColor (White);
Writeln;
Writeln ('After finishing the input routine, the computer will display');
Writeln ('a step-by-step solution to solve the puzzle. Read the');
Writeln ('instructions given on the screen and press the appropriate key');
Writeln ('to see the first move. The first move will appear in large');
Writeln ('symbols, underneath the phrase, "Do the move:".');
Writeln;
Writeln ('Each move will either: 1) turn one side independently of the');
Writeln ('others, or 2) rotate the entire cube so that a new side');
Writeln ('becomes the front.');
Writeln;
Writeln ('First, most moves will consist of a sides'' symbol (T, F, R,');
Writeln ('L, or B) and a rotation (+, 2, or -). This move means to turn');
Writeln ('the corresponding side clockwise (if a + follows), or counter-');
Writeln ('clockwise (if a - follows), or 2 times either way (if a 2');
Writeln ('follows). Each move is made as if you are viewing it face to');
Writeln ('face. For example, F+ means "turn the Front side clockwise."');
Writeln ('Second, a move might include RC (Rotate Cube) and a rotation.');
Writeln ('Thus, RC- means to rotate the cube clockwise as if you were');
Writeln ('looking at the top. After making the moves, check the cubes.');
Writeln; TextColor (Yellow); GotoXY (1, 24);
Write ('Press ESC to quit, any other key to continue.');
Read (Kbd, Ch); if Ch = Chr(ESC) then Exit;
{ -- Fifth Screen }
ClrScr; TextColor (Yellow);
Writeln ('Option 2. Text Solution'); TextColor (White);
Writeln;
Writeln ('In order to obtain the text solution, you must first');
Writeln ('enter the colors on the 54 squares into the computer.');
Writeln ('Choosing option 2 will allow you to enter the colors on the');
Writeln ('six sides of the cube. This input routine is the same as the');
Writeln ('one used for the Graphical Solution.');
Writeln;
Writeln ('The colors on each side are to be input from top to bottom,');
Writeln ('left to right by pressing the valid color symbol associated');
Writeln ('with each square. If you make a mistake, press the left arrow');
Writeln ('and then press the correct color symbol.');
Writeln;
Writeln ('After finishing the input routine, the computer will display');
Writeln ('a step-by-step solution to solve the puzzle. Read the');
Writeln ('instructions given on the screen and press the appropriate key');
Writeln ('to see the first move. The first move will appear between the');
Writeln ('two arrows on the bottom part of the screen.');
Writeln;
Writeln ('Each move will either: 1) turn one side independently of the');
Writeln ('others, or 2) rotate the entire cube so that a new side');
Writeln ('becomes the front. Moves are made as discussed before.');
Writeln; TextColor (Yellow); GotoXY (1, 24);
Write ('Press ESC to quit, any other key to continue.');
Read (Kbd, Ch); if Ch = Chr(ESC) then Exit;
{ -- Sixth Screen }
ClrScr; TextColor (Yellow);
Writeln ('Option 3. Instructions'); TextColor (White);
Writeln;
Writeln ('Choosing option 3 allows you to view a brief description');
Writeln ('of each of the menu options, as you are doing now. It');
Writeln ('will also emphasize that the first option that should be');
Writeln ('chosen (after reading the instructions) is number 4, to');
Writeln ('"Set Valid Colors".');
Writeln;
Writeln;
Writeln ('Since these instructions only briefly describe the program');
Writeln ('contents, you may want to read the User''s Guide. The manual');
Writeln ('gives an indepth description of each menu option and includes');
Writeln ('research about the Rubik''s Cube as well as strategies to solve');
Writeln ('the puzzle. In addition, a partial Pascal program listing is');
Writeln ('included. If you would like to have this, please write to: ');
Writeln; TextColor (Yellow);
Writeln (' Doug Woolley');
Writeln (' c/o Florida Center for Instructional Computing');
Writeln (' University of South Florida - EDU 123H');
Writeln (' Tampa, Fl 33620');
Writeln; TextColor (Yellow); GotoXY (1, 24);
Write ('Press ESC to quit, any other key to continue.');
Read (Kbd, Ch); if Ch = Chr(ESC) then Exit;
{ -- Seventh Screen }
ClrScr; TextColor (Yellow);
Writeln ('Option 4. Set Valid Colors'); TextColor (White);
Writeln;
Writeln ('The cube has six sides, each with a unique color in its');
Writeln ('original state. However, not all versions of the cube');
Writeln ('puzzle have the same six unique colors. If the colors');
Writeln ('are other than blue, green, orange, red, white, and yellow,');
Writeln ('then you must select option 4 to assign the valid colors on');
Writeln ('your cube.');
Writeln;
Writeln ('Instead of entering the actual name of the color, the');
Writeln ('computer will accept a one letter color symbol, such as the');
Writeln ('first letter in the name of the color. Six unique color');
Writeln ('symbols must be entered before a solution can be obtained.');
Writeln;
Writeln ('You may press a one letter color symbol to replace the default');
Writeln ('values that are shown that differ. If some of the color');
Writeln ('symbols match, then press the Enter key to select the default');
Writeln ('value shown.');
Writeln; TextColor (Yellow); GotoXY (1, 24);
Write ('Press ESC to quit, any other key to continue.');
Read (Kbd, Ch); if Ch = Chr(ESC) then Exit;
{ -- Eighth Screen }
ClrScr; TextColor (Yellow);
Writeln ('Option 5. Test Program'); TextColor (White);
Writeln;
Writeln ('Choosing option 5 allows you to "test" the program in');
Writeln ('particular features. The option provides statistical');
Writeln ('facts pertaining to the computer oriented solution.');
Writeln;
Writeln ('First, you must enter the number of imaginary cubes that');
Writeln ('you want the computer to solve. Next, you must enter the');
Writeln ('number of random turns to make to each of these solved');
Writeln ('imaginary cubes. The program will then attempt to solve');
Writeln ('each of these cubes and will display certain statistics.');
Writeln;
Writeln ('The program will display the number of moves it took to solve');
Writeln ('each puzzle, followed by the "Average # of moves" the program');
Writeln ('took to solve each of the puzzles. In addition, the "Most');
Writeln ('moves" required to solve one of these puzzles is displayed,');
Writeln ('along with the "Least moves" required to solve one of them.');
Writeln;
Writeln ('On the average, the program will usually require 140 moves');
Writeln ('(this is including about 15 rotational moves) to obtain a');
Writeln ('solution.');
Writeln; TextColor (Yellow); GotoXY (1, 24);
Write ('Press ESC to quit, any other key to continue.');
Read (Kbd, Ch); if Ch = Chr(ESC) then Exit;
{ -- Ninth Screen }
ClrScr; TextColor (Yellow);
Writeln ('Option 6. Exit'); TextColor (White);
Writeln;
Writeln ('Choosing option 6 will place the computer in DOS, the Disk');
Writeln ('Operating System.');
Writeln; TextColor (Yellow); GotoXY (1, 24);
Write ('Press any key to return to main menu.');
Read (Kbd, Ch); if Ch = Chr(ESC) then Exit;
end;
procedure DisplayGraphicsInstr;
{ -- This procedure will display commands needed for displaying the solution.}
{ -- 4 colors available (Graphics and Text):
0 = Background, 1 = LightCyan, 2 = LightMagenta, 3 = White. }
const
RtArrow = 26;
LtArrow = 27;
begin
{ -- First command }
TextColor (3);
GotoXY (1, 22); Write ('Press: ');
TextColor (2);
Write ('Space, ', Chr(RtArrow), ', ');
TextColor (3); Write ('or ');
TextColor (2); Write ('Enter');
TextColor (1);
Write (' and perform');
{ -- 2nd line/ 1st command. }
GotoXY (1, 23);
Write ('move shown above, then compare side(s);');
{ -- Third line/ 2nd command. }
GotoXY (1, 24);
TextColor (3); Write ('or ');
TextColor (2);
Write ('(T, F, R, P, L, B)');
TextColor (1);
Write (' to view sides;');
{ -- Fourth line/ 3rd command }
TextColor (3);
GotoXY (1, 25); Write ('or ');
TextColor (2);
Write (Chr(LtArrow));
TextColor (1);
Write (' for previous move;');
{ -- Fifth line/ 3rd command }
TextColor (3);
Write (' or ');
TextColor (2);
Write ('ESC ');
TextColor (1);
Write ('to quit.');
end;
procedure DisplayGraphics;
{ -- This procedure will display the Graphical cube. }
var
Co: Integer;
begin
GraphColorMode;
GraphBackGround (Blue);
Palette (3); { -- 4 colors available (Graphics and Text):
0 = Background, 1 = LightCyan, 2 = LightMagenta, 3 = White. }
{ -- Display Title }
Co := 3; { -- Color = White }
TextColor (Co); GotoXY (1,1);
Write ('Graphical Solution');
{ -- Draw Cube }
Co := 1; { -- Color = Cyan }
{ -- Draw Large Square for perimeter of Front side of Cube. }
Draw (130,20, 250,20, Co); Draw (250,20, 250,140, Co);
Draw (250,140, 130,140, Co); Draw (130,140, 130,20, Co);
{ -- Draw little squares on Front side. }
Draw (130,60, 250,60, Co); Draw (130,100, 250,100, Co);
Draw (170,20, 170,140, CO); Draw (210,20, 210,140, Co);
{ -- Draw perimeter of Right Side. }
Draw (250,20, 310,0, Co); Draw (250,140, 310,120, Co);
Draw (310,120, 310,0, Co);
{ -- Draw perimeter of Top Side. }
Draw (130,20, 190,0, Co); Draw (190,0, 310,0, Co);
{ -- Draw little squares on Top and Right sides. }
Draw (250,60, 310,40, Co); Draw (250,100, 310,80, Co);
Draw (170,20, 230,0, Co); Draw (210,20, 270,0, Co);
Draw (270,133, 270,13, Co); Draw (270,13, 150,13, Co);
Draw (290, 126, 290,6, Co); Draw (290,6, 170,6, Co);
{ -- Draw line above instructions area in white. }
Draw (0,165, 315, 165, 3);
end;
procedure DisplayGraphicsColors ({using} Side, Co: Integer);
{ -- This procedure displays the color contents of squares on the Side
if Co is 1, 2, or 3. If Co = 0 then the previous colors are erased. }
var
Row, Col, X, Y, InitX, InitY, Index: Integer;
begin
InitX := 142; { -- Top Left square starts at 142, 29 for display }
InitY := 29; { -- with the next squares 40 units apart. }
for Row := 1 to 3 do
for Col := 1 to 3 do begin
X := InitX + (Col-1)*40; Y := InitY + (Row-1)*40;
Index := (Side-1)*9 + (Row-1)*3 + Col;
MagnifyLetter (A[Index], 3, X, Y, Co);
end;
end;
procedure DisplayGraphicalSolution;
{ -- This procedure will display step-by-step the moves to restore the puzzle
-- in the array Solution[1..200] of string[3], with Solution[LastSolIndex]
-- having the last move of the solution. One side of a graphical cube is
-- displayed. }
const
Space = 32;
Enter = 13;
RtArr = 77;
LtArr = 75;
RtArrSh = 54;
LtArrSh = 52;
ESC = 27;
Sides = 'TFRPLB';
var
I, Index, Side,
LastSide, RotPos: Integer;
Ch, RotCh: Char;
Rotation: String1;
Co: Integer;
ChangeSide: Boolean;
begin
for I := 1 to 54 do { -- Initialize A array with Initial input colors. }
A[I] := AInit[I];
DisplayGraphics;
Palette (3); { -- 4 colors available (Graphics and Text):
0 = Background, 1 = LightCyan, 2 = LightMagenta, 3 = White. }
Side := 2; Co := 3; { -- Display initial input colors for Front Side }
DisplayGraphicsColors (Side, Co);
MagnifyLetter (Copy(Sides,Side,1), 4, 98, 131, 3); { -- put new one. }
TextColor (1);
GotoXY (16, 20);
Write ('ront side ');
if LastSolIndex > 0 then { -- Display instructions only if moves are made.}
DisplayGraphicsInstr;
Index := 0; LastSide := Side;
while Index < LastSolIndex do begin
{ -- Get valid command. }
repeat
Read (Kbd, Ch);
if Keypressed then Read (Kbd, Ch);
Ch := UpCase(Ch);
if Index > 0 then
ChangeSide := (Ch in ['T', 'F', 'R', 'P', 'L', 'B']) and
(Ch <> Copy(Sides, Side, 1))
else ChangeSide := False;
until (Ord(Ch) in [Space, Enter, RtArr, RtArrSh, ESC]) or
((Ord(Ch) in [LtArr, LtArrSh]) and (Index > 1)) or ChangeSide;
if Ord(Ch) in [ESC] then { -- Quit and return to main menu. }
begin TextMode; Exit; End;
if not ChangeSide then { -- New move is needed, so erase old move. }
if Index > 0 then begin { -- Erase previous move. }
Co := 0; { -- Color is the Background. }
for I := 0 to 2 do
MagnifyLetter (Copy(Solution[Index], I+1, 1), 7, 45*I, 39, Co);
end;
{ -- Erase Previous colors on the displayed side. }
Co := 0; { -- Color is the Background. }
DisplayGraphicsColors (Side, Co);
if Index = 0 then begin { -- Display only the first time through. }
{ -- Display 'Do move', number of moves, and underline for move. }
TextColor (2);
GotoXY (1,3); Write ('Do the move:');
GotoXY (1, 14); Write (' '); { -- Number of moves done. }
TextColor (1);
Write (' move ');
GotoXY (1, 15);
Write ('out of ');
TextColor (3); Write (LastSolIndex);
{ -- Underline the enlarged move. }
Draw (0, 90, 82,90, 2);
end;
if Ord(Ch) in [Space, Enter, RtArr, RtArrSh] then { -- Do next move. }
begin
Index := Index + 1;
MakeMove (Solution[Index]);
LastSide := Side;
Side := 2; { -- Display Front. }
end
else if Ord(Ch) in [LtArr, LtArrSh] then { -- Do reverse move. }
begin
RotCh := Copy(Solution[Index], 2, 1);
if (RotCh in ['+', '2', '-']) then
RotPos := 2
else RotPos := 3; { -- Assume RC+, RC2, or RC- }
Rotation := Copy (Solution[Index], RotPos, 1);
if Rotation = '+' then
Rotation := '-'
else if Rotation = '-' then
Rotation := '+';
MakeMove (Copy(Solution[Index], 1, RotPos-1) + Rotation + ' ');
Index := Index - 1;
LastSide := Side;
Side := 2; { -- Display front. }
end { -- if Ord (Ch) in LtArr }
else if ChangeSide then { -- Display new side}
begin
{ -- Remember the side currently displayed and change sides. }
LastSide := Side;
Side := Pos (Ch, Sides);
end;
if Side <> LastSide then begin { -- Erase Side symbol and put new one. }
{ -- Erase old Side symbol if there is one. }
MagnifyLetter (Copy(Sides,LastSide,1), 4, 98, 131, 0);
MagnifyLetter (Copy(Sides,Side,1), 4, 98, 131, 3); { -- put new one. }
TextColor (1);
GotoXY (16, 20);
Case side of
1: Write ('op side ');
2: Write ('ront side ');
3: Write ('ight side ');
4: Write ('osterior side');
5: Write ('eft side ');
6: Write ('ottom side ');
end;
end; { -- if Side }
{ -- Display move, colors on sides, and number of moves. }
Co := 3; { -- Color is White. }
for I := 0 to 2 do
MagnifyLetter (Copy(Solution[Index], I+1, 1), 7, 45*I, 39, Co);
Co := 3; { -- Color of letters will be White. }
DisplayGraphicsColors (Side, Co);
TextColor (3);
GotoXY (1, 14); Write (Index:3); { -- Number of moves done. }
TextColor (1);
if Index = 1 then Write (' move ')
else Write (' moves');
end; { -- while }
{ -- ******** Cube is solved ******** }
{ -- Clear Bottom Instructions.}
GotoXY (1, 22); for I := 1 to 39 do Write (' ');
GotoXY (1, 23); for I := 1 to 39 do Write (' ');
GotoXY (1, 24); for I := 1 to 39 do Write (' ');
GotoXY (1, 25); for I := 1 to 39 do Write (' ');
Delay (3000); { -- Wait 3 seconds for suspense }
if Keypressed then Read (Kbd, Ch); { -- Get impatient response. }
TextColor (3); GotoXY (3, 25);
Write ('Congratulations!!! Press any key.');
Sound (500); Delay (500);
Sound (700); Delay (500);
Sound (900); Delay (500);
Sound (700); Delay (500);
Sound (500); Delay (500);
NoSound;
Read (Kbd, Ch);
TextMode;
end;
{ -- **************** Test Program routine **************** }
procedure PutColorsOnCube; { -- output is global array of colors. }
{ -- This procedure will set all array items to Valid colors for a cube. }
var
Side, I, Index: Integer;
begin
for Side := 1 to 6 do
for I := 1 to 9 do begin
Index := (Side-1)*9 + I;
A[Index] := ValidColor[Side]; AInit[Index] := ValidColor[Side];
end;
end;
procedure GetNumber ({using} Col, Row: Integer; {giving} var Number: Integer);
{ -- This procedure will accept as input a 2 digit number. }
var
Ch: Char;
begin
TextColor (White);
GotoXY (Col, Row); Write ('--');
GotoXY (Col, Row);
repeat
Read (Kbd, Ch);
Number := Ord(Ch) - Ord('0')
until Number in [0..9];
TextColor (White);
Write (Ch);
repeat
Read (Kbd, Ch);
until (Ch in ['0' .. '9']) or (Ord(Ch) = 13);
if Ch in ['0' .. '9'] then
begin
Write (Ch);
Number := Number * 10 + (Ord(Ch) - Ord('0'));
repeat
Read (Kbd, Ch);
until Ord(Ch) = 13;
end
else Write (' ');
end;
procedure TestProgram ({using} TestOption: Integer);
{ -- This procedure will display statistics for solving random cubes. }
const { -- 5 sides x 3 = 15 + 3 rotations = 18 moves total }
Moves = 'T+ T2 T- F+ F2 F- R+ R2 R- L+ L2 L- B+ B2 B- RC+RC2RC-';
var
NumOfCubes, CubeNum, I: Integer;
NumOfRndMoves, TotalMoves: Integer;
NumOfMoves: Array [1..99] of Integer;
MoveToMake: String3;
ArrayOfMoves: Array [1..30] of String3;
Ch: Char;
MostMoves, LeastMoves: Integer;
begin
DisplayBorder (MenuOption[TestOption], 1);
MostMoves := 0; LeastMoves := 200;
repeat
GotoXY (3, 3); TextColor (Yellow);
Write ('Enter # of cubes to solve (1-14): ');
GetNumber (37, 3, NumOfCubes);
until NumOfCubes < 15;
if NumOfCubes = 0 then Exit;
repeat
GotoXY (3, 4); TextColor (Yellow);
Write ('Enter # of random turns (1-30): ');
GetNumber (35, 4, NumOfRndMoves);
until NumOfRndMoves < 31;
if NumOfRndMoves = 0 then Exit;
TextColor (LightCyan);
GotoXY (6, 6); Write ('# of moves');
TotalMoves := 0;
for CubeNum := 1 to NumOfCubes do begin
{ -- Let computer make random cube to solve. }
PutColorsOnCube;
Randomize;
for I := 1 to NumOfRndMoves do begin
MoveToMake := Copy (Moves, Random(18)*3 +1, 3);
MakeMove (MoveToMake);
ArrayOfMoves[I] := MoveToMake;
end;
{ -- Have computer solve random cube and display # of moves done in. }
GetRCSolution (MoveError);
GotoXY (3, 6+CubeNum); TextColor (LightMagenta);
Write (CubeNum:2, ': '); TextColor (White);
Write (LastSolIndex);
if MoveError then begin
Write (' Error: ', LastSolIndex, ' moves done.');
{ -- The following is for debugging purposes ONLY. }
{ for I := 1 to NumOfRndMoves do Write (ArrayOfMoves[I]); }
end;
{ -- Compute statistics: Total Moves, Most moves, Least moves. }
NumOfMoves[CubeNum] := LastSolIndex;
TotalMoves := TotalMoves + LastSolIndex;
if NumOfMoves[CubeNum] > MostMoves then { -- A new Least moves amount. }
MostMoves := NumOfMoves[CubeNum];
if NumOfMoves[CubeNum] < LeastMoves then { -- A new Most moves amount. }
LeastMoves:= NumOfMoves[CubeNum];
end;
{ -- Display Average number of moves, Most moves, Least Moves. }
TextColor (White);
GotoXY (3, 8+NumOfCubes);
TextColor (LightCyan);
Write ('Average # of moves: '); TextColor (White);
Write (TotalMoves div CubeNum);
GotoXY (3, 9+NumOfCubes); TextColor (LightCyan);
Write ('Most moves: '); TextColor (White);
Write (MostMoves);
GotoXY (23, 9+NumOfCubes); TextColor (LightCyan);
Write ('Least moves: '); TextColor (White);
Write (LeastMoves);
TextColor (Yellow);
GotoXY (14, 25);
Write ('Press any key');
Read (Kbd, Ch);
end;
{ -- *********** Main Flow of Program ************* }
begin
DisplayTitlePage;
InitValidColors;
repeat
DisplayMenu (Option);
case Option of
1, 2: begin
GetRCInput;
if CorrectInput then begin
GetRCSolution (MoveError);
if not MoveError then
if Option = 1 then { -- Graphical Solution }
DisplayGraphicalSolution
else { -- Option = 2 Text Solution }
DisplayTextSolution (Option)
end;
end;
3: DisplayInstr;
4: GetValidColors;
5: TestProgram (Option);
end;
until Option = LastOption;
ClrScr;
end.
Return to About Doug