Технический форум

Технический форум (http://www.tehnari.ru/)
-   Помощь студентам (http://www.tehnari.ru/f41/)
-   -   Паскаль. Расстановка 8-ми ферзей на шахматной доске. (http://www.tehnari.ru/f41/t37112/)

citrus 17.06.2010 18:23

Паскаль. Расстановка 8-ми ферзей на шахматной доске.
 
Уважаемые программисты, прошу помощи у вас.

Задача звучит так:

Цитата:

Дано натуральное число m. Получить m расстановок 8 ферзей на шахматной доске, при которых ни один из ферзей не угрожает другому. Если m больше, чем общее число таких расстановок, то следует получить все расстановки.

Мне надо как-то переделать какую-то из двух имеющихся вариантов задач с ферзями под мое условие.

У меня имеется два варианта задач с этими ферзями.
1) Она выдает кол-во расстановок и какие-то непонятные числа, судя по всему расстановки, но они в непонятном варианте каком-то:

Код:

program Queens;
uses crt;
  const N=8;
  type Index=1..N;
        Rasstanovka=array [Index] of 0..N;
  var X:Rasstanovka;
      Count:word;

  function P(var X:Rasstanovka;k,y:Index):boolean;
    var i:Index;
  begin
    i:=1;
    while (i<k)and(y<>X[i])and(abs(k-i)<>abs(y-X[i])) do inc(i);
    P:=i=k
  end;


  procedure Backtracking(k:Index);
    var i,y:Index;
  begin
    for y:=1 to N do
      if P(X,k,y) then
        begin
          X[k]:=y;
          if k=N then
            begin
              for i:=1 to N do write(X[i]);writeln;inc(Count)
            end;
          Backtracking(k+1)
        end
  end;


begin
clrscr;
  Count:=0;
  writeln('Rasstanovki ',N,' queens:');
  Backtracking(1);
  writeln('Vsego ',Count,' rasstanovok')
end.


2) Этот вариант выдает положение 8-ми ферзей в нормальном положении и даже "рисует" их расположение. Но проблема одна, выдает только один вариант расстановки:

Код:

Program QUEENS;
Uses CRT;
Const N = 8;
      M = 8;
Type Queen = record
          X,Y : Integer;
    End;
Var A : Array[1..N, 1..N] Of Integer;
    K : Array[1..M] Of Queen;
    I,J,Q,X,Y : Integer;

Procedure ClearQueen;
Var I : Integer;
Begin
    For I := 1 To M Do
    Begin
          K[I].X := 0;
          K[I].Y := 0;
    End;
End;

Procedure ShowQueen;
Var I : Integer;
Begin
    For I := 1 To M Do
        WriteLn('Q',I, ' [', K[I].X, ',', K[I].Y, ']');
End;

Procedure SetQueen;
Begin
    For I := 1 To M Do
        If (K[I].X <> 0) And (K[I].Y <> 0) Then
            A[K[I].X, K[I].Y] := I;
End;

Procedure ClearArray;
Var I,J : Integer;
Begin
    For I := 1 To N Do
        For J := 1 To N Do
            A[I, J] := 0;
End;

Procedure ShowArray;
Var I,J : Integer;
Begin
    For I := 1 To N Do
    Begin
        For J := 1 To N Do
            Write(A[I, J]:3);
        WriteLn;
    End;
End;

Procedure SetArray(X,Y : Integer);
Var I,J : Integer;
Begin
    For I := 1 To N Do Inc(A[I,Y]);
    For I := 1 To N Do Inc(A[X,I]);
    For I := -N To N Do
        If (X+I>=1) And (X+I<=N) And (Y+I>=1) And (Y+I<=N) Then
            Inc(A[X+I,Y+I]);
    For I := -N To N Do
        If (X+I>=1) And (X+I<=N) And (Y-I>=1) And (Y-I<=N) Then
            Inc(A[X+I,Y-I]);
End;

Function CountArray:Integer;
Var I,J,S : Integer;
Begin
    S := 0;
    For I := 1 To N Do
        For J := 1 To N Do
            If A[I, J] = 0 Then Inc(S);
    CountArray := S;
End;

Begin
ClrScr;
ClearArray;
ClearQueen;
Q := 1;
I := 1;
While (Q <= M) do begin
X := Trunc((I-1)/N)+1;
Y := I-N*(X-1);
If A[X,Y] = 0 then
Begin
SetArray(X,Y);
K[Q].X := X;
K[Q].Y := Y;
Inc(Q);
end
else Inc(I);
If I > N*N then
Begin
Dec(Q);
I := 1+((K[Q].X - 1) * N + K[Q].Y);
K[Q].X := 0;
K[Q].Y := 0;
ClearArray;
For J := 1 To Q-1 Do SetArray(K[J].X,K[J].Y);
end;
end;
ClrScr;
ShowQueen;
ClearArray;
SetQueen;
ShowArray;
readkey;
end.



Часовой пояс GMT +4, время: 14:07.

Powered by vBulletin® Version 4.5.3
Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.