Program Damy;
// makro heuristickým algoritmem řešící obtížnější
// kombinatorickou úlohu

const
  MINP = 2;
  MAXP = 9;
  DEFAULTP = 8;

var
  positions : array[1..MAXP] of integer;
  rozmer : integer;
  nalezlo : integer;
  user_stop : boolean;
  S : string[30];

function zadej_mez(var mez : integer) : boolean;
var
  result, ok : boolean;
  s1, s2 : string[10];
  sCapt: string[30];
  tmp : integer;
begin
  s1 := Int2Str(MINP);
  s2 := Int2Str(MAXP);
  sCapt:="Rozměr šachovnice (" + s1 + " - " + s2 + " ):";
  s1:= Int2Str(DEFAULTP);
  repeat
    result := Input_Box(sCapt, s1, 2);
    if result then
    begin
      tmp:=Str2Int(s1);
      if tmp = NONEINTEGER then
      begin
        Info_box("Informace", "Chybný zápis celého čísla !");
        ok:=false;
      end
      else if (tmp < MINP) or (tmp > MAXP) then
      begin
        Info_box("Informace", "číslo není v daných mezích !");
        ok:=false;
      end
      else ok:=true;
    end
    else ok:=true;
  until not (result and not ok);
  if result then mez := tmp;
  zadej_mez:=result;
 end;

function Message_stop : boolean;
var
   i : integer;
   sp : string[80];
   sv : string[30];
begin
  nalezlo:=nalezlo + 1;
  sv:="";
  for i:=1 to rozmer do
  begin
   sv:=sv + Char2Str(chr(ord('A') + i - 1));
   sv:=sv + Int2Str(positions[i]) + " ";
  end;
  sp:= "Pozice č. " + Int2Str(nalezlo) + " :"+ #13#10 + sv;
  sp:=sp + #13#10"Pokračovat ?";
  user_stop:= not YesNo_box("Informace", sp);
  Message_stop:= user_stop;
end;

{ vrací 0 nebyla-li nalezena nová pozice : }
function NewPos(sloupec, pos : integer) : integer;
var
  result, i, r : integer;
  ok : boolean;
begin
  result := 0;
  pos :=pos + 1;
  { projít zbývajici možné pozice ve sloupci : }
  while (result = 0) and (pos <= rozmer) do
  begin
    ok := true;   { otestovat novou možnou pozici : }
    i :=1;
    while ok and (i < sloupec) do  { projít už postavené dámy }
    begin
      r:=positions[i];
      if (r = pos) or  ((sloupec - i) = Iabs(pos - r))
        then ok := false           { ohrožují se }
        else i:= i + 1;            { otestuj další dámu }
    end;
    if ok then result := pos       { nová pozice vyhovuje }
          else pos:=pos + 1        { zkus další pozici }
  end;
  NewPos := result;
end;

procedure Nalezni;
var
  current, tmp : integer;
begin
  nalezlo:= 0;
  current := 1;         { inicializace zásobníku pozic  }
  positions[1]:= 0;
  while current > 0 do  { dokud je zásobník neprázdný : }
  begin
    tmp:=NewPos(current, positions[current]);
    if tmp > 0 then     { nalezena možná pozice ve sloupci : }
      begin
        positions[current]:=tmp;         { dosaď ji                 }
        if current = rozmer              { je to poslední sloupec ? }
        then begin
               if not Message_stop  then
               current := current - 1    { vrať se o sloupec zpět }
               else current:= 0;         { ukonči }
             end
        else begin
               current:=current + 1;     { vezmi další sloupec }
               positions[current]:=0;
             end;
      end
    else current := current - 1;         { vrať se o sloupec zpět }
  end;
end;

begin
  if YesNo_box("Nabídka :",
        "  Wintext vám poradí,"
        " kterak na šachovnici N x N "#13#10
        "rozmístit N dam tak,"
        " aby se žádné dvě neohrožovaly."#13#10
        "Pokračovat?") then
  if zadej_mez(rozmer)  then
  begin
     user_stop:=false;
     Nalezni;
     if (nalezlo > 0)
     then
       if user_stop
         then Info_Box("Informace",
                " Ukončil(a) jste běh programu")
         else begin
                S := "Pozice č. " + Int2Str(nalezlo) +
                     " byla poslední .";
                Info_Box("Informace", S)
              end
     else
       Info_Box("Politování",
         "Pro tento rozměr šachovnice "
         "žádné vyhovující rozmístěni neexistuje")
  end;
end.