Sakktábla

Készítsünk programot, mely egy sakktáblát jelenít meg. Ügyeljünk arra, hogy a tábla szabályos legyen (az a1 mezőnek sötétnek kell lenni). Vegyük figyelembe azt is, hogy a táblán később figurákat kell elhelyezni, azaz a sötét ne fekete és a világos mező ne fehér legyen. A fehér és fekete maradjon meg a figurák színének. Ha a formot átméretezzük, áthelyezzük, akkor rajzolja újra a táblát, ne legyen a sakktábla töredezett.

A program futási képe:

A program listája:

unit USakkTabla;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes,

Graphics, Controls, Forms, Dialogs, StdCtrls;

type
  TfmSakkTabla = class(TForm)
    btKilepes: TButton;
procedure FormPaint(Sender: TObject);
procedure btKilepesClick(Sender: TObject);
procedure FormCanResize(Sender: TObject; var NewWidth,
      NewHeight: Integer; var Resize: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;

var
  fmSakkTabla: TfmSakkTabla;

implementation

{$R *.dfm}

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

procedure TfmSakkTabla.FormPaint(Sender: TObject);
Var I, J: Word;
    Xk,Yk: Integer;
Const D=60;
begin
  Xk:= ClientWidth Div 2;
  Yk:= ClientHeight Div 2;
With Canvas Do
Begin
    Brush.Color:= clBtnFace;
    Pen.Color:= clBtnFace;
    Rectangle(0,0,2*Xk,2*Yk);
    Brush.Color:= clWhite;
    Pen.Color:= clWhite;
    Rectangle(Xk-9*(D Div 2),Yk-9*(D Div 2),
              Xk+9*(D Div 2),Yk+9*(D Div 2));
    Pen.Color:= RGB(144,144,0);
    Rectangle(Xk-4*D,Yk-4*D, Xk+4*D,Yk+4*D);
For I:= 1 To 8 Do For J:= 1 To 8 Do
Begin
If Odd(I+J) Then
Begin
        Brush.Color:= RGB(144,144,0);
        Pen.Color:= RGB(144,144,0);
End
Else
Begin
        Brush.Color:= RGB(224,224,224);
        Pen.Color:= RGB(224,224,224);
End;
      Rectangle(Xk-(5-I)*D,Yk-(5-J)*D,
                Xk-(4-I)*D,Yk-(4-J)*D);
End;
    Brush.Color:= clWhite;
    Pen.Color:= clBlack;
For I:= 1 To 8 Do
Begin
      Font.Size:= 12;
      TextOut(Xk+I*D-73*D Div 16,Yk+65*D Div 16, Chr(96+I));
      TextOut(Xk+33*D Div 8,Yk-I*D+71*D Div 16, IntToStr(I));
End;
End;
end;

procedure TfmSakkTabla.FormCanResize(Sender: TObject; var NewWidth,
  NewHeight: Integer; var Resize: Boolean);
begin
  FormPaint(Sender);
end;

end.

Vezérek elhelyezése a sakktáblán véletlen mutációval

Írjunk programot, mely véletlen mutáció segítségével ütésmentesen elhelyez 8 vezért a sakktáblán. Nem kell az összes megoldást megkeresnie, ha talál jó megoldást, a program álljon le. Az algoritmus megírásakor a következőket tartsuk be:

- az állapot leírására az 1-8 számok egy permutációját használjuk;

- a vezérek elhelyezkedését a következőképpen értelmezzük: a permutáció első helyén álló szám azt mutatja, hogy az ’a’ oszlopban melyik sorban van a vezér, a második helyen álló a ’b’, harmadik helyen a ’c’, … végül nyolcadik helyen lévő szám a ’h’ oszlopban lévő vezér sorának számát jelentse;

- a kezdőállapot az ’12345678’ permutáció legyen. Ez azt jelenti, hogy a vezérek az ’a1’-’h8’ átlón helyezkednek el. Minden sorban és oszlopban pontosan egy vezér. Így csak azért nem jó az elrendezés, mert a vezér átlós irányban is üt (nem úgy, mint a bástya), tehát ekkor minden vezér a többivel ütésben van;

- az elrendezéshez rendeljünk hibaszámot, mely legyen az összes bábu összesített ütési száma;

- ha az ütési számok összege (hibaszám) nulla, akkor a vezérek nem ütik egymást, a feladatot a program megoldotta;

- a kezdeti állapotból kiindulva cseréjük fel véletlen választással a permutáció két elemét (ez a csere nem hoz létre soron vagy oszlopon belüli ütközést, tehát továbbra is csak átlós ütközéseket kell számolni);

- nézzük meg, hogy a cserével létrejött permutációhoz tartozó felállás kisebb hibaszámú-e mint a csere előtti;

- ha igen, akkor a cserét tartsuk meg, ha nem, akkor figyelmen kívül hagyjuk;

- folytassuk addig a véletlen cserélgetés, ameddig jó megoldást nem kapunk.

A program jelenítse meg a feladat megoldását jelentő felállást, illetve minden a megoldást jelentő előtti állapotot is. Lehessen újra indítani a keresést.

A program futási képei. Az alapállapot:

Egy megtalált helyes felállás:

A program listája:

unit URndVezer;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes,

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

Const Max=8;

type
  TfmRndVezer = class(TForm)
    lbRndVezer: TLabel;
    btKilepes: TButton;
    sgRndVezer: TStringGrid;
    sgTabla: TStringGrid;
    btStart: TButton;
    btAlap: TButton;
    edN: TEdit;
Procedure Kepernyore;
Procedure Tablara;
Function HibaT: Byte;
Function HibaP: Byte;
Procedure Mutacio;
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
  fmRndVezer: TfmRndVezer;
  ACol, ARow: Integer;
  N: Word;
  T, P: Array[1..Max] Of Byte;

implementation

{$R *.dfm}

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

procedure TfmRndVezer.FormCreate(Sender: TObject);
Var I: Word;
    Ch: Char;
begin
With sgRndVezer 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;
  N:= 1; For I:= 1 To Max Do T[I]:= I;
  Kepernyore;
  Tablara;
end;

procedure TfmRndVezer.sgTablaDrawCell(Sender: TObject; Col, Row: Integer;
  Rect: TRect; State: TGridDrawState);
begin
//a sakktáblát és felállást megjelenítő StringGrid beállításai
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+16,
                          Rect.Top+4,sgTabla.Cells[Col,Row]);
