Találó

Ez a program egy egyszerű kis játékot tartalmaz. A gép által kitalált két szám közül az elsőt megmutatja és tippelhetünk, hogy másodikhoz nagyságát tekintve hogyan viszonyul. A gép ellen játszunk, minden jó válasz egy pontot érnek. Az győz, aki előbb éri el a 20-at. Ez a program inkább a Delphi lehetőségei bemutatását szolgálja, mintsem komoly játéklehetőséget adna.

A program futási képe:

A program listája:

unit UTalalo;

interface

uses
  Windows, Messages, SysUtils, Classes, 

Graphics, Controls, Forms, Dialogs, StdCtrls, ComCtrls;

type
  TfmTalalo = class(TForm)
    edA: TEdit;
    edB: TEdit;
    btNagyobb: TButton;
    btEgyenlo: TButton;
    btKisebb: TButton;
    btVege: TButton;
    lbJatekos: TLabel;
    lbGep: TLabel;
    pbJatekos: TProgressBar;
    pbGep: TProgressBar;
    lbEredmeny: TLabel;
    lbJ: TLabel;
    lbG: TLabel;
    btUj: TButton;
Procedure Ki;
Procedure Be;
Procedure Ertekelo;
procedure btVegeClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure btNagyobbClick(Sender: TObject);
procedure btEgyenloClick(Sender: TObject);
procedure btKisebbClick(Sender: TObject);
procedure btUjClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
  fmTalalo: TfmTalalo;
  A, B, J, G: Integer;
  Vege: Boolean;
  Gy: Byte;

Const N: Byte=20;

implementation

{$R *.DFM}

procedure TfmTalalo.btVegeClick(Sender: TObject);
begin
  Close;
end;

Procedure TfmTalalo.Ki;
Begin
  btNagyobb.Enabled:= False;
  btEgyenlo.Enabled:= False;
  btKisebb.Enabled:= False;
End;

Procedure TfmTalalo.Be;
Begin
  btNagyobb.Enabled:= True;
btEgyenlo.Enabled:= True;
  btKisebb.Enabled:= True;
End;

Procedure TfmTalalo.Ertekelo;
Begin
If J=N Then Gy:= 1;
If G=N Then Gy:= 2;
With lbEredmeny Do
If Gy<>0 Then
Begin
    Vege:= True;
Case Gy Of
      1: Caption:= 'Győztél!';
      2: Caption:= 'Győztem!';
End;
    Visible:= True;
    btUj.Visible:= True;
End;
End;

procedure TfmTalalo.FormCreate(Sender: TObject);
begin
  Randomize;
  A:= Random(6)+1;
  edA.Text:= IntToStr(A);
  J:= 0;
  G:= 0;
  Gy:= 0;
  Vege:= False;
  lbEredmeny.Visible:= False;
  btUj.Visible:= False;
end;

procedure TfmTalalo.btNagyobbClick(Sender: TObject);
begin
If Vege Then Exit;
  B:= Random(6)+1;
  edB.Text:= IntToStr(B);
  edB.Repaint;
If A>B Then
Begin
    Inc(J); pbJatekos.StepIt;
    lbJ.Caption:= IntToStr(J);
End Else
Begin
    Inc(G); pbGep.StepIt;
    lbG.Caption:= IntToStr(G);
End;
  Ki;
  Sleep(1000);
  Be;
  A:= Random(6)+1;
  edA.Text:= IntToStr(A);
  edB.Text:= '';
  Ertekelo;
end;

procedure TfmTalalo.btEgyenloClick(Sender: TObject);
begin
If Vege Then Exit;
  B:= Random(6)+1;
  edB.Text:= IntToStr(B);
  edB.Repaint;
If A=B Then
Begin
Inc(J); pbJatekos.StepIt;
    lbJ.Caption:= IntToStr(J);
End Else
Begin
    Inc(G); pbGep.StepIt;
    lbG.Caption:= IntToStr(G);
End;
  Ki;
  Sleep(1000);
  Be;
  A:= Random(6)+1;
  edA.Text:= IntToStr(A);
  edB.Text:= '';
  Ertekelo;
end;

procedure TfmTalalo.btKisebbClick(Sender: TObject);
begin
If Vege Then Exit;
  B:= Random(6)+1;
  edB.Text:= IntToStr(B);
  edB.Repaint;
If A<B Then
Begin
    Inc(J); pbJatekos.StepIt;
    lbJ.Caption:= IntToStr(J);
End Else
Begin
    Inc(G); pbGep.StepIt;
    lbG.Caption:= IntToStr(G);
End;
  Ki;
  Sleep(1000);
  Be;
  A:= Random(6)+1;
edA.Text:= IntToStr(A);
  edB.Text:= '';
  Ertekelo;
end;

procedure TfmTalalo.btUjClick(Sender: TObject);
begin
  J:= 0; lbJ.Caption:= '0';
  G:= 0; lbG.Caption:= '0';
  Gy:= 0;
  Vege:= False;
  btUj.Visible:= False;
  lbEredmeny.Visible:= False;
  pbJatekos.Position:= 0;
  pbGep.Position:= 0;
  A:= Random(6)+1;
  edA.Text:= IntToStr(A);
end;

end.

Számrendező (15-ös játék)

Valószínű sokan ismerik a 15-ös játékot. Ennek az a lényege, hogy egy 4x4-es mezőn összekeverve helyezkedik el 1-től 15-ig feliratozva egy-egy kis lapocska. Egy üresen van hagyva. Az üres helyre a mellette lévő lapszomszédos helyről a lapocska áttolható. Cél az, hogy sorfolytonosan 1-től 15-ig rendezetten kell, tologatással elhelyezni a lapocskákat úgy, hogy a jobb alsó hely maradjon üresen. A számítógépes megoldás ennél annyival több, hogy maximálisan 10x10–ig mi választhatjuk meg a játékteret. Természetesen akkor is csak egy üres hely marad, így a lapocskák száma mindig N x M -1. A program számolja az átrakások számát, és ha készen vagyunk, Gratuláló szöveget jelenít meg. Szerencsés próbálgatást.

A program egy futási képe:

A program listája:

unit USzamRend;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes,

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

type
  TfmSzamRend = class(TForm)
    lbSzamRend: TLabel;
    lbSorSzam: TLabel;
    edSorSzam: TEdit;
    lbOszlSzam: TLabel;
    edOszlSzam: TEdit;
    btKilepes: TButton;
    btKeveres: TButton;
    sgSzamRend: TStringGrid;
    lbLepes: TLabel;
    lbLepesSz: TLabel;
Procedure StartUp;
Function Vege: Boolean;
procedure btKilepesClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure edSorSzamChange(Sender: TObject);
procedure edOszlSzamChange(Sender: TObject);
procedure btKeveresClick(Sender: TObject);
procedure sgSzamRendDblClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
  fmSzamRend: TfmSzamRend;
  Nx, Ny, Ux, Uy, L: Word;

implementation

{$R *.dfm}

Procedure TfmSzamRend.StartUp;
Var I, J, N : Word;
Begin
  Nx:= StrToInt(edOszlSzam.Text);
  Ny:= StrToInt(edSorSzam.Text);
With sgSzamRend Do
Begin
    ColCount:= Nx+1; RowCount:= Ny+1;
For I:= 1 To ColCount-1 Do For J:= 1 To RowCount-1 Do Cells[I,J]:= '';
For I:= 1 To ColCount Do Cells[I,0]:= '*';
For J:= 1 To RowCount Do Cells[0,J]:= '*';
    DefaultColWidth:= Round(400/Nx); DefaultRowHeight:= Round(320/Ny);
    ColWidths[0]:= 0; RowHeights[0]:= 0;
    Font.Size:= 24-Nx; Font.Style:=[fsBold]; Col:= 1; Row:= 1;
    N:= Nx*Ny-1;
For I:= 1 To N Do
    Cells[(I-1) Mod Nx+1,(I-1) Div Nx+1]:= IntToStr(I);
    Ux:= ColCount-1; Uy:= RowCount-1;
End;
  L:= 0; lbLepesSz.Caption:= IntToStr(L);
End;

Function TfmSzamRend.Vege: Boolean;
Var I: Word;
Begin
  Vege:= False;
With sgSzamRend Do
Begin
If Cells[ColCount-1,RowCount-1]<>'' Then Exit;
For I:= 1 To Nx*Ny-1 Do
If Cells[(I-1) Mod Nx+1,(I-1) Div Nx+1]<>'' Then
If StrToInt(Cells[(I-1) Mod Nx+1,(I-1) Div Nx+1])<>I Then Exit;
End;
  Vege:= True;
End;

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

procedure TfmSzamRend.FormCreate(Sender: TObject);
begin
  Randomize;
  StartUp;
  btKeveresClick(Sender);
end;

procedure TfmSzamRend.edSorSzamChange(Sender: TObject);
Var Kod: Integer;
begin
With edSorSzam Do
Begin
    Val(Text,Ny,Kod); If Kod=0 Then
Begin
      L:= 0; If Ny>10 Then Ny:= 10; Text:= IntToStr(Ny);
      StartUp; btKeveresClick(Sender);
End;
End;
end;

procedure TfmSzamRend.edOszlSzamChange(Sender: TObject);
Var Kod: Integer;
begin
With edOszlSzam Do
Begin
    Val(Text,Nx,Kod); If Kod=0 Then
Begin
      L:= 0; If Nx>10 Then Nx:= 10; Text:= IntToStr(Nx);
      StartUp; btKeveresClick(Sender);
End;
End;
end;

procedure TfmSzamRend.btKeveresClick(Sender: TObject);
Var I, N: Word;
    P: String;
begin
  StartUp;
  N:= 100*Nx*Ny;
For I:= 1 To N Do With sgSzamRend Do
Case Random(4) Of
    0: If Uy-1 In [1..Ny] Then
Begin
         P:= Cells[Ux,Uy-1]; Cells[Ux,Uy-1]:= '';

Cells[Ux,Uy]:= P; Dec(Uy);
End;
    1: If Ux+1 In [1..Nx] Then
Begin
         P:= Cells[Ux+1,Uy]; Cells[Ux+1,Uy]:= '';

Cells[Ux,Uy]:= P; Inc(Ux);
End;
    2: If Uy+1 In [1..Ny] Then
Begin
         P:= Cells[Ux,Uy+1]; Cells[Ux,Uy+1]:= ''; 

Cells[Ux,Uy]:= P; Inc(Uy);
End;
    3: If Ux-1 In [1..Nx] Then
Begin
         P:= Cells[Ux-1,Uy]; Cells[Ux-1,Uy]:= '';

Cells[Ux,Uy]:= P; Dec(Ux);
End;
End;
end;

procedure TfmSzamRend.sgSzamRendDblClick(Sender: TObject);
Var P: String;
    Volt: Boolean;
begin
  Volt:= False;
With sgSzamRend Do
Begin
If Row-1 In [1..Ny] Then If Cells[Col,Row-1]='' Then
Begin
      P:= Cells[Col,Row]; Cells[Col,Row]:= ''; Cells[Col,Row-1]:= P;
      Volt:= True;
End;
If Col+1 In [1..Nx] Then If Cells[Col+1,Row]='' Then
Begin
      P:= Cells[Col,Row]; Cells[Col,Row]:= ''; Cells[Col+1,Row]:= P;
      Volt:= True;
End;
If Row+1 In [1..Ny] Then If Cells[Col,Row+1]='' Then
Begin
P:= Cells[Col,Row]; Cells[Col,Row]:= ''; Cells[Col,Row+1]:= P;
      Volt:= True;
End;
If Col-1 In [1..Nx] Then If Cells[Col-1,Row]='' Then
Begin
      P:= Cells[Col,Row]; Cells[Col,Row]:= ''; Cells[Col-1,Row]:= P;
      Volt:= True;
End;
End;
If Volt Then
Begin
    Inc(L); lbLepesSz.Caption:= IntToStr(L);
If Vege Then
Begin
      MessageDlg('Gratulálok',mtInformation,[mbOK],0);
      btKeveresClick(sender);
End;
End;
end;

end.

Bűvös lámpák

Az itt látható játékprogramban az a cél, hogy a megjelenő, kezdetben még nem látható (alvó) lámpák mindegyikét felkapcsoljuk. A kapcsolgatást egérkattintással végezhetjük. Ha egy lámpára kattintunk, akkor állapota megváltozik, de nem csak az övé, hanem minden lapszomszédjának állapota is.

Kezdetben megadhatjuk, hogy a lámpák hány sorban és hány oszlopban helyezkedjenek el. A sorok és oszlopok maximális száma 16.

A másik opció érdekesebb. Megadhatjuk, hogy a lámpák milyen felületen helyezkedjenek el. Lehet egy síkbeli téglalapon, vagy térben egy henger, vagy egy tórusz (úszógumi) felületén. Az utóbbiak a megjelenítésben nem láthatók, a működésben viszont igen. Úgy kell elképzelni a henger esetén, mintha az utolsó oszlop az első oszlop szomszédja lenne. Vagyis, ha az első oszlopon kattintunk, akkor annak az utolsó oszlopban is lesz hatása. A tórusznál pedig nemcsak az első oszlop és az utolsó oszlop szomszédos, hanem az első sor és az utolsó sor is.

Ha minden lámpát sikerült felkapcsolni, akkor a program írja ki: Game Over és ne engedje tovább a kapcsolgatást. A programból lehessen bármikor kilépni és bármikor új játékot kezdeni, valamint számolja, és írja ki a lépések számát a képernyőre.

A program egy futási képe:

Ha sikerült felkapcsolni minden lámpát:

A program listája:

unit ULampak;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes,

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

type
  TfmLampak = class(TForm)
    btKilepes: TButton;
    btStart: TButton;
    lbLampak: TLabel;
    rgFelulet: TRadioGroup;
    lbSSz: TLabel;
    lbOSz: TLabel;
    edSSz: TEdit;
    edOSz: TEdit;
