全国青少年信息学奥林匹克竞赛培训---pascal版“四皇后问题”

uses crt;

var a:array[1..4,1..4]of char;

procedure init;
var i,j:integer;
begin
  for i:=1 to 4 do
  begin
      for j:=1 to 4 do
      a[i][j]:='*';

  end;
end;

procedure print;
var i,j:integer;
begin

  for i:=1 to 4 do
  begin
    for j:=1 to 4 do
    write(a[i][j]:2);

  writeln();
  end;
end;

function valid(x,y:integer):boolean;
var i,j:integer;

begin

  valid:=true;
  {检查横线}
  for i:=x+1 to 4 do
     if a[i][y]='O' then valid:=false;
  for i:=1 to x-1 do
     if a[i][y]='O' then valid:=false;

  {检查纵线}
  for j:=1 to y-1 do
      if a[x][j]='O' then valid:=false;
  for j:=y+1 to 4 do
      if a[x][j]='O' then valid:=false;

  {检查斜线}
  i:=x-1;
  j:=y-1;
  while (i>=1) and (j>=1) do
  begin
       if a[i][j]='O' then valid:=false;
       i:=i-1;
       j:=j-1;
  end;//topleft

  i:=x+1;
  j:=y-1;
  while (i<=4) and (j>=1) do
  begin
       if a[i][j]='O' then valid:=false;
       i:=i+1;
       j:=j-1;
  end;//bottomleft

  i:=x-1;
  j:=y+1;
  while (i>=1) and (j<=4) do
  begin
       if a[i][j]='O' then valid:=false;
       i:=i-1;
       j:=j+1;
  end;//topright

  i:=x+1;
  j:=y+1;
  while (i<=4) and (j<=4) do
  begin
       if a[i][j]='O' then valid:=false;
       i:=i+1;
       j:=j+1;
  end;//bottomright
end;

procedure execute(row:integer);

var col:integer;

begin
  if row>=5 then
  begin
      print;
      writeln;
      exit;
  end;

  for col:=1 to 4 do
  begin
    a[row][col]:='O';
    if valid(row,col)=true then execute(row+1);
    a[row][col]:='*';

  end;//end of for

end;

procedure debug;
begin
    a[1][1]:='O';
end;

begin

  textcolor(green);
  init;

  execute(1);
  //print;

  readln;

end.