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.