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

 {Џа®Ја ¬¬  ­Ґ гзЁвлў ой п бЁ¬¬ҐваЁо аҐиҐ­Ё©.}
program queen_;
Uses Dos;

const maxN = 20;
type Nat  = 1..maxN;
var n : Nat;
    fout : Text;
    t, t1,t2 : LongInt;
    min, sec, s100 : Word;

procedure Queen( n : Nat );

type Nat0 = 0..maxN;
     Nat1 = 1..maxN+1;
     pos = array [Nat] of Nat1;
 var k : Nat0;
     i : Nat;
     a, s : pos;        { s[k] - ­ Ё¬Ґ­миЁ© н«Ґ¬Ґ­в ¬­®¦Ґбвў  Sk   }
                        { ­Ґ®Їа®Ў®ў ­­ле (¤®ЇгбвЁ¬ле) §­ зҐ­Ё©     }
     count : Longint;   { бзҐвзЁЄ ®Ўб«Ґ¤®ў ­­ле 㧫®ў ¤ҐаҐў  Ї®ЁбЄ }
     countS : Longint;  { бзҐвзЁЄ ­ ©¤Ґ­ле аҐиҐ­Ё©                 }
    
  function NoQueen : Boolean;
  { NoFerz = 'дҐа§м ­Ґ ¬®¦Ґв Ўлвм Ї®бв ў«Ґ­ ў бва®Єг s[k] бв®«Ўж  k' }
    var Flag : Boolean;
        i    : Nat;
  begin {NoFerz}
    Flag := True;
    i := 1;
    while (i<k) and Flag do
    begin { Flag='дҐа§Ё [1..i) ­Ґ  в Єгов Ї®«Ґ <k,s[k]>'}
          {  в ЄгҐв «Ё дҐа§м Ё§ i-Ј® бв®«Ўж  Ї®«Ґ <k,s[k]>?}
      Flag := not ( (a[i]=s[k]) or (abs(a[i]-s[k])=k-i) );
      i := i+1
    end {while};
   NoQueen := not Flag
  end {NoQueen};

  procedure RestSk;
  { ­ ©вЁ б«Ґ¤го饥 ­ Ё¬Ґ­м襥 §­ зҐ­ЁҐ s[k],
    ­ зЁ­ п б ⥪г饣® s[k]; Ґб«Ё в Є®ў®Ј® ­Ґв, в® s[k]=n+1 }
  begin
    while (s[k]<=n) and NoQueen do s[k] := s[k] + 1
  end {RestSk};

 begin{queen}
  a[1] := 1; s[1] := 1;
  k := 1;
  count :=0;  countS := 0;  

  while k>0 do
  begin
    while (k>=1) and (s[k]<=n) do
    begin
     a[k] := s[k];
     s[k] := s[k] + 1;
     RestSk;
     count := count + 1;
     if k=n then
       begin { аҐиҐ­ЁҐ ­ ©¤Ґ­® }
         countS := countS + 1;   Write(fout,countS:7,' :: ');
         for i:=1 to n do Write(fout, a[i]:3);  WriteLn(fout)
       end { дЁЄб жЁЁ аҐиҐ­Ёп }
     else
       begin { ЇҐаҐе®¤ Є б«Ґ¤го饩 ўҐавЁЄ «Ё }
         k := k + 1;
         s[k] := 1;
         RestSk
       end {if}
    end {while};
    k := k-1 {backtrack}
  end {while};
  WriteLn(fout,'ўбҐЈ® ўҐаиЁ­ = ',count)
end {Queen};

    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
  WriteLn(' n=?');  ReadLn(n);
  Assign(fout,'QOUT.DAT');
  Rewrite{Append}(fout);
  WriteLn(fout,'Є®«ЁзҐбвў® дҐа§Ґ© = ',n:2);
  WriteLn(fout,'а Ґ и Ґ ­ Ё п :');
  MyGetTime(t1);

  Queen ( n );

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