Тексты программ на Паскале

  { Программа решения задачи об 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.