Procedure Racs(BFx,BFy,Bx,By,Nx,Ny: Integer);
Procedure Kepre;
Function Vege: Boolean;
procedure btKilepesClick(Sender: TObject);
procedure edSSzChange(Sender: TObject);
procedure edOSzChange(Sender: TObject);
procedure btStartClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClick(Sender: TObject);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
procedure FormPaint(Sender: TObject);
procedure rgFeluletClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

Const Max=16;
      D=32;
      Dx=16;
      Dy=16;
      T=14;

var
  fmLampak: TfmLampak;
  Xk, Yk, Fx, Fy, Hx, Hy, Mx, My: Integer;
  L: Array[0..Max+1,0..Max+1] Of Byte;
  Felulet: Byte;
  F: Array[1..3] Of String;
  SSz, OSz: Byte;
  N: Word;
  VegeVan: Boolean;

implementation

{$R *.dfm}

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

procedure TfmLampak.FormPaint(Sender: TObject);
begin
With Canvas Do
Begin
    Pen.Color:= clBtnFace;
    Rectangle(Xk-80,35,Xk+80,80);
With Font Do
Begin
      Size:= 20;
      Name:= 'Times New Roman';
      Color:= clBlue;
End;
    TextOut(Xk-40,40,F[Felulet]);
    Pen.Color:= clBlack;
End;
end;

procedure TfmLampak.FormCreate(Sender: TObject);
begin
  Xk:= ClientWidth Div 2;
  Yk:= ClientHeight Div 2;
  F[1]:= 'Téglalap';
  F[2]:= 'Henger';
  F[3]:= 'Tórusz';
  Felulet:= 1;
  N:= 0;
VegeVan:= False;
end;

procedure TfmLampak.rgFeluletClick(Sender: TObject);
begin
  Felulet:= rgFelulet.ItemIndex+1;
  FormPaint(Sender);
  btStartClick(Sender);
end;

procedure TfmLampak.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  Mx:= X;
  My:= Y;
If (Mx<Xk-(Fx-1)*D-1-Dx-T) Or (Mx>Xk+(Fx-1)*D+10+Dx+T) Or
     (My<Yk-(Fy-1)*D-1-Dy-T) Or (My>Yk+(Fy-1)*D+10+Dy+T) Then
  Cursor:= crDefault Else Cursor:= crCross;
end;

Procedure TfmLampak.Racs(BFx,BFy,Bx,By,Nx,Ny: Integer);
Var I, Sx,Sy: Integer;
Begin
If Nx*Ny=0 Then Exit;
  Sx:= Bfx+Nx*(Bx+1);
Sy:= Bfy+Ny*(By+1);
With Canvas Do
Begin
    Rectangle(BFx,Bfy,Sx,Sy);
    I:= BFx+Bx+1; While I<Sx Do
Begin MoveTo(I,BFy); LineTo(I,Sy); Inc(I,Bx+1) End;
    I:= BFy+By+1; While I<Sy Do
Begin MoveTo(BFx,I); LineTo(Sx,I); Inc(I,By+1) End;
End;
End;

procedure TfmLampak.edSSzChange(Sender: TObject);
begin
With edSSz Do
Begin
If Length(Text)>0 Then
If Not (Text[Length(Text)] In ['0'..'9']) Then Text:= '';
If Length(Text)>2 Then Text:= '';
End;
end;

procedure TfmLampak.edOSzChange(Sender: TObject);
begin
With edOSz Do
Begin
If Length(Text)>0 Then
If Not (Text[Length(Text)] In ['0'..'9']) Then Text:= '';
If Length(Text)>2 Then Text:= '';
End;
end;

procedure TfmLampak.btStartClick(Sender: TObject);
Var I, J: Word;
begin
  SSz:= StrToInt(edSSz.Text);
If SSz>Max Then Begin SSz:= Max; edSSz.Text:= IntToStr(SSz) End;
  OSz:= StrToInt(edOSz.Text);
If OSz>Max Then Begin OSz:= Max; edOSz.Text:= IntToStr(OSz) End;
  Fx:= Max Div 2;
  Fy:= Max Div 2;
With Canvas Do
Begin
    Pen.Color:= clBtnFace;
    Brush.Color:= clBtnFace;
    Rectangle(Xk-(Fx+1)*D,Yk-(Fy+1)*D,Xk+(Fx+1)*D,Yk+(Fy+1)*D);
    Pen.Color:= clBlack;
End;
Fx:= OSz Div 2;
  Fy:= SSz Div 2;
  Racs(Xk-Fx*D,Yk-Fy*D,D,D,OSz,SSz);
For I:= 0 To Max+1 Do For J:= 0 To Max+1 Do L[I,J]:= 0;
  FormPaint(Sender);
  N:= 0;
  VegeVan:= False;
end;

Procedure TfmLampak.Kepre;
Var I, J: Word;
Begin
With Canvas Do
For I:= 1 To OSz Do For J:= 1 To SSz Do
Begin
Case L[I,J] Of
      0: Begin
           Pen.Color:= clBtnFace;
           Brush.Color:= clBtnFace;
End;
      1: Begin
           Pen.Color:= clBlue;
           Brush.Color:= clBlue;
End;
End;
    Ellipse(Xk-(Fx-I)*D+I-Dx-T,Yk-(Fy-J)*D+J-Dy-T,
Xk-(Fx-I)*D+I-Dx+T,Yk-(Fy-J)*D+J-Dy+T);
    Pen.Color:= clBtnFace;
    Brush.Color:= clBtnFace;
    Rectangle(Xk-30,2*Yk-80,Xk+30,2*Yk);
    Pen.Color:= clBlue;
    TextOut(Xk-20,2*Yk-80,IntToStr(N));
    Pen.Color:= clBlack;
End;
End;

Function TfmLampak.Vege: Boolean;
Var I, J, S: Word;
Begin
  S:= 0; Vege:= False; VegeVan:= False;
For I:= 1 To OSz Do For J:= 1 To SSz Do Inc(S,L[I,J]);
If S=OSz*SSz Then With Canvas Do
Begin
With Font Do
Begin
      Size:= 40;
      Name:= 'Times New Roman';
      Color:= clRed;
End;
    Brush.Color:= clWhite;
TextOut(Xk-130,Yk,' Game Over ');
    Vege:= True; VegeVan:= True; N:= 0;
End;
End;

procedure TfmLampak.FormClick(Sender: TObject);
begin
If VegeVan Then Exit;
  Hx:= (Mx-Xk+(Fx+1)*D-OSz Div 2) Div D;
  Hy:= (My-Yk+(Fy+1)*D-SSz Div 2) Div D;
If (Hx<1) Or (Hx>OSz) Or (Hy<1) Or (Hy>SSz) Then Exit;
  Inc(N);
  L[Hx,Hy]:= 1-L[Hx,Hy];
  L[Hx-1,Hy]:= 1-L[Hx-1,Hy];
  L[Hx+1,Hy]:= 1-L[Hx+1,Hy];
  L[Hx,Hy-1]:= 1-L[Hx,Hy-1];
  L[Hx,Hy+1]:= 1-L[Hx,Hy+1];
If Felulet>1 Then
Begin
If Hx=1 Then L[OSz,Hy]:= 1-L[OSz,Hy];
If Hx=OSz Then L[1,Hy]:= 1-L[1,Hy];
End;
If Felulet>2 Then
Begin
If Hy=1 Then L[Hx,SSz]:= 1-L[Hx,SSz];
If Hy=SSz Then L[Hx,1]:= 1-L[Hx,1];
End;
  Kepre;
  Vege;
end;

end.

Hamm

Írjunk játékprogramot, amellyel a következő futtatási képen látható tábláról, a korongok eltüntethetők. A korongokat egy lap- vagy csúcsszomszédján át lehet tenni egy üres helyre, ezáltal az átlépett korong eltűnik. Az a cél, hogy csak egyetlen korong maradjon. Ha a megoldás nehéznek bizonyul, akkor egy megoldást a Demo funkcióval meg lehessen nézni. A program futtatása bármikor megszakítható legyen (Demo alatt nem), illetve újra lehessen kezdeni a játékot. A program mindig figyelje, hogy nem ért-e véget a játék. Ha csak egy koron maradt, akkor írja ki, hogy Győztél, ha több és már nem lehet lépni, akkor azt, hogy Vesztettél.

A program indulási képe:

Lépés közbeni állapot, amikor kijelöltük azt a korongot, amivel lépni fogunk (piros):

A program listája:

unit UHamm;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes,

Graphics, Controls, Forms,

Dialogs, StdCtrls, Grids;

type
  TfmHamm = class(TForm)
    btKilepes: TButton;
    btDemo: TButton;
    btUjra: TButton;
Procedure Kepre;
procedure FormPaint(Sender: TObject);
procedure FormClick(Sender: TObject);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
procedure btKilepesClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure btDemoClick(Sender: TObject);
procedure btUjraClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

Const D=40;
Dx=20;
      Dy=20;
      T=5;

var
  fmHamm: TfmHamm;
  Xk, Yk, Mx, My: Integer;
  Hx, Hy, PHx, PHy: Byte;
  H: Array[0..8,0..8] Of Byte;
  VegeVan, Lepes: Boolean;

implementation

{$R *.dfm}

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

procedure TfmHamm.FormCreate(Sender: TObject);
Var I, J: Integer;
begin
For I:= 0 To 8 Do For J:= 0 To 8 Do H[I,J]:= 0;
  VegeVan:= False; Lepes:= False;
end;

Procedure TfmHamm.Kepre;
Var I, J: Integer;
Begin
With Canvas Do
Begin
For I:= 1 To 8 Do For J:= 1 To 8 Do
Begin
Case H[I,J] Of
        0: Begin
Pen.Color:= clBtnFace;
             Brush.Color:= clBtnFace;
End;
        1: Begin
             Pen.Color:= clBlue;
             Brush.Color:= clBlue;
End;
        2: Begin
             Pen.Color:= clRed;
             Brush.Color:= clRed;
End;
End;
      Ellipse(Xk+(I-4)*D-Dx-1+T,Yk+(J-4)*D-Dy-1+T,
              Xk+(I-4)*D+Dx-T,Yk+(J-4)*D+Dy-T);
End;
End;
End;

procedure TfmHamm.FormPaint(Sender: TObject);
Var I, J: Integer;
begin
  Xk:= ClientWidth Div 2;
  Yk:= ClientHeight Div 2;
With Canvas Do
Begin
    Pen.Color:= clBtnFace;
Rectangle(Xk+5*D,Yk,2*Xk,Yk+50);
    Pen.Width:= 2;
For I:= 1 To 7 Do For J:= 1 To 7 Do
If (I In [3..5]) Or (J In [3..5]) Then
Begin
      Pen.Color:= clBlack;
      Brush.Color:= clBtnFace;
      Rectangle(Xk+(I-4)*D-Dx-1,Yk+(J-4)*D-Dy-1, Xk+(I-4)*D+Dx,Yk+(J-4)*D+Dy);
      H[I,J]:= 1; If (I=4) And (J=4) Then H[I,J]:= 0;
End;
End;
  Kepre;
end;

Function Bent(A, B: Byte): Boolean;
Begin
  Bent:=((A In [3..5]) And (B In [1..7])) Or
        ((A In [1..7]) And (B In [3..5]));
End;

Function Lephet(A, B: Byte): Boolean;
Begin
  Lephet:= False; If H[A, B]= 0 Then Exit;
If Bent(A-1,B) And Bent(A-2,B) And (H[A-1,B]=1) And (H[A-2,B]=0)
Then Begin Lephet:= True; Exit End;
If Bent(A-1,B-1) And Bent(A-2,B-2) And (H[A-1,B-1]=1) And (H[A-2,B-2]=0)
Then Begin Lephet:= True; Exit End;
If Bent(A,B-1) And Bent(A,B-2) And (H[A,B-1]=1) And (H[A,B-2]=0)
Then Begin Lephet:= True; Exit End;
If Bent(A+1,B-1) And Bent(A+2,B-2) And (H[A+1,B-1]=1) And (H[A+2,B-2]=0)
Then Begin Lephet:= True; Exit End;
If Bent(A+1,B) And Bent(A+2,B) And (H[A+1,B]=1) And (H[A+2,B]=0)
Then Begin Lephet:= True; Exit End;
If Bent(A+1,B+1) And Bent(A+2,B+2) And (H[A+1,B+1]=1) And (H[A+2,B+2]=0)
Then Begin Lephet:= True; Exit End;
If Bent(A,B+1) And Bent(A,B+2) And (H[A,B+1]=1) And (H[A,B+2]=0)
Then Begin Lephet:= True; Exit End;
If Bent(A-1,B+1) And Bent(A-2,B+2) And (H[A-1,B+1]=1) And (H[A-2,B+2]=0)
Then Begin Lephet:= True; Exit End;
End;

Function Vege: Boolean;
Var I, J: Byte;
Begin
  Vege:= True; VegeVan:= True;
For I:= 1 To 7 Do For J:= 1 To 7 Do If Bent(I, J) And Lephet(I, J) Then
Begin Vege:= False; VegeVan:= False; Break End;
End;

procedure TfmHamm.FormClick(Sender: TObject);
Var I, J, V: Byte;
begin
If VegeVan Then Exit;
  Hx:= (Mx-Xk+4*D+Dx) Div D;
  Hy:= (My-Yk+4*D+Dy) Div D;
If Not Bent(Hx,Hy) Then Exit;
If Not Lepes And Lephet(Hx, Hy) Then
Begin
    Lepes:= True;
    H[Hx,Hy]:= 2;
    PHx:= Hx; PHy:= Hy;
    Kepre;
    Exit;
End;
If Lepes Then
Begin
    V:= 0;
