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;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;
Во-первых, прошлый раз не стал писать, но сильно уж глаза режет - два IF подряд:
if not RestoreLastSolution then...
if RestoreLastSolution then...
надо:
if RestoreLastSolution then
begin ... end
else
begin...end;
Во-вторых, никакой процедуры Solve1 не должно быть. Процедура RecursiveSolution делает по-разному инициализацию, а в конце в любом случае вызывает Solve(1).
В-третьих, нужно модифицировать саму процедуру Solve. В начале она должна проверять - это восстановление или нет? Ну а дальше прошлое моё сообщение перечитайте.