Program Encryption;
{$APPTYPE CONSOLE}
Type
MyArrayType = array of array of Char;
DirectionType = (Left, Right, Down, Up);
Var
Matrix: MyArrayType;
LenMyS, I, Temp: Integer;
MyString, HelpString: String;
SizeArray, Key: Integer;
InputText, KeyText, OutputText: TextFile;
Procedure MatrixInput(var M: MyArrayType; S: string; const N: integer);
Var I, J: Integer;
Begin
for I:=1 to N do
Begin
for J:=1 to N do
Begin
M[I,J]:=S[N*(i-1)+j];
write(M[I,J]:3)
End;
writeln
End;
End;
Procedure FillVerticalSide(var CurrentStep: Integer; var Pace: Integer; const Interim: Integer; var Orientation: DirectionType; var PositionY: Integer; TurningDirection: Boolean);
Begin
if TurningDirection then
Begin
PositionY:=PositionY+1;
if CurrentStep=Pace then
Begin
CurrentStep:=1;
if Interim mod 2 = 0 then Orientation:=Up
else Orientation:=Down;
if (Interim = 2) or (Interim = 3) then Pace:=Pace+1
End
else
CurrentStep:=CurrentStep+1
End
else
Begin
PositionY:=PositionY-1;
if CurrentStep=Pace then
Begin
CurrentStep:=1;
if Interim mod 2 = 0 then Orientation:=Down
else Orientation:=Up;
if (Interim = 2) or (Interim = 3) then Pace:=Pace+1
End
else
CurrentStep:=CurrentStep+1
End;
End;
Procedure FillHorizontalSide(var CurrentStep: Integer; var Pace: Integer; const Interim: Integer; var Orientation: DirectionType; var PositionX: Integer; TurningDirection: Boolean);
Begin
if TurningDirection then
Begin
PositionX:=PositionX+1;
if CurrentStep=Pace then
Begin
CurrentStep:=1;
if Interim mod 2 = 0 then Orientation:=Right
else Orientation:=Left;
if (Interim = 0) or (Interim = 1) then Pace:=Pace+1
End
else
CurrentStep:=CurrentStep+1
End
else
Begin
PositionX:=PositionX-1;
if CurrentStep=Pace then
Begin
CurrentStep:=1;
if Interim mod 2 = 0 then Orientation:=Left
else Orientation:=Right;
if (Interim = 0) or (Interim = 1) then Pace:=Pace+1
End
else
CurrentStep:=CurrentStep+1
End
End;
Procedure Spiral(var M: MyArrayType; SpirWrite: Boolean; var S: String; var Temp: integer);
Var
CurStep, Step, PosX, PosY: Integer;
Direction: DirectionType; //от 1 до 4 - 1 вправо, 2 вниз, 3 влево, 4 вверх
I: integer;
Begin
I:=1;
PosX:=Trunc(SizeArray/2)+1;
PosY:=Trunc(SizeArray/2)+1;
CurStep:=1;
Step:=1; //через сколько шагов повернуть
Temp:=Random(4);
Direction:=DirectionType(Temp);
write(KeyText, Temp mod 2,Temp);
while (PosX>0) and (PosX<=SizeArray) and (PosY>0) and (PosY<=SizeArray) do
Begin
S[I]:=M[PosX, PosY];
//движение матрицы по спирали
case Direction of
Right: FillVerticalSide(CurStep, Step, Temp, Direction, PosY, True);
Down: FillHorizontalSide(CurStep, Step, Temp, Direction, PosX, True);
Left: FillVerticalSide(CurStep, Step, Temp, Direction, PosY, False);
Up: FillHorizontalSide(CurStep, Step, Temp, Direction, PosX, False);
End;
Inc(I)
End
End;
Procedure CheckAndFixString(var S: String; NeedLength: Integer);
Begin
if (NeedLength>=1) or (NeedLength<=255) then
Begin
if Length(S)>NeedLength then
S:=Copy(S,1,NeedLength)
else
while length(S)<NeedLength do
S:=S + '#'
End
End;
Begin
Randomize;
MyString:='';
AssignFile(InputText, 'D:\Работы по ОАиП\2 семестр\InputText.txt');
Reset(InputText);
while (not EOF(InputText)) do
Begin
Readln(InputText, HelpString);
if not EOF(InputText) then MyString:=MyString+HelpString+'_'
else MyString:=MyString+HelpString;
End;
LenMyS:=length(MyString);
if Trunc(sqrt(LenMyS)) mod 2 = 0 then
SizeArray:=Trunc(sqrt(LenMyS))+1
else
SizeArray:=Trunc(sqrt(LenMyS))+2;
writeln('The required size of the matrix = ',SizeArray,'x',SizeArray);
Setlength(Matrix, SizeArray+1, SizeArray+1);
writeLn('The length of the string = ',LenMyS);
CheckAndFixString(MyString, sqr(SizeArray));
LenMyS:=length(MyString);
WriteLn('Required the length of the string = ',LenMyS);
writeln('Matrix:');
MatrixInput(Matrix, MyString, SizeArray);
Assign(KeyText, 'D:\Работы по ОАиП\2 семестр\Key.txt');
Rewrite(KeyText);
Key:=Random(16)+1;
write(KeyText,'Decryption key = ');
for i:=1 to Key do Spiral(Matrix, True, MyString, Temp);
writeln(KeyText);
writeln(KeyText,'Number of passes = ',Key);
Close(KeyText);
Assign(OutputText, 'D:\Работы по ОАиП\2 семестр\EncryptedOut.txt');
Rewrite(OutputText);
for I:=1 to SizeArray*SizeArray do
Write(OutputText,MyString[i]);
Close(OutputText);
writeln('Press Enter to exit...');
readln
End.
M[I,J]:=S[N*(i-1)+j];
while length(S)<NeedLength do S:=S+'#'
S := S + StringOfChar('#', NeedLength - length(S));
Здесь длина строки нужна только один раз, а не на каждом проходе цикла.procedure ...
var
Stack: TStack<integer>;
begin
Stack := TStack<integer>.Create;
try
//...
// Тут весь расчёт
// ...
finally
Stack.Free;
end;
end;
Stack: TStack<integer>;
procedure TfrmMain.FormCreateButton(Sender: TObject);
var
i, j: Integer;
Begin
for i := 1 to QueensCount do
for j := 1 to QueensCount do
Begin
grdChessBoard[i,j] := TButton.Create(Self);
with grdChessBoard[i,j] do
begin
Parent := frmMain;
Height := trunc((Height - QueensCount - 1) / QueensCount);
Width := trunc((Width - QueensCount - 1) / QueensCount);
Left := j* Width;
Top := i * Height;
//OnClick := если надо выполнять что-то при клике
Visible := True;
End
End
End;
procedure TfrmMain.grdChessBoardClick(Sender: TObject);
var
img1, img2: TPicture;
begin
img1:= TPicture.Create;
img1.LoadFromFile('D:\Работы по ОАиП\Курсовая работа\Формы(без стека)\Ферзь 1.bmp');
img2:= TPicture.Create;
img2.LoadFromFile('D:\Работы по ОАиП\Курсовая работа\Формы(без стека)\Ферзь 2.bmp');
with grdChessBoard do
if (grdChessBoard.Col+grdChessBoard.Row) mod 2 = 0 then
Canvas.StretchDraw(CellRect(grdChessBoard.Col, grdChessBoard.Row), img1.Graphic)
else
Canvas.StretchDraw(CellRect(grdChessBoard.Col, grdChessBoard.Row), img2.Graphic);
end;
procedure TfrmMain.grdChessBoardClick(Sender: TObject);
var
img1, img2: TPicture;
i, j: Integer;
begin
img1:= TPicture.Create;
img1.LoadFromFile('D:\Работы по ОАиП\Курсовая работа\Формы(без стека)\Ферзь 1.bmp');
img2:= TPicture.Create;
img2.LoadFromFile('D:\Работы по ОАиП\Курсовая работа\Формы(без стека)\Ферзь 2.bmp');
with grdChessBoard do
if (grdChessBoard.Col+grdChessBoard.Row) mod 2 = 0 then
Canvas.StretchDraw(CellRect(grdChessBoard.Col, grdChessBoard.Row), img1.Graphic)
else
Canvas.StretchDraw(CellRect(grdChessBoard.Col, grdChessBoard.Row), img2.Graphic);
inc(q);
Temp1[q]:=grdChessBoard.Col;
Temp2[q]:=grdChessBoard.Row;
for I := 1 to q do with grdChessBoard do
if (Temp1[i]+Temp2[i]) mod 2 = 0 then
Canvas.StretchDraw(CellRect(Temp1[i], Temp2[i]), img1.Graphic)
else
Canvas.StretchDraw(CellRect(Temp1[i], Temp2[i]), img2.Graphic);
if q-1 = QueensCount then grdChessBoard.Enabled := False;
end;
var
frmMain: TfrmMain;
...
Queens: array [0..MaxQueensCount-1, 0..MaxQueensCount-1] of boolean;
img1, img2: TPicture;
procedure TfrmMain.FormCreate(Sender: TObject);
var
i, j: Integer;
begin
...
for i := 0 to MaxQueensCount-1 do
for j := 0 to MaxQueensCount-1 do
Queens[i, j] := false;
img1:= TPicture.Create;
img1.LoadFromFile('E:\Ферзь 1.bmp');
img2:= TPicture.Create;
img2.LoadFromFile('E:\Ферзь 2.bmp');
end;
procedure TfrmMain.grdChessBoardClick(Sender: TObject);
var
CellColor: TColor;
begin
Queens[grdChessBoard.Col, grdChessBoard.Row] := not Queens[grdChessBoard.Col, grdChessBoard.Row];
with grdChessBoard do
if Queens[grdChessBoard.Col, grdChessBoard.Row] then
begin
if (Col + Row) mod 2 = 0 then
Canvas.StretchDraw(CellRect(Col, Row), img1.Graphic)
else
Canvas.StretchDraw(CellRect(Col, Row), img2.Graphic);
end
else
begin
if ((Col + Row) mod 2) = 0 then
CellColor := clWhite
else
CellColor := clGray;
grdChessBoard.Canvas.Brush.Color := CellColor;
grdChessBoard.Canvas.FillRect(CellRect(Col, Row));
end;
end;
procedure TfrmMain.grdChessBoardDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
var
CellColor: TColor;
begin
with grdChessBoard do
if Queens[ACol, ARow] then
begin
if (ACol + ARow) mod 2 = 0 then
Canvas.StretchDraw(CellRect(ACol, ARow), img1.Graphic)
else
Canvas.StretchDraw(CellRect(ACol, ARow), img2.Graphic);
end
else
begin
if ((ACol + ARow) mod 2) = 0 then
CellColor := clWhite
else
CellColor := clGray;
Canvas.Brush.Color := CellColor;
Canvas.FillRect(Rect);
end;
end;
procedure TfrmMain.grdChessBoardClick(Sender: TObject);
var
CellColor: TColor;
begin
Queens[grdChessBoard.Col, grdChessBoard.Row] := not Queens[grdChessBoard.Col, grdChessBoard.Row];
with grdChessBoard do
if Queens[grdChessBoard.Col, grdChessBoard.Row] then
begin
if (Col >= 1) and (Row >= 1) then
Begin
Mas[Col, Row]:=1;
if (Col + Row) mod 2 = 0 then
Canvas.StretchDraw(CellRect(Col, Row), img1.Graphic)
else
Canvas.StretchDraw(CellRect(Col, Row), img2.Graphic);
inc(Temp);
End;
end
else
begin
Mas[Col, Row]:=0;
if ((Col + Row) mod 2) = 0 then
CellColor := $9ecfff
else
CellColor := $478bd1;
grdChessBoard.Canvas.Brush.Color := CellColor;
grdChessBoard.Canvas.FillRect(CellRect(Col, Row));
dec(Temp);
end;
if Temp = QueensCount then
Begin
grdChessBoard.Enabled := False;
Check;
End;
end;
procedure TfrmMain.Check;
var
I, q: Integer;
J, f: Integer;
Temp1: Integer;
Flag: Boolean;
begin
I := 1;
Flag := True;
while (I <= QueensCount) and Flag do
Begin
J := 1;
Temp1 := 0;
while J <= QueensCount do
Begin
if Mas[I, J] = 1 then
inc(Temp1);
if Mas[J, I] = 1 then
inc(Temp1);
Inc(J);
End;
if Temp1 >= 2 then
Flag := False;
Inc(I);
End;
if not Flag then
Begin
frmMain.Hide;
Form1.Show;
End;
I := 1;
Flag := True;
while (I <= QueensCount) and Flag do
Begin
J := 1;
Temp1 := 0;
while (J <= QueensCount) and Flag do
Begin
if Mas[I, J] = 1 then
Begin
for Q := 1 to QueensCount do
for F := 1 to QueensCount do
if (Mas[Q,F]=1) and (abs(I-Q)=abs(J-F)) then
inc(Temp1);
End;
Inc(J);
if Temp1 >= 2 then
Flag := False;
End;
if Temp1 >= 2 then
Flag := False;
Inc(I);
End;
if not Flag then
Begin
frmMain.Hide;
Form1.Show;
End;
end;
procedure TfrmMain.Check;
var
I, q: Integer;
J, f: Integer;
Temp1: Integer;
Flag: Boolean;
begin
I := 1;
Flag := True;
while (I <= QueensCount) and Flag do
Begin
J := 1;
Temp1 := 0;
while (J <= QueensCount) and Flag do
Begin
if Mas[I, J] = 1 then
inc(Temp1);
Inc(J);
if Temp1 >= 2 then
Flag := False;
End;
Inc(I);
End;
if not Flag then
Begin
frmMain.Hide;
Form1.Show;
End;
I := 1;
Flag := True;
while (I <= QueensCount) and Flag do
Begin
J := 1;
Temp1 := 0;
while (J <= QueensCount) and Flag do
Begin
if Mas[J, I] = 1 then
inc(Temp1);
Inc(J);
if Temp1 >= 2 then
Flag := False;
End;
Inc(I);
End;
if not Flag then
Begin
frmMain.Hide;
Form1.Show;
End;
I := 1;
Flag := True;
while (I <= QueensCount) and Flag do
Begin
J := 1;
Temp1 := 0;
while (J <= QueensCount) and Flag do
Begin
if Mas[I, J] = 1 then
Begin
for Q := 1 to QueensCount do
for F := 1 to QueensCount do
if (Mas[Q,F]=1) and (abs(I-Q)=abs(J-F)) then
inc(Temp1);
End;
Inc(J);
if Temp1 >= 2 then
Flag := False;
End;
if Temp1 >= 2 then
Flag := False;
Inc(I);
End;
if not Flag then
Begin
frmMain.Hide;
Form1.Show;
End;
end;
if (Mas[I, J] = 1) or (Mas[J,I] = 1) then
inc(Temp1);
procedure TfrmMain.Check;
var
I, q: Integer;
J, f: Integer;
Temp1, Temp2: Integer;
Flag: Boolean;
begin
I := 1;
Flag := True;
while (I <= QueensCount) and Flag do
Begin
J := 1;
Temp1 := 0;
Temp2 := 0;
while (J <= QueensCount) and Flag do
Begin
if Mas[I, J] = 1 then
inc(Temp1);
if Mas[J, I] =1 then
inc(Temp2);
Inc(J);
if (Temp1 >= 2) or (Temp2 >= 2) then
Flag := False;
End;
Inc(I);
End;
if not Flag then
Begin
frmMain.Hide;
Form1.Show;
End;
I := 1;
Flag := True;
while (I <= QueensCount) and Flag do
Begin
J := 1;
Temp1 := 0;
while (J <= QueensCount) and Flag do
Begin
if Mas[I, J] = 1 then
Begin
for Q := 1 to QueensCount do
for F := 1 to QueensCount do
if (Mas[Q,F]=1) and (abs(I-Q)=abs(J-F)) then
inc(Temp1);
End;
Inc(J);
if Temp1 >= 2 then
Flag := False;
End;
if Temp1 >= 2 then
Flag := False;
Inc(I);
End;
if not Flag then
Begin
frmMain.Hide;
Form1.Show;
End;
end;
if not Flag then
Begin
frmMain.Hide;
Form1.Show;
End;
procedure TfrmMain.Clean;
var
CellColor: TColor;
ACol, ARow: Integer;
Rect: TRect;
begin
for ACol := 1 to QueensCount do
for ARow := 1 to QueensCount do
Begin
with grdChessBoard do
if (ACol >= 1) and (ARow >= 1) then
begin
if ((ACol + ARow) mod 2) = 0 then
CellColor := $9ecfff
else
CellColor := $478bd1;
Canvas.Brush.Color := CellColor;
Canvas.FillRect(Rect);
end;
End;
end;
procedure TfrmMain.grdChessBoardDrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
var
CellColor: TColor;
i, j: integer;
CurrentTickCount: cardinal;
SolutionArray: TArray<integer>;
img1, img2: TPicture;
t1: TRect;
str1, str2: string;
begin
with grdChessBoard do
if (ACol >= 1) and (ARow >= 1) then
if Queens[ACol, ARow] then
begin
if (ACol + ARow) mod 2 = 0 then
Canvas.StretchDraw(CellRect(ACol, ARow), img1.Graphic)
else
Canvas.StretchDraw(CellRect(ACol, ARow), img2.Graphic);
end
else
begin
if (ACol >= 1) and (ARow >= 1) then
if ((ACol + ARow) mod 2) = 0 then
CellColor := $9ecfff
else
CellColor := $478bd1;
Canvas.Brush.Color := CellColor;
Canvas.FillRect(Rect);
end;
i:=1;
J:=QueensCount;
while (I <= QueensCount) do with grdChessBoard do
begin
Font.Size:=20+trunc(grdChessBoard.DefaultRowHeight/QueensCount)-1;
Font.Style:=[fsBold];
Font.Name:='Times New Roman';
grdChessBoard.Canvas.Brush.Style:=bsClear;
t1:=grdChessBoard.CellRect(i,0);
str1:=char(ord(96+i));
canvas.textout(t1.left, t1.top, str1);
t1:=grdChessBoard.CellRect(0,i);
str2:=IntToStr(J);
canvas.textout(t1.left, t1.top, str2);
Inc(I);
Dec(J);
end;
end;
while (I <= QueensCount) do with grdChessBoard do
begin
Font.Size:=20+trunc(grdChessBoard.DefaultRowHeight/QueensCount)-1;
Font.Style:=[fsBold];
Font.Name:='Times New Roman';
grdChessBoard.Canvas.Brush.Style:=bsClear;
.....
end;
Function CountFunc: Integer;
Var
c,op: Char;
x,y: Integer;
Begin
Read(c);
If (c>='0') and (c<='9') then
Result:=Ord(c)-Ord('0')
else
Begin
x:=CountFunc;
read(op);
y:=CountFunc;
case op of
'+': Result:=x+y;
'-': Result:=x-y;
'*': Result:=x*y;
End;
Read(c);
End
End;
Begin
writeln(CountFunc);
readln;
End.
procedure TfrmMain.DrawSolution(Solution: TStack<Integer>);
var
I: Integer;
CurrentTickCount: cardinal;
SolutionArray: TArray<Integer>;
HelpString: String;
begin
SolutionCount := SolutionCount + 1;
lblSolutionCount.Caption := IntToStr(SolutionCount);
grdChessBoard.Repaint;
grdChessBoard.Canvas.Brush.Color := clBlack;
SolutionArray := Solution.ToArray;
for i := 1 to QueensCount do
with grdChessBoard do
if (i + SolutionArray[i - 1]) mod 2 = 0 then
Canvas.StretchDraw(CellRect(i, SolutionArray[i - 1]), img1.Graphic)
else
Canvas.StretchDraw(CellRect(i, SolutionArray[i - 1]), img2.Graphic);
Assignfile(Input, 'D:\Работы по ОАиП\Курсовая работа\Формы(без стека)\Placements.txt');
Append(Input);
writeln(Input,'Placement № ',IntToStr(SolutionCount));
for i:=1 to QueensCount-1 do
begin
Write(Input,char(ord(96+SolutionArray[i - 1])),'-',QueensCount-i);
if I <> QueensCount-1 then write(Input,',');
end;
writeln(Input);
writeln(Input,HelpString);
CloseFile(Input);
CurrentTickCount := GetTickCount;
Repeat
Application.ProcessMessages
Until (GetTickCount - CurrentTickCount) > ShowDelay
end;
procedure TfrmMain.Button2Click(Sender: TObject; Solution: TStack<Integer>);
var s: string;
i: integer;
SolutionArray: TArray<Integer>;
begin
Assignfile(Input, 'D:\Работы по ОАиП\Курсовая работа\Формы(без стека)\Placements.txt');
Reset(Input);
while (not EOF(Input)) do begin
Readln(Input, s);
end;
CloseFile(Input);
for I := 1 to QueensCount do
if s[i] in ['0'..'9'] then SolutionArray[i - 1]:=StrToInt(s[i]);
StopPressed := False;
StackSolution;
end;
procedure TfrmMain.Button2Click(Sender: TObject);
begin
StopPressed := False;
Fla:=False;
StackSolution();
end;
procedure StackSolution;
var
i, Y, x: Integer;
a: array [1 .. MaxQueensCount] of Boolean;
b: array [2 .. 2 * MaxQueensCount] of Boolean;
c: array [1 - MaxQueensCount .. MaxQueensCount - 1] of Boolean;
Stack: TStack<Integer>;
SolutionArray: TArray<Integer>;
s: string;
Function Uspeh: Boolean;
Var
usp: Boolean;
Begin
usp := False;
While (Y < QueensCount) And Not usp do
Begin
Y := Y + 1;
usp := a[Y] and b[x + Y] and c[Y - x];
End;
Result := usp;
End;
begin
Fla:=True;
For i := 1 to QueensCount do
a[i] := True;
For i := 2 to 2 * QueensCount do
b[i] := True;
For i := 1 - QueensCount to QueensCount - 1 do
c[i] := True;
if not Fla then
Begin
Assignfile(Input, 'D:\Работы по ОАиП\Курсовая работа\Формы(без стека)\Placements.txt');
Reset(Input);
while (not EOF(Input)) do begin
Readln(Input, s);
end;
CloseFile(Input);
for I := 1 to QueensCount do
if s[i] in ['0'..'9'] then SolutionArray[i - 1]:=StrToInt(s[i]);
End;
Stack := TStack<Integer>.Create;
try
x := 1;
Y := 0;
while (x <> 0) and not StopPressed do
Begin
If Uspeh Then
Begin
Stack.Push(Y);
If x < QueensCount Then
Begin
a[Y] := False;
b[x + Y] := False;
c[Y - x] := False;
x := x + 1;
Y := 0;
End
Else
begin
frmMain.DrawSolution(Stack);
Stack.Pop;
end;
End
Else
Begin
x := x - 1;
If x > 0 Then
Begin
Y := Stack.Pop;
a[Y] := True;
b[x + Y] := True;
c[Y - x] := True;
End;
End;
End;
finally
Stack.Free;
End;
End;
procedure StackSolution(RestoreLastSolution: boolean);
var
i, j, Y, x: Integer;
a: array [1 .. MaxQueensCount] of Boolean;
b: array [2 .. 2 * MaxQueensCount] of Boolean;
c: array [1 - MaxQueensCount .. MaxQueensCount - 1] of Boolean;
Stack: TStack<Integer>;
SolutionArray: TArray<Integer>;
s: string;
flag1, flag2: boolean;
Function Uspeh: Boolean;
Var
usp: Boolean;
Begin
usp := False;
While (Y < QueensCount) And Not usp do
Begin
Y := Y + 1;
usp := a[Y] and b[x + Y] and c[Y - x];
End;
Result := usp;
End;
begin
if not RestoreLastSolution then
begin
For i := 1 to QueensCount do
a[i] := True;
For i := 2 to 2 * QueensCount do
b[i] := True;
For i := 1 - QueensCount to QueensCount - 1 do
c[i] := True;
end;
if RestoreLastSolution then
begin
Assignfile(Input, 'D:\Работы по ОАиП\Курсовая работа\Формы(без стека)\Placements.txt');
Reset(Input);
while (not EOF(Input)) do begin
Readln(Input, s);
end;
CloseFile(Input);
For i := 1 to QueensCount do
if S[I]='T' then a[i] := True
else a[i] := False;
Delete(S,1,QueensCount+1);
For i := 2 to 2 * QueensCount do
if S[I]='T' then b[i] := True
else b[i] := False;
Delete(S,1,2 * QueensCount);
For i := 1 - QueensCount to QueensCount - 1 do
if S[I]='T' then c[i] := True
else c[i] := False;
Delete(S,1,QueensCount+QueensCount-1);
end;
Assignfile(Input, 'D:\Работы по ОАиП\Курсовая работа\Формы(без стека)\Placements.txt');
Rewrite(Input);
Stack := TStack<Integer>.Create;
try
if not RestoreLastSolution then
Begin
x := 1;
Y := 0;
End;
if RestoreLastSolution then
Begin
x := StrToInt(S[1]);
Y := StrToInt(S[2]);
End;
while (x <> 0) and not StopPressed do
Begin
If Uspeh Then
Begin
Stack.Push(Y);
If x < QueensCount Then
Begin
a[Y] := False;
b[x + Y] := False;
c[Y - x] := False;
x := x + 1;
Y := 0;
End
Else
begin
if not RestoreLastSolution then
Begin
For I := 1 to QueensCount do
begin
if A[I] then
write(Input, 'T')
else
write(Input, 'F')
End;
write(Input,'|');
For i := 2 to 2 * QueensCount do
begin
if B[I] then
write(Input, 'T')
else
write(Input, 'F')
End;
write(Input,'|');
For i := 1 - QueensCount to QueensCount - 1 do
Begin
if C[I] then
write(Input, 'T')
else
write(Input, 'F')
End;
write(Input, X, Y);
writeln(Input);
End;
frmMain.DrawSolution(Stack);
Stack.Pop;
end;
End
Else
Begin
x := x - 1;
If x > 0 Then
Begin
Y := Stack.Pop;
a[Y] := True;
b[x + Y] := True;
c[Y - x] := True;
End;
End;
End;
Closefile(Input);
finally
Stack.Free;
End;
End;
if RestoreLastSolution then
Begin
x := StrToInt(S[1];
Y := StrToInt(S[2]);
End;
if RestoreLastSolution then
Begin
x := 1;
Y := StrToInt(S[2]);
End;
if not RestoreLastSolution then
Begin
Assignfile(Input, 'D:\Работы по ОАиП\Курсовая работа\Формы(без стека)\Placements.txt');
Rewrite(Input);
Stack := TStack<Integer>.Create;
Solution := TStack<Integer>.Create;
End;
if RestoreLastSolution then
Begin
//Solution := TStack<Integer>.Create;
Stack := Solution;
End;
procedure StackSolution(RestoreLastSolution: boolean = false);
var
i, j, Y, X: integer;
a: array [1..MaxQueensCount] of boolean;
b: array [2..2*MaxQueensCount] of boolean;
c: array [1-MaxQueensCount..MaxQueensCount-1] of boolean;
Stack: TStack<integer>;
Function Uspeh: Boolean;
Var
usp: Boolean;
Begin
usp := false;
While (Y < QueensCount) And Not usp do
Begin
Y := Y + 1;
usp := a[Y] and b[X + Y] and c[Y - X];
End;
Result := usp;
End;
begin
Stack := TStack<integer>.Create;
try
// Сначала в любом случае заполняем массив True - все горизонтали и диагонали свободны
For i := 1 to QueensCount do
a[i] := True;
For i := 2 to 2*QueensCount do
b[i] := True;
For i := 1-QueensCount to QueensCount-1 do
c[i] := True;
if RestoreLastSolution then
begin
// Если восстанавливаем решение
// Отмечаем занятыми линии соответственно последнему решению (без последнего ферзя)
For i := 1 to QueensCount-1 do
begin
a[TmpArr[i]] := False;
b[i + TmpArr[i]] := False;
c[TmpArr[i] - i] := False;
end;
// В X и Y положение последнего ферзя в решении
X := QueensCount;
Y := TmpArr[QueensCount];
// Решение запихиваем в стек (без последнего ферзя)
For i := 1 to QueensCount-1 do
Stack.Push(TmpArr[i]);
end
else
begin
X := 1;
Y := 0;
end;
// Далее не меняется ничего
Repeat
if StopPressed then
Exit;
If Uspeh Then
Begin
Stack.Push(Y);
If X < QueensCount Then
Begin
a[Y] := False;
b[X + Y] := False;
c[Y - X] := False;
X := X + 1;
Y := 0;
End
Else
begin
frmMain.DrawSolution(Stack);
Stack.Pop;
end;
End
Else
Begin
X := X - 1;
If X > 0 Then
Begin
Y := Stack.Pop;
a[Y] := True;
b[X + Y] := True;
c[Y - X] := True;
End;
End;
Until X = 0;
finally
Stack.Free;
end;
end;
procedure RecursiveSolution(RestoreLastSolution: boolean = false);
var
i: Integer;
a: array [1 .. MaxQueensCount] of Boolean; // a[j] - на j-й горизонтали ферзя нет
b: array [2 .. 2 * MaxQueensCount] of Boolean; // b[k] - на k-й / диагонали ферзя нет (у всех полей на диагонали / постоянна сумма координат i и j)
c: array [1 - MaxQueensCount .. MaxQueensCount - 1] of Boolean; // c[k] - на k-й \ диагонали ферзя нет (у всех полей на диагонали \ постоянна разность координат i и j)
x: array [1 .. MaxQueensCount] of Integer; // x[i] - местоположение ферзя на i-й вертикали
procedure Solve(i: Integer);
var
j: Integer;
begin
if not StopPressed then
for j := 1 to QueensCount do
begin
if a[j] and b[i + j] and c[i - j] then
begin
x[i] := j;
a[j] := False;
b[i + j] := False;
c[i - j] := False;
if i < QueensCount then
Solve(i + 1)
else
frmMain.DrawSolution(x);
a[j] := True;
b[i + j] := True;
c[i - j] := True;
end;
end;
end;
begin
for i := 1 to QueensCount do
a[i] := True;
for i := 2 to 2 * QueensCount do
b[i] := True;
for i := 1 - QueensCount to QueensCount - 1 do
c[i] := True;
if RestoreLastSolution then
begin
For i := 1 to QueensCount-1 do
begin
a[TmpArr[i]] := False;
b[i + TmpArr[i]] := False;
c[TmpArr[i] - i] := False;
end;
end;
Solve(1);
end;
procedure RecursiveSolution(RestoreLastSolution: boolean = false);
var
i: Integer;
a: array [1 .. MaxQueensCount] of Boolean; // a[j] - на j-й горизонтали ферзя нет
b: array [2 .. 2 * MaxQueensCount] of Boolean; // b[k] - на k-й / диагонали ферзя нет (у всех полей на диагонали / постоянна сумма координат i и j)
c: array [1 - MaxQueensCount .. MaxQueensCount - 1] of Boolean; // c[k] - на k-й \ диагонали ферзя нет (у всех полей на диагонали \ постоянна разность координат i и j)
x: array [1 .. MaxQueensCount] of Integer; // x[i] - местоположение ферзя на i-й вертикали
procedure Solve(i: Integer);
var
j: Integer;
begin
if not StopPressed then
for j := 1 to QueensCount do
begin
if a[j] and b[i + j] and c[i - j] then
begin
x[i] := j;
a[j] := False;
b[i + j] := False;
c[i - j] := False;
if i < QueensCount then
Begin
Cout1 := j;
Cout2 := i;
Solve(i + 1)
End
else
frmMain.DrawSolution(x);
a[j] := True;
b[i + j] := True;
c[i - j] := True;
end;
end;
end;
procedure Solve1(i: Integer);
var
j: Integer;
begin
if i = QueensCount then
Exit;
for j := 1 to QueensCount do
begin
if a[j] and b[i + j] and c[i - j] then
begin
x[i] := j;
a[j] := False;
b[i + j] := False;
c[i - j] := False;
if i < QueensCount then
Solve1(i + 1)
else
frmMain.DrawSolution(x);
a[j] := True;
b[i + j] := True;
c[i - j] := True;
end;
end;
end;
begin
if not RestoreLastSolution then
Begin
for i := 1 to QueensCount do
a[i] := True;
for i := 2 to 2 * QueensCount do
b[i] := True;
for i := 1 - QueensCount to QueensCount - 1 do
c[i] := True;
End;
if RestoreLastSolution then
begin
For i := 1 to QueensCount do
x[i] := TmpArr[i];
a[Cout1] := True;
b[Cout2 + Cout1] := True;
c[Cout2 - Cout1] := True;
Solve1(1);
end;
Solve(1);
end;
if RestoreLastSolution then
Begin
if I <> QueensCount then
Solve(i + 1)
else
Begin
RestoreLastSolution := False;
Exit;
End;
End;
procedure RecursiveSolution(RestoreLastSolution: boolean = false);
var
i: Integer;
a: array [1 .. MaxQueensCount] of Boolean; // a[j] - на j-й горизонтали ферзя нет
b: array [2 .. 2 * MaxQueensCount] of Boolean; // b[k] - на k-й / диагонали ферзя нет (у всех полей на диагонали / постоянна сумма координат i и j)
c: array [1 - MaxQueensCount .. MaxQueensCount - 1] of Boolean; // c[k] - на k-й \ диагонали ферзя нет (у всех полей на диагонали \ постоянна разность координат i и j)
x: array [1 .. MaxQueensCount] of Integer; // x[i] - местоположение ферзя на i-й вертикали
procedure Solve(i: Integer);
var
j: Integer;
begin
if RestoreLastSolution then
Begin
if I <> QueensCount then
Solve(i + 1)
else
Begin
RestoreLastSolution := False;
Exit;
End;
End;
if not RestoreLastSolution then
Begin
if not StopPressed then
for j := 1 to QueensCount do
begin
if a[j] and b[i + j] and c[i - j] then
begin
x[i] := j;
a[j] := False;
b[i + j] := False;
c[i - j] := False;
if i < QueensCount then
Begin
Cout1 := j;
Cout2 := i;
Solve(i + 1)
End
else
frmMain.DrawSolution(x);
a[j] := True;
b[i + j] := True;
c[i - j] := True;
end;
end;
End;
end;
begin
if not RestoreLastSolution then
Begin
for i := 1 to QueensCount do
a[i] := True;
for i := 2 to 2 * QueensCount do
b[i] := True;
for i := 1 - QueensCount to QueensCount - 1 do
c[i] := True;
End;
if RestoreLastSolution then
begin
For i := 1 to QueensCount do
x[i] := TmpArr[i];
a[Cout1] := True;
b[Cout2 + Cout1] := True;
c[Cout2 - Cout1] := True;
i:=Cout2;
Solve(i);
end;
Solve(1);
end;
if RestoreLastSolution then
begin
For i := 1 to QueensCount do
x[i] := TmpArr[i];
a[Cout1] := True;
b[Cout2 + Cout1] := True;
c[Cout2 - Cout1] := True;
i:=Cout2;
Solve(i);
end;
procedure RecursiveSolution(RestoreLastSolution: boolean = false);
var
i: Integer;
a: array [1 .. MaxQueensCount] of Boolean; // a[j] - на j-й горизонтали ферзя нет
b: array [2 .. 2 * MaxQueensCount] of Boolean; // b[k] - на k-й / диагонали ферзя нет (у всех полей на диагонали / постоянна сумма координат i и j)
c: array [1 - MaxQueensCount .. MaxQueensCount - 1] of Boolean; // c[k] - на k-й \ диагонали ферзя нет (у всех полей на диагонали \ постоянна разность координат i и j)
x: array [1 .. MaxQueensCount] of Integer; // x[i] - местоположение ферзя на i-й вертикали
procedure Solve(i: Integer);
var
j: Integer;
begin
if RestoreLastSolution then
Begin
if I <> QueensCount then
Solve(I + 1)
else
Begin
RestoreLastSolution := False;
Exit;
End;
End;
if not RestoreLastSolution then
Begin
if not StopPressed then
for j := 1 to QueensCount do
begin
if a[j] and b[i + j] and c[i - j] then
begin
x[i] := j;
a[j] := False;
b[i + j] := False;
c[i - j] := False;
if i < QueensCount then
Begin
Cout1 := j;
Cout2 := i;
Solve(i + 1)
End
else
frmMain.DrawSolution(x);
a[j] := True;
b[i + j] := True;
c[i - j] := True;
end;
end;
End;
end;
grdChessBoard.Font.Size:= 20+trunc(grdChessBoard.DefaultRowHeight/QueensCount)-1;
grdChessBoard.Font.Style:=[fsBold];
grdChessBoard.Font.Name:='Times New Roman';
if ACol = 0 then
grdChessBoard.Canvas.TextRect(grdChessBoard.CellRect(ACol, ARow), grdChessBoard.CellRect(ACol, ARow).Left, grdChessBoard.CellRect(ACol, ARow).Top, IntToStr(QueensCount - ARow))
else if ARow = QueensCount then
grdChessBoard.Canvas.TextRect(grdChessBoard.CellRect(ACol, ARow), grdChessBoard.CellRect(ACol, ARow).Left, grdChessBoard.CellRect(ACol, ARow).Top, char(96+ACol))
else
// а тут уже отрисовка клеточек собственно доски
if CountForCorrect <> QueensCount * QueensCount then
buttonSelected := MessageDlg('Unfortunately, you did not place all the queens with hints. Do you want to try again?', mtInformation, [mbYes, mbNo], 0);
if buttonSelected = mrYes then
//...