Cod sursa(job #1131139)

Utilizator Vele_GeorgeVele George Vele_George Data 28 februarie 2014 18:05:03
Problema Problema Damelor Scor 60
Compilator fpc Status done
Runda Arhiva educationala Marime 2.52 kb
var v:array[1..20] of integer;
    a:array[1..20,1..20] of integer;
    n,k,nr:integer;
    f,g:text;
function test(x,y:integer):boolean;
 var i,j,k:integer;
  begin
   k:=0;
   i:=x;
   j:=y;
   while (i>1)and(j>1) do begin
                           dec(i);
                           dec(j);
                           if a[i,j]=1 then k:=1;
                          end;
   i:=x;
   j:=y;
   while (i>1)and(j<n) do begin
                           inc(j);
                           dec(i);
                           if a[i,j]=1 then k:=1;
                          end;
   i:=x;
   j:=y;
   while (i<n)and(j<n) do begin
                           inc(j);
                           inc(i);
                           if a[i,j]=1 then k:=1;
                          end;
   i:=x;
   j:=y;
   while (i<n)and(j>1) do begin
                           dec(j);
                           inc(i);
                           if a[i,j]=1 then k:=1;
                          end;

   i:=x;
   j:=y;
   while (i>1) do begin
                   dec(i);
                   if a[i,j]=1 then k:=1;
                  end;
   i:=x;
   j:=y;
   while (i<n)do begin                                // 1 2 3 4 5 6
                    inc(i);
                    if a[i,j]=1 then k:=1;
                   end;
   i:=x;
   j:=y;
   while (j>1) do begin
                   dec(j);
                   if a[i,j]=1 then k:=1;
                  end;
   i:=x;
   j:=y;
   while (j<n)do begin
                  inc(j);
                  if a[i,j]=1 then k:=1;
                 end;

  if k=0 then test:=true
         else test:=false;
  end;



procedure ins(pas,x,y:integer);
 var i,j:integer;
  begin
   a[x,y]:=1;
   v[pas]:=y;
   if (pas=n) then begin
                    if (k=0) then begin
                                   for i:=1 to n do write(g,v[i],' ');
                                   k:=1;
                                   writeln(g);
                                  end;
                    inc(nr);
                   end

              else
               for i:=x+1 to n do
                for j:=1 to n do
                 if (test(i,j)=true) and (a[i,j]<>1)
                  then ins(pas+1,i,j);


  a[x,y]:=0;

  end;

procedure backtrack;
 var j:integer;
  begin
   for j:=1 to n do ins(1,1,j);
  end;

begin

assign(f,'damesah.in');reset(f);
 readln(f,n);
close(f);

assign(g,'damesah.out');rewrite(g);
 nr:=0;
 backtrack;
 write(g,nr);
close(g);
end.