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.