old/PAS/Genetics/cellmach.pas

Uses Graph, CRT;
TYPE
  EBis	  = (NOTHING,BLINK,CREATECHILD,WALK,FIGHT,DYING);
  EStages = (CHILD,YOUTH,NORMAL,OLDMAN,DEAD);
  ESexes  = (MAN,WOMAN);

CONST
  DelayNum       = 100;
  DelaySize      = 65535;
  XCount         = 300;
  YCount         = 200;
  XSize          = 600 div XCount;
  YSize          = 400 div YCount;
  FieldSize	 = XCount * YCount div 8;
  TickPerYear	 = 4;
  CurID: longint = 0;

  AveLifeTime : array [0..1] of word = (65, 70);
  LifeTimeAdd : array [0..9] of word = (5,5,5,10,10,10,10,20,30,50);
  DyeAccur    = 1000;
  DyeChance   : array [0..3] of word = (10,5,6,15);

  YouthAge  = 15;
  NormalAge = 21;
  OldManAge = 50;
                {Sex,Stage,Random}
  Moods : array [0..1,0..3,0..9] of EBis =
  (((  {MaN}
     NOTHING,NOTHING,NOTHING,NOTHING,  {Child}
     BLINK,BLINK,BLINK,
     WALK,WALK,WALK
    ),
    (
     NOTHING,NOTHING,NOTHING,          {Youth}
     BLINK,BLINK,
     WALK,WALK,WALK,WALK,WALK
    ),
    (
     NOTHING,NOTHING,NOTHING,NOTHING,NOTHING,NOTHING,  {Normal}
     BLINK,
     WALK,WALK,WALK
    ),
    (
     NOTHING,NOTHING,NOTHING,NOTHING,NOTHING,NOTHING,NOTHING, {OldMan}
     BLINK,
     WALK,WALK
    )),
  (( {Woman}
     NOTHING,NOTHING,NOTHING,NOTHING, {Child}
     BLINK,BLINK,BLINK,BLINK,
     WALK,WALK
    ),
    (
     NOTHING,NOTHING,NOTHING,          {Youth}
     BLINK,BLINK,
     WALK,WALK,WALK,WALK,WALK
    ),
    (
     NOTHING,NOTHING,NOTHING,NOTHING,NOTHING,NOTHING,  {Normal}
     BLINK,
     WALK,WALK,WALK
    ),
    (
     NOTHING,NOTHING,NOTHING,NOTHING,NOTHING,NOTHING,NOTHING, {OldMan}
     BLINK,
     WALK,WALK
   )));

TYPE
  TPos = record
   x,y : word;
  end;

  PCell = ^TCell;
  TCell = record
    ID           : longint;
    ChildCount   : word;
    LifeTime     : word;
    Pos          : TPos;
    Age          : word;
    Mood         : EBis;
    MoodTickLeft : word;
    Stage        : EStages;
    Sex          : ESexes;
    BlinkStage   : boolean;
  end;

  PList = ^TList;
  TList = record
    C          : PCell;
    Next, Prev : PList;
  end;

VAR
  Field : array [1..FieldSize] of byte;
  CellList : PList;
  Tick     : longint;


Function CreateCell(x,y:word;aSex:ESexes):PCell;
var
 ret:PCell;
begin
 randomize;
 New(Ret);
 with ret^ do begin
  ID := CurId;
  inc(CurId);
  Sex := aSex;
  Pos.X := x; Pos.Y := y;
  Age := 0;
  LifeTime := AveLifeTime[Ord(Sex)] +
   {random SIGN}(random(1)*2-1) * random(LifeTimeAdd[random(10)]);
  ChildCount := 0;
  Mood := NOTHING;
  MoodTickLeft := 1;
  Stage := CHILD;
  BlinkStage := false;
 end;
 CreateCell := ret;
end;{CreateCell}
{------------------------------------------------}
procedure SetPos(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;{SetPos}
{--------------------------------------------------}
Procedure UnSetPos(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;{UnSetPos}
{------------------------------------------------------}
Function GetPos(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 GetPos := true
  else GetPos := false;
end;{GetPos}
{------------------------------------------------------}
Procedure NewCell(x,y:word;aSex : ESexes);
var
  NNN : PLIST;
  NC  : PCell;
begin
  NC := CreateCell(x,y,aSex);
  SetPos(X,Y);
  NNN := New(Plist);
  NNN^.C := NC;
  NNN^.Prev := CellList;
  NNN^.Next := nil;
  if CellList <> nil then CellList^.Next := NNN;
  CellList := NNN;
end;{NewCell}
{------------------------------------------------------}
Procedure DelayBlock(Num,Count : word);
var i:word;
begin
  for i:=0 to Num Do Delay(Count);
end;{DelayBlock}
{----------------------------------------------}
Procedure Step;
var
 C : PCell;
 CL,p : PList;
begin
 Cl := CellList;
 inc(Tick);
 while CL <> nil do begin
   C := CL^.C;
   with C^ do Begin
     Dec(MoodTickLeft);
     iF Stage <> DEAD then
     begin
      if Tick mod TickPerYear = 0 then begin
         Inc(Age);
         if Age > YouthAge  then Stage := YOUTH;
         if Age > NormalAge then Stage := NORMAL;
         if Age > OldManAge then Stage := OLDMAN;
         Mood := NOTHING;
         MoodTickLeft := 1;
      end;
     end else if MoodTickLeft = 0 then begin
      UnSetPos(Pos.X,Pos.Y);
      P := CL^.Next;
      CL^.Next^.Prev := CL^.Prev;
      CL^.Prev^.Next := CL^.Next;
      Dispose(C);
      Dispose(CL);
      Cl := P;
     end;
   end;
   Cl := CL^.Prev;
 end;
end;{Step}
{-----------------------------------------------}
BEGIN
END.