BUGS.PAS

{ This is an implementation of Scientific American "bugs" I did back in 1996 }

Program bugs;  { fucking evil bugs, no less}
 uses graph,crt;
 const max_num=870;
    sizex=160;
    sizey=160;
 var bnum,fnum,lastx,lasty:integer;
    sx,sy :real;
    b:array[1..max_num,1..7] of integer; {age,life,g1,g2,dir,xco,yxo}
    land:array[1..sizex,1..sizey] of (e,x,f,w);
    fertile:array[1..sizex,1..sizey] of boolean;
    finished:boolean;
    cha:char;

procedure init_graphics;
var graphdriver,graphmode,errorcode:integer;
begin
   graphdriver:=detect;
   initgraph(graphdriver,graphmode, 'c:\turbop~1\bgi');
   errorcode:=graphresult;
   if errorcode <> grok then
   begin
      writeln('error');
      readln;
      halt(1);
   end;
   clearviewport;
end;

procedure set_up_1;
var i,j:integer;
begin
   randomize;
   {setup graphics}
   init_graphics;
   {kill all bugs}
   for i:=1 to max_num do b[i,2]:=0;
   {empty land and make it fertile}
   for i:=1 to sizex do
      for j:=1 to sizey do
      begin
	 land[i,j]:=e; fertile[i,j]:=true;
      end;
   {clear number of bugs and food}
   bnum:=0; fnum:=0;
   {calculate scales for axes}
   sx:=getmaxx/max_num*0.75;	     {scale for bugs on x-axis}
   sy:=getmaxy/(sizex*sizey)*0.75; {scale for food on y-axis}
   {insert graph axis}
   {setcolor(2);
   line(0,sizey,0,getmaxy);
   line(0,getmaxy,getmaxx,getmaxy);
   {put in nice labels}
   outtextxy(sizex+50,50,'<-- actual land');
   line(sizex+200,50,sizex+200,120);
   outtextxy(sizex+202,50,'food');
   line(sizex+200,120,sizex+370,120);
   outtextxy(sizex+340,110,'bugs');
end;{set_up_1}

procedure set_up_2;
begin
   {need to init graph values}
   lastx:=trunc(bnum*sx);
   lasty:=getmaxy-trunc(fnum*sy);
end;{set_up_2}

procedure make_bugs(n,s:integer);
var i,g1,g2,c:integer;
   rep:boolean;
begin
   i:=0;
   c:=0;
   
   while (i<>max_num) and (c<>n) do
   begin
      i:=succ(i);
      if b[i,2]=0
	 then begin
	    bnum:=succ(bnum);
	    {new bug}
	    c:=succ(c);
	    {age=0}
	    b[i,1]:=0;
	    {assign strength}
	    b[i,2]:=s;
	    {assign genes}
	    rep:=true;
	    while rep do
	    begin
	       g1:=random(5)+1;
	       g2:=random(5)+1;
	       if g1<>g2 then rep:=false;
	    end;
	    if g1<g2 then begin b[i,3]:=g1; b[i,4]:=g2 end
	    else begin b[i,3]:=g2; b[i,4]:=g1 end;
	    {choose direction}
	    b[i,5]:=random(8)+1;
	    {choose x and y cords}
	    rep:=true;
	    while rep do
	    begin
	       b[i,6]:=random(sizex)+1;
	       b[i,7]:=random(sizey)+1;
	       if (land[b[i,6],b[i,7]]=e) then rep:=false;
	    end;
	    land[b[i,6],b[i,7]]:=x;
	    putpixel(b[i,6],b[i,7],2);
	 end;
   end;
end;{make_bugs}

procedure int_food(max_num,a,b,q,w:integer);
var i,x,y,c:integer;
begin
   i:=0; c:=0;
   while (i<>max_num) and (c<>100) do
   begin
      c:=succ(c);
      x:=random((q-a)+1)+a;
      y:=random((w-b)+1)+b;
      if (land[x,y]=e) and fertile[x,y] then
      begin
	 fnum:=succ(fnum);
	 land[x,y]:=f;
	 putpixel(x,y,1);
	 i:=succ(i);
	 c:=0;
      end;
   end;
end;{int_food}

procedure make_food(num:integer);
var i,x,y :integer;
   fin :boolean;
   
   function food_around(x,y:integer):boolean;
   begin
      if (land[x-1,y]=f)   or (land[x+1,y]=f)   or
	 (land[x-1,y-1]=f) or (land[x-1,y+1]=f) or
	 (land[x+1,y-1]=f) or (land[x+1,y+1]=f) or
	 (land[x,y-1]=f)   or (land[x,y+1]=f) then food_around:=true
      else food_around:=false;
   end; {food_around}

begin
   for i:=1 to num do
   begin
      x:=random(sizex)+1;
      y:=random(sizey)+1;
      if food_around(x,y) and (land[x,y]=e)
	 and fertile[x,y] then begin
	    land[x,y]:=f;
	    putpixel(x,y,1);
	    fnum:=succ(fnum);
	 end;
   end;
end;

procedure draw_land;
var i,j,c:integer;
begin
   for i:=1 to sizex do
      for j:=1 to sizey do
      begin
	 case land[i,j] of
	   e:c:=0;
	   f:c:=1;
	   x:c:=2;
	   w:c:=3; end;
	 putpixel(i,j,c);
      end;
end;{draw_land}

procedure one_day;
var i,mo:integer;
   
   procedure rev_dir(i:integer);
   begin
      b[i,5]:=b[i,5]+4; if b[i,5]>8 then b[i,5]:=b[i,5]-8;
   end;{rev_dir}

   procedure straight_ahead(i:integer);
   var nx,ny:integer;
   begin
      case b[i,5] of
	1: begin nx:=b[i,6];       ny:=pred(b[i,7]); end;
	2: begin ny:=pred(b[i,7]); nx:=succ(b[i,6]); end;
	3: begin nx:=succ(b[i,6]); ny:=b[i,7];       end;
	4: begin ny:=succ(b[i,7]); nx:=succ(b[i,6]); end;
	5: begin nx:=b[i,6];       ny:=succ(b[i,7]); end;
	6: begin nx:=pred(b[i,6]); ny:=succ(b[i,7]); end;
	7: begin nx:=pred(b[i,6]); ny:=b[i,7];       end;
	8: begin nx:=pred(b[i,6]); ny:=pred(b[i,7]); end;
      end;
      
      if nx<1 then nx:=sizex;	 if nx>sizex then nx:=1;
      if ny<1 then ny:=sizey;  if ny>sizey then ny:=1;
      
      case land[nx,ny] of
	e: begin
	      land[b[i,6],b[i,7]]:=e; {clear last pos}
	      putpixel(b[i,6],b[i,7],0); {clear last pixel}
	      b[i,6]:=nx; b[i,7]:=ny; {new cords}
	      land[nx,ny]:=x;
	      putpixel(nx,ny,2);{place bug}
	   end;
	w: begin  {nothing}  end;
	x: begin  {nothing}  end;
	f: begin
	      putpixel(b[i,6],b[i,7],0);  {clear last}
	      fnum:=pred(fnum); {one less bit of food}
	      land[b[i,6],b[i,7]]:=e;
	      b[i,2]:=b[i,2]+50; {get some strength}
	      if b[i,2]>=300 then b[i,2]:=300; {too much food}
	      b[i,6]:=nx; b[i,7]:=ny;  {new cords of bug}
	      land[nx,ny]:=x;          {place bug on land}
	      putpixel(nx,ny,2);
	   end;
      end;{case}
   end;{straight_ahead}

   procedure turn_left(i:integer);
   begin
      if b[i,5]=1 then b[i,5]:=8
      else b[i,5]:=pred(b[i,5]);
      {straight_ahead(i); }
   end;{turn_left}

   procedure turn_right(i:integer);
   begin
      if b[i,5]=8 then b[i,5]:=1
      else b[i,5]:=succ(b[i,5]);
      {straight_ahead(i); }
   end;{turn_right}

   procedure spawn(p:integer);
   var i,dir:integer;
      fin,rep:boolean;
   begin
      fin:=false;
      i:=0;
      while (not fin) and (i<>max_num) do
      begin
	 i:=succ(i);
	 if b[i,2]=0
	    then begin
	       {extra bug}
	       bnum:=succ(bnum);
	       fin:=true;
	       {age=0}
	       b[i,1]:=0;
	       {50% of parent strength}
	       b[i,2]:=trunc(b[p,2]/2);
	       {parent loses this}
	       b[p,2]:=b[p,2]-b[i,2];
	       {change either gene1 or gene2}
	       if random(0)=1
		  then begin {change gene1}
		     b[i,3]:=b[p,3]+random(3)-1;
		     b[i,4]:=b[p,4];
		  end
		  else begin	{change gene2}
		     b[i,3]:=b[p,3];
		     b[i,4]:=b[p,4]+random(3)-1;
		  end;
	       {change direction based on parent}
	       b[i,5]:=b[p,5]; rev_dir(i);
	       {decide on new pos}
	       b[i,6]:=b[p,6];
	       b[i,7]:=b[p,7];
	       {place it there}
	       land[b[i,6],b[i,7]]:=x;
	       putpixel(b[i,6],b[i,7],2);
	    end;
      end;
   end;{spawn}

begin{of one_day}
   finished:=true; {assume so and later prove otherwise}
   for i:=1 to max_num do
      if b[i,2]<>0 then
      begin
	 {not all dead}						finished:=false;
	 {grow older}			        b[i,1]:=succ(b[i,1]);
	 {die a bit} 			        b[i,2]:=pred(b[i,2]);
	 {decide if die of old age}
	 if b[i,1]>300 then
	    if (random(100)+1)<=(b[i,1]-300)
	       then begin
		  b[i,2]:=0; {kill bug}
		  putpixel(b[i,6],b[i,7],0);
	       end;
	 
	 if b[i,2]<>0
	    then {bug is alive}
	 begin
	    {decide to breed}
	    if (random(50)=35) and (b[i,1]>100) and (b[i,2]>80)
	       then spawn(i);
	    
	    {decide move}
	    mo:=random(10)+1;
	    if mo<=b[i,3] then turn_left(i)
	    else if mo<=b[i,4] then turn_right(i)
	    else straight_ahead(i);
	 end
	 else begin
	    {bug is dead}
	    land[b[i,6],b[i,7]]:=e;
	    putpixel(b[i,6],b[i,7],0);
	    bnum:=pred(bnum);
	 end;
      end;
end;{one_day}

procedure show_attr;
var i,c:integer;
const size=2;
begin
   i:=1; c:=0;
   for i:=1 to max_num do
   begin
      setcolor(0);
      rectangle(400+i*size,400,401+i*size,0);
      if b[i,2]<>0
	 then begin
	    {line for age}
	    setcolor(2);
	    line(400+i*size,400,400+i*size,400-b[i,1]);
	    {line for health}
	    setcolor(5);
	    line(401+i*size,400,401+i*size,400-b[i,2]);
	 end;
   end;
end;{show_attr}

procedure make_wall(x1,y1,x2,y2:integer);
var i,l:integer;
   d:(x,y);

   procedure swap(var a,b:integer);
   var t:integer;
   begin
      t:=a; a:=b; b:=t;
   end;

begin
   if (x1=x2) or (y1=y2) then
   begin
      if x1=x2 then begin d:=y; l:=abs(y1-y2);
	 if (y1>y2) then swap(y1,y2); end
	 else begin d:=x; l:=abs(x1-x2);
	    if (x1>x2) then swap(x1,x2); end;
      for i:=0 to l do
	 if d=x then begin putpixel(x1+i,y1,3); land[x1+i,y1]:=w; end
	 else begin putpixel(x1,y1+i,3); land[x1,y1+i]:=w; end;
   end;
end; {make_wall}

procedure make_desert(a,b,c,d:integer);
var i,j:integer;
begin
   for i:=a to a+c do
      for j:=b to b+d do
	 if (i<=sizex) and (i<=sizey) then fertile[i,j]:=false;
end; {make_desert}

procedure graph_phase_plane;
var x,y:integer;
begin
   x:=trunc(bnum*sx);
   y:=getmaxy-trunc(fnum*sy);
   setcolor(7);
   line(lastx+5,lasty,x+5,y);
   lastx:=x; lasty:=y;
end;

procedure create_landscape;
begin
   {borders} make_wall(1,1,160,1); make_wall(1,1,1,160);
   make_wall(160,1,160,160); make_wall(1,160,160,160);
   
   {inner borders} make_Wall(80,1,80,79); make_wall(80,81,80,160);
   make_wall(1,80,79,80); make_wall(81,80,160,80);
   
   {make centre point a desert}
   make_desert(80,80,1,1);
end; {create_landscape}

begin{ning of main program}
   set_up_1;
   create_landscape;
   make_bugs(1,100);
   int_food(600,1,1,sizex,sizey);
   set_up_2;
   
   finished:=false;
   while (not finished) {and (not keypressed)} do
   begin
      make_food(65);
      one_day;
      graph_phase_plane;
      show_attr;
   end;
   readln;
   closegraph;
end.{of main program}