Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/MADTRB18.ZIP/WATORC.PAS

Pascal/Delphi Source File | 1985-08-04 | 14.3 KB | 606 lines

{  wator program -- December 1984 Scientific American                   }
{  The world of Wa-Tor is torus shaped, like a donut, but it is         }
{  represented here by a flat two dimensional image which wraps around. }
{  The primary species on Wa-Tor resemble earth fishes (*) and earth    }
{  sharks (@).  In this version, the water is blue, fishes are white    }
{  and sharks are red.  There always seem to be enough fish for the     }
{  sharks to eat.  Run this program and find out why...                 }

{  Copyright (C) 1985, Jay R. Jaeger, Madison WI                        }
{  This program may be copied for personal enjoyment only.              }

{$R+}

program wator;


{ these constants describe the size of the wator world and the characteristics }
{ of the wator environment.                                                    }

const
   _sbreed = 10;      { chronons between a shark breeding               }
   _fbreed = 3;       { chronons between a fish  breeding               }
   _xsize  = 79;      { horizontal size of wator                        }
   _maxx   = 78;      { _xsize -1                                       }
   _ysize  = 20;      { vertical size of wator                          }
   _maxy   = 19;      { _ysize -1                                       }
   _starve = 3;       { how long a shark can go without eating          }
   _fishes = 200;     { initial number of fishes in pond                }
   _sharks = 20;      { initial number of sharks in pond                }


