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

{$E+,N+}
program Monte_Carlo;
Uses Crt, Dos;
const maxN = 20;
type Nat  = 1..maxN;
     Nat0 = 0..maxN;
     pos = array[Nat] of Nat;
var n    : Nat;
    nExp : integer;
    v    : Double;
    fout : Text;
    t, t1,t2 : LongInt;
    min, sec, s100 : Word;

procedure MonteCarlo ( nExp : integer; n : Nat; var v: Double );
 var k : Nat0;
     m_k, num : Nat0;
     i : Nat;
     iExp : Word;
     a, S_k : pos;
     n_div_2 : Nat0;
     all, sum, prod : Double;
   function NoFerz ( k: Nat; s: Nat) : Boolean;
  { NoFerz = 'дҐа§м ­Ґ ¬®¦Ґв Ўлвм Ї®бв ў«Ґ­ ў бва®Єг s бв®«Ўж  k' }
  { ¬ ббЁў a[*] - ў­Ґи­Ё© }
    var Flag : Boolean;
        i    : Nat;
  begin {NoFerz}
    Flag := True;
    i := 1;
    while (i<k) and Flag do
    begin { Flag='дҐа§Ё [1..i) ­Ґ  в Єгов Ї®«Ґ <k,s>'}
          {  в ЄгҐв «Ё дҐа§м Ё§ i-Ј® бв®«Ўж  Ї®«Ґ <k,s>?}
      Flag := not ( (a[i]=s) or (abs(a[i]-s)=k-i) );
      i := i+1
    end {while};
   NoFerz := not Flag
  end {NoFerz};

  procedure FormSk ( k: Nat; var m_k: Nat0; var S_k: pos );
  { д®а¬ЁагҐв "¬­®¦Ґбвў®" (ўҐЄв®а) S_k ў®§¬®¦­ле 室®ў Ё
    ҐЈ® ¬®й­®бвм m_k; Ґб«Ё S_k Їгбв®, в® m_k=0 }
    var s: Nat;
  begin
    m_k := 0;
    for s:=1 to n do
      if not NoFerz( k, s) then
      begin { ¬®¦­® бв ўЁвм }
       m_k := m_k + 1;
       S_k[m_k] := s
      end;
  end {FormSk};

begin { MonteCarlo }
 Randomize;
 n_div_2 := n div 2;
 all := 0;
 for iExp:=1 to nExp do
 begin { ®зҐаҐ¤­®Ґ ЁбЇлв ­ЁҐ }
  m_k :=n-1;
  num := Random ( m_k )+1;
  a[1] := num+1;
  k := 1;
  prod :=1;
  sum := prod;
  FormSk ( k, m_k, S_k );

  while m_k<>0  do
  begin
   prod := prod*m_k;
   sum := sum + prod;
   num := Random ( m_k ) + 1;
   a[k] := S_k[num];
   k := k + 1;
   FormSk ( k, m_k, S_k );
  end {while};

  all := all + sum
 end {for};
 v := all/nExp
end { MonteCarlo };

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

  MyGetTime(t1);

  MonteCarlo ( nExp, n, v );

  MyGetTime(t2);
  WriteLn(fout,'Є®«ЁзҐбвў® 㧫®ў ў ¤ҐаҐўҐ Ї®ЁбЄ  :', v :12:1 );
  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.