Vezérek elhelyezése a sakktáblán ütközésmentesítő algoritmussal

Írjunk programot, mely az ütközésmentesítő algoritmus segítségével ütésmentesen elhelyez 8 vezért a sakktáblán. Nem kell az összes megoldást megkeresnie, ha talál egy jó megoldást, a program álljon le.

A program tesztelése közben kiderült, hogy a kettős cserét alkalmazó algoritmus gyakran nem tudja befejezni eredményesen a keresést, ezért a hármas cserét használót alkalmaztam. A biztonság kedvéért a maximális próbálgatási lehetőséget 1000-re állítottam be. Tesztelés közben 772 volt a maximális menetszám. Az alaphelyzet, amiből a keresés indul, a vezérek egy véletlen elhelyezése a táblán. A futtatási környezet a véletlen mutációt alkalmazó programhoz hasonló. A keresés a Start gombra indul, Alap gombbal újra kereshetünk. A program kiírja a lépések számát és az ütközésszámot.

A program futási képe a keresés előtt:

Majd a keresés befejeztével (futási idő 1 másodpercnél kisebb úgy, hogy a képernyő minden lépésben frissül):

A program listája:

unit UUtkVez;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, 

Graphics, Controls, Forms, Dialogs, StdCtrls, Grids;

Const Max=8;

type
  TfmUtkVez = class(TForm)
    lbUtkVez: TLabel;
    btKilepes: TButton;
    sgTabla: TStringGrid;
    sgUtkVez: TStringGrid;
    btStart: TButton;
    edN: TEdit;
    btAlap: TButton;
    edUtOSz: TEdit;
Procedure Kepernyore;
Procedure Tablara;
Function UTSz(O: Word): Word;
Procedure Utkozesek;
procedure btKilepesClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure sgTablaDrawCell(Sender: TObject; Col, Row: Integer;
      Rect: TRect; State: TGridDrawState);
procedure btStartClick(Sender: TObject);
procedure btAlapClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
  fmUtkVez: TfmUtkVez;
  ACol, ARow: Integer;
  MaxMenet, Menet, UtOSz: Word;
  T, UTT: Array[1..Max] Of Word;

implementation

{$R *.dfm}

procedure TfmUtkVez.btKilepesClick(Sender: TObject);
begin
  Close;
end;

procedure TfmUtkVez.sgTablaDrawCell(Sender: TObject; Col, Row: Integer;
  Rect: TRect; State: TGridDrawState);
begin
With sgTabla.Canvas.Brush Do
Begin
{rögzített cellák}
If gdFixed In State Then Color:=clWhite;

{kiválasztott cella}
If gdSelected In State Then Color:= clSilver;

{a táblázat belseje}
If Not((gdSelected In State) Or (gdFixed In State)) Then
Begin
Case Odd(Col) XOr Odd(Row) Of
        False: Color:= clWindow;
        True: Color:= clSilver;
End;
End;
    sgTabla.Canvas.Font.Size:= 17;
End;
  sgTabla.Canvas.TextRect(Rect,Rect.Left+12,
                          Rect.Top+1,sgTabla.Cells[Col,Row]);
If gdFocused In State Then sgTabla.Canvas.DrawFocusRect(Rect);
end;

procedure TfmUtkVez.FormCreate(Sender: TObject);
Var I: Word;
    Ch: Char;
begin
With sgUtkVez Do
Begin
For I:= 1 To Max Do Cells[I,0]:= Chr(96+I);
End;

With sgTabla Do
Begin
    ColWidths[9]:= 0;
    RowHeights[9]:= 0;
For I:= 1 To 8 Do Cells[0,I]:= IntToStr(9-I);
For Ch:= 'a' To 'h' Do Cells[Ord(Ch)-96,0]:= Ch;
    Col:= 9; Row:= 9;
End;

  Randomize;
  btAlapClick(Sender);
  MaxMenet:= 1000;
end;

procedure TfmUtkVez.btAlapClick(Sender: TObject);
Var I, J, A, B, P: Word;
begin
For I:= 1 To Max Do T[I]:= I;
For I:= 1 To 1000 Do
Begin
A:= Random(Max)+1; B:= Random(Max)+1;
    P:= T[A]; T[A]:= T[B]; T[B]:= P;
End;
With sgUtkVez Do
Begin
For I:= 1 To ColCount-1 Do For J:= 1 To RowCount-1 Do Cells[I,J]:= '';
    RowCount:= 5;
End;
  Menet:= 1;
  Kepernyore;
  Tablara;
  Utkozesek;
  edUtOSz.Text:= IntToStr(UTOSz);
end;

Procedure TfmUtkVez.Kepernyore;
Var I: Word;
Begin
With sgUtkVez Do
Begin
If RowCount-1<Menet Then RowCount:= Menet+1;
    Cells[0,Menet]:= IntToStr(Menet)+'.';
For I:= 1 To Max Do Cells[I,Menet]:= IntToStr(T[I]);
End;
End;

Procedure TfmUtkVez.Tablara;
Var I, J: Word;
Begin
With sgTabla Do
Begin
For I:= 1 To ColCount-1 Do For J:= 1 To RowCount-1 Do Cells[I,J]:= '';
For I:= 1 To Max Do Cells[I,Max-T[I]+1]:= 'V';
End;
End;

Function TfmUtkVez.UTSz(O: Word): Word;
Var I, U: Word;
Begin
  U:= 0;
For I:= 1 To Max Do If I<>O Then
If Abs(T[O]-T[I])=Abs(O-I) Then Inc(U);
  UTSz:= U;
End;

Procedure TfmUtkVez.Utkozesek;
Var I: Word;
Begin
  UTOSz:= 0; For I:= 1 To Max Do
Begin UTT[I]:= UTSz(I); Inc(UTOSz,UTT[I]) End;
End;

procedure TfmUtkVez.btStartClick(Sender: TObject);
Var X1, X2, X3, P, A, B: Word;
begin
  Menet:= 1;
While (UTOSz>0) And (Menet<MaxMenet) Do
Begin
    Inc(Menet); Utkozesek; A:= UTOSz;
    X1:= 1; While UTT[X1]=0 Do X1:= Random(Max)+1;
    X2:= Random(Max)+1; X3:= Random(Max)+1;
    P:= T[X1]; T[X1]:= T[X2]; T[X2]:= T[X3]; T[X3]:= P;
    Utkozesek; B:= UTOSz;
If B>A Then
Begin P:= T[X3]; T[X3]:= T[X2]; T[X2]:= T[X1]; T[X1]:= P End;
    Utkozesek;
    edN.Text:= IntToStr(Menet);
    edUtOSz.Text:= IntToStr(UTOSz);
    Tablara;
    Kepernyore;
    RePaint;
End;
end;

end.