home *** CD-ROM | disk | FTP | other *** search
/ Chip 1997 October / Chip_1997-10_cd.bin / tema / sw602 / wintext / disk1 / data.1 / DAMY.TXT < prev    next >
Text File  |  1995-02-13  |  4KB  |  151 lines
  1. Program Damy;
  2. // makro heuristick²m algoritmem °eÜφcφ obtφ₧n∞jÜφ
  3. // kombinatorickou ·lohu
  4.  
  5. const
  6.   MINP = 2;
  7.   MAXP = 9;
  8.   DEFAULTP = 8;
  9.  
  10. var
  11.   positions : array[1..MAXP] of integer;
  12.   rozmer : integer;
  13.   nalezlo : integer;
  14.   user_stop : boolean;
  15.   S : string[30];
  16.  
  17. function zadej_mez(var mez : integer) : boolean;
  18. var
  19.   result, ok : boolean;
  20.   s1, s2 : string[10];
  21.   sCapt: string[30];
  22.   tmp : integer;
  23. begin
  24.   s1 := Int2Str(MINP);
  25.   s2 := Int2Str(MAXP);
  26.   sCapt:="Rozm∞r Üachovnice (" + s1 + " - " + s2 + " ):";
  27.   s1:= Int2Str(DEFAULTP);
  28.   repeat
  29.     result := Input_Box(sCapt, s1, 2);
  30.     if result then
  31.     begin
  32.       tmp:=Str2Int(s1);
  33.       if tmp = NONEINTEGER then
  34.       begin
  35.         Info_box("Informace", "Chybn² zßpis celΘho Φφsla !");
  36.         ok:=false;
  37.       end
  38.       else if (tmp < MINP) or (tmp > MAXP) then
  39.       begin
  40.         Info_box("Informace", "Φφslo nenφ v dan²ch mezφch !");
  41.         ok:=false;
  42.       end
  43.       else ok:=true;
  44.     end
  45.     else ok:=true;
  46.   until not (result and not ok);
  47.   if result then mez := tmp;
  48.   zadej_mez:=result;
  49.  end;
  50.  
  51. function Message_stop : boolean;
  52. var
  53.    i : integer;
  54.    sp : string[80];
  55.    sv : string[30];
  56. begin
  57.   nalezlo:=nalezlo + 1;
  58.   sv:="";
  59.   for i:=1 to rozmer do
  60.   begin
  61.    sv:=sv + Char2Str(chr(ord('A') + i - 1));
  62.    sv:=sv + Int2Str(positions[i]) + " ";
  63.   end;
  64.   sp:= "Pozice Φ. " + Int2Str(nalezlo) + " :"+ #13#10 + sv;
  65.   sp:=sp + #13#10"PokraΦovat ?";
  66.   user_stop:= not YesNo_box("Informace", sp);
  67.   Message_stop:= user_stop;
  68. end;
  69.  
  70. { vracφ 0 nebyla-li nalezena novß pozice : }
  71. function NewPos(sloupec, pos : integer) : integer;
  72. var
  73.   result, i, r : integer;
  74.   ok : boolean;
  75. begin
  76.   result := 0;
  77.   pos :=pos + 1;
  78.   { projφt zb²vajici mo₧nΘ pozice ve sloupci : }
  79.   while (result = 0) and (pos <= rozmer) do
  80.   begin
  81.     ok := true;   { otestovat novou mo₧nou pozici : }
  82.     i :=1;
  83.     while ok and (i < sloupec) do  { projφt u₧ postavenΘ dßmy }
  84.     begin
  85.       r:=positions[i];
  86.       if (r = pos) or  ((sloupec - i) = Iabs(pos - r))
  87.         then ok := false           { ohro₧ujφ se }
  88.         else i:= i + 1;            { otestuj dalÜφ dßmu }
  89.     end;
  90.     if ok then result := pos       { novß pozice vyhovuje }
  91.           else pos:=pos + 1        { zkus dalÜφ pozici }
  92.   end;
  93.   NewPos := result;
  94. end;
  95.  
  96. procedure Nalezni;
  97. var
  98.   current, tmp : integer;
  99. begin
  100.   nalezlo:= 0;
  101.   current := 1;         { inicializace zßsobnφku pozic  }
  102.   positions[1]:= 0;
  103.   while current > 0 do  { dokud je zßsobnφk neprßzdn² : }
  104.   begin
  105.     tmp:=NewPos(current, positions[current]);
  106.     if tmp > 0 then     { nalezena mo₧nß pozice ve sloupci : }
  107.       begin
  108.         positions[current]:=tmp;         { dosa∩ ji                 }
  109.         if current = rozmer              { je to poslednφ sloupec ? }
  110.         then begin
  111.                if not Message_stop  then
  112.                current := current - 1    { vra¥ se o sloupec zp∞t }
  113.                else current:= 0;         { ukonΦi }
  114.              end
  115.         else begin
  116.                current:=current + 1;     { vezmi dalÜφ sloupec }
  117.                positions[current]:=0;
  118.              end;
  119.       end
  120.     else current := current - 1;         { vra¥ se o sloupec zp∞t }
  121.   end;
  122. end;
  123.  
  124. begin
  125.   if YesNo_box("Nabφdka :",
  126.         "  Wintext vßm poradφ,"
  127.         " kterak na Üachovnici N x N "#13#10
  128.         "rozmφstit N dam tak,"
  129.         " aby se ₧ßdnΘ dv∞ neohro₧ovaly."#13#10
  130.         "PokraΦovat?") then
  131.   if zadej_mez(rozmer)  then
  132.   begin
  133.      user_stop:=false;
  134.      Nalezni;
  135.      if (nalezlo > 0)
  136.      then
  137.        if user_stop
  138.          then Info_Box("Informace",
  139.                 " UkonΦil(a) jste b∞h programu")
  140.          else begin
  141.                 S := "Pozice Φ. " + Int2Str(nalezlo) +
  142.                      " byla poslednφ .";
  143.                 Info_Box("Informace", S)
  144.               end
  145.      else
  146.        Info_Box("Politovßnφ",
  147.          "Pro tento rozm∞r Üachovnice "
  148.          "₧ßdnΘ vyhovujφcφ rozmφst∞ni neexistuje")
  149.   end;
  150. end.
  151.