Задача о расстановке ферзей / QUEEN99 / QUEEN / QUEEN

 {‡ ¤ з :
         ђ ббв ўЁвм ­  и е¬ в­®© ¤®бЄҐ а §¬Ґа  N ­  N, N дҐа§Ґ© в Є,
        зв®Ўл ­Ё ®¤Ё­ дҐа§м ­Ґ гЈа®¦ « ¤агЈ®¬г.}

  {Џа®Ја ¬¬  ®вᥨў ой п ­ҐЄ®в®алҐ ў аЁ ­вл бЁ¬¬ҐваЁз­ле аҐиҐ­Ё©.}

 Uses Dos,crt;

 const MaxN=15;
 type  Nat=1..MaxN;
 var
       H:array[1..MaxN] of boolean;        { § ­пв (false) Ј®аЁ§®­в «м }
       D1:array[2..2*MaxN] of boolean;     { § ­пв (false) /-¤Ё Ј®­ «м }
       D2:array[1-MaxN..MaxN-1] of boolean;{ § ­пв (false) \-¤Ё Ј®­ «м }

       N:Nat;                    { а §¬Ґа ¤®бЄЁ(Є®«ЁзҐбвў® дҐа§Ґ©) }
       X:array[1..MaxN] of Nat;  { аҐиҐ­ЁҐ }

       fout:text; {ўл室­®© д ©«}

{--------------------------------------------------------------------------}
       t, t1,t2 : LongInt;
       min, sec, s100 : Word;

       countS,       { Є®«ЁзҐбвў® аҐиҐ­Ё©(ЎҐ§ гзҐв  бЁ¬¬ҐваЁЁ) }
       count:Longint;{ Є®«ЁзҐбвў® ўҐаиЁ­ ў ¤ҐаҐўҐ }
       n_div_2,j:integer;
{--------------------------------------------------------------------------}

   procedure print;
   { ўлў®¤ аҐиҐ­Ёп ў д ©«}
    var k:Nat;
   begin
    countS:=countS+1;
    write(fout,countS:8,':');
    for k:=1 to N do write(fout,X[k]:3);
    writeln(fout);
   end{ print };

   procedure Queen(i:Nat);
   { ­ е®¤Ёв ўбҐ ў®§¬®¦­лҐ аҐиҐ­Ёп § ¤ зЁ (ЎҐ§ гзҐв  бЁ¬¬ҐваЁЁ) }
    var j:Nat;
   begin
    for j:=1 to N do
     if H[j] and D1[i+j] and D2[i-j] then { ¬®¦­® Ї®бв ўЁвм }
       begin
        X[i]:=j; count:=count+1;
        H[j]:=false; D1[i+j]:=false; D2[i-j]:=false; { бв ўЁ¬  }
        if i<N then Queen(i+1)
               else print;
        H[j]:=true; D1[i+j]:=true; D2[i-j]:=true;    { гЎЁа Ґ¬ }
       end;
   end{ Ferz };

   procedure Mass;
   { Ё§­ з «м­® ¬ ббЁўл Їгбвл(­Ґв § ­пвле Ї®§ЁжЁ©) }
    var i:integer;
   begin
    for i:=1   to N   do H[i]:=true;
    for i:=2   to 2*N do D1[i]:=true;
    for i:=1-N to N-1 do D2[i]:=true;
   end{ Mass };

   procedure MyGetTime ( var t : LongInt );
   {ўл¤ Ґв ўаҐ¬п ў б®вле ¤®«пе ᥪ㭤л}
    var h, m, s , hund : Word;
   begin
    GetTime( h, m , s, hund);
    t:= s + 60 * m;
    t:= hund + 100 * t
   end{ MyGetTime };

   procedure MyUnPackTime ( t: LongInt; var m, s, hund : Word );
   {ЇҐаҐў®¤Ёв ўаҐ¬п t (ў б®вле ¤®«пе ᥪ㭤л)
    ў ¬Ё­гвл m, ᥪ㭤л s, б®влҐ hund       }
   begin
    hund:= t mod 100;
    t:= t div 100; {ў ᥪ㭠е}
    s:= t mod 60;
    m:= t div 60
   end{ MyUnPackTime };


  begin
   clrscr;
   Write('‚ўҐ¤ЁвҐ а §¬Ґал ¤®бЄЁ (N):');  ReadLn(n);
   Assign(fout,'QOut___.DAT');
   Rewrite(fout);
   WriteLn(fout,'Є®«ЁзҐбвў® дҐа§Ґ© = ',n:2);
   WriteLn(fout,'а Ґ и Ґ ­ Ё п :');
   MyGetTime(t1);

   count:=0; countS:=0; Mass;

   n_div_2:=(n div 2);
   for j:=2 to n_div_2 do
    begin
     X[1]:=j;  count:=count+1;
     H[j]:=false; D1[1+j]:=false; D2[1-j]:=false;
      Queen(2);
     H[j]:=true; D1[1+j]:=true; D2[1-j]:=true;
    end;

   MyGetTime(t2);
   t := t2 - t1; MyUnPackTime( t, min, sec, s100);
   Writeln(fout,' ўбҐЈ® ўҐаиЁ­ = ',count);
   if(s100<10)
    then Write(fout,'ўаҐ¬п = ', min,' ¬Ё­ ', sec,'.0', s100,' ᥪ')
    else Write(fout,'ўаҐ¬п = ', min,' ¬Ё­ ', sec,'.', s100,' ᥪ');
   Close (fout)
  end.