{ these types descirbe the fish lists used to keep track of wator's beings }

type
   species = (fish,shark,empty);
   xcoord  = 0.._maxx;
   ycoord  = 0.._maxy;

   link = ^fishes;
   fishes = record
      next: link;
      prev: link;
      kind: species;
      age:  integer;
      x:    xcoord;
      y:    ycoord;
      ate:  integer;
   end;


{ string parameter type }

type
   anystring = string[255];


{ these variables are the heads and tails of the lists of beings on wator }

var
   fish_head: fishes;
   fish_tail: fishes;
   shark_head: fishes;
   shark_tail: fishes;


{ this is the array used to identify what is currently at a place in wator }

var
   pond: array [xcoord,ycoord] of species;


{ this array type is used to identify neighbors of a given fish or shark }

type
   neighbor = record
      x:     integer;
      y:     integer;
      kind:  species;
   end;

   neighborhood = array[1..8] of neighbor;


{ these variables are used to save window states when switching windows }

var
   window_pond_x:    integer;
   window_pond_y:    integer;
   window_debug_x:   integer;
   window_debug_y:   integer;
   last_window:      (debug_window,pond_window);


{ main program "local" variables }

var
   counts: array[fish..shark] of integer;
   generation: integer;
   neighbors: array[1..4] of neighbor;


{ utility function to implement universe wrapping }

function wrap(c,l: integer): integer;

   begin
   c := c mod l;
   if c < 0 then
      c := c + l;
   wrap := c;
   end;


{ procedure to wait for the user to press return }

procedure wait_user;

   begin
   writeln('Press RETURN to continue.');
   readln;
   end;


{ procedure to set window to pond area }

procedure set_pond_window;

   begin
   if last_window = debug_window then
      begin;
      window_debug_x := wherex;
      window_debug_y := wherey;
      window(1,1,80,_ysize);
      last_window := pond_window;
      gotoxy(window_pond_x,window_pond_y);
      end;
   end;


{ procedure to set window to text area }

procedure set_debug_window;

   begin
   if last_window = pond_window then
      begin
      window_pond_x := wherex;
      window_pond_y := wherey;
      end;
   window(1,_ysize+2,59,25);
   last_window := debug_window;
   gotoxy(window_debug_x,window_debug_y);
   end;


{ procedure to write an error message to the debugging window }

procedure errmsg(s: anystring);

   begin
   set_debug_window;
   writeln(s);
   wait_user;
   end;


{ procedure to display a fish (or water) at a given location }

procedure dis_fish(x: xcoord; y:ycoord; t:species);

   begin
   if (not x in [0.._maxx]) or (not y in [0.._maxy]) then
      errmsg('dis_fish: illegal coordinates.');
   set_pond_window;
   gotoxy(x+1,y+1);
   if t = fish then
      begin
      textcolor(lightgray);
      write('*');
      textcolor(white);
      end
   else if t = shark then
      begin
      textcolor(red);
      write('@');
      textcolor(white);
      end
   else
      write(' ');
   pond[x,y] := t;
   end;


{ procedure to add a new fish (or shark) to the pond }

procedure add_fish(p: link; p_kind: species; p_x: xcoord; p_y: ycoord);

   var t: link;

   begin
   if p^.next = nil then
      errmsg('add_fish: next pointer is nil.')
   else if not (p_kind in [fish,shark]) then
      errmsg('add_fish: illegal species.')
   else
      begin
      new(t);
      counts[p_kind] := counts[p_kind] + 1;
      with t^ do
         begin
         next := p^.next;
         prev := p;
         kind := p_kind;
         age  := 0;
         x    := p_x;
         y    := p_y;
         ate  := 0;
         dis_fish(p_x,p_y,p_kind);
         end;
      p^.next^.prev := t;
      p^.next := t;
      end;
   end;


{ procedure to display an entry on a fish list, for debugging }

procedure prt_fish(p: link);

   begin
   set_debug_window;
   if p = addr(fish_head) then
      writeln('*** head of fish list')
   else if p = addr(fish_tail) then
      writeln('*** tail of fish list')
   else if p = addr(shark_head) then
      writeln('*** head of shark list')
   else if p = addr(shark_tail) then
      writeln('*** tail of shark list')
   else
      with p^ do
         begin
         if kind = fish then
            write('FISH  ')
         else
            write('SHARK ');
         write('age: ',age,', at x=',x,' y=',y);
         if kind = fish then
            writeln
         else
            writeln(' ate ',ate,' chronons ago');
         if not ((x in [0.._maxx]) and (y in [0.._maxy])) then
            writeln('*** illegal coordinates.');
         end;
   end;


{ procedure to display an entire list of fishes }

procedure prt_list(p: link);

   begin
   while p <> nil do
      begin
      prt_fish(p);
      p := p^.next;
      end;
   end;


{ procedure to delete an entry from a fish list }

procedure del_fish(p: link);

   begin
   with p^ do
      begin
      if next = nil then
         errmsg('del_fish: next is nil.')
      else if prev = nil then
         errmsg('del_fish: prev is nil.')
      else if not (p^.kind in [fish,shark]) then
         errmsg('del_fish: deleting bad kind.')
      else
         begin
         counts[p^.kind] := counts[p^.kind] - 1;
         prev^.next := next;
         next^.prev := prev;
         dis_fish(x,y,empty);
         dispose(p);
         end;
      end;
   end;


{ procedure to display wator world on screen }

procedure dis_world;

   var
      tx:   xcoord;
      ty:   ycoord;

   begin
   set_pond_window;
   clrscr;
   for ty := 0 to _maxy do
      for tx := 0 to _maxx do
         if pond[tx,ty] <> empty then
            begin
            gotoxy(tx+1,ty+1);
            if pond[tx,ty] = fish then
               write('*')
            else
               begin
               textcolor(blink+white);
               write('@');
               textcolor(white);
               end;
            end;
   set_debug_window;
   end;


{ procedure to check the pond around a given fish/shark }

procedure check_pond(p_x: xcoord; p_y:ycoord; t: species;
                     var n: integer; var a: neighborhood);
   var
      tx: xcoord;
      ty: ycoord;
      i:  integer;

   begin
   n := 0;
   for i := 1 to 4 do
      begin
      tx := wrap(p_x+neighbors[i].x,_xsize);
      ty := wrap(p_y+neighbors[i].y,_ysize);
      if pond[tx,ty] = t then
         begin
         n := n+1;
         with a[n] do
            begin
            x := tx;
            y := ty;
            kind := pond[tx,ty];
            end;
         end;
      end;
   end;


{ fish swim process }

procedure fish_swim;

   var
      f_link:  link;
      f_n:     integer;
      f_nghbr: neighborhood;
      old_x:   xcoord;
      old_y:   ycoord;
      r:       integer;

   begin
   f_link := fish_head.next;
   while f_link <> addr(fish_tail) do
      with f_link^ do
         begin
         check_pond(x,y,empty,f_n,f_nghbr);
         if f_n > 0 then
            begin
            old_x := x;
            old_y := y;
            r := random(f_n)+1;
            dis_fish(x,y,empty);
            x := f_nghbr[r].x;
            y := f_nghbr[r].y;
            dis_fish(x,y,fish);
            if age >= _fbreed then
               begin
               add_fish(addr(fish_head),fish,old_x,old_y);
               age := 0;
               end
            else
               age := age + 1;
            end
         else
            age := age + 1;
         f_link := next;
         end;
   end;


{ subroutine where a fish turns into a shark nummy }

procedure eat_fish(p_x: xcoord; p_y:ycoord);

   var
      f_link: link;
      eaten:  boolean;

   begin
   eaten := false;
   f_link := fish_head.next;
   while (f_link <> addr(fish_tail)) and (not eaten) do
      with f_link^ do
         if (x = p_x) and (y = p_y) then
            begin
            del_fish(f_link);
            f_link := nil;
            eaten := true;
            end
         else
            f_link := next;
   if not eaten then
      begin
      set_debug_window;
      writeln('unable to eat imaginary fish at ',p_x,':',p_y);
      wait_user;
      end;
   end;


{ shark hunt and breeding procedure }

procedure shark_move;

   label
      next_shark;

   var
      s_link:  link;
      s_n:     integer;
      s_nghbr: neighborhood;
      old_x:   xcoord;
      old_y:   ycoord;
      r:       integer;

   begin
   s_link := shark_head.next;
   while s_link <> addr(shark_tail) do
      with s_link^ do
         begin
         { feeding section }
         check_pond(x,y,fish,s_n,s_nghbr);
         if s_n > 0 then
            begin
            old_x := x;
            old_y := y;
            r := random(s_n)+1;
            dis_fish(x,y,empty);
            x := s_nghbr[r].x;
            y := s_nghbr[r].y;
            eat_fish(x,y);
            dis_fish(x,y,shark);
            ate := 0;
            if age >= _sbreed then
               begin
               add_fish(addr(shark_head),shark,old_x,old_y);
               age := 0;
               end
            else
               age := age + 1;
            s_link := next;
            goto next_shark;
            end;
         { starvation section }
         ate := ate + 1;
         if ate > _starve then
            begin
            set_debug_window;
            writeln('shark at ',x,':',y,' starved...');
            s_link := next;
            del_fish(s_link^.prev);
            goto next_shark;
            end;
         { move to unoccupied section }
         check_pond(x,y,empty,s_n,s_nghbr);
         if s_n > 0 then
            begin
            old_x := x;
            old_y := y;
            r := random(s_n)+1;
            dis_fish(x,y,empty);
            x := s_nghbr[r].x;
            y := s_nghbr[r].y;
            dis_fish(x,y,shark);
            if age >= _sbreed then
               begin
               add_fish(addr(shark_head),shark,old_x,old_y);
               age := 0;
               end
            else
               age := age + 1;
            s_link := next;
            goto next_shark;
            end;
         { if we get here, the shark just gets older }
         age := age + 1;
         s_link := next;
         goto next_shark;

next_shark:
          end;
    end;


{ initialization procedure }

procedure init;

   var i: integer;
       tx: xcoord;
       ty: ycoord;
       tt: boolean;

   begin
   textmode(bw80);
   textbackground(blue);
   window_pond_x := 1;
   window_pond_y := 1;
   window_debug_x := 1;
   window_debug_y := 1;
   last_window := pond_window;
   set_debug_window;
   neighbors[1].x := 0;
   neighbors[1].y := -1;
   neighbors[2].x := -1;
   neighbors[2].y := 0;
   neighbors[3].x := 1;
   neighbors[3].y := 0;
   neighbors[4].x := 0;
   neighbors[4].y := 1;
   fish_head.next := addr(fish_tail);
   fish_head.prev := nil;
   fish_tail.next := nil;
   fish_tail.prev := addr(fish_head);
   shark_head.next := addr(shark_tail);
   shark_head.prev := nil;
   shark_tail.next := nil;
   shark_tail.prev := addr(shark_head);
   counts[fish] := 0;
   counts[shark] := 0;
   generation := 1;
   for tx := 0 to _maxx do
      for ty := 0 to _maxy do
         pond[tx,ty] := empty;
   for i := 1 to _fishes do
      begin
      tt := true;
      while tt do
         begin
         tx := random(_xsize);
         ty := random(_ysize);
         if pond[tx,ty] = empty then
            begin
            add_fish(addr(fish_head),fish,tx,ty);
            fish_head.next^.age := random(_fbreed);
            tt := false;
            end;
         end;
      end;
   for i := 1 to _sharks do
      begin
      tt := true;
      while tt do
         begin
         tx := random(_xsize);
         ty := random(_ysize);
         if pond[tx,ty] = empty then
            begin
            add_fish(addr(shark_head),shark,tx,ty);
            with shark_head.next^ do
               begin
               age := random(_sbreed);
               ate := random(_starve);
               end;
            tt := false;
            end;
         end;
      end;
   end;

begin
   init;
   while (fish_head.next <> addr(fish_tail)) and
         (shark_head.next <> addr(shark_tail)) do
      begin
      set_debug_window;
      window_debug_x := wherex;
      window_debug_y := wherey;
      window(60,_ysize+2,80,25);
      gotoxy(1,1);
      clrscr;
      writeln('fish   = ',counts[fish]);
      writeln('sharks = ',counts[shark]);
      writeln('avail  = ',maxavail);
      write  ('gen #  = ',generation);
      set_debug_window;
      fish_swim;
      shark_move;
      generation := generation + 1;
      end;
end.