If gdFocused In State Then sgTabla.Canvas.DrawFocusRect(Rect);
end;

procedure TfmRndVezer.btAlapClick(Sender: TObject);
Var I,J: Word;
begin
  N:= 1; For I:= 1 To Max Do T[I]:= I;
With sgRndVezer Do
Begin
For I:= 1 To ColCount-1 Do For J:= 1 To RowCount-1 Do Cells[I,J]:= '';
    RowCount:= 5;
End;
  Kepernyore;
  Tablara;
end;

Procedure TfmRndVezer.Kepernyore;
Var I: Word;
Begin
With sgRndVezer Do
Begin
If RowCount-1<N Then RowCount:= N+1;
    Cells[0,N]:= IntToStr(N)+'.';
For I:= 1 To Max Do Cells[I,N]:= IntToStr(T[I]);
End;
  EdN.Text:= IntToStr(N); edN.Repaint;
End;

Procedure TfmRndVezer.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
Begin
      Cells[I,Max-T[I]+1]:= 'V';
End;
End;
  sgTabla.Repaint;
End;

Function TfmRndVezer.HibaT: Byte;
Var I, J, H: Byte;
Begin
  HibaT:= 0; H:= 0;
For I:= 1 To Max-1 Do For J:= I+1 To Max Do
If Abs(T[I]-T[J])=J-I Then Inc(H);
  HibaT:= H;
End;

Function TfmRndVezer.HibaP: Byte;
Var I, J, H: Byte;
Begin
  HibaP:= 0; H:= 0;
For I:= 1 To Max-1 Do For J:= I+1 To Max Do
If Abs(P[I]-P[J])=J-I Then Inc(H);
  HibaP:= H;
End;

Procedure TfmRndVezer.Mutacio;
Var I, J, Puf: Byte;
Begin
  Inc(N);
  P:= T;
  I:= Random(Max)+1;
  J:= Random(Max)+1;
  Puf:= P[I]; P[I]:= P[J]; P[J]:= Puf;
Case N Mod 10 Of
    0..8: If HibaP<HibaT Then T:= P;
       9: If HibaP>0 Then T:= P;
End;
End;

procedure TfmRndVezer.btStartClick(Sender: TObject);
begin
While HibaT>0 Do
Begin
    Mutacio;
    Kepernyore;
    Tablara;
End;
end;

end.

Vezérek elhelyezése a sakktáblán Backtrack algoritmussal

Írjunk programot, mely a Backtrack algoritmus segítségével ütésmentesen elhelyez 8 vezért a sakktáblán. Nem kell az összes megoldást megkeresnie, ellenben minden ’a’ oszlopban elhelyezett vezérhez keressen egy-egy megoldást (azaz nyolcat).

A program indulási képe:

A megtalált nyolc lehetséges elrendezés (a sakktáblán az utolsóként megtalált felállás látható):

A program listája:

unit UBTrVezer;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes,

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

Const Max=8;

type
  TfmBTrVezer = class(TForm)
    lbBTrVezer: TLabel;
    btKilepes: TButton;
    sgBTrVezer: TStringGrid;
    sgTabla: TStringGrid;
    btStart: TButton;
    btAlap: TButton;
    lbKesz: TLabel;
Function Rossz(B,C: Byte): Boolean;
Function Jo(A: Byte): Boolean;
Procedure Keres;
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
  fmBTrVezer: TfmBTrVezer;
  ACol, ARow: Integer;
  N: Word;
  T: Array[1..Max] Of Byte;
  I: Word;

implementation

{$R *.dfm}

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

procedure TfmBTrVezer.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
Case Odd(Col) XOr Odd(Row) Of
      False: Color:= clWindow;
      True: Color:= clSilver;
End;
    sgTabla.Canvas.Font.Size:= 17;
End;
{szöveg beállítása rácson belül: +6 +4}
{kövér betüket akkor tud, ha DefaultDrawing=True}
  sgTabla.Canvas.TextRect(Rect,Rect.Left+16,Rect.Top+4,sgTabla.Cells[Col,Row]);
If gdFocused In State Then sgTabla.Canvas.DrawFocusRect(Rect);
end;

procedure TfmBTrVezer.FormCreate(Sender: TObject);
Var I: Word;
    Ch: Char;
