回 帖 发 新 帖 刷新版面

主题:八女皇问题

国际象棋棋盘上有八只皇后,如何摆放使其不能互吃?
[marquee]HELP!!![/marquee][b]HELP!!![/b]

回复列表 (共14个回复)

11 楼

program eightqueens;
 var
  x:array[1..8] of integer;
  a,b,c:array[-7..16] of boolean;
  i:integer;
 procedure print;
  var k:integer;
  begin
   for k:=1 to 8 do write(x[k]:4);
   writeln;
  end;
 procedure try(i:integer);
  var j:integer;
  begin
   for j:=1 to 8 do
    if a[j] and b[i+j] and c[i-j]
     then begin
   x:=j;
   a[j]:=false;
   b[i+j]:=false;
   c[i-j]:=false;
   if i<8 then try(i+1)
    else print;
   a[j]:=true;
   b[i+j]:=true;
   c[i-j]:=true
  end
 end;
 begin
  for i:=-7 to 16 do
   begin
    a:=true;
    b:=true;
    c:=true
   end;
  try(1);
 end.

12 楼

用图论可以解决,但是我不知道怎么做

13 楼

var
  a:array [1..9] of 1..9;
  n,t:word;
procedure print;
var
  j:byte;
begin
  t:=t+1;
  write('No. ',t,' ');
  for j:=1 to n do
   write('(',j,',',a[j],') ');
   writeln;
  if t mod 24=0 then readln;
end;
function check(s,i:byte):boolean;
var
  j:byte;
begin
  check:=false;
  for j:=1 to s-1 do
    if (i=a[j]) or (abs(s-j)=abs(i-a[j])) then exit;
  check:=true;
end;
procedure sub(s:byte);
var
  i:byte;
begin
  if s>n then
    print
   else
    for i:=1 to n do
      if check(s,i) then
       begin
        a[s]:=i;
        sub(s+1);
       end;
end;
begin
  repeat
   write('Queen Number: ');
   readln(n);
  until n in [4..9];
  t:=0;
  sub(1);
  readln;
end.

14 楼

以上为递归

我来回复

您尚未登录,请登录后再回复。点此登录或注册