{ Программа решения задачи об n ферзях перебором с возвратом } program BacktrackQueens; var n : integer; { размер доски } queen : array[1..100] of integer; { массив положений ферзей } { Процедура печати решения } procedure WriteSolution; var i : integer; begin for i := 1 to n do Write(queen[i],' '); WriteLn end; { Функция проверки совместимости m-го ферзя с предыдущими } function Check(m : integer) : boolean; var i : integer; begin for i := 1 to m-1 do if (queen[i] = queen[m]) { совпадают горизонтали } Or (i+queen[i] = m+queen[m]) { нисходящие диагонали } Or (i-queen[i] = m-queen[m]) { восходящие диагонали } then begin Check := False; Exit; end; Check := True; end; { Процедура, осуществляющая перебор } procedure Backtrack(m : integer); var i : integer; begin if m > n then { найдено решение } WriteSolution else for i := 1 to n do begin queen[m] := i; if Check(m) { m-ый ферзь не бьёт предыдущих } then Backtrack(m+1); end; end; begin Write('Размер доски? '); Read(n); Backtrack(1) end. { Программа решения задачи об n ферзях перебором с распостранением ограничений и просмотром вперёд } program PropagateQueens; var n : integer; { размер доски } queen : array[1..160] of integer; { массив положений ферзей } space : array[1..160,1..160] of integer;{пространство перебора} step : array[1..160] of integer; { порядок выбора ферзей } cases : array[1..160] of integer; { количество вариантов } { Процедура печати решения } procedure WriteSolution; var i : integer; begin for i := 1 to n do Write(queen[i],' '); WriteLn end; { Процедура сокращения пространства перебора } procedure Prune(qm,queen,m : integer); var i, nq : integer; procedure ExcludeField(queen : integer); begin if (queen >= 1) and (queen <= n) then if space[nq,queen] := 0 then begin Dec(cases[nq]); space[nq,queen] := m; end; end; begin for i := m+1 to n do begin nq := step[i]; ExcludeField(queen); { на той же горизонтали } ExcludeField(queen+nq-qm); { на той же диагонали } ExcludeField(queen-nq+qm); end; end; { Процедура восстановления пространства перебора } procedure Restore(qm,queen,m : integer); var i, nq : integer; procedure IncludeField(queen : integer); begin if (queen >= 1) and (queen <= n) then if space[nq,queen] = m then begin Inc(cases[nq]); space[nq,queen] = 0; end; end; begin for i := m+1 to n do begin nq := step[i]; IncludeField(queen); { на той же горизонтали } IncludeField(queen+nq-qm); { на той же диагонали } IncludeField(queen-nq+qm); end; end; var minq, l : integer; procedure Propagate(m : integer); var i, qm : integer; begin if m > n then WriteSolution else begin { Выбирается ферзь с наименьшим количеством вариантов } minq := n+1; for i := m to n do if cases[step[i]] <= minq then begin l := i; qm := step[l]; minq := cases[qm]; end; step[l] := step[m]; step[m] := qm; for i := 1 to n do if space[qm,i] = 0 then begin queen[qm] := i; Prune(qm,i,m); Propagate(m+1); Restore(qm,i,m); end; end; end; var i, j : integer; begin Write('Размер доски? '); Read(n); for i := 1 to n do begin for j := 1 to n do space[i,j] := 0; step[i] := i; cases[i] := n; end; Propagate(1) end.