old/PAS/Genetics/genunit.pas

unit genunit;
interface
CONST
  XCount         = 30; {Размер поля}
  YCount         = 20;
  FieldSize	 = XCount * YCount div 8; {Объем информации, требуемой для ее хранения}
  LifeTimeAdd    : array [0..9] of longint = (50,30,20,10,10,10,10,5,5,5);


type
              {Самый примитивный, всего одна хромосома - Х}
  EChromos = (CR_X); {Переч. хромосом}
CONST
  CFirstChromo : EChromos = CR_X;
   CLastChromo : EChromos = CR_X;
TYPE
	     {Пол (0-м), 2 бита цвета, ост 2 бита цвета,размер,Сила,Ум,
	      Возраст,-//-2}
  EGenesX = (GEN_X_GENDER,GEN_X_COL_RG,GEN_X_COL_BA, {Перечень генов в X-хромосоме}
	   GEN_X_SIZE,GEN_X_STRENGTH,GEN_X_MIND,GEN_X_AGE1,GEN_X_AGE2);
CONST
  CFirstGeneX : EGenesX = GEN_X_GENDER;
   CLastGeneX : EGenesX = GEN_X_AGE2;
TYPE
  EColors  = (COL_Black,COL_Blue,COL_Green,COL_Cyan,COL_Red,COL_Magenta,
	      COL_Brown,COL_LightGray,COL_DarkGray,COL_LightBlue,
	      COL_LightGreen,COL_LightCyan,COL_LightRed,COL_LightMagenta,
	      COL_Yellow,COL_White);


  EAStages = (AGE_CHILD,AGE_YOUTH,AGE_NORMAL,AGE_OLDMAN,AGE_DEAD);
  	   {Стадии возраста клеток}

  TChromo  = array [EGenesX] of byte; {Хромосома, как набор генов}

  TChromos = array [EChromos] of TChromo;
    {Одиночный хромосомный набор (гаплоидный)}
  Tvec	= record x,y:real; end;
  PCreature = ^Creature;
{CReature}
  Creature  = object
    private
      Genos                  : array [1..2] of TChromos;
					 {Генотип (диплоидный набор)}
      Age                    : longint;  {Возраст}
      AgeStage               : EAStages; {Стадии возраста}
      MaxAge                 : longint;	 {Возраст смерти}
      Children		     : longint;
      CrMom, CrDad           : pcreature;{Родители}
    Public
      Gender                 : char;	 {Пол (W/M)}
      Color                  : EColors;	 {Цвет}
      Size                   : byte;	 {Размер}
      Pos                    : Tvec;	 {Положение на поле}
      Constructor Init(apos : tvec; aC1,aC2 : TChromos;aMom,aDad : pcreature);
      Procedure   SetGamete(var aG : TChromos);
      Procedure   AddChild;
      Function    GetRandomGene(aJ : EGenesX):Byte;
  end;
{/CReature}

  PCList = ^TCList;
  TCList = record	{Список существ}
    Cr   : pcreature;
    Next,Prev : PCList;
  end;

  TCreatureEnumProc = procedure(pC : PCreature);

{CWorld}
  CWorld = object	{Объект - мир}
    Field 	   : array [1..FieldSize] of byte; {Битовое поле существ}
    Creatures      : PCList;			   {Сами существа}
    CreatureCount  : longint;			   {Их кол-во}
    Constructor Init;
    Function  CreateChild(aPos:TVec; aMom,aDad : PCreature):PCreature;
    procedure SetFieldPos(x,y : word);		   {Установка бита в поле}
    Function  GetFieldPos(x,y:word) : boolean;     {..}
    Procedure ForEachCreature(aProc : TCreatureEnumProc);
    procedure UnSetFieldPos(x,y : word);	   {Снятие бита поля}
    Function  AddNewCreature(aPos : tvec; aC1,aC2 : TChromos;aMom,aDad : pcreature):pCreature;
					   {Добавление существа в мир}
    Destructor Done;
  end;
{CWorld}

Implementation

Constructor Creature.Init;
begin
  Randomize;
  Children := 0;
  pos := aPos;
  Age := 0;
  AgeStage := AGE_CHILD;
  move(aC1,Genos[1],Sizeof(aC1));
  move(aC2,Genos[2],Sizeof(aC2));
  if Genos[1][CR_X][GEN_X_GENDER] = Genos[2][CR_X][GEN_X_GENDER] then Gender := 'W'
  else Gender := 'M';
  MaxAge := random(LifeTimeAdd[random(10)]);
  MaxAge := Integer(random(2)*2-1)*MaxAge;
  MaxAge := MaxAge + Genos[1][CR_X][GEN_X_AGE1] + Genos[2][CR_X][GEN_X_AGE1]+
	    Genos[1][CR_X][GEN_X_AGE2] + Genos[2][CR_X][GEN_X_AGE2]+LongInt(51);

  Color := EColors(Genos[1][CR_X][GEN_X_COL_RG] and 1 +
		   Genos[2][CR_X][GEN_X_COL_RG] and 2 +
		   Genos[1][CR_X][GEN_X_COL_BA] and 4 +
		   Genos[2][CR_X][GEN_X_COL_BA] and 8
		   );
  if (Genos[1][CR_X][GEN_X_SIZE] <> 0) or (Genos[2][CR_X][GEN_X_SIZE] <> 0) then
    Size := 10
  else
    Size := 5;

  CrMom := aMom;
  CrDad := aDad;
end;{Creature.Init}
{------------------------------}
Function Creature.GetRandomGene(aJ : EGenesX):Byte;
begin
  GetRandomGene := Genos[random(2)+1][CR_X][aJ]
end;{Creature.GetRandomGene}
{------------------------------}
Procedure Creature.SetGamete;
var
  j : EGenesX;
begin
  randomize;
  for j := CFirstGeneX to CLastGeneX do aG[CR_X][j] := GetRandomGene(j);
end;{Creature.SetGamete}
{------------------------------}
Procedure Creature.AddChild;
begin
  inc(Children);
end;{Creature.AddChild}
{/Creature}


{/////////////////////////////////////////////////////////}


{CWorld}
Constructor CWorld.Init;
begin
  Creatures := nil;
  CreatureCount :=0;
  FillChar(Field,FieldSize,0);
end;{CWorld.Init}
{----------------------------------------------}
Function CWorld.AddNewCreature;
var
  NNN : PCList;
  NC  : PCreature;
begin
  New(NC);
  NC^.Init(aPos,aC1,aC2,aMom,aDad);
  SetFieldPos(Round(aPos.X),Round(aPos.Y));
  Inc(CreatureCount);
  NNN := New(PClist);
  NNN^.Cr   := NC;
  NNN^.Prev := Creatures;
  NNN^.Next := nil;
  if Creatures <> nil then Creatures^.Next := NNN;
  Creatures := NNN;
  AddNewCreature := NC;
End;{CWorld.AddNewCreature}
{-----------------------------------------------}
Function CWorld.CreateChild;
var
 cr1,cr2 : TChromos;
begin
  aMom^.SetGamete(cr1);
  aDad^.SetGamete(cr2);
  aMom^.AddChild;
  aDad^.AddChild;
  CreateChild:=AddNewCreature(aPos,cr1,cr2,aMom,aDad);
end;{CWorld.CreateChild}
{-----------------------------------------------}
procedure CWorld.SetFieldPos(x,y : word);
var
  Cbyte : longint;
  Cbit  : byte;
  Mask  : byte;
begin
  CByte := (y*YCount + X) div 8;
  CBit  := (y*YCount + X) mod 8;
  Mask := 1 shl (7-CBit);
  Field[Cbyte] := Field[Cbyte] or Mask;
end;{CWorld.SetFieldPos}
{--------------------------}
procedure CWorld.UnSetFieldPos(x,y : word);
var
  Cbyte : longint;
  Cbit  : byte;
  Mask  : byte;
begin
  CByte := (y*YCount + X) div 8;
  CBit  := (y*YCount + X) mod 8;
  Mask  := 255 xor (1 shl (7-CBit));
  Field[Cbyte] := Field[Cbyte] and Mask;
end;{CWorld.UnSetFieldPos}
{------------------------------------------}
Function  CWorld.GetFieldPos(x,y:word) : boolean;
var
  Cbyte : longint;
  Cbit  : byte;
  Mask  : byte;
begin
  CByte := (y*YCount + X) div 8;
  CBit  := (y*YCount + X) mod 8;
  Mask  := Field[Cbyte] shr (7-Cbit);
  if Mask and 1 = 1 then GetFieldPos := true
  else GetFieldPos := false;
end; {CWorld.GetFieldPos}
{-----------------------------------------------}
Procedure CWorld.ForEachCreature;
var
 C : PCList;
begin
  C := Creatures;
  while C <> nil do begin aProc(C^.Cr); c:=c^.prev; end;
end;{CWorld.ForEachCreature}
{-----------------------------------------------}
Destructor CWorld.Done;
var
 C : PCList;
begin
  while Creatures <> nil do
   begin
     C:=Creatures;
     Creatures:=Creatures^.Prev;
     Dispose(C);
   end;
end;{CWorld.Done}
{/CWorld}
{////////////////////////////////////////////////////}
end.