If H[Hx, Hy]=0 Then
Begin
If (Hx= PHx-2) And (Hy= PHy  ) And (H[PHx-1, PHy  ]=1) Then V:=1;
If (Hx= PHx-2) And (Hy= PHy-2) And (H[PHx-1, PHy-1]=1) Then V:=2;
If (Hx= PHx-2) And (Hy= PHy+2) And (H[PHx-1, PHy+1]=1) Then V:=3;
If (Hx= PHx+2) And (Hy= PHy  ) And (H[PHx+1, PHy  ]=1) Then V:=4;
If (Hx= PHx+2) And (Hy= PHy-2) And (H[PHx+1, PHy-1]=1) Then V:=5;
If (Hx= PHx+2) And (Hy= PHy+2) And (H[PHx+1, PHy+1]=1) Then V:=6;
If (Hx= PHx  ) And (Hy= PHy-2) And (H[PHx  , PHy-1]=1) Then V:=7;
If (Hx= PHx  ) And (Hy= PHy+2) And (H[PHx  , PHy+1]=1) Then V:=8;
End;
If V>0 Then
Begin
      H[PHx, PHy]:= 0;
Case V Of
        1: H[PHx - 1, PHy    ]:= 0;
        2: H[PHx - 1, PHy - 1]:= 0;
        3: H[PHx - 1, PHy + 1]:= 0;
        4: H[PHx + 1, PHy    ]:= 0;
5: H[PHx + 1, PHy - 1]:= 0;
        6: H[PHx + 1, PHy + 1]:= 0;
        7: H[PHx    , PHy - 1]:= 0;
        8: H[PHx    , PHy + 1]:= 0;
End;
      H[Hx,Hy]:= 1; Lepes:= False;
End;
    Kepre;
If Vege Then With Canvas Do
Begin
With Font Do
Begin
        Name:= 'Times New Roman';
        Size:= 30;
        Color:= clBlue;
End;
      V:= 0;
For I:= 1 To 7 Do For J:= 1 To 7 Do Inc(V,H[I, J]);
Case V Of
        1: TextOut(Xk+5*D,Yk,'GYŐZTÉL');
Else TextOut(Xk+5*D,Yk,'VESZTETTÉL');
End;
End;
End;
end;

procedure TfmHamm.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  Mx:= X;
  My:= Y;
end;

procedure TfmHamm.btDemoClick(Sender: TObject);
Const L: Array[1..31,1..3,1..2] Of Byte=
               (((6,4),(4,4),(5,4)), ((4,2),(6,4),(5,3)),
                ((2,4),(4,2),(3,3)), ((4,6),(2,4),(3,5)),
                ((6,4),(4,6),(5,5)), ((3,1),(5,3),(4,2)),
                ((1,5),(3,3),(2,4)), ((5,7),(3,5),(4,6)),
                ((5,2),(5,4),(5,3)), ((4,4),(6,4),(5,4)),
                ((7,3),(5,5),(6,4)), ((7,5),(7,3),(7,4)),
((7,3),(5,3),(6,3)), ((3,4),(5,2),(4,3)),
                ((2,3),(4,3),(3,3)), ((5,1),(3,1),(4,1)),
                ((3,1),(3,3),(3,2)), ((3,6),(5,4),(4,5)),
                ((6,5),(4,5),(5,5)), ((3,7),(5,7),(4,7)),
                ((5,7),(5,5),(5,6)), ((5,2),(3,4),(4,3)),
                ((3,4),(3,6),(3,5)), ((1,3),(1,5),(1,4)),
                ((1,5),(3,5),(2,5)), ((3,6),(3,4),(3,5)),
                ((3,3),(3,5),(3,4)), ((4,5),(6,5),(5,5)),
                ((5,3),(5,5),(5,4)), ((6,5),(4,5),(5,5)),
                ((3,5),(5,5),(4,5)));
Var I: Byte;
Begin
  FormPaint(Sender);
For I:=1 To 31 Do
Begin
    H[L[I,1,1],L[I,1,2]]:= 2;
    Kepre; Sleep(300);
    H[L[I,3,1],L[I,3,2]]:= 1;
    Kepre; Sleep(300);
    H[L[I,1,1],L[I,1,2]]:= 0;
    H[L[I,3,1],L[I,3,2]]:= 0;
    H[L[I,2,1],L[I,2,2]]:= 1;
    Kepre; Sleep(800);
End;
With Canvas Do
Begin
With Font Do
Begin
      Name:= 'Times New Roman';
      Size:= 30;
      Color:= clBlue;
End;
    TextOut(Xk+5*D,Yk,'Kész');
End;
End;

procedure TfmHamm.btUjraClick(Sender: TObject);
begin
  VegeVan:= False;
  FormPaint(Sender);
end;

end.

Life Game

Manfred Eigen – Ruthild Winkler: A játék című 1981-ben megjelent könyvnek a 231-239. oldalán leírt, J. H. Conway nyomán megjelentetett életjáték számítógépes megvalósítását találjuk ebben a programban. A sejtek (kék korongok) túlélési szabályai:

1. Túlélés: Ha egy korongnak 2 vagy 3 szomszédja van (a 8-ból!), akkor a következő generációban is él.

2. Halál: Ha egy korongnak háromnál több szomszédja van, akkor túlnépesedés miatt kihal, ha kettőnél kevesebb, akkor elnéptelenedés miatt hal ki.

3. Születés: ha egy helyen nincs korong, de pontosan három szomszédja van, akkor ott korong születik.

A lehetőségekre a látható menükből könnyen következtethetünk. Az élettér a pontok halmaza 60x60-as. Kérhetünk a géptől meghatározott számú, véletlen elhelyezkedésű elemet. Saját magunk is helyezhetünk el és vehetünk le elemeket egér kettős kattintással. Lehet lépésenként lejátszani az életfolyamatokat, de lehet automatikus ismétléssel is. Az idő, a két ciklus közötti várakozási időt jelenti. Két beprogramozott szituációt is választhatunk, az egyik a sikló, mely vándorol az élettérben, és egy ágyúnak nevezett konfiguráció, mely tetszőleges sokszor megismétli önmagát. Az automatikus fázisok a Stop funkcióval megállíthatók, de starttal újra indíthatók.

Egy véletlen indítás:

A „kihalási” állapot:

Az ágyú működés közben:

A program listája:

unit ULifeGame;

interface

uses
  Windows, Messages, SysUtils, Classes,

Graphics, Controls, Forms, Dialogs, ExtCtrls, StdCtrls, Spin;

type
  TfmLifeGame = class(TForm)
    btKezdet: TButton;
    btKilep: TButton;
    btKovetkezo: TButton;
    edEgyedSz: TEdit;
    lbEgyed: TLabel;
    tiIdozito: TTimer;
    btStart: TButton;
    btStop: TButton;
    lbLepesSz: TLabel;
    lbAktualSz: TLabel;
    cbVegeFigy: TCheckBox;
    btTorles: TButton;
    lbVege: TLabel;
    seSebess: TSpinEdit;
    lbIdo: TLabel;
    btSiklo: TButton;
    btAgyu: TButton;
Procedure Start;
Procedure Kepre;
Procedure Ciklus;
Function VegeVan: Boolean;
procedure btKezdetClick(Sender: TObject);
procedure btKilepClick(Sender: TObject);
procedure btKovetkezoClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure tiIdozitoTimer(Sender: TObject);
procedure btStartClick(Sender: TObject);
procedure btStopClick(Sender: TObject);
procedure seSebessChange(Sender: TObject);
procedure btTorlesClick(Sender: TObject);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
procedure FormPaint(Sender: TObject);
procedure FormDblClick(Sender: TObject);
procedure btSikloClick(Sender: TObject);
procedure btAgyuClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

Const Max=60;
      D=12;
      Dx=6;
      Dy=6;
      Bal=150;
      Fent=20;
      R=5;
      FigyH=10;
var
  fmLifeGame: TfmLifeGame;
  Et, Eo, Sz: Array[0..Max,0..Max] Of Byte;
  Mx, My: Integer;
  EgyedSz, LepesSz, AktualSz: Word;
  EggyesLepo, Folyamatos, VegFigyelo: Boolean;
  FigyTomb: Array[1..FigyH] Of Word;
  SikloVan, AgyuVan: Boolean;

implementation

{$R *.DFM}

procedure TfmLifeGame.Start;
Var I, J, M, N: Word;
Begin
  Randomize; EgyedSz:= StrToInt(edEgyedSz.Text); LepesSz:= 0;
If EgyedSz>Max*Max Then EgyedSz:= Max*Max;
  edEgyedSz.Text:= IntToStr(EgyedSz);
  lbAktualSz.Caption:= IntToStr(EgyedSz);
  lbLepesSz.Caption:= IntToStr(LepesSz);
For I:= 0 To Max Do For J:= 0 To Max Do Et[I,J]:= 0; Eo:= Et; Sz:= Et;
For I:= 1 To EgyedSz Do
Begin
Repeat
      M:= Random(Max+1);
      N:= Random(Max+1);
Until Et[M,N]=0;
    Et[M,N]:= 1;
End;
For I:= 1 To FigyH Do FigyTomb[I]:= 0;
End;

procedure TfmLifeGame.Ciklus;
Var I, J, SS: Word;
Begin
For I:= 0 To Max Do For J:= 0 To Max Do Sz[I,J]:= 0; Eo:= Et;
For I:= 1 To Max-1 Do For J:= 1 To Max-1 Do
Begin
    SS:= Et[I-1,J-1]+Et[I-1, J]+Et[I-1,J+1]+
         Et[  I,J-1]+           Et[  I,J+1]+
         Et[I+1,J-1]+Et[I+1, J]+Et[I+1,J+1];
If (Et[I,J]=0) And (SS=3) Then Sz[I,J]:= 1; //születik
If Et[I,J]=1 Then //ha élt
Case SS Of
      2,3: Sz[I,J]:= 1;                         //túlél
Else Sz[I,J]:= 0;      //túlnépesedés miatt kihal
End;                     //vagy 0,1 esetén elszigetelődés miatt hal ki
End;
  Et:= Sz;
End;

procedure TfmLifeGame.Kepre;
Var I, J: Word;
Begin
With Canvas Do
Begin
    Pen.Color:= clBtnFace;
    Brush.Color:= clBtnFace; Rectangle(Bal-R,Fent-R,900,800);
    Pen.Color:= clBlue; Brush.Color:= clBlue;
For I:= 0 To Max Do For J:= 0 To Max Do If Et[I,J]=0 Then
    Pixels[Bal+D*I,Fent+D*J]:= clBlue Else
    Ellipse(Bal+D*I-R,Fent+D*J-R, Bal+D*I+R,Fent+D*J+R)
End;
End;

Function TfmLifeGame.VegeVan: Boolean;
Var I, J: Word;
    Vege: Boolean;
Begin
  Vege:= True; VegeVan:= False;
If cbVegeFigy.Checked Then
Begin
For I:= 1 To FigyH-1 Do For J:= I+1 To FigyH Do
If FigyTomb[I]<>FigyTomb[J] Then Vege:= False;
    lbVege.Visible:= Vege;
    VegeVan:= Vege; Exit;
End;
End;

procedure TfmLifeGame.btKezdetClick(Sender: TObject);
begin
  Start;
  Kepre;
  lbVege.Visible:= False;
  SikloVan:= False;
  AgyuVan:= False;
end;

procedure TfmLifeGame.btKilepClick(Sender: TObject);
begin
  Close;
end;

procedure TfmLifeGame.btKovetkezoClick(Sender: TObject);
Var I, J, N: Word;
    Ures: Boolean;
begin
  Inc(LepesSz); lbLepesSz.Caption:= IntToStr(LepesSz); Ciklus;
With Canvas Do
Begin
    Pen.Color:= clBtnFace;
Brush.Color:= clBtnFace; Rectangle(Bal-R,Fent-R,900,800);
    Pen.Color:= clBlue; Brush.Color:= clBlue;
    N:= 0; Ures:= True;
For I:= 0 To Max Do For J:= 0 To Max Do If Et[I,J]=0 Then
    Pixels[Bal+D*I,Fent+D*J]:= clBlue Else
Begin
      Ellipse(Bal+D*I-R,Fent+D*J-R, Bal+D*I+R,Fent+D*J+R);
      Inc(N); Ures:= False;
End;
End;
If Ures Then Begin Folyamatos:= False; lbVege.Visible:= True; Exit End;
For I:= 1 To FigyH-1 Do FigyTomb[I]:= FigyTomb[I+1]; FigyTomb[FigyH]:= N;
  lbAktualSz.Caption:= IntToStr(N);
end;

procedure TfmLifeGame.FormCreate(Sender: TObject);
begin
EgyedSz:= 1000; AktualSz:= EgyedSz; LepesSz:= 0;
  edEgyedSz.Text:= IntToStr(EgyedSz);
  lbLepesSz.Caption:= IntToStr(LepesSz);
  lbAktualSz.Caption:= IntToStr(AktualSz);
  Eggyeslepo:= True;
  Folyamatos:= False;
  cbVegeFigy.Checked:= True;
  SikloVan:= False;
  AgyuVan:= False;
end;

procedure TfmLifeGame.FormPaint(Sender: TObject);
begin
  Kepre;
end;

procedure TfmLifeGame.tiIdozitoTimer(Sender: TObject);
begin
If Not Folyamatos Then Exit;
If (Not SikloVan Or AgyuVan) Then
If VegeVan Then Begin Folyamatos:= False; lbVege.Visible:= True End;
  btKovetkezoClick(Sender);
end;

procedure TfmLifeGame.btStartClick(Sender: TObject);
begin
  Folyamatos:= True;
end;

procedure TfmLifeGame.btStopClick(Sender: TObject);
begin
  Folyamatos:= False;
end;

procedure TfmLifeGame.seSebessChange(Sender: TObject);
begin
  tiIdozito.Interval:= StrToInt(seSebess.Text);
end;

procedure TfmLifeGame.btTorlesClick(Sender: TObject);
Var I, J: Word;
begin
For I:= 0 To Max Do For J:= 0 To Max Do Et[I,J]:= 0; Eo:= Et; Sz:= Et;
  LepesSz:= 0; AktualSz:= 0;
  Kepre;
