Рассмотрим известные решения задач, связанных с расстановкой ферзей на доске NxN: завершение расстановки, конструирование расстановки, генерация всех завершений, генерация всех расстановок, в том числе с учетом симметрии.
Разные задачи, разные решения
Вариант 1 задачи о ферзях, самый известный: найти хотя бы одну расстановку N ферзей на доске размером NxN клеток, при которой ферзи не атакуют друг друга, или доказать что таких расстановок не существует. Очевидно, что для N=2 и N=3 таких расстановок нет. Для остальных натуральных N можно указать простое правило, следуя которому, можно расставить ферзей, не проверяя взаимные атаки.
Вариант 2 задачи о ферзях требует подсчитать все возможные расстановки без взаимных атак N ферзей на доске размером NxN.
Кроме того, можно решать задачу о ферзях при дополнительном условии, что на доске уже стоят M неатакующих друг друга ферзей.
Таким образом, мы получаем 4 варианта задачи: 1, 2, 1M, 2M. Традиционно, все 4 варианта задачи решаются методом поиска с возвратом (backtracking), сложность алгоритма экспоненциальная. Вариант 1 также решается прямым конструированием (explicit solution), сложность алгоритма линейная. Кроме того, варианты 1 и 1M решаются методом градиентного спуска (gradient descent, gradient-based heuristic, combinatorial search), сложность алгоритма полиномиальная. К сожалению, методом градиентного спуска невозможно доказать отсутствие решения в варианте 1M.
Иногда в задаче 2 ищут количество так называемых модулярных расстановок ферзей при дополнительном ограничении, что диагонали ниже главных являются продолжением соответствующих диагоналей выше главных, так что суммарная длина каждой диагонали становится равна N. Модулярные расстановки хороши тем, что с их помощью можно генерировать фрактальные размещения и мостить доски больших размеров. Модулярные расстановки существуют для досок с размерами, не кратными 2 и 3, т.е. для N=6*K-1 и N=6*K+1. Ограничения модулярности легко проверить либо в процессе поиска, либо для уже найденного решения.
Задача 1 или Всегда одно и то же
Найти хотя бы одну расстановку N ферзей на доске размером NxN клеток, при которой ферзи не атакуют друг друга.
Известно явное (explicit) решение этой задачи, при котором ферзи располагаются двумя лесенками (автор Bo Bernhardsson):
type
TSolution= array of integer; //список номеров столбцов, в которых стоят ферзи в первой, второй и т.д. строках
procedure ExplicitSolution(Size: integer);
var
i, j, last, pos13, pos5: integer;
Solution: TSolution;
begin;
if (Size>=4) or (Size=1) then begin;
SetLength(Solution, Size);
i:=Size mod 12; //1. Разделить N на 12 и запомнить остаток.
last:=-1;
j:=2;
while j<=Size do begin; //2. Занести в список все четные числа от 2 до N по порядку.
inc(last); Solution[last]:=j;
j:=j+2;
end;
if (i=3) or (i=9) then begin; //3. Если остаток равен 3 или 9, перенести 2 в конец списка.
for j:=0 to last-1 do Solution[j]:=Solution[j+1];
Solution[last]:=2;
end;
j:=1; pos13:=last+1;
while j<=Size do begin; //4а. Добавить в список все нечетные числа от 1 до N по порядку,
inc(last); Solution[last]:=j;
j:=j+2;
if j>Size then break;
inc(last); Solution[last]:=j;
if i=8 then begin; //4б. но, если остаток равен 8, перевернуть пары соседних чисел,
Solution[last-1]:=j; Solution[last]:=j-2; // например: 3, 1, 7, 5, 11, 9, …
end;
j:=j+2;
end;
if i=2 then begin; //5а. Если остаток равен 2 и N>=3, поменять местами 1 и 3,
Solution[pos13]:=Solution[pos13] xor 2;
Solution[pos13+1]:=Solution[pos13+1] xor 2;
if Size>=5 then begin; //5б. затем, если N>=5, перенести 5 в конец списка.
pos5:=pos13+2;
if Solution[pos5]<>5 then inc(pos5);
for j:=pos5 to last-1 do Solution[j]:=Solution[j+1];
Solution[last]:=5;
end;
end;
if (i=3) or (i=9) then begin; //6. Если остаток равен 3 или 9, переместить 1 и 3
for j:=pos13 to last-2 do Solution[j]:=Solution[j+2]; // (именно в этом порядке) в конец списка.
Solution[last-1]:=1;
Solution[last]:=3;
end;
for j:=0 to last do dec(Solution[j]); //Вычтем 1 из номера столбца, т.к. у нас нумерация с нуля
ShowSolution(Solution);
end;
end;Задача 1M или Найдем, если сможем
Найти хотя бы одну расстановку N ферзей на доске размером NxN клеток, при которой ферзи не атакуют друг друга, или доказать что такой расстановки не существует при условии, что на доске уже стоят M неатакующих друг друга ферзей.
Алгоритм завершения расстановки ферзей методом градиентного спуска описан в статье "A Polynomial Time Algorithm for the N-Queen Problem" авторов Rok Sosic, Jun Gu. Это алгоритм поиска одного случайного решения путем последовательного устранения коллизий.
Суть алгоритма в следующем. В начале работы недостающие N-M ферзей случайным образом размещаются на свободных горизонталях и вертикалях, при этом атаки по диагоналям (коллизии) не учитываются. Затем для каждой пары строк выполняется обмен номерами занятых столбцов, если он приводит к уменьшению общего числа коллизий. Процесс продолжается до тех пор, пока это возможно. Разумеется, такой способ поиска не всегда находит нужную расстановку. В некоторых случаях, пытаясь уменьшить количество коллизий, алгоритм попадает в "яму", из которой невозможно выбраться без увеличения количества коллизий. В этом случае ферзи снова перемешиваются и делается повторная попытка найти решение. И так до тех пор, пока не будет исчерпано отведенное количество попыток. Это кажется совершенно нереальным, но с увеличением N-K вероятность найти решение с первой попытки возрастает и при N-K>=50000 практически равна 1.
Объявление переменных и инициализация:
type
TQueenColRow= record
QueenCol: integer;
QueenRow: integer;
end;
const
MaxBoardSize= 100000;
var
BoardSize: integer;
QueenCount: integer;
SolutionCount: int64;
CountCol: array[0..MaxBoardSize-1] of byte;
CountRow: array[0..MaxBoardSize-1] of byte;
CountDiagP: array[0..2*MaxBoardSize-2] of byte;
CountDiagM: array[-MaxBoardSize+1..MaxBoardSize-1] of byte;
QueenColRow: array[0..MaxBoardSize-1] of TQueenColRow;
procedure InitBoard(Size: integer);
var
i: integer;
begin;
BoardSize:=Size;
QueenCount:=Size;
SolutionCount:=0;
FillChar(CountRow[0], Size, 0);
FillChar(CountCol[0], Size, 0);
FillChar(CountDiagP[0], 2*Size-1, 0);
FillChar(CountDiagM[1-Size], 2*Size-1, 0);
for i:=0 to Size-1 do with QueenColRow[i] do begin;
QueenCol:=i;
QueenRow:=i;
end;
end;Переменная BoardSize задает размер доски, а QueenCount - количество ферзей, которые осталось поставить на доску. Переменные CountCol, CountRow, CountDiagP, CountDiagM - счетчики ферзей, размещенных в соответствующих позициях, для этих переменных мы используем тип byte, а не boolean, чтобы подсчитывать коллизии. В данном случае удобно использовать массивы с фиксированными границами, чтобы не сдвигать индексы при обращении к массиву разностных диагоналей, и, кроме того, это немного повышает скорость вычислений.
И наконец, мы используем структуру TQueenColRow, а не вектор столбцов, чтобы оставить за рамками вычислений те строки, в которых уже стоят ферзи. Начальное расположение ферзей будем задавать при помощи последовательных вызовов функции SetColRow:
function SetColRow(Col, Row: integer): boolean;
var
Q, C, R: integer;
begin;
if (Col<BoardSize) and (Row<BoardSize)
and (CountCol[Col]=0) and (CountRow[Row]=0)
and (CountDiagP[Col+Row]=0) and (CountDiagM[Col-Row]=0) then begin;
CountRow[Row]:=1;
CountCol[Col]:=1;
CountDiagP[Col+Row]:=1;
CountDiagM[Col-Row]:=1;
dec(QueenCount);
with QueenColRow[QueenCount] do begin;
C:=QueenCol; QueenCol:=Col;
R:=QueenRow; QueenRow:=Row;
end;
for Q:=QueenCount-1 downto 0 do with QueenColRow[Q] do begin;
if QueenCol=Col then QueenCol:=C;
if QueenRow=Row then QueenRow:=R;
end;
Result:=true;
end
else Result:=false;
end;По описанию авторов, оставивших некоторый простор для возможных реализаций, был воссоздан алгоритм поиска случайного решения:
procedure GradientSearch;
var
Attempt, Col, Row, Queen, C, R, Q: integer;
Attacked, A: byte;
Swapped: boolean;
label
RandomizeColumns, Fail;
begin;
Attempt:=100000 div (QueenCount+10) + 5;
repeat;
RandomizeColumns:
for Q:=QueenCount-1 downto 0 do with QueenColRow[Random(Q+1)] do begin;
C:=QueenColRow[Q].QueenCol; QueenColRow[Q].QueenCol:=QueenCol; QueenCol:=C;
end;
for Q:=0 to 2*BoardSize-2 do begin;
CountDiagP[Q]:=0;
CountDiagM[Q-BoardSize+1]:=0;
end;
for Q:=0 to BoardSize-1 do with QueenColRow[Q] do begin;
C:=QueenCol;
R:=QueenRow;
inc(CountDiagP[C+R]);
inc(CountDiagM[C-R]);
if CountDiagP[C+R] or CountDiagM[C-R]>=64 then goto RandomizeColumns; //unbelievable
end;
if QueenCount>1 then repeat;
Queen:=QueenCount-1;
Swapped:=false;
repeat;
with QueenColRow[Queen] do begin;
Col:=QueenCol;
Row:=QueenRow;
end;
Attacked:=CountDiagP[Col+Row] + CountDiagM[Col-Row] - 4;
Q:=Queen-1;
repeat;
with QueenColRow[Q] do begin;
C:=QueenCol;
R:=QueenRow;
end;
A:=CountDiagP[C+R] + CountDiagM[C-R] + Attacked;
if (Col+R=C+Row) or (Col+Row=C+R) then A:=A - 2;
if (A>0) and (A>CountDiagP[Col+R] + CountDiagP[C+Row] + CountDiagM[Col-R] + CountDiagM[C-Row]) then begin;
dec(CountDiagP[C+R]);
inc(CountDiagP[Col+R]);
dec(CountDiagP[Col+Row]);
inc(CountDiagP[C+Row]);
dec(CountDiagM[C-R]);
inc(CountDiagM[Col-R]);
dec(CountDiagM[Col-Row]);
inc(CountDiagM[C-Row]);
Attacked:=CountDiagP[C+Row] + CountDiagM[C-Row] - 4;
QueenColRow[Q].QueenCol:=Col;
QueenColRow[Queen].QueenCol:=C;
Col:=C;
Swapped:=true;
end;
dec(Q)
until Q<0;
dec(Queen);
until Queen<=0;
until not Swapped;
for Q:=0 to 2*BoardSize-2 do if CountDiagP[Q] or CountDiagM[Q-BoardSize+1]>1 then goto Fail;
CountSolution;
exit;
Fail:
dec(Attempt);
until Attempt<=0;
end;На компьютере с процессором E6850 требуется менее 40 сек, чтобы найти случайное решение на доске 10^5x10^5.
Если решение существует, то оно находится практически всегда. Алгоритм можно настроить на более агрессивный поиск, однако при этом возрастет время его работы в случае отсутствия решения.
Задача 2 или Королевство кривых зеркал
Подсчитать все возможные расстановки без взаимных атак N ферзей на доске размером NxN.
В данном случае единственный практичный (но все равно очень затратный) алгоритм - поиск с возвратом. В настоящее время получены результаты только для N=1..27, что не превышает разрядности современных компьютеров. Удивительно, но это можно обратить себе на пользу, если представить каждую горизонталь доски целым числом, а номер занятой ферзем вертикали кодировать одним битом этого числа. Алгоритм, полностью основанный на битовых масках (автор идеи Martin Richards), работает очень быстро:
var
SolutionCount: int64;
procedure BitwiseRecursive(Columns, Left, Right: integer);
var
Used, Place: integer;
begin;
if Columns=-1 then inc(SolutionCount)
else begin;
Used:=Columns or Left or Right;
while Used<>-1 do begin;
Place:=Used;
Used:=(Used+1) or Place;
Place:=Place xor Used;
BitwiseRecursive(Columns or Place, (Left or Place) shl 1, (Right or Place) shr 1);
end;
end;
end;
procedure BacktrackingBitwise(Size: integer);
begin;
if Size<4 then SolutionCount:=ord(Size=1)
else begin;
SolutionCount:=0;
BitwiseRecursive(-2 shl (Size-1), 0, 0);
end;
end;Здесь Columns - битовая маска занятых вертикалей, Left - маска занятых левых диагоналей, Right - маска занятых правых диагоналей.
Понятно, что количество расстановок ферзей кратно двум, т.к. шахматная доска зеркально симметрична. Поэтому скорость алгоритма легко увеличить в 2 раза, если ставить ферзей на доску таким образом, чтобы ферзь в первой строке был всегда левее ферзя во второй строке, а затем найденное количество расстановок умножить на 2:
procedure BacktrackingBitwiseBy2(Size: integer);
var
Col0, Col1, Columns, Left, Right: integer;
begin;
if Size<4 then SolutionCount:=ord(Size=1)
else begin;
SolutionCount:=0;
Columns:=-2 shl (Size-1);
Col0:=1 shl (Size-1);
repeat;
Col1:=Col0 shr 2;
repeat;
Right:=Col0 shr 1 or Col1;
Left:=Col0 shl 1 + Col1;
BitwiseRecursive(Col0 or Col1 or Columns, Left shl 1, Right shr 1);
Col1:=Col1 shr 1;
until Col1=0;
Col0:=Col0 shr 1;
until Col0=2;
SolutionCount:=2*SolutionCount;
end;
end;Можно предположить, что совместное использование горизонтальной и вертикальной симметрий увеличит быстродействие еще в 2 раза. В моих экспериментах это не дало никакого выигрыша по сравнению с одной симметрией относительно вертикали. Причина в том, что симметрия относительно горизонтали ограничивает размещения ферзя в последней, а не во второй строке и поэтому начинает отсекать варианты слишком поздно. Читатель может самостоятельная проверить это.
Давайте рассмотрим совместное использование симметрии относительно вертикали и вращений на 90, 180 и 270 градусов. Теоретически это могло бы дать почти 8-кратное ускорение, т.к. большинство размещений ферзей не совпадут сами с собой при таких преобразованиях, и из одного фундаментального (уникального) размещения мы могли бы получить 2, 4 или 8 производных. На практике по ряду причин получается только примерно 4-кратное ускорение. Во-первых, снаружи основного цикла нам придется накладывать ограничения на размещения 3-4 ферзей на периметре доски (в общем случае на двух вертикалях и двух горизонталях, но рваная доска неудобна для циклов). Во вторых, как уже отмечалось, ограничения на последнюю строку начинают работать слишком поздно. В-третьих, диагональные ограничения на боковые столбцы в сумме эквивалентны только двум большим диагоналям. И, наконец, в-четвертых, и это самое важное, нам все равно придется определять, является ли полученное размещение фундаментальным, и определять его кратность, т.к. ограничения симметрии на периметр в общем случае не гарантируют фундаментальности порожденного размещения. Учетом этого последнего фактора как раз и обусловлена тяжеловесность приводимого алгоритма (страница автора):
// N-Queens Solutions ver3.2 takaken 2011
{
First queen is not here(X). [N>=2]
X X X - - - X X X - -
- - - - - - - - - - -
- - - - - - - - - - -
- - - - - - - - - - -
- - - - - - - - - - -
- - - - - -
If first queen is in the corner, a queen is not here(X).
X X X - X Q
- Q - - X -
- - - - X -
- - - - X -
- - - - - -
- - - - - -
First queen is inside, a queen is not here(X).
X X X X - Q X X
X - - - x x x X
C - - x - x - x
- - x - - x - -
- x - - - x - -
x - - - - x - A
X - - - - x - X
X X B - - x X X
If a queen is not in A and B and C, all Solutions is Unique.
Judgment value is investigated when that is not right.
90-degree rotation. (A)
180-degree rotation. (B)
270-degree rotation. (C)
Total Solutions from Unique Solutions
If first queen is in the corner.
Total Solutions = Unique Solutions X 8.
If first queen is inside.
If 90-degree rotation is same pattern as the original.
Total Solutions = Unique Solutions X 2.
Else if 180-degree rotation is same pattern as the original.
Total Solutions = Unique Solutions X 4.
Else
Total Solutions = Unique Solutions X 8.
}
const
MAXSIZE= 30;
MINSIZE= 5;
// Check Unique Solutions
procedure Check(board: PIntegerArray; size, last, topb, posa, posb, posc: integer; var cnt8, cnt4, cnt2: int64);
var
pos1, pos2, bit1, bit2: integer;
begin;
// 90-degree rotation
if board[posa]=1 then begin;
pos1:=1;
bit2:=2;
while pos1<size do begin;
pos2:=last;
bit1:=1;
while (board[pos1]<>bit1) and (board[pos2]<>bit2) do begin;
dec(pos2);
bit1:=bit1 shl 1;
end;
if board[pos1]<>bit1 then exit;
if board[pos2]<>bit2 then break;
inc(pos1);
bit2:=bit2 shl 1;
end;
if pos1=size then begin;
cnt2:=cnt2+1;
//Display(size, board);
exit;
end;
end;
// 180-degree rotation
if board[last]=posb then begin;
pos1:=1;
pos2:=size-2;
while pos1<size do begin;
bit2:=topb;
bit1:=1;
while (board[pos1]<>bit1) and (board[pos2]<>bit2) do begin;
bit2:=bit2 shr 1;
bit1:=bit1 shl 1;
end;
if board[pos1]<>bit1 then exit;
if board[pos2]<>bit2 then break;
inc(pos1);
dec(pos2);
end;
if pos1=size then begin;
cnt4:=cnt4+1;
//Display(size, board);
exit;
end;
end;
// 270-degree rotation
if board[posc]=topb then begin;
pos1:=1;
bit2:=topb shr 1;
while pos1<size do begin;
pos2:=0;
bit1:=1;
while (board[pos1]<>bit1) and (board[pos2]<>bit2) do begin;
inc(pos2);
bit1:=bit1 shl 1;
end;
if board[pos1]<>bit1 then exit;
if board[pos2]<>bit2 then break;
inc(pos1);
bit2:=bit2 shr 1;
end;
end;
cnt8:=cnt8+1;
//Display(size, board);
end;
// First queen is inside
procedure Inside(n, x0, x1: integer; var uniq, allc: int64);
var
size, last, y, i: integer;
bits, bit, mask, left, rigt: integer;
posa, posb, posc, topb, side, gate: integer;
board, s_mask, s_left, s_rigt, s_bits: array[0..MAXSIZE-1] of integer;
cnt8, cnt4, cnt2: int64;
label
NEXT1, NEXT2, NEXT3, PROC1, PROC2, PROC3, BACK1, BACK2, BACK3, FINISH;
begin;
// Initialize
size:=n;
last:=n - 1;
mask:=1 shl n - 1;
cnt8:=0;
cnt4:=0;
cnt2:=0;
// ControlValue
topb:=1 shl last;
side:=topb or 1;
gate:=(mask shr x0) and (mask shl x0);
posa:=last - x0;
posb:=topb shr x0;
posc:=x0;
// y:=0: 000001110 (select)
// y:=1: 111111111 (select)
board[0]:=1 shl x0;
bit:=1 shl x1;
board[1]:=bit;
mask:=mask xor (board[0] or bit);
left:=board[0] shl 2 or bit shl 1;
rigt:=board[0] shr 2 or bit shr 1;
i:=2;
y:=i;
// y -> posc
if posc=1 then goto NEXT2;
mask:=mask xor side;
NEXT1:
if i=posc then begin;
mask:=mask or side;
goto NEXT2;
end;
bits:=mask and not (left or rigt);
if bits<>0 then begin;
s_mask[i]:=mask;
s_left[i]:=left;
s_rigt[i]:=rigt;
PROC1:
bit:=-bits and bits;
bits:=bits xor bit;
board[i]:=bit;
s_bits[i]:=bits; inc(i);
mask:=mask xor bit;
left:=(left or bit) shl 1;
rigt:=(rigt or bit) shr 1;
goto NEXT1;
BACK1:
dec(i); bits:=s_bits[i];
if bits<>0 then begin;
mask:=s_mask[i];
left:=s_left[i];
rigt:=s_rigt[i];
goto PROC1;
end;
end;
if i=y then goto FINISH;
goto BACK1;
// posc -> posa
NEXT2:
bits:=mask and not (left or rigt);
if bits<>0 then begin;
s_mask[i]:=mask;
s_left[i]:=left;
s_rigt[i]:=rigt;
PROC2:
bit:=-bits and bits;
bits:=bits xor bit;
board[i]:=bit;
s_bits[i]:=bits; inc(i);
mask:=mask xor bit;
left:=(left or bit) shl 1;
rigt:=(rigt or bit) shr 1;
if i=posa then begin;
if mask and topb<>0 then goto BACK2;
if mask and 1<>0 then begin;
if (left or rigt) and 1<>0 then goto BACK2;
bits:=1;
end
else begin;
bits:=mask and not (left or rigt);
if bits=0 then goto BACK2;
end;
goto NEXT3;
end
else goto NEXT2;
BACK2:
dec(i); bits:=s_bits[i];
if bits<>0 then begin;
mask:=s_mask[i];
left:=s_left[i];
rigt:=s_rigt[i];
goto PROC2;
end;
end;
if i=y then goto FINISH;
if i>posc then goto BACK2;
goto BACK1;
// posa -> last
NEXT3:
if i=last then begin;
if bits and gate<>0 then begin;
board[i]:=bits;
Check(@board, size, last, topb, posa, posb, posc, cnt8, cnt4, cnt2);
end;
goto BACK3;
end;
s_mask[i]:=mask;
s_left[i]:=left;
s_rigt[i]:=rigt;
PROC3:
bit:=-bits and bits;
bits:=bits xor bit;
board[i]:=bit;
s_bits[i]:=bits; inc(i);
mask:=mask xor bit;
left:=(left or bit) shl 1;
rigt:=(rigt or bit) shr 1;
bits:=mask and not (left or rigt);
if bits<>0 then goto NEXT3;
BACK3:
dec(i); bits:=s_bits[i];
if bits<>0 then begin;
mask:=s_mask[i];
left:=s_left[i];
rigt:=s_rigt[i];
goto PROC3;
end;
if i>posa then goto BACK3;
goto BACK2;
FINISH:
uniq:=cnt8 + cnt4 + cnt2;
allc:=cnt8 * 8 + cnt4 * 4 + cnt2 * 2;
end;
// First queen is in the corner
procedure Corner(n, x1: integer; var uniq, allc: int64);
var
size, last, y, i: integer;
bits, bit, mask, left, rigt: integer;
posa: integer;
board, s_mask, s_left, s_rigt, s_bits: array[0..MAXSIZE-1] of integer;
cnt8: int64;
label
NEXT1, NEXT2, PROC1, PROC2, BACK1, BACK2, FINISH;
begin;
// Initialize
size:=n;
last:=n - 1;
mask:=1 shl n - 1;
cnt8:=0;
// ControlValue
posa:=x1;
// y:=0: 000000001 (static)
// y:=1: 011111100 (select)
board[0]:=1;
bit:=1 shl x1;
board[1]:=bit;
mask:=mask xor (1 or bit);
left:=1 shl 2 or bit shl 1;
rigt:=1 shr 2 or bit shr 1;
i:=2;
y:=i;
// y -> posa
mask:=mask xor 2;
NEXT1:
if i=posa then begin;
mask:=mask or 2;
goto NEXT2;
end;
bits:=mask and not (left or rigt);
if bits<>0 then begin;
s_mask[i]:=mask;
s_left[i]:=left;
s_rigt[i]:=rigt;
PROC1:
bit:=-bits and bits;
bits:=bits xor bit;
board[i]:=bit;
s_bits[i]:=bits; inc(i);
mask:=mask xor bit;
left:=(left or bit) shl 1;
rigt:=(rigt or bit) shr 1;
goto NEXT1;
BACK1:
dec(i); bits:=s_bits[i];
if bits<>0 then begin;
mask:=s_mask[i];
left:=s_left[i];
rigt:=s_rigt[i];
goto PROC1;
end;
end;
if i=y then goto FINISH;
goto BACK1;
// posa -> last
NEXT2:
bits:=mask and not (left or rigt);
if bits<>0 then begin;
if i=last then begin;
board[i]:=bits;
cnt8:=cnt8+1;
//Display(size, board);
goto BACK2;
end;
s_mask[i]:=mask;
s_left[i]:=left;
s_rigt[i]:=rigt;
PROC2:
bit:=-bits and bits;
bits:=bits xor bit;
board[i]:=bit;
s_bits[i]:=bits; inc(i);
mask:=mask xor bit;
left:=(left or bit) shl 1;
rigt:=(rigt or bit) shr 1;
goto NEXT2;
BACK2:
dec(i); bits:=s_bits[i];
if bits<>0 then begin;
mask:=s_mask[i];
left:=s_left[i];
rigt:=s_rigt[i];
goto PROC2;
end;
end;
if i=y then goto FINISH;
if i>posa then goto BACK2;
goto BACK1;
FINISH:
uniq:=cnt8;
allc:=cnt8 * 8;
end;
// Search of N-Queens
procedure Takaken2011(n: integer; var unique, allcnt: int64);
var
x0, x1: integer;
uniq, allc: int64;
begin;
unique:=0;
allcnt:=0;
for x0:=0 to n shr 1 - 1 do begin;
for x1:=0 to n-1 do begin;
if x0=0 then begin;
// y:=0: 000000001 (static)
// y:=1: 011111100 (select)
if (x1<2) or (x1=n-1) then continue;
Corner(n, x1, uniq, allc);
end
else begin;
// y:=0: 000001110 (select)
// y:=1: 111111111 (select)
if (x1>=x0-1) and (x1<=x0+1) then continue;
if (x0>1) and ((x1=0) or (x1=n-1)) then continue;
Inside(n, x0, x1, uniq, allc);
end;
unique:=unique + uniq;
allcnt:=allcnt + allc;
end;
end;
end;Задача 2M или Безнадега
Подсчитать все возможные расстановки без взаимных атак N ферзей на доске размером NxN при условии, что на доске уже стоят M неатакующих друг друга ферзей.
Для решения этой задачи мы адаптируем алгоритм BacktrackingBitwise, избавившись от рекурсии и добавив работу с предварительно заполненным массивом горизонталей Rows. Массив State выполняет роль стека и, кроме того, хранит маски атак поставленных ферзей.
procedure BacktrackingBitwiseComplete(Size: integer);
const
MaxSize=SizeOf(integer) * 8;
StateCount=MaxSize * 6;
var
Columns, Left, Right, Used, Place, No: integer;
State: array[0..StateCount-1] of integer;
begin;
if Size<4 then begin;
SolutionCount:=ord(Size=1); exit;
end;
SolutionCount:=0;
Columns:=-2 shl (Size-1);
for No:=0 to Size-1 do State[6*No]:=0;
for No:=0 to Size-1 do begin;
Used:=Rows[No]; //бит в строке соответствует предварительно поставленному ферзю
if Used<>0 then begin;
Columns:=Columns or Used;
for Place:=1 to MaxSize-1 do begin;
Left:=Used shl Place or Used shr Place;
Right:=No-Place; if Right>=0 then State[6*Right]:=State[6*Right] or Left;
Right:=No+Place; if Right<Size then State[6*Right]:=State[6*Right] or Left;
end;
end;
end;
Place:=0; Used:=0;
for No:=0 to Size-1 do begin;
inc(Used);
if Rows[No]=0 then begin;
State[6*Place]:=State[6*No] or Columns;
State[6*Place+5]:=Used;
inc(Place); Used:=0;
end;
end;
No:=0; Left:=0; Right:=0; Used:=Columns or State[No];
while true do begin;
while Used<>-1 do begin;
Place:=Used;
Used:=(Used+1) or Place;
Place:=Place xor Used;
Columns:=Columns or Place;
if Columns=-1 then begin;
inc(SolutionCount);
break;
end
else begin;
State[No+1]:=Left; State[No+2]:=Right; State[No+3]:=Used; State[No+4]:=Columns xor Place;
Used:=State[No+11]; inc(No,6);
Left:=(Left or Place) shl Used;
Right:=(Right or Place) shr Used;
Used:=Columns or Left or Right or State[No];
end;
end;
dec(No,6);
if No<0 then exit;
Left:=State[No+1]; Right:=State[No+2]; Used:=State[No+3]; Columns:=State[No+4];
end;
end;На доске размером 32x32 при заданном предварительном размещении 12 ферзей алгоритм обычно находит все возможные размещения остальных 20 ферзей менее, чем за 1 минуту.
При больших значениях N уже невозможно представить горизонталь шахматной доски целым числом, и вместо операций сразу над всеми битами строки придется использовать индивидуальные проверки для каждого столбца. В результате скорость алгоритмов поиска с возвратом падает в несколько раз:
procedure BacktrackingRecursive(Queen: integer);
var
Col, Row: integer;
begin;
with QueenColRow[Queen] do begin;
Row:=QueenRow;
for Col:=0 to BoardSize-1 do begin;
if CountCol[Col] or CountDiagP[Col+Row] or CountDiagM[Col-Row]=0 then begin;
QueenCol:=Col;
CountCol[Col]:=1;
CountDiagP[Col+Row]:=1;
CountDiagM[Col-Row]:=1;
if Queen>0 then BacktrackingRecursive(Queen-1) else CountSolution;
CountCol[Col]:=0;
CountDiagP[Col+Row]:=0;
CountDiagM[Col-Row]:=0;
end;
end;
end;
end;Здесь Queen - номер ферзя, которого ставим на доску, декрементируется перед рекурсивным вызовом. Данный алгоритм использует те же самые переменные и процедуры InitBoard и SetColRow, что и алгоритм GradientSearch из раздела 1M.
Скорость можно увеличить примерно на 20%, если убрать рекурсию:
procedure BacktrackingIterative;
var
Queen, Col, Row: integer;
begin;
Queen:=QueenCount-1;
if Queen>=0 then begin;
with QueenColRow[Queen] do begin;
Col:=BoardSize-1;
Row:=QueenRow;
end;
while true do begin;
while Col>=0 do begin;
if CountCol[Col] or CountDiagP[Col+Row] or CountDiagM[Col-Row]=0 then begin;
CountCol[Col]:=1;
CountDiagP[Col+Row]:=1;
CountDiagM[Col-Row]:=1;
QueenColRow[Queen].QueenCol:=Col;
if Queen>0 then begin;
dec(Queen);
Row:=QueenColRow[Queen].QueenRow;
Col:=BoardSize-1;
continue;
end;
CountSolution;
//exit; //comment this statement to count all solutions
CountCol[Col]:=0;
CountDiagP[Col+Row]:=0;
CountDiagM[Col-Row]:=0;
end;
dec(Col);
end;
inc(Queen);
if Queen>=QueenCount then break;
with QueenColRow[Queen] do begin;
Col:=QueenCol;
Row:=QueenRow;
end;
CountCol[Col]:=0;
CountDiagP[Col+Row]:=0;
CountDiagM[Col-Row]:=0;
dec(Col);
end;
end
else CountSolution;
end;Продолжение следует, но как обычно задерживается в пути.