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

 {‡ ¤ з :
         ђ ббв ўЁвм ­  и е¬ в­®© ¤®бЄҐ а §¬Ґа  N ­  N, N дҐа§Ґ© в Є,
        зв®Ўл ­Ё ®¤Ё­ дҐа§м ­Ґ гЈа®¦ « ¤агЈ®¬г.
         ‚ ®ЇЁб ­®© ўлиҐ § ¤ зҐ ®жҐ­Ёвм Є®«ЁзҐбвў® 㧫®ў ¤ҐаҐў 
        Ї®ЁбЄ  Ї® ¬Ґв®¤г Њ®­вҐ-Љ а«®.}
 Uses Dos,crt;

 const MaxN=16;
 type  Nat=1..MaxN;
       Nat0=0..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;
       nExp:integer; { Є®«ЁзҐбвў® Їа®е®¤®ў Ї® ¤ҐаҐўг }
       v:Real;       { Є®«ЁзҐбвў® Є®а­Ґ© }

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

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

   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 FormS( num:Nat0;i:Nat );
   { ўлЎЁа Ґв 室 б ­®¬Ґа®¬  (num) Ё§ ўбҐе ў®§¬¦­ле }
    var j:Nat;
        k:Nat0;
   begin
    k:=0; j:=1;
    while (j<=n)and(k<>num) do
     begin
      if H[j] and D1[i+j] and D2[i-j] then k:=k+1;
      j:=j+1;
     end;
    H[j-1]:=false; D1[i+j-1]:=false; D2[i-j+1]:=false;
   end{ FormS };

  function ModS(i:Nat):Nat0;
  { ­ е®¤Ёв Є®«ЁзҐбвў® ў®§¬®¦­ле 室®ў }
    var j:Nat;
        m:Nat0;
  begin
   m:=0;
   if i<=N then
   for j:=1 to N do
     if H[j] and D1[i+j] and D2[i-j] then m:=m+1;
   ModS:=m;
  end { ModS };

   procedure MonteCarlo( nExp:integer; var v: Real );
    var iExp:integer;
        num,m:Nat0;
        all,sum, prod : Real;
        i:Nat;
   begin { MonteCarlo }
     Randomize;
     all:=0;
    for iExp:=1 to nExp do
     begin { ®зҐаҐ¤­®Ґ ЁбЇлв ­ЁҐ }
      Mass; prod:=1; i:=1; m:=N; sum:=0;
      while m<>0  do
       begin
        prod:=prod*m;
        sum:=sum+prod;
        num:=Random(m); if (num=0) then num:=m;
        FormS(num,i); i:=i+1; m:=ModS(i);
       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
   clrscr;
   WriteLn(' n = ?');  ReadLn(n);
   WriteLn(' nExp = ?');  ReadLn(nExp);
   Assign(fout,'MONTE‘.DAT');
   Rewrite(fout);
   WriteLn(fout,'Є®«ЁзҐбвў® дҐа§Ґ© = ',n:2);
   WriteLn(fout,'Є®«ЁзҐбвў® ЁбЇлв ­Ё© = ',nExp:2);
   MyGetTime(t1);

   MonteCarlo ( nExp, v );

   MyGetTime(t2);
   WriteLn(fout,'Є®«ЁзҐбвў® 㧫®ў ў ¤ҐаҐўҐ Ї®ЁбЄ  :', v :12:1 );
   t := t2 - t1; MyUnPackTime( t, min, sec, s100);
   if(s100<10)
    then Write(fout,'ўаҐ¬п = ', min,' ¬Ё­ ', sec,'.0', s100,' ᥪ')
    else Write(fout,'ўаҐ¬п = ', min,' ¬Ё­ ', sec,'.', s100,' ᥪ');
   Close (fout)
  end.