Задача о расстановке ферзей / Queen
.rtf
1. ЗАДАЧА
Расставить на шахматной доске размера N на N, N ферзей так, чтобы ни один ферзь не угрожал другому.
Пример:
номера горизонталей
¦
----T---T---T---T---T---T---T---¬
1 ¦ * ¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
+---+---+---+---+---+---+---+---+
2 ¦ ¦ ¦ ¦ ¦ ¦ ¦ * ¦ ¦
+---+---+---+---+---+---+---+---+
3 ¦ ¦ ¦ ¦ ¦ * ¦ ¦ ¦ ¦
+---+---+---+---+---+---+---+---+
4 ¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦ * ¦
+---+---+---+---+---+---+---+---+
5 ¦ ¦ * ¦ ¦ ¦ ¦ ¦ ¦ ¦
+---+---+---+---+---+---+---+---+
6 ¦ ¦ ¦ ¦ * ¦ ¦ ¦ ¦ ¦
+---+---+---+---+---+---+---+---+
7 ¦ ¦ ¦ ¦ ¦ ¦ * ¦ ¦ ¦
+---+---+---+---+---+---+---+---+
8 ¦ ¦ ¦ * ¦ ¦ ¦ ¦ ¦ ¦
L---+---+---+---+---+---+---+----
1 2 3 4 5 6 7 8 - номера вертикалей
2. ИДЕИ АЛГОРИТМОВ
Рассмотренные в работе решения основаны на алгоритме с возвратом.
Общая схема алгоритма поиска всех возможных решений:
procedure Queen ( i : integer );
{Ставим i-го ферзя в i-ую вертикаль}
begin
инициировать выбор позиции для i-го ферзя;
repeat
выбрать позицию;
if безопасно then
begin
поставить ферзя;
if i < N then Queen ( i+1 )
else записать решение;
убрать ферзя;
end
until нет больше позиций;
end;
Различие двух алгоритмов заключается в том, как представить данные о том, куда можно поставить очередного ферзя, а куда - нельзя.
Алг1:
Хранит на каждом шаге одну границу S [1..N] (т.е. ферзя можно попытаться поставить на горизонталь от S до N) и поднимает ее, пока не получит S=N, тогда происходит возврат.
В этом случае для того, чтобы проверить, можно ли поставить очередного ферзя, нужно вернутся ко всем уже поставленным.
Алг2:
Хранит множество возможных позиций в явном виде тремя массивами
H [1..N] занята(false) горизонталь
D1[2..2*N] занята(false) /-диагональ
D2[1-N..N-1] занята(false) \-диагональ
В этом случае проверка того, можно ли поставить нового ферзя, достаточно проста.
Заметим, что среди полученных решений есть много симметричных, некоторые из них можно отсечь, если начинать заполнять первую вертикаль со второй горизонтали и заполнять только до середины.
ПРИМЕЧАНИЕ: Алг2 рассмотрен в книге Н. Вирта "Алгоритмы + структуры данных = программы"
3. КОММЕНТАРИИ К РАБОТЕ
К отчету прилагаются программы, находящиеся в директории QUEEN.
Программы реализованные по Алг1 в QUEEN95.
Программы реализованные по Алг2 в QUEEN99.
В каждом из этих директориев находятся программы с учетом некоторых
симметричных решений (QUEEN) и без (QUEEN1).
В директориях под названием MONTECAR находятся программы, оценивающие
количество вариантов, перебираемых соответствующим алгоритмом.
Работа всех программ оценивалась по времени, результаты оценок
хранятся в файлах с расширением (tab).
Варианты решений для 8<=N<=14 хранятся в файлах с расширением (dat).
4 ТАБЛИЦЫ РЕЗУЛЬТАТОВ И РЕШЕНИЯ.
4.1 ТАБЛИЦЫ СРАВНЕНИЯ РЕЗУЛЬТАТОВ РАБОТЫ ПРОГРАММ
НАПИСАННЫХ ПО Алг1 и Алг2.
Результаты тестирования программы queen.pas из ...\QUEEN\QUEEN95\QUEEN\...
и ...QUEEN\QUEEN99\QUEEN\... соответственно.
количество ферзей - n
количество узлов в дереве поиска - N
количество найденных решений - nS
время решения - T и T1 соответственно
...\QUEEN\QUEEN95\QUEEN\... и ...QUEEN\QUEEN99\QUEEN\...
( с учетом симметрии некоторых решений)
----T-------T----------T----------------T----------------¬
¦ n ¦ nS ¦ N ¦ T ¦ T1 ¦
+---+-------+----------+----------------+----------------+
¦ 8 ¦ 42¦ 801¦ 0 мин 0.06 сек¦ 0 мин 0.00 сек¦
¦ ¦ ¦ ¦ ¦ ¦
¦ 9 ¦ 121¦ 2 857¦ 0 мин 0.16 сек¦ 0 мин 0.06 сек¦
¦ ¦ ¦ ¦ ¦ ¦
¦10 ¦ 298¦ 14 566¦ 0 мин 0.71 сек¦ 0 мин 0.11 сек¦
¦ ¦ ¦ ¦ ¦ ¦
¦11 ¦ 1 069¦ 62 284¦ 0 мин 3.63 сек¦ 0 мин 0.50 сек¦
¦ ¦ ¦ ¦ ¦ ¦
¦12 ¦ 6 600¦ 367 016¦ 0 мин 24.93 сек¦ 0 мин 2.91 сек¦
¦ ¦ ¦ ¦ ¦ ¦
¦13 ¦ 30 061¦ 1 840 253¦ 2 мин 20.17 сек¦ 0 мин 14.94 сек¦
¦ ¦ ¦ ¦ ¦ ¦
¦14 ¦170 906¦12 075 381¦ - ¦ 1 мин 39.47 сек¦
¦ ¦ ¦ ¦ ¦ ¦
L---+-------+----------+----------------+-----------------
Результаты тестирования программы queen1.pas из ...\QUEEN\QUEEN95\QUEEN1\...
и ...QUEEN\QUEEN99\QUEEN1\... соответственно.
количество ферзей - n
количество узлов в дереве поиска - N
количество найденых решений - nS
время решения - T и T1 соответсвенно
...\QUEEN\QUEEN95\QUEEN1\... и ...QUEEN\QUEEN99\QUEEN1\...
( все решения )
----T-------T----------T----------------T---------------¬
¦ n ¦ nS ¦ N ¦ T ¦ T1 ¦
+---+-------+----------+----------------+---------------+
¦ 8 ¦ 92¦ 2 056¦ 0 мин 0.11 сек¦0 мин 0.06 сек¦
¦ ¦ ¦ ¦ ¦ ¦
¦ 9 ¦ 352¦ 8 393¦ 0 мин 0.38 сек¦0 мин 0.11 сек¦
¦ ¦ ¦ ¦ ¦ ¦
¦10 ¦ 724¦ 35 538¦ 0 мин 1.75 сек¦0 мин 0.28 сек¦
¦ ¦ ¦ ¦ ¦ ¦
¦11 ¦ 2 680¦ 166 925¦ 0 мин 9.45 сек¦0 мин 1.21 сек¦
¦ ¦ ¦ ¦ ¦ ¦
¦12 ¦ 14 200¦ 856 188¦ 0 мин 56.51 сек¦0 мин 6.59 сек¦
¦ ¦ ¦ ¦ ¦ ¦
¦13 ¦ 73 712¦ 4 674 889¦ 5 мин 54.49 сек¦0 мин 38.45 сек¦
¦ ¦ ¦ ¦ ¦ ¦
¦14 ¦365 596¦27 358 552¦ - ¦3 мин 40.91 сек¦
¦ ¦ ¦ ¦ ¦ ¦
L---+-------+----------+----------------+----------------
4.2 РЕЗУЛЬТАТЫ СЧЕТА И ОЦЕНКИ МЕТОДОМ МОНТЕ-КАРЛО
количество ферзей - n
количество узлов в дереве поиска - N
количество найденых решений - nS
время решения - T
количество испытаний - nExp
оценка количества узлов в дереве поиска - N^
время работы программы оценки - t
Тестировались прграммы ...\QUEEN\QUEEN95\QUEEN\...
----T-------T----------T----------------T-----------T------T---------¬
¦ n ¦ nS ¦ N ¦ T ¦ N^ ¦ nExp ¦ t ¦
+---+-------+----------+----------------+-----------+------+---------+
¦ 8 ¦ 42¦ 801¦ 0 мин 0.06 сек¦ 812¦ 1000 ¦ 0.17 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
¦ 9 ¦ 121¦ 2 857¦ 0 мин 0.16 сек¦ 2 899¦ 1000 ¦ 0.22 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
¦10 ¦ 298¦ 14 566¦ 0 мин 0.71 сек¦ 14 632¦ 1000 ¦ 0.22 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
¦11 ¦ 1 069¦ 62 284¦ 0 мин 3.63 сек¦ 60 549¦ 1000 ¦ 0.33 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
¦12 ¦ 6 600¦ 367 016¦ 0 мин 24.93 сек¦ 377 011¦ 1000 ¦ 0.44 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
¦13 ¦ 30 061¦ 1 840 253¦ 2 мин 20.17 сек¦ 1 872 805¦ 1000 ¦ 0.49 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
¦14 ¦ - ¦ - ¦ - ¦ 11 814 047¦ 1000 ¦ 0.54 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
¦15 ¦ - ¦ - ¦ - ¦ 68 186 811¦ 1000 ¦ 0.66 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
L---+-------+----------+----------------+-----------+------+----------
Тестировались программы ...\QUEEN\QUEEN95\QUEEN1\...
----T-------T----------T----------------T-------------T------T---------¬
¦ n ¦ nS ¦ N ¦ T ¦ N^ ¦ nExp ¦ t ¦
+---+-------+----------+----------------+-------------+------+---------+
¦ 8 ¦ 92¦ 2 056¦ 0 мин 0.11 сек¦ 2 038¦ 1000 ¦ 0.17 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
¦ 9 ¦ 352¦ 8 393¦ 0 мин 0.38 сек¦ 8 312¦ 1000 ¦ 0.22 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
¦10 ¦ 724¦ 35 538¦ 0 мин 1.75 сек¦ 37 881¦ 1000 ¦ 0.27 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
¦11 ¦ 2 680¦ 166 925¦ 0 мин 9.45 сек¦ 161 948¦ 1000 ¦ 0.33 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
¦12 ¦ 14 200¦ 856 188¦ 0 мин 56.51 сек¦ 849 387¦ 1000 ¦ 0.38 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
¦13 ¦ 73 712¦ 4 674 889¦ 5 мин 54.49 сек¦ 4 671 732¦ 1000 ¦ 0.49 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
¦14 ¦ - ¦ - ¦ - ¦ 28 439 200¦ 1000 ¦ 0.60 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
¦15 ¦ - ¦ - ¦ - ¦ 172 600 442¦ 1000 ¦ 0.71 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
L---+-------+----------+----------------+-------------+------+----------
Тестировались программы ...\QUEEN\QUEEN99\QUEEN1\...
----T-------T----------T----------------T-------------T-------T---------¬
¦ n ¦ nS ¦ N ¦ T ¦ N^ ¦ nExp ¦ t ¦
+---+-------+----------+----------------+-------------+-------+---------+
¦ 8 ¦ 92¦ 2 056¦ 0 мин 0.06 сек¦ 2 040¦ 10000 ¦ 0.83 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
¦ 9 ¦ 352¦ 8 393¦ 0 мин 0.11 сек¦ 8 376¦ 10000 ¦ 0.99 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
¦10 ¦ 724¦ 35 538¦ 0 мин 0.28 сек¦ 35 421¦ 10000 ¦ 1.16 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
¦11 ¦ 2 680¦ 166 925¦ 0 мин 1.21 сек¦ 166 431¦ 10000 ¦ 1.32 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
¦12 ¦ 14 200¦ 856 188¦ 0 мин 6.59 сек¦ 849 257¦ 10000 ¦ 1.49 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
¦13 ¦ 73 712¦ 4 674 889¦ 0 мин 38.45 сек¦ 4 605 375¦ 10000 ¦ 1.71 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
¦14 ¦365 596¦27 358 552¦ 3 мин 40.91 сек¦ 27 282 972¦ 10000 ¦ 1.92 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
¦15 ¦ - ¦ - ¦ - ¦ 170 106 627¦ 10000 ¦ 2.09 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
¦16 ¦ - ¦ - ¦ - ¦1 163 698 634¦ 10000 ¦ 2.36 сек¦
¦ ¦ ¦ ¦ ¦ ¦ ¦ ¦
L---+-------+----------+----------------+-------------+-------+----------
Программы тестировалась на 486\dx100.
4.3 ВАРИАНТЫ РЕШЕНИЙ.
количество ферзей = 8
р е ш е н и я :
1: 1 5 8 6 3 7 2 4
------------------------------
92: 8 4 1 3 6 2 7 5
количество ферзей = 9
р е ш е н и я :
1: 1 3 6 8 2 4 9 7 5
---------------------------------
352: 9 7 4 2 8 6 1 3 5
количество ферзей = 10
р е ш е н и я :
1: 1 3 6 8 10 5 9 2 4 7
-----------------------------------
724: 10 8 5 3 1 6 2 9 7 4
количество ферзей = 11
р е ш е н и я :
1: 1 3 5 7 9 11 2 4 6 8 10
-------------------------------------------
2680: 11 9 7 5 3 1 10 8 6 4 2
количество ферзей = 12
р е ш е н и я :
1: 1 3 5 8 10 12 6 11 2 7 9 4
------------------------------------------
14200: 12 10 8 5 3 1 7 2 11 6 4 9
количество ферзей = 13
р е ш е н и я :
1: 1 3 5 2 9 12 10 13 4 6 8 11 7
----------------------------------------------
73712: 13 11 9 12 5 2 4 1 10 8 6 3 7
количество ферзей = 14
р е ш е н и я :
1: 1 3 5 7 12 10 13 4 14 9 2 6 8 11
--------------------------------------------------
365596: 14 12 10 8 3 5 2 11 1 6 13 9 7 4
ПРИМЕЧАНИЕ: в работе использовались готовые программы, которые находятся в ...\QUEEN\QUEEN95\QUEEN\....
5.ПРОГРАММЫ.
{===========================================================================}
Процедуры для измерения времени общие для всех программ.
procedure MyGetTime ( var t : LongInt );
{выдает время в сотых долях секунды}
var h, m, s , hund : Word;
begin
GetTime( h, m , s, hund);
t := s + 60 * m;
t := hund + 100 * t
end { MyGetTime };
procedure MyUnPackTime ( t: LongInt; var m, s, hund : Word );
{переводит время t (в сотых долях секунды)
в минуты m, секунды s, сотые hund }
begin
hund := t mod 100;
t := t div 100; {в секунах}
s := t mod 60;
m := t div 60
end { MyUnPackTime };
{==========================================================================}
QUEEN.PAS Алг1
{Программа отсеивающая некоторые варианты симметричных решений.}
program queen_;
Uses Dos;
const maxN = 20;
type Nat = 1..maxN;
var n : Nat;
fout : Text;
t, t1,t2 : LongInt;
min, sec, s100 : Word;
procedure Queen( n : Nat );
type Nat0 = 0..maxN;
Nat1 = 1..maxN+1;
pos = array [Nat] of Nat1;
var k : Nat0;
i : Nat;
a, s : pos; { s[k] - наименьший элемент множества Sk }
{ неопробованных (допустимых) значений }
count : Longint; { счетчик обследованных узлов дерева поиска}
countS : Longint; { счетчик найденых решений }
n_div_2 : Nat0;
function NoQueen : Boolean;
{ NoQueen = 'ферзь не может быть поставлен в строку s[k] столбца k' }
var Flag : Boolean;
i : Nat;
begin {NoQueen}
Flag := True;
i := 1;
while (i<k) and Flag do
begin { Flag='ферзи [1..i) не атакуют поле <k,s[k]>'}
{ атакует ли ферзь из i-го столбца поле <k,s[k]>?}
Flag := not ( (a[i]=s[k]) or (abs(a[i]-s[k])=k-i) );
i := i+1
end {while};
NoQueen := not Flag
end {NoQueen};
procedure RestSk;
{ найти следующее наименьшее значение s[k],
начиная с текущего s[k]; если такового нет, то s[k]=n+1 }
begin
while (s[k]<=n) and NoQueen do s[k] := s[k] + 1
end {RestSk};
begin{Queen}
a[1] := 2; s[1] := 3;
k := 2; s[2] := 4;
count := 1; countS := 0; n_div_2 := n div 2;
while k>0 do
begin
while (k>1) and (s[k]<=n) or (k=1) and (s[1]<=(n_div_2)) do
begin
a[k] := s[k];
s[k] := s[k] + 1;
RestSk;
count := count + 1;
if k=n then
begin { решение найдено }
countS := countS + 1; Write(fout,countS:5,' :: ');
for i:=1 to n do Write(fout, a[i]:3); WriteLn(fout)
end { фиксации решения }
else
begin { переход к следующей вертикали }
k := k + 1;
s[k] := 1;
RestSk
end {if}
end {while};
k := k-1 {backtrack}
end {while};
WriteLn(fout,'всего вершин = ',count)
end {Queen};
begin
WriteLn(' n=?'); ReadLn(n);
Assign(fout,'QOUT.DAT');
Rewrite{Append}(fout);
WriteLn(fout,'количество ферзей = ',n:2);
WriteLn(fout,'р е ш е н и я :');
MyGetTime(t1);
Queen ( n );
MyGetTime(t2);
t := t2 - t1; MyUnPackTime( t, min, sec, s100);
if(s100<10)
then WriteLn(fout,'время = ', min,' мин ', sec,'.0', s100,' сек')
else WriteLn(fout,'время = ', min,' мин ', sec,'.', s100,' сек');
Close (fout)
end.
{===========================================================================}
QUEEN1.PAS Алг1
{ поиск всех решений }
program queen_;
Uses Dos;
const maxN = 20;
type Nat = 1..maxN;
var n : Nat;
fout : Text;
t, t1,t2 : LongInt;
min, sec, s100 : Word;
procedure Queen( n : Nat );
type Nat0 = 0..maxN;
Nat1 = 1..maxN+1;
pos = array [Nat] of Nat1;
var k : Nat0;
i : Nat;
a, s : pos; { s[k] - наименьший элемент множества Sk }
{ неопробованных (допустимых) значений }
count : Longint; { счетчик обследованных узлов дерева поиска}
countS : Longint; { счетчик найденых решений }
function NoQueen : Boolean;
{ NoFerz = 'ферзь не может быть поставлен в строку s[k] столбца k' }
var Flag : Boolean;
i : Nat;
begin {NoFerz}
Flag := True;
i := 1;
while (i<k) and Flag do
begin { Flag='ферзи [1..i) не атакуют поле <k,s[k]>'}
{ атакует ли ферзь из i-го столбца поле <k,s[k]>?}
Flag := not ( (a[i]=s[k]) or (abs(a[i]-s[k])=k-i) );
i := i+1
end {while};
NoQueen := not Flag
end {NoQueen};
procedure RestSk;
{ найти следующее наименьшее значение s[k],
начиная с текущего s[k]; если такового нет, то s[k]=n+1 }
begin
while (s[k]<=n) and NoQueen do s[k] := s[k] + 1
end {RestSk};
begin{queen}
a[1] := 1; s[1] := 1;
k := 1;
count :=0; countS := 0;
while k>0 do
begin
while (k>=1) and (s[k]<=n) do
begin
a[k] := s[k];
s[k] := s[k] + 1;
RestSk;
count := count + 1;
if k=n then
begin { решение найдено }
countS := countS + 1; Write(fout,countS:7,' :: ');
for i:=1 to n do Write(fout, a[i]:3); WriteLn(fout)
end { фиксации решения }
else
begin { переход к следующей вертикали }
k := k + 1;
s[k] := 1;
RestSk
end {if}
end {while};
k := k-1 {backtrack}
end {while};
WriteLn(fout,'всего вершин = ',count)
end {Queen};
begin
WriteLn(' n=?'); ReadLn(n);
Assign(fout,'QOUT.DAT');
Rewrite{Append}(fout);
WriteLn(fout,'количество ферзей = ',n:2);
WriteLn(fout,'р е ш е н и я :');
MyGetTime(t1);
Queen ( n );
MyGetTime(t2);
t := t2 - t1; MyUnPackTime( t, min, sec, s100);
if(s100<10)
then WriteLn(fout,'время = ', min,' мин ', sec,'.0', s100,' сек')
else WriteLn(fout,'время = ', min,' мин ', sec,'.', s100,' сек');
Close (fout)
end.
{===========================================================================}
QUEEN.PAS Алг2
{Программа отсеивающая некоторые варианты симметричных решений.}
Uses Dos,crt;
const MaxN=15;
type Nat=1..MaxN;
var
H:array[1..MaxN] of boolean; { занята(false) горизонталь }
D1:array[2..2*MaxN] of boolean; { занята(false) /-диагональ }
D2:array[1-MaxN..MaxN-1] of boolean;{ занята(false) \-диагональ }
N:Nat; { размер доски(количество ферзей) }
X:array[1..MaxN] of Nat; { решение }
fout:text; {выходной файл}
{--------------------------------------------------------------------------}
t, t1,t2 : LongInt;
min, sec, s100 : Word;
countS, { количество решений(без учета симметрии) }
count:Longint;{ количество вершин в дереве }
n_div_2,j:integer;
{--------------------------------------------------------------------------}
procedure print;
{ вывод решения в файл}
var k:Nat;
begin
countS:=countS+1;
write(fout,countS:8,':');
for k:=1 to N do write(fout,X[k]:3);
writeln(fout);
end{ print };
procedure Queen(i:Nat);
{ находит все возможные решения задачи (без учета симметрии) }
var j:Nat;
begin
for j:=1 to N do
if H[j] and D1[i+j] and D2[i-j] then { можно поставить }
begin
X[i]:=j; count:=count+1;
H[j]:=false; D1[i+j]:=false; D2[i-j]:=false; { ставим }
if i<N then Queen(i+1)
else print;
H[j]:=true; D1[i+j]:=true; D2[i-j]:=true; { убираем }
end;
end{ Ferz };
procedure Mass;
{ изначально массивы пусты(нет занятых позиций) }
var i:integer;
begin
for i:=1 to N do H[i]:=true;
for i:=2 to 2*N do D1[i]:=true;
for i:=1-N to N-1 do D2[i]:=true;
end{ Mass };
begin
clrscr;
Write('Введите размеры доски (N):'); ReadLn(n);
Assign(fout,'QOut___.DAT');
Rewrite(fout);
WriteLn(fout,'количество ферзей = ',n:2);
WriteLn(fout,'р е ш е н и я :');
MyGetTime(t1);
count:=0; countS:=0; Mass;
n_div_2:=(n div 2);
for j:=2 to n_div_2 do
begin
X[1]:=j; count:=count+1;
H[j]:=false; D1[1+j]:=false; D2[1-j]:=false;
Queen(2);
H[j]:=true; D1[1+j]:=true; D2[1-j]:=true;
end;
MyGetTime(t2);
t := t2 - t1; MyUnPackTime( t, min, sec, s100);
Writeln(fout,' всего вершин = ',count);
if(s100<10)
then Write(fout,'время = ', min,' мин ', sec,'.0', s100,' сек')
else Write(fout,'время = ', min,' мин ', sec,'.', s100,' сек');
Close (fout)
end.
{===========================================================================}
QUEEN1.PAS Алг2
{ поиск всех решений }
Uses Dos,crt;
const MaxN=15;
type Nat=1..MaxN;
var
H:array[1..MaxN] of boolean; { занята(false) горизонталь }
D1:array[2..2*MaxN] of boolean; { занята(false) /-диагональ }
D2:array[1-MaxN..MaxN-1] of boolean;{ занята(false) \-диагональ }
N:Nat; { размер доски(количество ферзей) }
X:array[1..MaxN] of Nat; { решение }
fout:text; {выходной файл}
{--------------------------------------------------------------------------}
t, t1,t2 : LongInt;
min, sec, s100 : Word;
countS, { количество решений(без учета симметрии) }
count:Longint;{ количество вершин в дереве }
{--------------------------------------------------------------------------}
procedure print;
{ вывод решения в файл}
var k:Nat;
begin
countS:=countS+1;
write(fout,countS:8,':');
for k:=1 to N do write(fout,X[k]:3);
writeln(fout);
end{ print };
procedure Queen(i:Nat);
{ находит все возможные решения задачи (без учета симметрии) }
var j:Nat;
begin
for j:=1 to N do
if H[j] and D1[i+j] and D2[i-j] then { можно поставить }
begin
X[i]:=j; count:=count+1;
H[j]:=false; D1[i+j]:=false; D2[i-j]:=false; { ставим }
if i<N then Queen(i+1)
else print;
H[j]:=true; D1[i+j]:=true; D2[i-j]:=true; { убираем }
end;
end{ Ferz };
procedure Mass;
{ изначально массивы пусты(нет занятых позиций) }
var i:integer;
begin
for i:=1 to N do H[i]:=true;
for i:=2 to 2*N do D1[i]:=true;
for i:=1-N to N-1 do D2[i]:=true;
end{ Mass };
begin
clrscr;
Write('Введите размеры доски (N):'); ReadLn(n);
Assign(fout,'QOut.DAT');
Rewrite(fout);
WriteLn(fout,'количество ферзей = ',n:2);
WriteLn(fout,'р е ш е н и я :');
MyGetTime(t1);
count:=0; countS:=0; Mass;
Queen(1);
MyGetTime(t2);
t := t2 - t1; MyUnPackTime( t, min, sec, s100);
Writeln(fout,' всего вершин = ',count);
if(s100<10)
then Write(fout,'время = ', min,' мин ', sec,'.0', s100,' сек')
else Write(fout,'время = ', min,' мин ', sec,'.', s100,' сек');
Close (fout)
end.
{===========================================================================}
MONTECAR.PAS Алг1
{Программа отсеивающая некоторые варианты симметричных решений.}
program Monte_Carlo;
Uses Crt, Dos;
const maxN = 20;
type Nat = 1..maxN;
Nat0 = 0..maxN;
pos = array[Nat] of Nat;
var n : Nat;
nExp : integer;
v : Double;
fout : Text;
t, t1,t2 : LongInt;
min, sec, s100 : Word;
procedure MonteCarlo ( nExp : integer; n : Nat; var v: Double );
var k : Nat0;
m_k, num : Nat0;
i : Nat;
iExp : Word;
a, S_k : pos;
n_div_2 : Nat0;
all, sum, prod : Double;
function NoQueen ( k: Nat; s: Nat) : Boolean;
{ NoFerz = 'ферзь не может быть поставлен в строку s столбца k' }
{ массив a[*] - внешний }
var Flag : Boolean;
i : Nat;
begin {NoQueen}
Flag := True;
i := 1;
while (i<k) and Flag do
begin { Flag='ферзи [1..i) не атакуют поле <k,s>'}
{ атакует ли ферзь из i-го столбца поле <k,s>?}
Flag := not ( (a[i]=s) or (abs(a[i]-s)=k-i) );
i := i+1
end {while};
NoQueen := not Flag
end {NoQueen};
procedure FormSk ( k: Nat; var m_k: Nat0; var S_k: pos );
{ формирует "множество" (вектор) S_k возможных ходов и
его мощность m_k; если S_k пусто, то m_k=0 }
var s: Nat;
begin
m_k := 0;
for s:=1 to n do
if not NoQueen( k, s) then
begin { можно ставить }
m_k := m_k + 1;
S_k[m_k] := s
end;
end {FormSk};
begin { MonteCarlo }
Randomize;
n_div_2 := n div 2;
all := 0;
for iExp:=1 to nExp do
begin { очередное испытание }
m_k := n_div_2 - 1;
num := Random ( m_k ) + 1;
a[1] := 1+num;
k := 2;
prod := m_k;
sum := prod;
FormSk ( k, m_k, S_k );
while m_k<>0 do
begin
prod := prod*m_k;
sum := sum + prod;
num := Random ( m_k ) + 1;
a[k] := S_k[num];
k := k + 1;
FormSk ( k, m_k, S_k );
end {while};
all := all + sum
end {for};
v := all/nExp
end { MonteCarlo };
begin
WriteLn(' n = ?'); ReadLn(n);
WriteLn(' nExp = ?'); ReadLn(nExp);
Assign(fout,'MONTEC.DAT');
Rewrite{Append}(fout);
WriteLn(fout,'количество ферзей = ',n:2);
WriteLn(fout,'количество испытаний = ',nExp:2);
MyGetTime(t1);
MonteCarlo ( nExp, n, v );
MyGetTime(t2);
WriteLn(fout,'количество узлов в дереве поиска :', v :12:1 );
t := t2 - t1; MyUnPackTime( t, min, sec, s100);
if(s100<10)
then WriteLn(fout,'время = ', min,' мин ', sec,'.0', s100,' сек')
else WriteLn(fout,'время = ', min,' мин ', sec,'.', s100,' сек');
Close (fout)
end.
{===========================================================================}
MONTECAR.PAS Алг1
{ поиск всех решений }
program Monte_Carlo;
Uses Crt, Dos;
const maxN = 20;
type Nat = 1..maxN;
Nat0 = 0..maxN;
pos = array[Nat] of Nat;
var n : Nat;
nExp : integer;
v : Double;
fout : Text;
t, t1,t2 : LongInt;
min, sec, s100 : Word;
procedure MonteCarlo ( nExp : integer; n : Nat; var v: Double );
var k : Nat0;
m_k, num : Nat0;
i : Nat;
iExp : Word;
a, S_k : pos;
n_div_2 : Nat0;
all, sum, prod : Double;
function NoFerz ( k: Nat; s: Nat) : Boolean;
{ NoFerz = 'ферзь не может быть поставлен в строку s столбца k' }
{ массив a[*] - внешний }
var Flag : Boolean;
i : Nat;
begin {NoFerz}
Flag := True;
i := 1;
while (i<k) and Flag do
begin { Flag='ферзи [1..i) не атакуют поле <k,s>'}
{ атакует ли ферзь из i-го столбца поле <k,s>?}
Flag := not ( (a[i]=s) or (abs(a[i]-s)=k-i) );
i := i+1
end {while};
NoFerz := not Flag
end {NoFerz};
procedure FormSk ( k: Nat; var m_k: Nat0; var S_k: pos );
{ формирует "множество" (вектор) S_k возможных ходов и
его мощность m_k; если S_k пусто, то m_k=0 }
var s: Nat;
begin
m_k := 0;
for s:=1 to n do
if not NoFerz( k, s) then
begin { можно ставить }
m_k := m_k + 1;
S_k[m_k] := s
end;
end {FormSk};
begin { MonteCarlo }
Randomize;
n_div_2 := n div 2;
all := 0;
for iExp:=1 to nExp do
begin { очередное испытание }
m_k :=n-1;
num := Random ( m_k )+1;
a[1] := num+1;
k := 1;
prod :=1;
sum := prod;
FormSk ( k, m_k, S_k );
while m_k<>0 do
begin
prod := prod*m_k;
sum := sum + prod;
num := Random ( m_k ) + 1;
a[k] := S_k[num];
k := k + 1;
FormSk ( k, m_k, S_k );
end {while};
all := all + sum
end {for};
v := all/nExp
end { MonteCarlo };
begin
WriteLn(' n = ?'); ReadLn(n);
WriteLn(' nExp = ?'); ReadLn(nExp);
Assign(fout,'MONTEC.DAT');
Rewrite{Append}(fout);
WriteLn(fout,'количество ферзей = ',n:2);
WriteLn(fout,'количество испытаний = ',nExp:2);
MyGetTime(t1);
MonteCarlo ( nExp, n, v );
MyGetTime(t2);
WriteLn(fout,'количество узлов в дереве поиска :', v :12:1 );
t := t2 - t1; MyUnPackTime( t, min, sec, s100);
if(s100<10)
then WriteLn(fout,'время = ', min,' мин ', sec,'.0', s100,' сек')
else WriteLn(fout,'время = ', min,' мин ', sec,'.', s100,' сек');
Close (fout)
end.
{===========================================================================}
MONTECAR.PAS Алг2
{ поиск всех решений }
Uses Dos,crt;
const MaxN=16;
type Nat=1..MaxN;
Nat0=0..MaxN;
var
H:array[1..MaxN] of boolean; { занята(false) горизонталь }
D1:array[2..2*MaxN] of boolean; { занята(false) /-диагональ }
D2:array[1-MaxN..MaxN-1] of boolean;{ занята(false) \-диагональ }
N:Nat;
nExp:integer; { количество проходов по дереву }
v:Real; { количество корней }
fout:text; {выходной файл}
{--------------------------------------------------------------------------}
t, t1,t2 : LongInt;
min, sec, s100 : Word;
{--------------------------------------------------------------------------}
procedure Mass;
{ изначально массивы пусты(нет занятых позиций) }
var i:integer;
begin
for i:=1 to N do H[i]:=true;
for i:=2 to 2*N do D1[i]:=true;
for i:=1-N to N-1 do D2[i]:=true;
end{ Mass };
procedure FormS( num:Nat0;i:Nat );
{ выбирает ход с номером (num) из всех возмжных }
var j:Nat;
k:Nat0;
begin
k:=0; j:=1;
while (j<=n)and(k<>num) do
begin
if H[j] and D1[i+j] and D2[i-j] then k:=k+1;
j:=j+1;
end;
H[j-1]:=false; D1[i+j-1]:=false; D2[i-j+1]:=false;
end{ FormS };
function ModS(i:Nat):Nat0;
{ находит количество возможных ходов }
var j:Nat;
m:Nat0;
begin
m:=0;
if i<=N then
for j:=1 to N do
if H[j] and D1[i+j] and D2[i-j] then m:=m+1;
ModS:=m;
end { ModS };
procedure MonteCarlo( nExp:integer; var v: Real );
var iExp:integer;
num,m:Nat0;
all,sum, prod : Real;
i:Nat;
begin { MonteCarlo }
Randomize;
all:=0;
for iExp:=1 to nExp do
begin { очередное испытание }
Mass; prod:=1; i:=1; m:=N; sum:=0;
while m<>0 do
begin
prod:=prod*m;
sum:=sum+prod;
num:=Random(m); if (num=0) then num:=m;
FormS(num,i); i:=i+1; m:=ModS(i);
end {while};
all:=all+sum;
end {for};
v:=all/nExp;
end{ MonteCarlo };
begin
clrscr;
WriteLn(' n = ?'); ReadLn(n);
WriteLn(' nExp = ?'); ReadLn(nExp);
Assign(fout,'MONTEС.DAT');
Rewrite(fout);
WriteLn(fout,'количество ферзей = ',n:2);
WriteLn(fout,'количество испытаний = ',nExp:2);
MyGetTime(t1);
MonteCarlo ( nExp, v );
MyGetTime(t2);
WriteLn(fout,'количество узлов в дереве поиска :', v :12:1 );
t := t2 - t1; MyUnPackTime( t, min, sec, s100);
if(s100<10)
then Write(fout,'время = ', min,' мин ', sec,'.0', s100,' сек')
else Write(fout,'время = ', min,' мин ', sec,'.', s100,' сек');
Close (fout)
end.
{===========================================================================}