begin
With sgBTrVezer Do
For I:= 1 To Max Do
Begin
    Cells[I,0]:= IntToStr(I)+'.';
    Cells[0,I]:= IntToStr(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;
  N:= 0;
  lbKesz.Caption:= '';
end;

procedure TfmBTrVezer.btAlapClick(Sender: TObject);
Var I, J: Word;
begin
For I:= 1 To Max Do T[I]:= 0;
For I:= 1 To Max Do For J:= 1 To Max Do
Begin
    sgBTrVezer.Cells[I,J]:= '';
    sgTabla.Cells[I,J]:= '';
End;
  N:= 0;
  lbKesz.Caption:= '';
end;

Function TfmBTrVezer.Rossz(B,C: Byte): Boolean;
Var J: Word;
Begin
  J:= 1; While (J<B) And (C<>T[J]) And (Abs(C-T[J])<>Abs(B-J)) Do Inc(J);
  Rossz:= Not(J<B);
End;

Function TfmBTrVezer.Jo(A: Byte): Boolean;
Label 1;
Begin
Repeat
    Inc(T[I]);
If T[I]>8 Then GoTo 1;
Until (T[I]<=8) And Rossz(A,T[I]);
  1: Jo:= T[I]<=8;
End;

Procedure TfmBTrVezer.Keres;
Begin
  I:= 1;
With sgTabla Do While I In [1..8] Do If Jo(I) Then
Begin
    Cells[I,Max-T[I]+1]:= 'V'; Inc(I); T[I]:= 0;
    RePaint;
    Sleep(50);
End
Else
Begin
    Dec(I); Cells[I,Max-T[I]+1]:= '';
    RePaint;
    Sleep(50);
End;
End;

procedure TfmBTrVezer.btStartClick(Sender: TObject);
Var K, J, U, V: Word;
begin
For K:= 0 To 7 Do
Begin
For J:= 1 To 8 Do T[J]:= K;
For U:= 1 To Max Do For V:= 1 To Max Do sgTabla.Cells[U,V]:= '';
    Keres;
    Inc(N); For U:= 1 To Max Do sgBTrVezer.Cells[U,N]:= IntToStr(T[U]);
    sgBTrVezer.Repaint;
    Sleep(500);
End;
  lbKesz.Caption:= 'Kész';
end;

end.

Nyolc vezér a sakktáblán (minden lehetséges eset)

Feladat: írjunk programot, mely nyolc vezérnek egy sakktáblán való ütésmentes elhelyezését oldja meg. A programnak az összes lehetséges felállítást meg kell keresnie. (Ha valaki nem tudná: a vezér minden irányba, akárhányat léphet, az irány lehet oldallal párhuzamos és átlós is.)

A megoldásnál egy olyan alapfelállásból indulunk, amikor soronként és oszloponként nincs ütközés. Ha nyolc különböző számot (1..8) permutálunk, és azt mondjuk, hogy az egyes oszlopokon a vezér abban a sorban legyen, amit a permutáció megfelelő helyén álló szám mutat, akkor egy ilyen felállításban biztosan nincs két vagy több vezér egy sorban vagy oszlopban. Mivel az ilyen alapesetek száma 8! = 40320, először egy elegáns rekurzióval ezeket állítjuk elő, tároljuk egy táblázatban, majd ezek közül kiválogatjuk azokat, amelyek ütközésmentesek. 92 ilyen, átlós ütközésmentes permutációt találunk. Ezeket a képernyőn megjelenő sakktáblán el is lehet helyezni, ellenőrizhetjük, hogy valóban ütközésmentes a felállás. Ezen 92 között találhatók olyanok, melyek egymásnak elemi geometriai transzformációi (eltolás, tükrözés). Utolsó lépésben ezeket is kiszórjuk, vagyis meghatározzuk azt a 12-t, amelyből az összes többi geometriai transzformációval származtatható. A szűrést a következőkre hajtottam végre: 8 vízszintes eltolás, 8 függőleges eltolás, 4 szimmetriatengelyre való tükrözés, középpontos tükrözés, 90 fokos elforgatás jobbra és végül 90 fokos elforgatás balra. Az alapesetek táblán való kattintás is megmutatja a vezérek elhelyezkedését a sakktáblán.

A program futási képe:

A program listája:

unit UVezer;

interface

uses
  Windows, Messages, SysUtils, Classes,

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

type
  St8= String[8];
  TfmVezer = class(TForm)
    sgMind: TStringGrid;
    lbOsszes: TLabel;
    sgJo: TStringGrid;
    lbJo: TLabel;
    sgTabla: TStringGrid;
    lbTabla: TLabel;
    sgAlap: TStringGrid;
    lbAlap: TLabel;
Function Ugyanaz(A,B: St8): Boolean;
procedure FormCreate(Sender: TObject);
procedure sgTablaDrawCell(Sender: TObject; Col, Row: Integer;
      Rect: TRect; State: TGridDrawState);
procedure sgJoClick(Sender: TObject);
procedure sgAlapClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

Const M=1*2*3*4*5*6*7*8;

var
  fmVezer: TfmVezer;
  S: St8;
  PT: Array[1..M] Of St8;
  Ind: Word;


implementation

{$R *.DFM}

Procedure Permut(I: Word);
Var J: Word;
    Ch: Char;
Begin
If I=1 Then Begin Inc(Ind); PT[Ind]:= S End Else
Begin
    Permut(I-1);
For J:= 1 To I-1 Do
Begin
      Ch:= S[J]; S[J]:= S[I]; S[I]:= Ch; Permut(I-1);
      Ch:= S[J]; S[J]:= S[I]; S[I]:= Ch;
End;
End;
End;

Function TfmVezer.Ugyanaz(A,B: St8): Boolean;
Var I: Word;
    Ws: St8;

Function EltolasVB(C: St8): St8; //vizszintesen balra
Begin
    C:= Copy(C+C[1],2,8);
    EltolasVB:= C;
End;

Function EltolasFF(C: St8): St8; //függőlegesen felfelé
Var J, X: Word;
Begin
For J:= 1 To 8 Do
Begin
      X:= Ord(C[J]); Inc(X); If X=57 Then X:= 49; C[J]:= Chr(X);
      EltolasFF:= C;
End;
End;

Function TukrozesVT(C: St8): St8;  //vízsintes tengelyre
Var J: Word;
Begin
For J:= 1 To 8 Do C[J]:= Chr(105-Ord(C[J]));
    TukrozesVT:= C;
End;

Function TukrozesFT(C: St8): St8;  //függőleges tengelyre
Var J: Word;
      X: St8;
Begin
    X:= '12345678';
For J:= 1 To 8 Do X[J]:= C[9-J];
    TukrozesFT:= X;
End;

Function TukrozesLA(C: St8): St8;  //lefutó átlóra
Var I: Word;
      X: St8;
      S: String;
Begin
    X:= '12345678';
For I:= 1 To 8 Do
Begin Str(9-I,S); X[9-StrToInt(C[I])]:= S[1] End;
    TukrozesLA:= X;
End;

Function TukrozesFA(C: St8): St8;  //felfutó átlóra
Var I: Word;
      X: St8;
      S: String;
Begin
    X:= '12345678';
For I:= 1 To 8 Do
Begin Str(I,S); X[StrToInt(C[I])]:= S[1] End;
    TukrozesFA:= X;
End;

Function ForgatasJ(C: St8): St8; //forgatás jobbra
Var I: Word;
      X: St8;
      S: String;
Begin
    X:= '12345678';
For I:= 1 To 8 Do
Begin Str(9-I,S); X[StrToInt(C[I])]:= S[1] End;
    ForgatasJ:= X;
End;

Function ForgatasB(C: St8): St8; //forgatás balra
Var I: Word;
      X: St8;
      S: String;
Begin
    X:= '12345678';
For I:= 1 To 8 Do
Begin Str(I,S); X[9-StrToInt(C[I])]:= S[1] End;
    ForgatasB:= X;
End;

Function KozeppontosT(C: St8): St8; //középpontos tükrözés
Begin
    KozeppontosT:= TukrozesVT(TukrozesFT(C));
End;

Begin
  Ugyanaz:= False;
//eltolás víszsintesen balra
  Ws:= B; For I:= 1 To 7 Do
Begin Ws:= EltolasVB(Ws); If A=Ws Then Ugyanaz:= True End;
//eltolás függőlegesen felfelé
  Ws:= B; For I:= 1 To 7 Do
Begin Ws:= EltolasFF(Ws); If A=Ws Then Ugyanaz:= True End;
//vízszintes tengelyre való tükrözés
If A=TukrozesVT(B) Then Ugyanaz:= True;
//függőleges tengelyre való tükrözés
If A=TukrozesFT(B) Then Ugyanaz:= True;
//lefutó átlóra való tükrözés
If A=TukrozesLA(B) Then Ugyanaz:= True;
//felfutó átlóra való tükrözés
If A=TukrozesFA(B) Then Ugyanaz:= True;
//forgatas jobbra
If A=ForgatasJ(B) Then Ugyanaz:= True;
//forgatás balra
If A=ForgatasB(B) Then Ugyanaz:= True;
//középpontos tükrözes
If A=KozeppontosT(B) Then Ugyanaz:= True;
End;

procedure TfmVezer.FormCreate(Sender: TObject);
Var I, J, K, N: Word;
    Jo: Boolean;
    Ch: Char;
    SI,SJ: St8;
begin
With sgAlap Do
Begin
For I:= 1 To 8 Do Cells[I,0]:= IntToStr(I)+'.';
End;
With sgJo Do
Begin
    ColWidths[0]:= 42;
For I:= 1 To 8 Do Cells[I,0]:= IntToStr(I)+'.';
End;
With sgTabla Do
Begin
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:= 1; Row:= 8;
End;
With sgMind Do
Begin
    ColWidths[0]:= 42;
    RowCount:= M+1;
For I:= 1 To M Do Cells[0,I]:= IntToStr(I)+'.';
For I:= 1 To 8 Do Cells[I,0]:= IntToStr(I)+'.';
    Ind:= 0; S:= '12345678'; Permut(8);
For J:= 1 To M Do For I:= 1 To 8 Do Cells[I,J]:= PT[J,I];
    N:= 1;
For J:= 1 To M Do
Begin
      Jo:= True; For I:= 1 To 7 Do For K:= I+1 To 8 Do
If Abs(StrToInt(Cells[I,J])-StrToInt(Cells[K,J]))= K-I Then
      Jo:= False;
If Jo Then
Begin
For I:= 1 To 8 Do sgJo.Cells[I,N]:= Cells[I,J];
        sgJo.Cells[0,N]:= IntToStr(N)+'.'; Inc(N);
If sgJo.RowCount<N Then sgJo.RowCount:= sgJo.RowCount+1;
End;
End;
End;
With sgJo Do
Begin
    N:= RowCount-1;
For I:= 1 To N-1 Do If Cells[0,I]<>'' Then
For J:= I+1 To N Do If Cells[0,J]<>'' Then
Begin
      SI:= ''; SJ:= '';
For K:= 1 To 8 Do SI:= SI+Cells[K,I];
For K:= 1 To 8 Do SJ:= SJ+Cells[K,J];
If Ugyanaz(SI,SJ) Then Cells[0,J]:= '';
End;
    K:= 0;
For I:= 1 To RowCount-1 Do If Cells[0,I]<>'' Then
Begin
      Inc(K);
      sgAlap.Cells[0,K]:= IntToStr(K)+'.';
For J:= 1 To 8 Do sgAlap.Cells[J,K]:= Cells[J,I];
End;
End;
end;

procedure TfmVezer.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
Case Odd(Col) XOr Odd(Row) Of
      False: Color:= clWindow;
      True: Color:= clSilver;
End;
    sgTabla.Canvas.Font.Size:= 17;
End;
{szöveg beállítása rácson belül: +6 +4}
{kövér betüket akkor tud, ha DefaultDrawing=True}
  sgTabla.Canvas.TextRect(Rect,Rect.Left+16,Rect.Top+4,sgTabla.Cells[Col,Row]);
If gdFocused In State Then sgTabla.Canvas.DrawFocusRect(Rect);
end;

procedure TfmVezer.sgJoClick(Sender: TObject);
Var I, J: Word;
begin
With sgJo Do
Begin
For I:= 1 To 8 Do For J:= 1 To 8 Do sgTabla.Cells[I,J]:= '';
For I:= 1 To 8 Do sgTabla.Cells[I,9-StrToInt(Cells[I,Row])]:= 'V';
End;
end;

procedure TfmVezer.sgAlapClick(Sender: TObject);
Var I, J: Word;
begin
With sgAlap Do
Begin
For I:= 1 To 8 Do For J:= 1 To 8 Do sgTabla.Cells[I,J]:= '';
For I:= 1 To 8 Do sgTabla.Cells[I,9-StrToInt(Cells[I,Row])]:= 'V';
End;
end;

end.

Vezérek elhelyezése a sakktáblán Back Track algoritmussal (teljes)

Írjunk programot, mely a Backtrack algoritmus segítségével megkeresi az összes lehetséges ütésmentes vezérelhelyezést a sakktáblán. A sakktábla méretét beviteli mező segítségével lehessen megadni (1-20 értékhatárok között). A keresés eredményét egy StrigGridben helyezzük el, melyre kattintva a sakktáblán az elhelyezés szerint a vezérek (V betűk) megjelennek. A keresés végén a program írja ki az elhelyezési lehetőségek számát.

A program néhány futási képe. Méret = 5:

Méret = 8:

Méret = 12:

A program listája:

unit UBTrVezer;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, 

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

Const Max=20;

type
  TfmBTrVezer = class(TForm)
    lbBTrVezer: TLabel;
    btKilepes: TButton;
    sgBTrVezer: TStringGrid;
    sgTabla: TStringGrid;
    btStart: TButton;
    btAlap: TButton;
    lbKesz: TLabel;
    lbMeret: TLabel;
    edMeret: TEdit;
    lbN: TLabel;
Function Rossz(B,C: Word): Boolean;
Function Jo(A: Word): Boolean;
Procedure Keres;
Procedure Tablara;
procedure btKilepesClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure sgTablaDrawCell(Sender: TObject; Col, Row: Integer;
      Rect: TRect; State: TGridDrawState);
procedure btAlapClick(Sender: TObject);
procedure btStartClick(Sender: TObject);
procedure sgBTrVezerClick(Sender: TObject);
procedure edMeretChange(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
  fmBTrVezer: TfmBTrVezer;
  ACol, ARow: Integer;
  T: Array[1..Max] Of Word;
  Meret: Word;
  N: Word;

implementation

{$R *.dfm}

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

procedure TfmBTrVezer.sgTablaDrawCell(Sender: TObject; Col, Row: Integer;
  Rect: TRect; State: TGridDrawState);
begin
With sgTabla.Canvas.Brush Do
Begin
If gdFixed In State Then Color:=clWhite;

If gdSelected In State Then Color:= clSilver;

If Not((gdSelected In State) Or (gdFixed In State)) Then
Case Odd(Col) XOr Odd(Row) Of
      False: Color:= clWindow;
      True: Color:= clSilver;
End;
    sgTabla.Canvas.Font.Size:= 17;
End;
  sgTabla.Canvas.TextRect(Rect,Rect.Left+10,Rect.Top+4,sgTabla.Cells[Col,Row]);
If gdFocused In State Then sgTabla.Canvas.DrawFocusRect(Rect);
end;

procedure TfmBTrVezer.FormCreate(Sender: TObject);
begin
  Meret:= 8;
  btAlapClick(Sender);
end;

procedure TfmBTrVezer.btAlapClick(Sender: TObject);
Var I, J: Word;
begin
With sgBTrVezer Do
Begin
    ColCount:= Meret+1;
    ColWidths[0]:= 52;
For I:= 1 To Meret Do Cells[I,0]:= Chr(96+I);
For I:= 1 To 92 Do Cells[0,I]:= IntToStr(I)+'.';
End;

With sgTabla Do
Begin
    ColCount:= Meret+2;
    RowCount:= Meret+2;
For I:= 1 To ColCount-2 Do ColWidths[I]:= 40;
For I:= 1 To RowCount-1 Do RowHeights[I]:= 32;
    ColWidths[ColCount-1]:= 0;
    RowHeights[RowCount-1]:= 0;
For I:= 1 To Meret Do Cells[0,I]:= IntToStr(Meret+1-I);
For I:= 1 To Meret Do Cells[I,0]:= Chr(96+I);
    Col:= ColCount-1; Row:= RowCount-1;
End;
With sgBTrVezer Do
For I:= 1 To ColCount-1 Do For J:= 1 To RowCount-1 Do Cells[I,J]:= '';
With sgTabla Do
For I:= 1 To ColCount-1 Do For J:= 1 To RowCount-1 Do Cells[I,J]:= '';
  lbKesz.Caption:= '';
  N:= 0; lbN.Caption:= IntToStr(N);
end;

Function TfmBTrVezer.Rossz(B,C: Word): Boolean;
Begin
  Rossz:= (T[B]=T[C]) Or (Abs(T[B]-T[C])=Abs(B-C));
End;

Function TfmBTrVezer.Jo(A: Word): Boolean;
Var J: Word;
Begin
  J:= 1; While Not Rossz(A,J) And (J<A) Do Inc(J); Jo:= A=J;
End;

Procedure TfmBTrVezer.Keres;
Var I, J: Word;
    Vege: Boolean;
Begin
  Vege:= False; For I:= 1 To Meret Do T[I]:= 0; I:= 1;
Repeat
While I In [1..Meret] Do
Begin
      Inc(T[I]);
If T[I]>Meret Then Begin T[I]:= 0; Dec(I); End Else If Jo(I) Then Inc(I);
End;
If I>Meret Then
Begin
      Tablara; Inc(N);
With sgBTrVezer Do
Begin
If RowCount<N+1 Then
Begin
          Cells[0,RowCount-1]:= IntToStr(RowCount-1)+'.';
          RowCount:= N+1;
End;
For J:= 1 To Meret Do Begin Cells[J,N]:= IntToStr(T[J]) End;
End;
End;
If I>1 Then Begin Dec(I); Inc(T[I]) End Else Vege:= True;
Until Vege;
With sgBTrVezer Do If RowCount>94 Then
Begin
    RowCount:= RowCount+1;
    Cells[0,RowCount-2]:= IntToStr(RowCount-2)+'.';
End;
End;

Procedure TfmBTrVezer.Tablara;
Var I, J: Word;
Begin
With sgTabla Do
Begin
For I:= 1 To Meret Do For J:= 1 To Meret Do Cells[I,J]:= '';
For I:= 1 To Meret Do If T[I]<>0 Then Cells[I,Meret+1-T[I]]:= 'V';
End;
End;

procedure TfmBTrVezer.btStartClick(Sender: TObject);
begin
  sgBTrVezer.RowCount:= 94; N:= 0;
  Keres; lbKesz.Caption:= 'Kész:'; lbN.Caption:= IntToStr(N);
end;

procedure TfmBTrVezer.sgBTrVezerClick(Sender: TObject);
Var I, J: Word;
begin
With sgTabla Do
For I:= 1 To ColCount-1 Do For J:= 1 To RowCount-1 Do Cells[I,J]:= '';
With sgBTrVezer Do If Cells[Col,Row]<>'' Then
For I:= 1 To ColCount-1 Do
  sgTabla.Cells[I,Meret+1-StrToInt(Cells[I,Row])]:= 'V';
end;

procedure TfmBTrVezer.edMeretChange(Sender: TObject);
Var Kod: Integer;
begin
  Val(edMeret.Text,Meret,Kod);
  btAlapClick(Sender);
end;

end.

Vezérek elhelyezése sakktáblán Genetikus algoritmussal

A genetikus algoritmusoknak ott nagy a létjogosultsága, ahol a feladatok megoldását nagyon magas elemszámú állapottérből kell megkeresni. Ekkor a fentebb (előző vezér-elhelyezési programokban) is használt keresési eljárások a gépek korlátozott sebessége miatt nem használható.

Mint láttuk, vannak olyan reprezentációi a kitűzött feladatnak, melyek egész hamar megoldásra vezetnek. Ezek a reprezentációk már önmagukban hordozzák a feladat specifikus tulajdonságait, így az állapottér elemszáma értelmes méretekre csökkenthető volt.

Ebben a szakaszban mintegy elfelejtve az imént említett reprezentációkat, úgy tekintünk a feladatra, mintha az elemi tulajdonságait nem ismernénk, azt csak az algoritmus közben, az egyedek jóságának vizsgálatakor érvényesítjük. Így az egyedek a populációk során válnak külön-külön a jó tulajdonságok hordozóivá.

A Genetikus algoritmus lényege az, hogy kezdetben véletlenül megválasztott elemekből létrehozunk egy populációt (genetikus kódot, elrendezést, az elemszámot a feladat maga, illetve a rendelkezésre álló erőforrás erősen befolyásolja). Majd a következő populációt (generációt) az előzőből például keresztezéssel és/vagy mutációval létrehozzuk. A keresztezés azt jelenti, hogy két egyed genetikus kódját részben kicseréljük, így új egyedeket hozunk létre. A mutációnál az egyes egyed genetikus kódját véletlen módon megváltoztatjuk.

A keresztezésnél az a cél, hogy azon egyedek kódja öröklődjenek, amelyek jók. Tehát két jónak minősített egyedet keresztezünk, és két rossznak (gyengének) mutatkozó egyed helyett ezek fognak szerepelni a következő populációban. Így elvileg a populáció egyre jobb tulajdonságú elemekből fog állni. Azt várjuk, hogy keresztezés révén a populációban elő fog fordulni legalább egy, a lehető legjobb tulajdonságokkal rendelkező egyed, ami a feladat megoldását jelenti. Ez persze általában nem így van. Ha az egyedek összességében nem hordozzák a legjobb megoldás kódját, akkor nem kapjuk meg a feladat megoldását. Ekkor az egyedek jósága egy bizonyos szint fölé nem fog emelkedni és szükség lesz a mutációra.

Mutációt akkor kell alkalmazni, amikor a populáció jósága egy szinten (de nem a tökéletes megoldást jelentőn) megakad, azaz keresztezéssel már nem képes tovább fejlődni. Ekkor az egyedek genetikus kódját egy adott százalékos valószínűséggel, véletlen értékre változtatjuk, azaz a kódot frissítjük. Ettől azt várjuk, hogy a holtponti helyzetből a populáció kimozdul, lesznek újra rossz és jó tulajdonságú egyedek, és reményeink szerint a véletlen választás folytán előáll a legjobb tulajdonságú egyed előállítására alkalmas genetikai kód is. Általában igaz, hogy a mutációt nem túl magas százalékban kell alkalmazni, különben a már felhalmozódott jó tulajdonságok eltűnnek az egyedekből.

Az itt leírtak szerint készült a címben megfogalmazott feladatra a program. A programnak nem az a célja, hogy az előző feladatokban látható megoldások felett győzedelmeskedjen. Az összes lehetséges elhelyezést megadó programon egyébként már nincs mit javítani, az pillanatok alatt mindent elmond a problémáról. A cél tehát a genetikus algoritmus bemutatása egy viszonylag egyszerű, más eszközökkel is megoldott problémára. A program listája szerintem megfelelően kommentezett, így magyarázatra nem szorul.

A program futási képei. Induláskor:

A keresés végén:

A program listája.

unit UGenVezer;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes,

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

Const EgyedSz=40;
      Max=8;
type
  TfmGenVezer = class(TForm)
    lbHenVezer: TLabel;
    btKilepes: TButton;
    sgGenVezer: TStringGrid;
    btUjPop: TButton;
    sgTabla: TStringGrid;
    lbJosag: TLabel;
    edJosag: TEdit;
    lbEgyedSz: TLabel;
    edEgyedSz: TEdit;
    lbJokSz: TLabel;
    edJokSz: TEdit;
    btStart: TButton;
    lbPopSz: TLabel;
    edPSz: TEdit;
    lbKesz: TLabel;
    edKesz: TEdit;
    lbIndex: TLabel;
    edIndex: TEdit;
    lbMutacio: TLabel;
    edMutacio: TEdit;
    lbSzazalek: TLabel;
    lbKereszt: TLabel;
    edKereszt: TEdit;
Procedure PopInit;
Procedure Vizsgal;
Procedure PopKepre;
Procedure Tablara(Ind: Word);
Procedure Keresztez;
Procedure Mutacio;
procedure FormCreate(Sender: TObject);
procedure btKilepesClick(Sender: TObject);
procedure sgGenVezerDrawCell(Sender: TObject; Col, Row: Integer;
      Rect: TRect; State: TGridDrawState);
procedure sgGenVezerClick(Sender: TObject);
procedure btUjPopClick(Sender: TObject);
procedure sgTablaDrawCell(Sender: TObject; Col, Row: Integer;
      Rect: TRect; State: TGridDrawState);
procedure btStartClick(Sender: TObject);
procedure edMutacioChange(Sender: TObject);
procedure edKeresztChange(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

  THely=Record
    X, Y: Byte;
    Jo: Boolean;      //true, ha a vezér nincs ütésben
End;

  TEgyed=Record
    EXY: Array[1..Max] Of THely;
    EOK: Byte;        //az ütésben nem álló vezérek száma
    JoEgyed: Boolean; //true, ha az ütésben nem álló vezérek szám átlag feletti
End;

var
  fmGenVezer: TfmGenVezer;
  ACol, ARow: Integer;
  Colors: Array[1..Max,1..Max] Of Boolean;
  EgyedT: Array[1..EgyedSz] Of TEgyed;
  JokSz: Word;        //az átlag feletti egyedek száma
  Josag: Real;        //a populáció ütésben nem álló vezéreinek átlaga
  Kereszt: Byte;      //a keresztezési index
  Uj1, Uj2: TEgyed;   //új egyedek
  IR1, IR2, IJ1, IJ2: Word;  //régi és új egyedek tömbindexei
  PSz: Word;                 //populációk száma
  OKMax, IMax, OldMax, //segédváltozók a populációk generálásánál
  MutSz: Word;         //mutáció erősségét mutató százalékérték

implementation

{$R *.dfm}

procedure TfmGenVezer.btKilepesClick(Sender: TObject);
begin
//kilépés a programból
  Close;
end;

procedure TfmGenVezer.sgGenVezerClick(Sender: TObject);
begin
//kattintás után az egyed megjelenítése a képernyőn lévő sakktáblán
  PopKepre;
With sgGenVezer Do Begin ACol:= Col; ARow:= Row; RePaint End;
  Tablara(ARow);
end;

procedure TfmGenVezer.sgGenVezerDrawCell(Sender: TObject; Col,
  Row: Integer; Rect: TRect; State: TGridDrawState);
begin
//a populációt megjelenítő StringGrid beállításai
With sgGenVezer.Canvas.Brush Do
Begin
{rögzített cellák}
If (gdFixed In State) And ((Col=ACol) Or (Row=ARow)) Then
    Color:= clYellow Else Color:=clBtnFace;

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

{a táblázat belseje}
If Not((gdSelected In State) Or (gdFixed In State)) Then
If Odd(Col) Then Color:= clAqua Else Color:= clWindow;
End;
  sgGenVezer.Canvas.TextRect(Rect,Rect.Left+3,Rect.Top+1,
                             sgGenVezer.Cells[Col,Row]);
If gdFocused In State Then sgGenVezer.Canvas.DrawFocusRect(Rect);
end;

procedure TfmGenVezer.sgTablaDrawCell(Sender: TObject; Col, Row: Integer;
  Rect: TRect; State: TGridDrawState);
begin
//a sakktáblát és felállást megjelenítő StringGrid beállításai
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;
If Colors[Col,Row] Then Color:= clGreen;
End;
    sgTabla.Canvas.Font.Size:= 17;
End;
  sgTabla.Canvas.TextRect(Rect,Rect.Left+16,
                          Rect.Top+4,sgTabla.Cells[Col,Row]);
If gdFocused In State Then sgTabla.Canvas.DrawFocusRect(Rect);
end;

procedure TfmGenVezer.edKeresztChange(Sender: TObject);
Var Kod: Integer;
begin
  Val(edKereszt.Text, Kereszt, Kod);
end;

procedure TfmGenVezer.edMutacioChange(Sender: TObject);
Var Kod: Integer;
begin
  Val(edMutacio.Text, MutSz, Kod);
end;

Procedure TfmGenVezer.PopInit;
Var I, J: Word;
Begin
//egy teljes populáció létrehozása
For I:= 1 To EgyedSz Do With EgyedT[I] Do
Begin
For J:= 1 To Max Do With EXY[J] Do
Begin
      X:= Random(Max)+1;
      Y:= Random(Max)+1;
      Jo:= True;
End;
    EOK:= 0;
    JoEgyed:= False;
End;
End;

Procedure TfmGenVezer.Vizsgal;
Var I, J, K, Sz: Word;
    Utesben: Boolean;
Begin
//a populáció vizsgálata
//megállapítja minden vezérről, hogy ütésben van-e (-> Utesben)
//megállapítja minden egyedről, hogy hány vezér elhelyezkedése jó (-> Jo)
  JokSz:= 0; OKMax:= 0;
For I:= 1 To EgyedSz Do With EgyedT[I] Do
Begin
    Sz:= 0;
For J:= 1 To Max Do
Begin
      Utesben:= False; For K:= 1 To Max Do If J<>K Then
If EXY[J].X=EXY[K].X Then Begin Utesben:= True; Break End;
If Not Utesben Then For K:= 1 To Max Do If J<>K Then
If EXY[J].Y=EXY[K].Y Then Begin Utesben:= True; Break End;
If Not Utesben Then For K:= 1 To Max Do If J<>K Then
If Abs(EXY[J].X-EXY[K].X)=Abs(EXY[J].Y-EXY[K].Y) Then
Begin Utesben:= True; Break End;
      EXY[J].Jo:= Not Utesben;
If Not Utesben Then Inc(Sz);
End;
    EOK:= Sz; If EOK>OKMax Then Begin OKMax:= EOK; IMax:= I End;
    Inc(JokSz,EOK);
End;
//megállapítja a populáció jóságát:
//jó helyezetű vezérek számának átlaga-> Josag
  Josag:= JokSz/EgyedSz;
  edJosag.Text:= FloatToStr(Josag);
//minden egyedről megállapítja, hogy jó-e:
//átlag feletti a jó helyzetű vezérek száma -> JoEgyed:= True
  JokSz:= 0;
For I:= 1 To EgyedSz Do With EgyedT[I] Do If EOK>Josag Then
Begin
    Inc(JokSz);
    JoEgyed:= True;
End Else JoEgyed:= False;
  edJokSz.Text:= IntToStr(JokSz);
End;

Procedure TfmGenVezer.Keresztez;
Var I, V, R: Word;
Begin
  Inc(PSz);
//a két legrosszabb egyed keresése
  V:= Random(EgyedSz)+1; R:= Max; IR1:= 0;
For I:= V+1 To EgyedSz Do With EgyedT[I] Do
If Not JoEgyed And (EOK<R) Then Begin R:= EOK; IR1:= I End;
For I:= 1 To V  Do With EgyedT[I] Do
If Not JoEgyed And (EOK<R) Then Begin R:= EOK; IR1:= I End;

  V:= Random(EgyedSz)+1; R:= Max; IR2:= 0;
For I:= V+1 To EgyedSz Do With EgyedT[I] Do If I<>IR1 Then
If Not JoEgyed And (EOK<R)Then Begin R:= EOK; IR2:= I End;
For I:= 1 To V  Do With EgyedT[I] Do If I<>IR1 Then
If Not JoEgyed And (EOK<R) Then Begin R:= EOK; IR2:= I End;

//két jó egyed keresése:
//nem a két legjobbat, mert akkor nem lenne eléggé nagy a változatosság
  V:= Random(EgyedSz)+1; IJ1:= 0;
For I:= V+1 To EgyedSz Do With EgyedT[I] Do If JoEgyed Then IJ1:= I;
For I:= 1 To V  Do With EgyedT[I] Do If JoEgyed Then IJ1:= I;

  V:= Random(EgyedSz)+1; IJ2:= 0;
For I:= V+1 To EgyedSz Do With EgyedT[I] Do If I<>IJ1 Then
If JoEgyed Then IJ2:= I;
For I:= 1 To V  Do With EgyedT[I] Do If I<>IJ1 Then
If JoEgyed Then IJ2:= I;

//két jó egyed keresztezése -> Uj1, Uj2: TEgyed
If IJ1*IJ2<>0 Then
Begin
For I:= 1 To Kereszt Do Uj1.EXY[I]:= EgyedT[IJ1].EXY[I];
For I:= Kereszt+1 To Max Do Uj1.EXY[I]:= EgyedT[IJ2].EXY[I];
    Uj1.JoEgyed:= False;
For I:= 1 To Kereszt Do Uj2.EXY[I]:= EgyedT[IJ2].EXY[I];
For I:= Kereszt+1 To Max Do Uj2.EXY[I]:= EgyedT[IJ1].EXY[I];
    Uj2.JoEgyed:= False;
End;
End;

Procedure TfmGenVezer.Mutacio;
Var I, J: Word;
Begin
//a populáció minden egyedének mindkét koordinátáját MutSz valószínűséggel
//módosítjuk egy véletlen értékr
For I:= 1 To EgyedSz Do With EgyedT[I] Do
For J:= 1 To Max Do With EXY[J] Do
Begin
If Random(100)<MutSz Then X:= Random(Max)+1;
If Random(100)<MutSz Then Y:= Random(Max)+1;
End;
End;

procedure TfmGenVezer.btStartClick(Sender: TObject);
begin
//populációk generálása és vizsgálata
  OKMax:= 0; IMax:= 0; PSz:= 0;
Repeat
    OldMax:= OKMax;
    Keresztez;
If JokSz In [2,3,4] Then Mutacio;
If (IR1*IR2<>0) And (IJ1*IJ2<>0) Then
Begin
      EgyedT[IR1]:= Uj1;
      EgyedT[IR2]:= Uj2;
End
Else Mutacio;
    Vizsgal;
    PopKepre;
    edPSz.Repaint;
If OKMax>OldMax Then
Begin
      sgGenVezer.Repaint;
      edKesz.Text:= IntToStr(OKMax); edKesz.Repaint;
      edIndex.Text:= IntToStr(IMax); edIndex.Repaint;
      Tablara(IMax); sgTabla.Repaint;
End;
Until (OKMax>=Max) Or (PSz>20000);
//max értékig, vagy maximum 20000 permutációig keresünk

end;

Procedure TfmGenVezer.PopKepre;
Var I, J: Word;
Begin
//a populáció minden egyedét, a jó elhelyezkedésü vezérek számával együtt
//megjeleníti egy StringGrid-ben
With sgGenVezer Do
Begin
For I:= 1 To EgyedSz Do With EgyedT[I] Do
Begin
For J:= 1 To Max Do With EXY[J] Do
Begin
        Cells[2*J-1,I]:= Char(96+X);
        Cells[2*J  ,I]:= IntToStr(Y);
End;
      Cells[ColCount-1,I]:= IntToStr(EOK);
End;
End;
  edPSz.Text:= IntToStr(PSz);
End;

Procedure TfmGenVezer.Tablara(Ind: Word);
Var I, J: Word;
Begin
//egy egyed megjelenítés a sakktáblán
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 For J:= 1 To Max Do Colors[I,J]:= False;
With EgyedT[Ind] Do For I:= 1 To Max Do With EXY[I] Do
Begin
      Cells[X,Max-Y+1]:= 'V';
      Colors[X,Max-Y+1]:= Jo;
End;
End;
  sgTabla.Repaint;
End;

procedure TfmGenVezer.FormCreate(Sender: TObject);
Var I: Word;
    Ch: Char;
begin
//a program vízuális elemeinek megjelenítése, a kezdeti populáció generálása
  ACol:= 1; ARow:= 1;
With sgGenVezer Do
Begin
    RowCount:= EgyedSz+1;
    ColWidths[0]:= 35;
For I:= 1 To RowCount-1 Do Cells[0,I]:= IntToStr(I)+'.';
For I:= 1 To Max Do
Begin
      Cells[2*I-1,0]:= IntToStr(I)+'.X';
      Cells[2*I  ,0]:= IntToStr(I)+'.Y';
End;
    Cells[ColCount-1,0]:= 'EOK';
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;
  PopInit;
  Vizsgal;
  PopKepre;

//kezdő és alapértelmezett értékek:
  edEgyedSz.Text:= IntToStr(EgyedSz);
  PSz:= 1; edPSz.Text:= IntToStr(PSz);
  MutSz:= 25; edMutacio.Text:= IntToStr(MutSz);
  Kereszt:= 4; edKereszt.Text:= IntToStr(Kereszt);

end;

procedure TfmGenVezer.btUjPopClick(Sender: TObject);
Var I, J: Word;
begin
//új populáció generálása
For I:= 1 To Max Do For J:= 1 To Max Do Colors[I,J]:= False;
With sgTabla Do
For I:= 1 To ColCount-1 Do For J:= 1 To RowCount-1 Do Cells[I,J]:= '';
  PopInit;
  Vizsgal;
  PopKepre;
  PSz:= 1; edPSz.Text:= IntToStr(PSz);
end;

end.

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.