end;

procedure TfmLifeGame.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  Mx:= X;
  My:= Y;
end;

procedure TfmLifeGame.FormDblClick(Sender: TObject);
Var I, J: Word;
begin
  edEgyedSz.Text:= '0'; AktualSz:= 0; LepesSz:= 0;
  Et[(Mx-Bal+Dx) Div D,(My-Fent+Dy) Div D]:=
  1 - Et[(Mx-Bal+Dx) Div D,(My-Fent+Dy) Div D];
For I:= 0 To Max Do For J:= 0 To Max Do If Et[I,J]=1 Then Inc(AktualSz);
  Kepre; lbAktualSz.Caption:= IntToStr(AktualSz);
end;

procedure TfmLifeGame.btSikloClick(Sender: TObject);
begin
  SikloVan:= True;
  AgyuVan:= False;
  btTorlesClick(Sender);
  Et[2,1]:= 1;
  Et[3,2]:= 1;
  Et[1,3]:= 1;
  Et[2,3]:= 1;
  Et[3,3]:= 1;
  Kepre;
  Folyamatos:= False;
end;

procedure TfmLifeGame.btAgyuClick(Sender: TObject);
Var Ex, Ey: Word;
begin
  SikloVan:= True;
  AgyuVan:= False;
  btTorlesClick(Sender);
  Et[2,7]:= 1; Et[2,8]:= 1;
  Et[3,7]:= 1; Et[3,8]:= 1;
  Et[13,7]:= 1; Et[13,8]:= 1; Et[13,9]:= 1;
  Et[14,6]:= 1; Et[14,10]:= 1;
  Et[15,5]:= 1; Et[15,11]:= 1;
  Et[16,6]:= 1; Et[16,10]:= 1;
  Et[17,7]:= 1; Et[17,8]:= 1; Et[17,9]:= 1;
  Et[18,7]:= 1; Et[18,8]:= 1; Et[18,9]:= 1;
  Et[23,5]:= 1; Et[23,6]:= 1; Et[23,7]:= 1;
  Et[24,4]:= 1; Et[24,5]:= 1; Et[24,7]:= 1; Et[24,8]:= 1;
  Et[25,4]:= 1; Et[25,5]:= 1; Et[25,7]:= 1; Et[25,8]:= 1;
Et[26,4]:= 1; Et[26,5]:= 1; Et[26,6]:= 1; Et[26,7]:= 1; Et[26,8]:= 1;
  Et[27,3]:= 1; Et[27,4]:= 1; Et[27,8]:= 1; Et[27,9]:= 1;
  Et[32,7]:= 1; Et[32,8]:= 1;
  Et[36,5]:= 1; Et[36,6]:= 1;
  Et[37,5]:= 1; Et[37,6]:= 1;
  Ex:= 38; Ey:= 27;   {dx=dy=30}
  Et[Ex,Ey]:= 1;
  Et[Ex+1,Ey]:= 1;
  Et[Ex+2,Ey-1]:= 1; Et[Ex+2,Ey+1]:= 1;
  Et[Ex+3,Ey]:= 1;
  Et[Ex+4,Ey]:= 1;
  Et[Ex+5,Ey]:= 1;
  Et[Ex+6,Ey]:= 1;
  Et[Ex+7,Ey-1]:= 1; Et[Ex+7,Ey+1]:= 1;
  Et[Ex+8,Ey]:= 1;
  Et[Ex+9,Ey]:= 1;
  Kepre;
  Folyamatos:= False;
end;

end.

New Life Game

A Manfred Eigen – Ruthil Winkler: A játék című, 1981-ben kiadott könyvnek a 140-141. oldalain a Stanislaw Ulman-féle reprodukciós játék első 11 illetve a 45. fázisát láthatjuk. A képeken egyetlen egyedből kiindulva, egy folyamatosan növekvő szimmetrikus minták sorozatát kapjuk. Az életfázisok változási szabálya:

- Születés: ha egy hely négy lapszomszédjában összesen csak egy golyó található, akkor ott golyó jön létre.

- Kihalás: minden generáció csak kétgenerációnyi életet él, amikor 3. generációs lenne, akkorra kihal.

Legnagyobb igyekezetem ellenére, a 45. generáció képét előállítani nem tudtam. Hogy algoritmusom nem teljesen idegen a szabálytól, azt az is bizonyítja, hogy a 11. generációig hibátlanul működik. Nem értem, hogy miért nem jön létre az tankönyvi ábra szerinti 45. generáció. Ha valaki segítene benne, megköszönném.

A 8. generáció:

A 11. generáció:

A 45. generáció:

A program listája:

unit UNewLifeGame;

interface

uses
  Windows, Messages, SysUtils, Classes,

Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, Spin;

type
  TfmNewLifeGame = class(TForm)
    btKilepes: TButton;
    btStart: TButton;
    lbEgyed: TLabel;
    edEgyedSz: TEdit;
    lbAktualSz: TLabel;
    lbLepesSz: TLabel;
    btKezdet: TButton;
    btKovetkezo: TButton;
    seSebess: TSpinEdit;
    lbIdo: TLabel;
    btStop: TButton;
    btTorles: TButton;
    tiIdozito: TTimer;
    lbX: TLabel;
    lbY: TLabel;
Procedure Start;
Procedure Kepre;
Procedure Ciklus;
procedure btKilepesClick(Sender: TObject);
procedure btStartClick(Sender: TObject);
procedure btKezdetClick(Sender: TObject);
procedure btKovetkezoClick(Sender: TObject);
procedure btStopClick(Sender: TObject);
procedure seSebessChange(Sender: TObject);
procedure btTorlesClick(Sender: TObject);
procedure tiIdozitoTimer(Sender: TObject);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
procedure FormPaint(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDblClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

Const Max=95;
D=8;
      Dx=4;
      Dy=4;
      Bal=150;
      Fent=3;
      R=3;
      FigyH=10;

var
  fmNewLifeGame: TfmNewLifeGame;
  Et, Ge, Sz: Array[0..Max,0..Max] Of Byte;
  Mx, My: Integer;
  EgyedSz, LepesSz, AktualSz: Word;
  EggyesLepo, Folyamatos, VegFigyelo: Boolean;
  FigyTomb: Array[1..FigyH] Of Word;

implementation

{$R *.DFM}

procedure TfmNewLifeGame.Start;
Var I, J, M, N: Word;
Begin
  Randomize; EgyedSz:= StrToInt(edEgyedSz.Text); LepesSz:= 1;
If EgyedSz>Max*Max Then EgyedSz:= Max*Max;
  edEgyedSz.Text:= IntToStr(EgyedSz);
  lbAktualSz.Caption:= IntToStr(EgyedSz);
lbLepesSz.Caption:= IntToStr(LepesSz);
For I:= 0 To Max Do For J:= 0 To Max Do Et[I,J]:= 0; Sz:= Et;
For I:= 1 To EgyedSz Do
Begin
Repeat
      M:= Random(Max+1);
      N:= Random(Max+1);
Until Et[M,N]=0;
    Et[M,N]:= 1;
End;
For I:= 1 To FigyH Do FigyTomb[I]:= 0;
End;

procedure TfmNewLifeGame.Kepre;
Var I, J: Word;
Begin
With Canvas Do
Begin
    Pen.Color:= clBtnFace;
    Brush.Color:= clBtnFace; Rectangle(Bal-R,Fent-R,980,800);
    Pen.Color:= clBlue; Brush.Color:= clBlue;
For I:= 0 To Max Do For J:= 0 To Max Do If Et[I,J]=0 Then
Pixels[Bal+D*I,Fent+D*J]:= clBlue Else
    Ellipse(Bal+D*I-R,Fent+D*J-R, Bal+D*I+R,Fent+D*J+R)
End;
End;

Procedure TfmNewLifeGame.Ciklus;
Var I, J, SS: Word;
Begin
For I:= 0 To Max Do For J:= 0 To Max Do Sz[I,J]:= 0;
For I:= 1 To Max-1 Do For J:= 1 To Max-1 Do
Begin
    SS:= 0;
If Et[I-1,J]<>0 Then Inc(SS);
If Et[I,J-1]<>0 Then Inc(SS); If Et[I,J+1]<>0 Then Inc(SS);
If Et[I+1,J]<>0 Then Inc(SS);

If (Et[I,J]=0) And (SS=1) Then Sz[I,J]:= 1; //születik
End;
For I:= 0 To Max Do For J:= 0 To Max Do
If Et[I,J]<>0 Then Sz[I,J]:= Et[I,J]+1;      //ha él öregszik

For I:= 0 To Max Do For J:= 0 To Max Do
If Sz[I,J]>2 Then Sz[I,J]:= 0;                //ha túlságosan öreg, kihal
  Et:= Sz;
End;

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

procedure TfmNewLifeGame.btStartClick(Sender: TObject);
begin
  Folyamatos:= True;
end;

procedure TfmNewLifeGame.btKezdetClick(Sender: TObject);
begin
  Start;
  Kepre;
end;

procedure TfmNewLifeGame.btKovetkezoClick(Sender: TObject);
Var I, J, N: Word;
begin
Inc(LepesSz); lbLepesSz.Caption:= IntToStr(LepesSz); Ciklus;
With Canvas Do
Begin
    N:= 0;
    Pen.Color:= clBtnFace;
    Brush.Color:= clBtnFace; Rectangle(Bal-R,Fent-R,900,800);
For I:= 0 To Max Do For J:= 0 To Max Do
Case Et[I,J] Of
      0: Begin
           Pixels[Bal+D*I,Fent+D*J]:= clBlue;
End;
      1: Begin
           Pen.Color:= clBlue; Brush.Color:= clBlue;
           Ellipse(Bal+D*I-R,Fent+D*J-R, Bal+D*I+R,Fent+D*J+R);
           Inc(N);
End;
      2: Begin
           Pen.Color:= clRed; Brush.Color:= clRed;
Ellipse(Bal+D*I-R,Fent+D*J-R, Bal+D*I+R,Fent+D*J+R);
           Inc(N);
End;
End;
End;
  lbAktualSz.Caption:= IntToStr(N);
end;

procedure TfmNewLifeGame.btStopClick(Sender: TObject);
begin
  Folyamatos:= False;
end;

procedure TfmNewLifeGame.seSebessChange(Sender: TObject);
begin
  tiIdozito.Interval:= StrToInt(seSebess.Text);
end;

procedure TfmNewLifeGame.btTorlesClick(Sender: TObject);
Var I,J: Word;
begin
For I:= 0 To Max Do For J:= 0 To Max Do Et[I,J]:= 0; Sz:= Et;
  LepesSz:= 0; AktualSz:= 0;
  Kepre; lbAktualSz.Caption:= IntToStr(AktualSz);
end;

procedure TfmNewLifeGame.tiIdozitoTimer(Sender: TObject);
begin
If Not Folyamatos Then Exit;
  btKovetkezoClick(Sender);
end;

procedure TfmNewLifeGame.FormMouseMove(Sender: TObject; Shift: TShiftState;
  X, Y: Integer);
begin
  Mx:= X;
  My:= Y;
If ((Mx-Bal+Dx) Div D) In [0..Max] Then
  lbX.Caption:= IntToStr((Mx-Bal+Dx) Div D);
If ((My-Fent+Dy) Div D) In [0..Max] Then
  lbY.Caption:= IntToStr((My-Fent+Dy) Div D);
end;

procedure TfmNewLifeGame.FormPaint(Sender: TObject);
begin
  Kepre;
end;

procedure TfmNewLifeGame.FormCreate(Sender: TObject);
begin
EgyedSz:= 0; AktualSz:= 0; LepesSz:= 1;
  edEgyedSz.Text:= IntToStr(EgyedSz);
  lbLepesSz.Caption:= IntToStr(LepesSz);
  lbAktualSz.Caption:= IntToStr(AktualSz);
  Eggyeslepo:= True;
  Folyamatos:= False;
end;

procedure TfmNewLifeGame.FormDblClick(Sender: TObject);
Var I, J: Word;
begin
  edEgyedSz.Text:= '1'; AktualSz:= 0; LepesSz:= 1;
  Et[(Mx-Bal+Dx) Div D,(My-Fent+Dy) Div D]:=
  1 - Et[(Mx-Bal+Dx) Div D,(My-Fent+Dy) Div D];
For I:= 0 To Max Do For J:= 0 To Max Do If Et[I,J]=1 Then Inc(AktualSz);
  Kepre; lbAktualSz.Caption:= IntToStr(AktualSz);
end;

end.

Amőba

Készítsünk programot, amely amőba játékot tud játszani. Írja képernyőre a szabályokat:

- az X gép jele, és a gép kezdi a játékot,

- az O a játékos jele,

- a gép és a játékos felváltva helyezik el jelüket a rácson,

- az nyer, akinek 5 szomszédos jele lesz,

- szomszéd: vagy lap-, vagy csúcsszomszéd.

A gép valamilyen algoritmus szerint találjon maga számára célravezető lépéseket. Legyen védekező és némi támadó stratégiája. A játék csak a megadott keretek között folytatódhat. Bármikor meg lehessen szakítani a játékot (Kilépés). Lehessen új játékot kérni. Ha véget ér a játék, az eredményt írja a képernyőre: Győztem, Győztél. A nyerő jelsorozatot vörös színnel jelenítse meg.

A program egy futtatási képe:

Ahogy az a futási képből is látható, a fmAmoba form BorderIcons tulajdonságaiból a biMinimize-t és a biMaximize-t False-ra kell állítani, hogy a látványt átméretezéssel ne lehessen elrontani.

A program listája:

unit UAmoba;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, 

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

type
  TfmAmoba = class(TForm)
    lbAmoba: TLabel;
    lbSz1: TLabel;
    lbSz2: TLabel;
    lbSz3: TLabel;
    lbSz4: TLabel;
    lbSz5: TLabel;
    btKilepes: TButton;
    btUjJatek: TButton;
Procedure Kepre;
procedure FormPaint(Sender: TObject);
procedure btKilepesClick(Sender: TObject);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
procedure FormClick(Sender: TObject);
Procedure Gep;
Function Vege: Byte;
procedure btUjJatekClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

Const Max=25;
      D=16;
      Dx=8;
      Dy=8;
      R=5;
var
  fmAmoba: TfmAmoba;
  Xk, Yk, Mx, My, F: Integer;
  Mezo, PMezo: Array[0..Max+1,0..Max+1] Of Byte;
  LMezo: Array[0..100,1..2] Of Byte;
  VegeVan: Byte;

implementation

{$R *.dfm}

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

procedure TfmAmoba.FormCreate(Sender: TObject);
begin
  Canvas.Brush.Color:= clBtnFace;
end;

procedure TfmAmoba.FormPaint(Sender: TObject);
Var I, J: Integer;
begin
  Xk:= ClientWidth Div 2;
  Yk:= ClientHeight Div 2;
  F:= Max Div 2;
With Canvas Do
Begin
With Pen Do
Begin
      Color:= clBlack;
      Width:= 2;
End;
    Rectangle(Xk-(F+1)*D,Yk-(F+1)*D, Xk+(F+1)*D,Yk+(F+1)*D);
For I:= -F To F Do For J:= -F To F Do
    Pixels[Xk+I*D, Yk+J*D]:= 0;
End;
  Mezo[F+1,F+1]:= 1;
  Kepre;
end;

Procedure TfmAmoba.Kepre;
Var I, J: Integer;
Begin
For I:= -F To F Do For J:= -F To F Do With Canvas Do
Begin
With Pen Do
Case Mezo[I+F+1,J+F+1] Of
      1,2: Color:= clBlack;
      3,4: Color:= clRed;
End;
Case Mezo[I+F+1,J+F+1] Of
      1,3: Begin
             MoveTo(Xk+I*D-R,Yk+J*D-R);
             LineTo(Xk+I*D+R,Yk+J*D+R);
             MoveTo(Xk+I*D-R,Yk+J*D+R);
             LineTo(Xk+I*D+R,Yk+J*D-R);
End;
      2,4: Ellipse(Xk+I*D-R,Yk+J*D-R,Xk+I*D+R,Yk+J*D+R);
End;
End;
End;

procedure TfmAmoba.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  Mx:= X; My:= Y;
end;

Function TfmAmoba.Vege: Byte;
Var M, N, P, Q, S: Byte;
Procedure Valto(M, N, D, T: Byte); Var K: Byte;
Begin
For K:=0 To 4 Do
Case D Of
1: If T=1 Then Mezo[M+K,N]:= 3 Else Mezo[M+K,N]:= 4;
      2: If T=1 Then Mezo[M+K,N+K]:= 3 Else Mezo[M+K,N+K]:= 4;
      3: If T=1 Then Mezo[M,N+K]:= 3 Else Mezo[M,N+K]:= 4;
      4: If T=1 Then Mezo[M-K,N+K]:= 3 Else Mezo[M-K,N+K]:= 4;
End;
End;
Begin
  Vege:= 0; VegeVan:= 0;
For M:= 1 To Max Do For N:= 1 To Max Do If Mezo[M, N] In [1,2] Then
Begin
    S:= 1; P:= M + 1;
While Mezo[P, N]= Mezo[M, N] Do Begin Inc(S); Inc(P) End;
If S= 5 Then
Begin
      Vege:= Mezo[M, N]; VegeVan:= Mezo[M, N];
      Valto(M, N, 1, Mezo[M, N]); Kepre; Exit;
End;
S:= 1; P:= M + 1; Q:= N + 1;
While Mezo[P, Q]= Mezo[M, N] Do Begin Inc(S); Inc(P); Inc(Q) End;
If S=5 Then
Begin
      Vege:=Mezo[M,N]; VegeVan:= Mezo[M, N];
      Valto(M,N,2,Mezo[M,N]); Kepre; Exit;
End;
    S:= 1; Q:= N + 1;
While Mezo[M, Q]= Mezo[M, N] Do Begin Inc(S); Inc(Q) End;
If S= 5 Then
Begin
      Vege:= Mezo[M, N]; VegeVan:= Mezo[M, N];
      Valto(M, N, 3, Mezo[M, N]); Kepre; Exit;
End;
    S:= 1; P:= M - 1; Q:= N + 1;
While Mezo[P, Q]= Mezo[M, N] Do Begin Inc(S); Dec(P); Inc(Q) End;
If S=5 Then
Begin
Vege:= Mezo[M,N]; VegeVan:= Mezo[M, N];
      Valto(M,N,4,Mezo[M,N]); Kepre; Exit;
End;
End;
End;

procedure TfmAmoba.FormClick(Sender: TObject);
begin
If VegeVan<>0 Then Exit;
If (Mx<Xk-F*D) Or
     (Mx>Xk+F*D) Or
     (My<Yk-F*D) Or
     (My>Yk+F*D) Then Exit;
If Mezo[(Mx-Xk+(F+1)*D+Dx) Div D,(My-Yk+(F+1)*D+Dy) Div D]<>0 Then Exit;
With Canvas Do
Begin
With Font Do
Begin
      Name:= 'Times New Roman';
      Size:= 30;
      Color:= clBlue;
End;
    Mezo[(Mx-Xk+(F+1)*D+Dx) Div D,(My-Yk+(F+1)*D+Dy) Div D]:= 2;
    Kepre;
Case Vege Of
1: TextOut(Xk+(F+2)*D,Yk,' Győztem ');
      2: TextOut(Xk+(F+2)*D,Yk,' Győztél ');
End;
If VegeVan=0 Then
Begin
      Gep;
      Kepre;
Case Vege Of
        1: TextOut(Xk+(F+2)*D,Yk,' Győztem ');
        2: TextOut(Xk+(F+2)*D,Yk,' Győztél ');
End;
End;
End;
end;

Procedure TfmAmoba.Gep;
Var I, J, K, L, M, S, V, T: Integer;
Begin
For I:= 1 To 25 Do For J:= 1 To 25 Do PMezo[i,j]:= 0;
For I:= 1 To 25 Do For J:= 1 To 25 Do
For K:= -1 To 1 Do For L:= -1 To 1 Do
If Not (Mezo[I, J] In [1, 2]) And (Mezo[I + K, J + L] in [1, 2]) Then
  PMezo[I, J]:= 3;
L:= 0; For I:= 1 To 25 Do For J:= 1 To 25 Do If PMezo[I, J]=3 Then
Begin LMezo[L, 1]:= I; LMezo[L, 2]:= J; Inc(L) End;
For I:= 0 To L-1 Do
Begin
    J:= LMezo[I, 1] - 1; K:= LMezo[I, 2]; T:= Mezo[J, K]; S:= 0;
If T In [1,2] Then While Mezo[J, K]= T Do
Begin Inc(PMezo[LMezo[I, 1], LMezo[I, 2]]); Dec(J); Inc(S) End;
If S>=3 Then Inc(PMezo[LMezo[I, 1], LMezo[I, 2]], 50*s);
    J:= LMezo[I, 1] + 1; K:= LMezo[I, 2]; T:= Mezo[J, K]; S:= 0;
If T In [1,2] Then While Mezo[J, K]= T Do
Begin Inc(PMezo[LMezo[I, 1], LMezo[I, 2]]); Inc(J); Inc(S) End;
If S>=3 Then Inc(PMezo[LMezo[I, 1], LMezo[I, 2]], 50*s);
    J:= LMezo[I, 1]; K:= LMezo[I, 2] - 1; T:= Mezo[J, K]; S:= 0;
If T In [1,2] Then While Mezo[J, K]= T Do
Begin Inc(PMezo[LMezo[I, 1], LMezo[I, 2]]); Dec(K); Inc(S) End;
If S>=3 Then Inc(PMezo[LMezo[I, 1], LMezo[I, 2]], 50*s);
    J:= LMezo[I, 1]; K:= LMezo[I, 2] + 1; T:= Mezo[J, K]; S:= 0;
If T In [1,2] Then While Mezo[J, K]= T Do
Begin Inc(PMezo[LMezo[I, 1], LMezo[I, 2]]); Inc(K); Inc(S) End;
If S>=3 Then Inc(PMezo[LMezo[I, 1], LMezo[I, 2]], 50*s);
J:= LMezo[I, 1] - 1; K:= LMezo[I, 2] - 1; T:= Mezo[J, K]; S:= 0;
If T In [1,2] Then While Mezo[J, K]= T Do
Begin Inc(PMezo[LMezo[I, 1], LMezo[I, 2]]); Dec(J); Dec(K); Inc(S) End;
If S>=3 Then Inc(PMezo[LMezo[I, 1], LMezo[I, 2]], 50*s);
    J:= LMezo[I, 1] + 1; K:= LMezo[I, 2] - 1; T:= Mezo[J, K]; S:= 0;
If T In [1,2] Then While Mezo[J, K]= T Do
Begin Inc(PMezo[LMezo[I, 1], LMezo[I, 2]]); Inc(J); Dec(K); Inc(S) End;
If S>=3 Then Inc(PMezo[LMezo[I, 1], LMezo[I, 2]], 50*s);
    J:= LMezo[I, 1] - 1; K:= LMezo[I, 2] + 1; T:= Mezo[J, K]; S:= 0;
If T In [1,2] Then While Mezo[J, K]= T Do
Begin Inc(PMezo[LMezo[I, 1], LMezo[I, 2]]); Dec(J); Inc(K); Inc(S) End;
If S>=3 Then Inc(PMezo[LMezo[I, 1], LMezo[I, 2]], 50*s);
    J:= LMezo[I, 1] + 1; K:= LMezo[I, 2] + 1; T:= Mezo[J, K]; S:= 0;
If T In [1,2] Then While Mezo[J, K]= T Do
Begin Inc(PMezo[LMezo[I, 1], LMezo[I, 2]]); Inc(J); Inc(K); Inc(S) End;
If S>=3 Then Inc(PMezo[LMezo[I, 1], LMezo[I, 2]], 50*s);
End;
  M:=0; For I:= 0 To L-1 Do If PMezo[LMezo[I, 1], LMezo[I, 2]]> M Then
  M:= PMezo[LMezo[I, 1], LMezo[I, 2]]; T:= 0;
For I:= 0 To L-1 Do If PMezo[LMezo[I, 1], LMezo[I, 2]]=M Then
Begin
    LMezo[T, 1]:= LMezo[I, 1]; LMezo[T, 2]:= LMezo[I, 2]; Inc(T);
End;
  V:= Random(T); Mezo[LMezo[V, 1], LMezo[V, 2]]:= 1;
End;

procedure TfmAmoba.btUjJatekClick(Sender: TObject);
Var I, J: Integer;
begin
For I:= 0 To Max+1 Do For J:= 0 To Max+1 Do Mezo[I,J]:= 0;
  VegeVan:= 0;
With Canvas Do
Begin
    Pen.Color:= clBtnFace;
    Brush.Color:= clBtnFace;
    Rectangle(Xk+(F+2)*D,Yk,Xk+(F+13)*D,Yk+3*D);
End;
  FormPaint(Sender);
end;

end.

Nyerő négyzet

Írjunk az amőbához hasonló játékprogramot, amelyben a cél az, hogy jeleinket egy négyzet csúcsaiban kell elhelyezni. A négyzet elhelyezkedése nemcsak tengelyirányú lehet, azaz az oldalai akár L alakban is elhelyezkedhetnek a rácshoz képest.

A program írja ki a képernyőre a szabályokat:

- az X gép jele, és a gép kezdi a játékot,

- az O a játékos jele,

- a gép és a játékos felváltva helyezik el jelüket a rácson,

- az nyer, akinek 4 jele egy négyzet négy csúcsában helyezkedik el,

- a négyzet oldali nem feltétlen párhuzamosak a rácsrendszer soraival, oszlopaival.

A gép valamilyen algoritmus szerint találjon maga számára célravezető lépéseket. Legyen védekező és némi támadó stratégiája. A játék csak a megadott keretek között folytatódhat. Bármikor meg lehessen szakítani a játékot (Kilépés). Lehessen új játékot kérni. Ha véget ér a játék, az eredményt írja a képernyőre: Győztem, Győztél. A nyerő jelsorozatot vörös színnel jelenítse meg.

A program egy futtatási képe:

A program listája:

unit UNegyzet;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes,

Graphics, Controls, Forms, Dialogs, StdCtrls;

type
  TfmNegyzet = class(TForm)
    lbNegyzet: TLabel;
    lbSzabaly: TLabel;
    btKilepes: TButton;
    btUjJatek: TButton;
Procedure Kepre;
Function Vege: Byte;
Procedure Gep;
procedure FormPaint(Sender: TObject);
procedure btKilepesClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
procedure FormClick(Sender: TObject);
procedure btUjJatekClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

Const Max=31;
      D=16;
      Dx=8;
      Dy=8;
      R=5;

var
  fmNegyzet: TfmNegyzet;
  Xk, Yk, Mx, My, F: Integer;
  Mezo: Array[0..Max+1,0..Max+1] Of Byte;
  VegeVan: Byte;

implementation

{$R *.dfm}

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

procedure TfmNegyzet.FormCreate(Sender: TObject);
begin
  Canvas.Brush.Color:= clBtnFace;
  Randomize;
end;

procedure TfmNegyzet.FormPaint(Sender: TObject);
Var I, J: Integer;
begin
  Xk:= ClientWidth Div 2;
  Yk:= ClientHeight Div 2;
With Canvas Do
Begin
    F:= Max Div 2;
With Canvas Do
Begin
With Pen Do
Begin
        Color:= clBlack;
        Width:= 2;
End;
      Rectangle(Xk-(F+1)*D,Yk-(F+1)*D, Xk+(F+1)*D,Yk+(F+1)*D);
For I:= -F To F Do For J:= -F To F Do
      Pixels[Xk+I*D, Yk+J*D]:= 0;
End;
    Mezo[F+1,F+1]:= 1;
    Kepre;
End;
end;

Procedure TfmNegyzet.Kepre;
Var I, J: Integer;
Begin
For I:= -F To F Do For J:= -F To F Do With Canvas Do
Begin
With Pen Do
Case Mezo[I+F+1,J+F+1] Of
      1,2: Color:= clBlack;
      3,4: Color:= clRed;
End;
Case Mezo[I+F+1,J+F+1] Of
      1,3: Begin
MoveTo(Xk+I*D-R,Yk+J*D-R);
             LineTo(Xk+I*D+R,Yk+J*D+R);
             MoveTo(Xk+I*D-R,Yk+J*D+R);
             LineTo(Xk+I*D+R,Yk+J*D-R);
End;
      2,4: Ellipse(Xk+I*D-R,Yk+J*D-R,Xk+I*D+R,Yk+J*D+R);
End;
End;
End;

procedure TfmNegyzet.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  Mx:= X; My:= Y;
end;

procedure TfmNegyzet.FormClick(Sender: TObject);
begin
If VegeVan<>0 Then Exit;
If (Mx<Xk-F*D) Or (Mx>Xk+F*D) Or
     (My<Yk-F*D) Or (My>Yk+F*D) Then Exit;
If Mezo[(Mx-Xk+(F+1)*D+Dx) Div D,(My-Yk+(F+1)*D+Dy) Div D]<>0 Then Exit;
With Canvas Do
Begin
With Font Do
Begin
      Name:= 'Times New Roman';
      Size:= 30;
      Color:= clBlue;
End;
    Mezo[(Mx-Xk+(F+1)*D+Dx) Div D,(My-Yk+(F+1)*D+Dy) Div D]:= 2;
Case Vege Of
      1: TextOut(Xk+(F+2)*D,Yk,' Győztem ');
      2: TextOut(Xk+(F+2)*D,Yk,' Győztél ');
End;
    Kepre;
If VegeVan=0 Then
Begin
      Gep;
Case Vege Of
        1: TextOut(Xk+(F+2)*D,Yk,' Győztem ');
        2: TextOut(Xk+(F+2)*D,Yk,' Győztél ');
End;
      Kepre;
End;
End;
end;

Function TfmNegyzet.Vege: Byte;
Var I, J, N, M, V: Word;
Begin
Vege:= 0; VegeVan:= 0;
For I:= 1 To Max Do For J:= 1 To Max Do If Mezo[I,J]<>0 Then
Begin
    V:= Max-I; If Max-J<V Then V:= Max-J;
For N:= 1 To V Do For M:= 0 To V Do
If ((I+N-M)>0) And ((I-M)>0) Then
If (Mezo[I,J]=Mezo[I+N  ,J  +M]) And
       (Mezo[I,J]=Mezo[I+N-M,J+N+M]) And
       (Mezo[I,J]=Mezo[I  -M,J+N  ]) Then
Begin
      Vege:= Mezo[I,J]; VegeVan:= Mezo[I,J];
      Inc(Mezo[I,    J    ],2);
      Inc(Mezo[I+N  ,J  +M],2);
      Inc(Mezo[I+N-M,J+N+M],2);
      Inc(Mezo[I  -M,J+N  ],2);
      Break;
End;
End;
End;

Procedure TfmNegyzet.Gep;
Var I, J, N, M, P, Q, R, V, Z: Word;
Begin
For I:= 1 To Max Do For J:= 1 To Max Do
Begin
    V:= Max-I; If Max-J<V Then V:= Max-J;
For N:= 1 To V Do For M:= 0 To V Do
If ((I+N-M)>0) And ((I-M)>0) Then
Begin
      P:= 0; Q:= 0; R:= 0; Z:= 0;
If Mezo[I,J]=0 Then Begin Inc(R); Z:= 1 End;
If Mezo[I,J]=1 Then Inc(P);
If Mezo[I,J]=2 Then Inc(Q);
If Mezo[I+N  ,J  +M]=0 Then Begin Inc(R); Z:= 2 End;
If Mezo[I+N  ,J  +M]=1 Then Inc(P);
If Mezo[I+N  ,J  +M]=2 Then Inc(Q);
If Mezo[I+N-M,J+N+M]=0 Then Begin Inc(R); Z:= 3 End;
If Mezo[I+N-M,J+N+M]=1 Then Inc(P);
If Mezo[I+N-M,J+N+M]=2 Then Inc(Q);
If Mezo[I  -M,J+N  ]=0 Then Begin Inc(R); Z:= 4 End;
If Mezo[I  -M,J+N  ]=1 Then Inc(P);
If Mezo[I  -M,J+N  ]=2 Then Inc(Q);
If (R=1) And ((P=3) Or (Q=3)) Then
Begin
Case Z Of
          1: Mezo[I,J]:= 1;
          2: Mezo[I+N  ,J  +M]:= 1;
          3: Mezo[I+N-M,J+N+M]:= 1;
          4: Mezo[I  -M,J+N  ]:= 1;
End;
        Exit;
End;
End;
End;

For I:= 1 To Max Do For J:= 1 To Max Do
Begin
    V:= Max-I; If Max-J<V Then V:= Max-J;
For N:= 1 To V Do For M:= 0 To V Do
If ((I+N-M)>0) And ((I-M)>0) Then
Begin
      P:= 0; Q:= 0; R:= 0; Z:= 0;
If Mezo[I,J]=0 Then Begin Inc(R); Z:= 1 End;
If Mezo[I,J]=1 Then Inc(P);
If Mezo[I,J]=2 Then Inc(Q);
If Mezo[I+N  ,J  +M]=0 Then Begin Inc(R); Z:= 2 End;
If Mezo[I+N  ,J  +M]=1 Then Inc(P);
If Mezo[I+N  ,J  +M]=2 Then Inc(Q);
If Mezo[I+N-M,J+N+M]=0 Then Begin Inc(R); Z:= 3 End;
If Mezo[I+N-M,J+N+M]=1 Then Inc(P);
If Mezo[I+N-M,J+N+M]=2 Then Inc(Q);
If Mezo[I  -M,J+N  ]=0 Then Begin Inc(R); Z:= 4 End;
If Mezo[I  -M,J+N  ]=1 Then Inc(P);
If Mezo[I  -M,J+N  ]=2 Then Inc(Q);
If (R=2) And ((P=2) Or (Q=2)) Then
Begin
Case Z Of
          1: Mezo[I,J]:= 1;
          2: Mezo[I+N  ,J  +M]:= 1;
          3: Mezo[I+N-M,J+N+M]:= 1;
          4: Mezo[I  -M,J+N  ]:= 1;
End;
        Exit;
End;
End;
End;
Repeat
    I:= Random(Max)+1;
    J:= Random(Max)+1;
Until (Mezo[I,J]=0) And
        (Mezo[I-1,J-1]+Mezo[I  ,J-1]+Mezo[I+1,J-1]+
         Mezo[I-1,J  ]+              Mezo[I+1,J  ]+
         Mezo[I-1,J+1]+Mezo[I  ,J+1]+Mezo[I+1,J+1]>0);
  Mezo[I,J]:= 1;
//(0,0); (n,0);(n,n);(0,n); (0,1);(-1,1);(-1,0)
End;

procedure TfmNegyzet.btUjJatekClick(Sender: TObject);
Var I, J: Integer;
begin
For I:= 0 To Max+1 Do For J:= 0 To Max+1 Do Mezo[I,J]:= 0;
  VegeVan:= 0;
With Canvas Do
Begin
    Pen.Color:= clBtnFace;
    Brush.Color:= clBtnFace;
    Rectangle(Xk+(F+2)*D,Yk,Xk+(F+13)*D,Yk+3*D);
End;
  FormPaint(Sender);
end;

end.

Rubik körök

Ez a játék két egymásba kapcsolódó körgyűrűt tartalmaz, melyben golyókat (fillezett köröket) találunk. Rendezett állapotban, a baloldaliban piros, a jobboldaliban zöld színűeket. A felső találkozási pontnál zöld színű, az alsónál piros színű golyót látunk, mintha fent a zöld golyókat tartalmazó, alul pedig a piros golyókat tartalmazó gyűrű lenne felül (azaz látható).

A két gyűrű közös részén a golyók az egyik gyűrűből a másikba, a golyók görgetése révén átkerülhetnek, így jöhet létre a rendezetlen állapot. A gép a keverés gomb megnyomására 300 véletlen forgatást hajt végre. A programot használónak az a feladata, hogy a rendezett állapotot újra létrehozza.

A forgatás egérrel lett megoldva. Az ívelt alakú nyilak végei a vezérlő pontok, a forgatási irányokat a nyilak jelzik. Szerencsés próbálkozást a rendezéshez.

A rendezett állapot:

Egy kevert állapot:

A program listája:

unit UKorok;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes,

Graphics, Controls, Forms, Dialogs, StdCtrls;

type
  TfmKorok = class(TForm)
    btKilepes: TButton;
    btKever: TButton;
Procedure Forgat;
procedure btKilepesClick(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClick(Sender: TObject);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
procedure btKeverClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

  TGolyo=Class
    Fx, Fy: Integer;
    Fc: TColor;
Procedure Init(Ix, Iy: Integer; Ic: TColor);
Procedure Show;
Procedure Hide;
Function GetColor: TColor;
Procedure SetColor(C: TColor);
End;

Const Dx=125;
      Dy=130;
      Nr=200;
      Kr=154;
      Vr=120;
      Gr=18;

var
  fmKorok: TfmKorok;
  Xk, Yk, Mx, My: Integer;
  GT: Array[1..48] Of TGolyo;
  Gk: Array[1..48,1..2] Of Integer;
  Vp: Array[1..4,1..2] Of Integer;
  Forg: Word;

implementation

{$R *.dfm}

Procedure TGolyo.Init(Ix, Iy: Integer; Ic: TColor);
Begin
  Fx:= Ix; Fy:= Iy; Fc:= Ic;
End;

Procedure TGolyo.Show;
Begin
With fmKorok.Canvas Do
Begin
Pen.Color:= Fc;
    Brush.Color:= Fc;
    Ellipse(Fx-Gr,Fy-Gr, Fx+Gr,Fy+Gr);
End;
End;

Procedure TGolyo.Hide;
Begin
With fmKorok.Canvas Do
Begin
    Pen.Color:= clBtnFace;
    Brush.Color:= clBtnFace;
    Ellipse(Fx-Gr,Fy-Gr, Fx+Gr,Fy+Gr);
End;
End;

Function TGolyo.GetColor: TColor;
Begin
  GetColor:= Fc;
End;

Procedure TGolyo.SetColor(C: TColor);
Begin
  Hide; Fc:= C; Show;
End;

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

procedure TfmKorok.FormCreate(Sender: TObject);
begin
  Xk:= ClientWidth Div 2;
  Yk:= ClientHeight Div 2;
  Randomize;
end;

procedure TfmKorok.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  Mx:= X;
  My:= Y;
end;

procedure TfmKorok.FormPaint(Sender: TObject);
Var I: Word;
    R: Integer;
begin
With Canvas Do
Begin
With Pen Do
Begin
      Color:= clWhite;
      Width:= 2;
End;
    Arc(Xk-Dx-Nr,Yk-Nr,Xk-Dx+NR,Yk+Nr,Xk,Yk,Xk,Yk);
    Arc(Xk+Dx-Nr,Yk-Nr,Xk+Dx+NR,Yk+Nr,Xk,Yk,Xk,Yk);
    Arc(Xk-Dx-Kr,Yk-Kr,Xk-Dx+KR,Yk+Kr,Xk,Yk,Xk,Yk);
    Arc(Xk+Dx-Kr,Yk-Kr,Xk+Dx+KR,Yk+Kr,Xk,Yk,Xk,Yk);
With Pen Do
Begin
      Color:= clBlue;
      Width:= 6;
End;
Arc(Xk-Dx-Vr,Yk-Vr,Xk-Dx+Vr,Yk+Vr,Xk-Dx-Vr,Yk-Vr,Xk-Dx-Vr,Yk+Vr);
    Vp[1,1]:= Xk-Dx-Vr+35;     //bal -
    Vp[1,2]:= Yk-85;
    MoveTo(Xk-Dx-Vr+35,Yk-85); LineTo(Xk-Dx-Vr+35,Yk-65);
    MoveTo(Xk-Dx-Vr+35,Yk-85); LineTo(Xk-Dx-Vr+15,Yk-80);
    Vp[2,1]:= Xk-Dx-Vr+35;     //bal +
    Vp[2,2]:= Yk+85;
    MoveTo(Xk-Dx-Vr+35,Yk+85); LineTo(Xk-Dx-Vr+35,Yk+65);
    MoveTo(Xk-Dx-Vr+35,Yk+85); LineTo(Xk-Dx-Vr+15,Yk+80);
    Arc(Xk+Dx-Vr,Yk-Vr,Xk+Dx+Vr,Yk+Vr,Xk+Dx+Vr,Yk+Vr,Xk+Dx+Vr,Yk-Vr);
    Vp[3,1]:= Xk+Dx+Vr-35;     //jobb +
    Vp[3,2]:= Yk-85;
MoveTo(Xk+Dx+Vr-35,Yk-85); LineTo(Xk+Dx+Vr-35,Yk-65);
    MoveTo(Xk+Dx+Vr-35,Yk-85); LineTo(Xk+Dx+Vr-15,Yk-80);
    Vp[4,1]:= Xk+Dx+Vr-35;     //jobb -
    Vp[4,2]:= Yk+85;
    MoveTo(Xk+Dx+Vr-35,Yk+85); LineTo(Xk+Dx+Vr-35,Yk+65);
    MoveTo(Xk+Dx+Vr-35,Yk+85); LineTo(Xk+Dx+Vr-15,Yk+80);
End;

For I:= 1 To 48 Do GT[I]:= TGolyo.Create;
  R:= (Nr+Kr) Div 2;
For I:= 1 To 24 Do With GT[I] Do
Begin
    Gk[I,1]:= Xk-Dx+Round(R*Sin(I*360/24*Pi/180));
    Gk[I,2]:= Yk+Round(R*Cos(I*360/24*Pi/180));
    Init(Gk[I,1],Gk[I,2], clRed);
If I<>9 Then Show;
End;
For I:= 25 To 48 Do With GT[I] Do
Begin
    Gk[I,1]:= Xk+Dx+Round(R*Sin(I*360/24*Pi/180));
    Gk[I,2]:= Yk+Round(R*Cos(I*360/24*Pi/180));
    Init(Gk[I,1],Gk[I,2], clGreen);
If I<>45 Then Show;
End;
end;

procedure TfmKorok.Forgat;
Var I: Word;
    P: TColor;
Begin
Case Forg Of
    1: Begin
         P:= GT[10].GetColor;
For I:= 10 To 24 Do GT[I].SetColor(GT[I+1].GetColor);
         GT[24].SetColor(GT[1].GetColor);
For I:= 1 To 7 Do GT[I].SetColor(GT[I+1].GetColor);
         GT[8].SetColor(GT[39].GetColor);
         GT[39].SetColor(P);
End;
    2: Begin
P:= GT[8].GetColor;
For I:= 8 DownTo 2 Do GT[I].SetColor(GT[I-1].GetColor);
         GT[1].SetColor(GT[24].GetColor);
For I:= 24 DownTo 11 Do GT[I].SetColor(GT[I-1].GetColor);
         GT[10].SetColor(GT[39].GetColor);
         GT[39].SetColor(P);
End;
    3: Begin
         P:= GT[44].GetColor;
For I:= 44 DownTo 26 Do GT[I].SetColor(GT[I-1].GetColor);
         GT[25].SetColor(GT[48].GetColor);
For I:= 48 DownTo 47 Do GT[I].SetColor(GT[I-1].GetColor);
         GT[46].SetColor(GT[3].GetColor);
         GT[3].SetColor(P);
End;
    4: Begin
P:= GT[46].GetColor;
For I:= 46 To 47 Do GT[I].SetColor(GT[I+1].GetColor);
         GT[48].SetColor(GT[25].GetColor);
For I:= 25 To 43 Do GT[I].SetColor(GT[I+1].GetColor);
         GT[44].SetColor(GT[3].GetColor);
         GT[3].SetColor(P);
End;
End;
End;

procedure TfmKorok.btKeverClick(Sender: TObject);
Var I: Word;
begin
For I:= 1 To 300 Do Begin Forg:= Random(4)+1; Forgat End;
end;

procedure TfmKorok.FormClick(Sender: TObject);
Var I: Word;
begin
  Forg:= 0;
For I:= 1 To 4 Do If Sqrt(Sqr(Vp[I,1]-Mx)+Sqr(Vp[I,2]-My))<16 Then
Begin Forg:= I; Break End;
  Forgat;
end;

end.

Rubik kocka

A bűvös kocka 1974-ben jelent meg először Rubik Ernő képzeletében, és rá 7 évre már sok országban elterjedt a 3*3*3-as változata. Mára világméretű biznisszé vált. Az alapötletet felhasználva szinte megmondhatatlan, hogy hány verziója látott napvilágot a kockához hasonló játékoknak. Ezzel a programmal az alapkocka forgatását lehet gyakorolni.

A program nem használ animációt, a forgatási fázisok átrendezéssel jönnek létre. A másik jellegzetessége és talán egyedi vonása a programnak, hogy egyszerre a kocka mind a hat lapját láthatjuk. A képernyő felső részét úgy kell elképzelni, mintha az, az alsónak a tükörben látható (szemből nem látható) lapjai lennének.

A forgatás egérrel lett megoldva. A vékonyabb nyilakkal rétegek forgathatók 90 fokkal, a vastagabb nyilakkal lapok forgathatók. A nyilak végei a vezérlő pontok, a forgatási irányokat használat közben megszokhatjuk (egyébként ezt a nyíl vége jelzi: ha rámutat a kockára, akkor a megcélzott felület távolodik a nyíltól, a másik végére kattintva közeledik).

A program a rendezett állapottól indul. A kevert állapotot a Kever feliratú nyomógombbal hozhatjuk létre. Aki jártas a kockaforgatásban, biztosan könnyedén elboldogul evvel a programmal is. Akinek gondja van a kocka rendezésével, annak javaslom, hogy nézzen utána az Interneten, számos rendezési módszer leírását megtalálhatja.

A futtatási kép rendezetlen állapotban:

A futtatási kép a fehér színű lap kirakása után:

És a rendezett állapot:

A program listája:

unit URubik;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes,

Graphics, Controls, Forms, Dialogs, StdCtrls;

type
  TfmRubik = class(TForm)
    btKever: TButton;
    btKilep: TButton;
Procedure Fest;
Procedure Forgat;
procedure FormCreate(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure btKeverClick(Sender: TObject);
procedure btKilepClick(Sender: TObject);
procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
procedure FormClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

Const Dy=24;
      Le=150;
      Fel=150;

var
fmRubik: TfmRubik;
  Xk, Yk: Integer;
  Dx, Fx, Fy, Mx, My: Integer;
  Lk: Array[1..6,1..3,1..3,1..2] Of Integer;
  Ls: Array[1..6,1..3,1..3] Of TColor;
  Ps: Array[1..3] Of TColor;
  Vp: Array[1..24,1..2] Of Integer;
  Forg: Word;

implementation

{$R *.dfm}

procedure TfmRubik.btKilepClick(Sender: TObject);
begin
  Close;
end;

procedure TfmRubik.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  Mx:= X;
  My:= Y;
end;

procedure TfmRubik.FormCreate(Sender: TObject);
Var I, J: Word;
begin
  Xk:= ClientWidth Div 2;
  Yk:= ClientHeight Div 2;
Dx:= Round(1.1*Sqrt(3)*Dy);
  Fx:= Dx Div 2;
  Fy:= (Dy Div 2);
For I:= 1 To 3 Do For J:= 1 To 3 Do Ls[1,I,J]:= RGB(255,128,64);
For I:= 1 To 3 Do For J:= 1 To 3 Do Ls[2,I,J]:= clWhite;
For I:= 1 To 3 Do For J:= 1 To 3 Do Ls[3,I,J]:= clGreen;
For I:= 1 To 3 Do For J:= 1 To 3 Do Ls[4,I,J]:= RGB(192,0,0);
For I:= 1 To 3 Do For J:= 1 To 3 Do Ls[5,I,J]:= clBlue;
For I:= 1 To 3 Do For J:= 1 To 3 Do Ls[6,I,J]:= clYellow;
  Randomize;
end;

Procedure TfmRubik.Fest;
Var I, J, K: Word;
Begin
With Canvas Do
For I:= 1 To 6 Do For J:= 1 To 3 Do For K:= 1 To 3 Do
Begin
Brush.Color:= Ls[I,J,K];
    FloodFill(Lk[I,J,K,1],Lk[I,J,K,2],clBlack,fsBorder);
End;
End;

Procedure TfmRubik.Forgat;
Var I, P: Word;
Begin
  P:= 0;
Case Forg Of
    1,2,3:
Begin
For I:= 1 To 3 Do Ps[I]:= Ls[1,I,Forg];
For I:= 1 To 3 Do Ls[1,I,Forg]:= Ls[6,4-Forg,4-I];
For I:= 1 To 3 Do Ls[6,4-Forg,4-I]:= Ls[4,I,4-Forg];
For I:= 1 To 3 Do Ls[4,I,4-Forg]:= Ls[2,Forg,4-I];
For I:= 1 To 3 Do Ls[2,Forg,4-I]:= Ps[I];
If Forg In [1,3] Then
Begin
If Forg=1 Then P:= 3; If Forg=3 Then P:= 5;
For I:= 1 To 3 Do Ps[I]:= Ls[P,I,1];
For I:= 1 To 3 Do Ls[P,I,1]:= Ls[P,3,I];
For I:= 1 To 3 Do Ls[P,3,I]:= Ls[P,4-I,3];
For I:= 1 To 3 Do Ls[P,4-I,3]:= Ls[P,1,4-I];
For I:= 1 To 3 Do Ls[P,1,4-I]:= Ps[I];
End;
End;
    4,5,6:
Begin
For I:= 1 To 3 Do Ps[I]:= Ls[1,I,Forg-3];
For I:= 1 To 3 Do Ls[1,I,Forg-3]:= Ls[2,Forg-3,4-I];
For I:= 1 To 3 Do Ls[2,Forg-3,4-I]:= Ls[4,I,7-Forg];
For I:= 1 To 3 Do Ls[4,I,7-Forg]:= Ls[6,7-Forg,4-I];
For I:= 1 To 3 Do Ls[6,7-Forg,4-I]:= Ps[I];
If Forg In [4,6] Then
Begin
If Forg=4 Then P:= 3; If Forg=6 Then P:= 5;
For I:= 1 To 3 Do Ps[I]:= Ls[P,1,I];
For I:= 1 To 3 Do Ls[P,1,I]:= Ls[P,I,3];
For I:= 1 To 3 Do Ls[P,I,3]:= Ls[P,3,4-I];
For I:= 1 To 3 Do Ls[P,3,4-I]:= Ls[P,4-I,1];
For I:= 1 To 3 Do Ls[P,4-I,1]:= Ps[I];
End;
End;
    7,8,9:
Begin
For I:= 1 To 3 Do Ps[I]:= Ls[1,Forg-6,I];
For I:= 1 To 3 Do Ls[1,Forg-6,I]:= Ls[5,10-Forg,4-I];
For I:= 1 To 3 Do Ls[5,10-Forg,I]:= Ls[4,10-Forg,4-I];
For I:= 1 To 3 Do Ls[4,10-Forg,I]:= Ls[3,Forg-6,4-I];
For I:= 1 To 3 Do Ls[3,Forg-6,4-I]:= Ps[I];
If Forg In [7,9] Then
Begin
If Forg=7 Then P:= 2; If Forg=9 Then P:= 6;
For I:= 1 To 3 Do Ps[I]:= Ls[P,I,1];
For I:= 1 To 3 Do Ls[P,I,1]:= Ls[P,3,I];
For I:= 1 To 3 Do Ls[P,3,I]:= Ls[P,4-I,3];
For I:= 1 To 3 Do Ls[P,4-I,3]:= Ls[P,1,4-I];
For I:= 1 To 3 Do Ls[P,1,4-I]:= Ps[I];
End;
End;
    10,11,12:
Begin
For I:= 1 To 3 Do Ps[I]:= Ls[1,Forg-9,I];
For I:= 1 To 3 Do Ls[1,Forg-9,I]:= Ls[3,Forg-9,4-I];
For I:= 1 To 3 Do Ls[3,Forg-9,I]:= Ls[4,13-Forg,4-I];
For I:= 1 To 3 Do Ls[4,13-Forg,I]:= Ls[5,13-Forg,4-I];
For I:= 1 To 3 Do Ls[5,13-Forg,4-I]:= Ps[I];
If Forg In [10,12] Then
Begin
If Forg=10 Then P:= 2; If Forg=12 Then P:= 6;
For I:= 1 To 3 Do Ps[I]:= Ls[P,4-I,1];
For I:= 1 To 3 Do Ls[P,I,1]:= Ls[P,1,I];
For I:= 1 To 3 Do Ls[P,1,I]:= Ls[P,I,3];
For I:= 1 To 3 Do Ls[P,I,3]:= Ls[P,3,4-I];
For I:= 1 To 3 Do Ls[P,3,4-I]:= Ps[I];
End;
End;
    13,14,15:
Begin
For I:= 1 To 3 Do Ps[I]:= Ls[3,I,Forg-12];
For I:= 1 To 3 Do Ls[3,I,Forg-12]:= Ls[6,4-I,16-Forg];
For I:= 1 To 3 Do Ls[6,4-I,16-Forg]:= Ls[5,I,16-Forg];
For I:= 1 To 3 Do Ls[5,I,16-Forg]:= Ls[2,4-I,Forg-12];
For I:= 1 To 3 Do Ls[2,4-I,Forg-12]:= Ps[I];
If Forg In [13,15] Then
Begin
If Forg=13 Then P:= 1; If Forg=15 Then P:= 4;
For I:= 1 To 3 Do Ps[I]:= Ls[P,I,1];
For I:= 1 To 3 Do Ls[P,I,1]:= Ls[P,3,I];
For I:= 1 To 3 Do Ls[P,3,I]:= Ls[P,4-I,3];
For I:= 1 To 3 Do Ls[P,4-I,3]:= Ls[P,1,4-I];
For I:= 1 To 3 Do Ls[P,1,4-I]:= Ps[I];
End;
End;
    16,17,18:
Begin
For I:= 1 To 3 Do Ps[I]:= Ls[3,I,Forg-15];
For I:= 1 To 3 Do Ls[3,I,Forg-15]:= Ls[2,4-I,Forg-15];
For I:= 1 To 3 Do Ls[2,4-I,Forg-15]:= Ls[5,I,19-Forg];
For I:= 1 To 3 Do Ls[5,I,19-Forg]:= Ls[6,4-I,19-Forg];
For I:= 1 To 3 Do Ls[6,4-I,19-Forg]:= Ps[I];
If Forg In [16,18] Then
Begin
If Forg=16 Then P:= 1; If Forg=18 Then P:= 4;
For I:= 1 To 3 Do Ps[I]:= Ls[P,4-I,1];
For I:= 1 To 3 Do Ls[P,4-I,1]:= Ls[P,1,I];
For I:= 1 To 3 Do Ls[P,1,I]:= Ls[P,I,3];
For I:= 1 To 3 Do Ls[P,I,3]:= Ls[P,3,4-I];
For I:= 1 To 3 Do Ls[P,3,4-I]:= Ps[I];
End;
End;
End;
End;

procedure TfmRubik.FormPaint(Sender: TObject);
Var I, J: Word;
begin
With Canvas Do
Begin
    Yk:= Yk+Le; Pen.Width:= 4; MoveTo(Xk,Yk);
//felső
    LineTo(Xk-3*Dx,Yk-3*Dy); LineTo(Xk     ,Yk-6*Dy);
    LineTo(Xk+3*Dx,Yk-3*Dy); LineTo(Xk     ,Yk     );
//bal
    LineTo(Xk     ,Yk+6*Dy); LineTo(Xk-3*Dx,Yk+3*Dy);
    LineTo(Xk-3*Dx,Yk-3*Dy);
//jobb
MoveTo(Xk     ,Yk+6*Dy); LineTo(Xk+3*Dx,Yk+3*Dy);
    LineTo(Xk+3*Dx,Yk-3*Dy);
//felső rács
    MoveTo(Xk-  Dx,Yk-  Dy); LineTo(Xk+2*Dx,Yk-4*Dy);
    MoveTo(Xk-2*Dx,Yk-2*Dy); LineTo(Xk+  Dx,Yk-5*Dy);
    MoveTo(Xk+  Dx,Yk-  Dy); LineTo(Xk-2*Dx,Yk-4*Dy);
    MoveTo(Xk+2*Dx,Yk-2*Dy); LineTo(Xk-  Dx,Yk-5*Dy);
For I:= 1 To 3 Do For J:= 1 To 3 Do
Begin
      Lk[1,I,J,1]:= Xk+(I-J)*Dx;
      Lk[1,I,J,2]:= Yk+(1-I-J)*Dy;
End;
//bal rács
    MoveTo(Xk-  Dx,Yk-  Dy); LineTo(Xk-  Dx,Yk+5*Dy);
    MoveTo(Xk-2*Dx,Yk-2*Dy); LineTo(Xk-2*Dx,Yk+4*Dy);
MoveTo(Xk     ,Yk+2*dy); LineTo(Xk-3*Dx,Yk-  Dy);
    MoveTo(Xk     ,Yk+4*dy); LineTo(Xk-3*Dx,Yk+  Dy);
For I:= 1 To 3 Do For J:= 1 To 3 Do
Begin
      Lk[2,I,J,1]:= Xk-Fx-(I-1)*Dx;
      Lk[2,I,J,2]:= Yk+Fy+(2*J-I-1)*Dy;
End;
//jobb rács
    MoveTo(Xk+  Dx,Yk-  Dy); LineTo(Xk+  Dx,Yk+5*Dy);
    MoveTo(Xk+2*Dx,Yk-2*Dy); LineTo(Xk+2*Dx,Yk+4*Dy);
    MoveTo(Xk     ,Yk+2*dy); LineTo(Xk+3*Dx,Yk-  Dy);
    MoveTo(Xk     ,Yk+4*dy); LineTo(Xk+3*Dx,Yk+  Dy);
For I:= 1 To 3 Do For J:= 1 To 3 Do
Begin
      Lk[3,I,J,1]:= Xk+Fx+(I-1)*Dx;
      Lk[3,I,J,2]:= Yk+Fy+(2*J-I-1)*Dy;
End;
//vezérlők
    Pen.Width:= 3;
For I:= 1 To 3 Do
Begin
      MoveTo(Xk-I*Dx,Yk+(7-I)*Dy);
      Vp[I,1]:= Xk-I*Dx;                       //1-3
      Vp[I,2]:= Yk+(7-I)*Dy;
      LineTo(Xk-(I+1)*Dx,Yk+(8-I)*Dy);
      Vp[I+3,1]:= Xk-(I+1)*Dx;                 //4-6
      Vp[I+3,2]:= Yk+(8-I)*Dy;
      MoveTo(Xk-I*Dx,Yk+(7-I)*Dy);
      LineTo(Xk-I*Dx-16,Yk+(7-I)*Dy);
      MoveTo(Xk-I*Dx,Yk+(7-I)*Dy);
      LineTo(Xk-I*Dx-6,Yk+(7-I)*Dy+10);
      MoveTo(Xk-(I+1)*Dx,Yk+(8-I)*Dy);
      LineTo(Xk-(I+1)*Dx+16,Yk+(8-I)*Dy);
      MoveTo(Xk-(I+1)*Dx,Yk+(8-I)*Dy);
LineTo(Xk-(I+1)*Dx+6,Yk+(8-I)*Dy-10);
End;
For I:= 1 To 3 Do
Begin
      MoveTo(Xk+I*Dx,Yk+(7-I)*Dy);
      Vp[I+6,1]:= Xk+I*Dx;                     //7-9
      Vp[I+6,2]:= Yk+(7-I)*Dy;
      LineTo(Xk+(I+1)*Dx,Yk+(8-I)*Dy);
      Vp[I+9,1]:= Xk+(I+1)*Dx;                 //10-12
      Vp[I+9,2]:= Yk+(8-I)*Dy;
      MoveTo(Xk+I*Dx,Yk+(7-I)*Dy);
      LineTo(Xk+I*Dx+16,Yk+(7-I)*Dy);
      MoveTo(Xk+I*Dx,Yk+(7-I)*Dy);
      LineTo(Xk+I*Dx+6,Yk+(7-I)*Dy+10);
      MoveTo(Xk+(I+1)*Dx,Yk+(8-I)*Dy);
      LineTo(Xk+(I+1)*Dx-16,Yk+(8-I)*Dy);
      MoveTo(Xk+(I+1)*Dx,Yk+(8-I)*Dy);
LineTo(Xk+(I+1)*Dx-6,Yk+(8-I)*Dy-10);
End;
For I:= 1 To 3 Do
Begin
      MoveTo(Xk+3*Dx+Fx,Yk+2*(I-2)*Dy-Fy);
      Vp[I+12,1]:= Xk+3*Dx+Fx;                 //13-15
      Vp[I+12,2]:= Yk+2*(I-2)*Dy-Fy;
      LineTo(Xk+4*Dx+Fx,Yk+(2*I-5)*Dy-Fy);
      Vp[I+15,1]:= Xk+4*Dx+Fx;                 //16-18
      Vp[I+15,2]:= Yk+(2*I-5)*Dy-Fy;
      MoveTo(Xk+3*Dx+Fx,Yk+2*(I-2)*Dy-Fy);
      LineTo(Xk+3*Dx+Fx+8,Yk+2*(I-2)*Dy-Fy-12);
      MoveTo(Xk+3*Dx+Fx,Yk+2*(I-2)*Dy-Fy);
      LineTo(Xk+3*Dx+Fx+16,Yk+2*(I-2)*Dy-Fy);
      MoveTo(Xk+4*Dx+Fx,Yk+(2*I-5)*Dy-Fy);
LineTo(Xk+4*Dx+Fx-16,Yk+(2*I-5)*Dy-Fy);
      MoveTo(Xk+4*Dx+Fx,Yk+(2*I-5)*Dy-Fy);
      LineTo(Xk+4*Dx+Fx-8,Yk+(2*I-5)*Dy-Fy+12);
End;
    Pen.Width:= 8;
    Yk:= Yk-Le;
    MoveTo(Xk-5*Dx,Yk+4*Dy+Fy);
    LineTo(Xk-4*Dx+Fx,Yk+5*Dy+2*Fy);
    LineTo(Xk-4*Dx+Fx-16,Yk+5*Dy+2*Fy);
    MoveTo(Xk-4*Dx+Fx,Yk+5*Dy+2*Fy);
    Vp[19,1]:= Xk-4*Dx+Fx;                     //19
    Vp[19,2]:= Yk+5*Dy+2*Fy;
    LineTo(Xk-4*Dx+Fx-12,Yk+5*Dy+2*Fy-12);
    MoveTo(Xk-5*Dx+16,Yk+4*Dy+Fy);
    LineTo(Xk-5*Dx,Yk+4*Dy+Fy);
    Vp[20,1]:= Xk-5*Dx;                        //20
    Vp[20,2]:= Yk+4*Dy+Fy;
LineTo(Xk-5*Dx+12,Yk+4*Dy+Fy+12);

    MoveTo(Xk-Dx-Fx,Yk-Dy);
    LineTo(Xk-Dx-Fx,Yk+Dy);
    LineTo(Xk-Dx-Fx-10,Yk+Dy-10);
    MoveTo(Xk-Dx-Fx,Yk+Dy);
    Vp[21,1]:= Xk-Dx-Fx;                       //21
    Vp[21,2]:= Yk+Dy;
    LineTo(Xk-Dx-Fx+10,Yk+Dy-10);
    MoveTo(Xk-Dx-Fx-10,Yk-Dy+10);
    LineTo(Xk-Dx-Fx,Yk-Dy);
    Vp[22,1]:= Xk-Dx-Fx;                       //22
    Vp[22,2]:= Yk-Dy;
    LineTo(Xk-Dx-Fx+10,Yk-Dy+10);

    MoveTo(Xk+Dx+Fx,Yk-Dy);
    LineTo(Xk+Dx+Fx,Yk+Dy);
    LineTo(Xk+Dx+Fx-10,Yk+Dy-10);
    MoveTo(Xk+Dx+Fx,Yk+Dy);
Vp[23,1]:= Xk+Dx+Fx;                       //23
    Vp[23,2]:= Yk+Dy;
    LineTo(Xk+Dx+Fx+10,Yk+Dy-10);
    MoveTo(Xk+Dx+Fx-10,Yk-Dy+10);
    LineTo(Xk+Dx+Fx,Yk-Dy);
    Vp[24,1]:= Xk+Dx+Fx;                       //24
    Vp[24,2]:= Yk-Dy;
    LineTo(Xk+Dx+Fx+10,Yk-Dy+10);

//tükörkép
    Yk:= Yk-Fel; Pen.Width:= 4; MoveTo(Xk,Yk);
//alsó
    LineTo(Xk-3*Dx,Yk+3*Dy); LineTo(Xk     ,Yk+6*Dy);
    LineTo(Xk+3*Dx,Yk+3*Dy); LineTo(Xk     ,Yk     );
//bal
    LineTo(Xk     ,Yk-6*Dy); LineTo(Xk-3*Dx,Yk-3*Dy);
    LineTo(Xk-3*Dx,Yk+3*Dy);
//jobb
MoveTo(Xk     ,Yk-6*Dy); LineTo(Xk+3*Dx,Yk-3*Dy);
    LineTo(Xk+3*Dx,Yk+3*Dy);
//alsó rács
    MoveTo(Xk-  Dx,Yk+5*Dy); LineTo(Xk+2*Dx,Yk+2*Dy);
    MoveTo(Xk-2*Dx,Yk+4*Dy); LineTo(Xk+  Dx,Yk+  Dy);
    MoveTo(Xk+  Dx,Yk+5*Dy); LineTo(Xk-2*Dx,Yk+2*Dy);
    MoveTo(Xk+2*Dx,Yk+4*Dy); LineTo(Xk-  Dx,Yk+  Dy);
For I:= 1 To 3 Do For J:= 1 To 3 Do
Begin
      Lk[4,I,J,1]:= Xk+(J-I)*Dx;
      Lk[4,I,J,2]:= Yk+(I+J-1)*Dy;
End;
//bal rács
    MoveTo(Xk-  Dx,Yk+  Dy); LineTo(Xk-  Dx,Yk-5*Dy);
    MoveTo(Xk-2*Dx,Yk+2*Dy); LineTo(Xk-2*Dx,Yk-4*Dy);
MoveTo(Xk     ,Yk-4*dy); LineTo(Xk-3*Dx,Yk-  Dy);
    MoveTo(Xk     ,Yk-2*dy); LineTo(Xk-3*Dx,Yk+  Dy);
For I:= 1 To 3 Do For J:= 1 To 3 Do
Begin
      Lk[5,I,J,1]:= Xk-Fx-(I-1)*Dx;
      Lk[5,I,J,2]:= Yk+Fy+(I-2*J)*Dy;
End;
//jobb rács
    MoveTo(Xk+  Dx,Yk+  Dy); LineTo(Xk+  Dx,Yk-5*Dy);
    MoveTo(Xk+2*Dx,Yk+2*Dy); LineTo(Xk+2*Dx,Yk-4*Dy);
    MoveTo(Xk     ,Yk-4*dy); LineTo(Xk+3*Dx,Yk-  Dy);
    MoveTo(Xk     ,Yk-2*dy); LineTo(Xk+3*Dx,Yk+  Dy);
For I:= 1 To 3 Do For J:= 1 To 3 Do
Begin
      Lk[6,I,J,1]:= Xk+Fx+(I-1)*Dx;
      Lk[6,I,J,2]:= Yk+Fy+(I-2*J)*Dy;
End;
End;
  Fest;
end;

procedure TfmRubik.btKeverClick(Sender: TObject);
Var I: Word;
begin
For I:= 1 To 300 Do Begin Forg:= Random(18)+1; Forgat End; Fest;
end;

procedure TfmRubik.FormClick(Sender: TObject);
Var I: Word;
begin
  Forg:= 0;
For I:= 1 To 24 Do If Sqrt(Sqr(Vp[I,1]-Mx)+Sqr(Vp[I,2]-My))<16 Then
Begin Forg:= I; Break End;
If Forg<>0 Then
Case Forg Of
    19: Begin Forg:= 16; Forgat; Forg:= 17; Forgat; Forg:= 18; Forgat; Fest End;
    20: Begin Forg:= 13; Forgat; Forg:= 14; Forgat; Forg:= 15; Forgat; Fest End;
21: Begin Forg:= 10; Forgat; Forg:= 11; Forgat; Forg:= 12; Forgat; Fest End;
    22: Begin Forg:= 7; Forgat; Forg:= 8; Forgat; Forg:= 9; Forgat; Fest End;
    23: Begin Forg:= 4; Forgat; Forg:= 5; Forgat; Forg:= 6; Forgat; Fest End;
    24: Begin Forg:= 1; Forgat; Forg:= 2; Forgat; Forg:= 3; Forgat; Fest End;
Else
Begin Forgat; Fest End;
End;
end;

end.