Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/LIFE4.ZIP/LIFE4.PAS

Pascal/Delphi Source File | 1985-12-28 | 17.0 KB | 551 lines

program life (input, output, config);
   { Simulation of Conway's game of Life on a bounded grid
   { Version 3.
   { This version employs
   {    direct cursor addressing, and
   {    doubly linked lists, with header cells.
   { It uses a data file called config.dat which contains the coordinates
   { of the starting life configuration.  A sample file would be
   10 10
   10 11
   10 12

   }
const
        T_DELAY = 5;                 { delay constant }
        SUB     = 26;                { ASCII CODE, clears screen    }
        RS      = 30;                { ASCII CODE, home up cursor   }
        ESC     = 27;                { ASCII CODE, escape character }
        EQUAL   = 61;                { ASCII CODE, equals character }

        MAXROW  = 24;
        MAXCOL  = 79;
type
        row      = 1..MAXROW;
        col      = 1..MAXCOL;
        status   = (dead, alive);
        grid     = array[row,col] of status;
        intarray = array[row,col] of integer;

        coord  = record         { Typical element specified as x,y coordinates }
                 x : row;
                 y : col;
                 end;
        list    = ^element;
        ptr     = ^element;
        element = record                        { Typical list element }
                  inlink  : ptr;
                  entry   : coord;
                  outlink : ptr;
                 end;

var
        config: text;         { file for reading initial configuration }

{ - - - - - - - - - - - - END of GLOBAL DEFINITIONS - - - - - - - - - - - - }

procedure freecell (cell : ptr);
begin
mark (cell);
release (cell);
end; {freecell}

procedure stop_with_message ( message : integer );

begin
  case message of
  1  : write ('Must have a positive number of generations ');
  2  : write ('Illegal input');
  3  : write ('Error in birtheffects');
  end; {case }
  halt;

end; { stop with message }

procedure open_file;
begin
assign (config, 'config.dat');
reset  (config);
end; { open_file }

{ - - - - - - - - - - - - - END of Machine Dependent Code - - - - - - - - - }
procedure clearscreen;
    { clear entire screen }
begin
write(chr(SUB));
end;

procedure home;
   { Move the cursor to the "home" position (1,1) }
begin
write(chr(RS));
end;

procedure gotoxy ( x,y : integer );
   { this will put the cursor at the specified screen position with
   { 1,1 at the top left and 24,80 at the lower right. for the ADM 5
   }
   var  rowchar, colchar : char;
begin
rowchar := chr ( x + 31 );
colchar := chr ( y + 31 );
write (chr(ESC), chr(EQUAL), rowchar, colchar);
end;

{ - - - - - - - - - - END of DIRECT SCREEN CONTROL - - - - - - - - - - - }

procedure add (L:ptr; point : coord);
  { Add the specified element 'point' to the list 'L'
  { NOTE: L is known to have a header cell.
  }
  var
    cell,
    temp   : ptr;

begin { add }
new (cell);
if L^.outlink <> nil
  then begin
       temp := L^.outlink;
       temp^.inlink := cell;
       end
  else temp := nil;

L^.outlink := cell;
cell^.inlink := L;
cell^.outlink := temp;
cell^.entry.x := point.x;
cell^.entry.y := point.y;
end; { add }

procedure delete (var element : ptr);
  { delete the indicated "element" from any list it is in.
  { "element" is left pointing at the "next" element in the list that replaced
  { it, if any.
  }
  var
    temp_front,   { points to next cell }
    temp_back     { points to previous cell }
                : ptr;

begin { delete }
if element^.outlink <> nil
  then begin
       temp_front := element^.outlink;
       temp_front^.inlink := element^.inlink;
       temp_back := element^.inlink;
       temp_back^.outlink := temp_front;
       freecell (element);
       element := temp_front;
       end { then }
  else begin
       temp_back := element^.inlink;
       temp_back^.outlink := nil;
       freecell (element);
       element := nil;
       end; { else }

end; { delete }

function first (list : ptr) : ptr;
  { Returns a pointer to the first element in a list. }
begin
if list <> nil
   then first := list^.outlink
   else first := nil;
end;

function next (element : ptr) : ptr;
  { Given a pointer to an "element" in a list, this function returns
  { a pointer to the next element.
  }
begin
next := element^.outlink;
end;

procedure emptylist (var x:ptr);
  { Make "x" an empty list with zero elements
  { consisting of a single "header" cell.
  }

begin { emptylist }
new (x);
x^.outlink := nil;
x^.inlink  := nil;

end; { emptylist }

procedure copylist (var x,y : ptr);
  { Simply make "y" a duplicate of "x"
  { That is x -> y, except that first we must return any storage that
  { may have been associated with y.
  }
  var  cell, oldcell : ptr;
begin
cell := y;
while cell <> nil do
        begin                   { Dispose of all cells formerly in the list y }
        oldcell := cell;
        cell := next(cell);
        freecell (oldcell);
        end;
y := x;
end;

{ - - - - - - - - - - END of low-level LIST routines - - - - - - - - - - }

function xmin (x : row) : row;
begin
if x = 1
   then xmin := 1
   else xmin := x-1;
end;

function xmax (x : row) : row;
begin
if x = MAXROW
   then xmax := MAXROW
   else xmax := x+1;
end;

function ymin (y : col) : col;
begin
if y = 1
   then ymin := 1
   else ymin := y-1;
end;

function ymax (y : col) : col;
begin
if y = MAXCOL
   then ymax := MAXCOL
   else ymax := y+1;
end;

function neighborcount(var cellmap: grid; i: row; j: col): integer;
  { This procedure counts the number of alive neighbors of
  { cellmap[i,j] and returns this number as its function value.
  }
var
   x,
   xlow, xhigh: row;            { limits for row loop }
   y,
   ylow, yhigh: col;            { limits for column loop }
   count: integer;
begin                           { Handle boundary elements differently }
xlow  := xmin(i);
xhigh := xmax(i);
ylow  := ymin(j);
yhigh := ymax(j);

count := 0;
for x := xlow to xhigh do
     for y := ylow to yhigh do
         if (cellmap[x,y] = alive)
            then count := count + 1;
if (cellmap[i,j] = alive)
   then count := count - 1;
neighborcount := count;
end;

procedure initialize (var universe:grid; var numgenerations:integer;
                        var births, deaths:ptr;
                        var no_neighbors:intarray);
  { Create an initial universe for the game of LIFE, in which
  { all cells are "dead", except for those specified by the user
  { (in the file "config").
  { Then examine this initial configuration and determine which
  { cells should be "born" and should "die" in the next generation.
  { These are put in the lists "births" and "deaths" respectively.
  {
  { Note that "initialize" does two things, it initializes the
  { actual universe, and it initializes the first "increment".
  }
var
   cell : coord;
   x, y   : integer;                     { coordinates of cell }
   lineno : integer;

begin
writeln ('This program is a simulation of the game of Life');
write   ('Enter number of generations to run - ');
readln (numgenerations);
if (numgenerations < 0)
   then stop_with_message (1);
for x := 1 to MAXROW do
     for y := 1 to MAXCOL do
         begin
         universe[x,y] := dead;
         no_neighbors[x,y] := 0;
         end;

{  read file that contains initial configuration }

emptylist (births);
emptylist (deaths);
clearscreen;
home;
write ('The map at generation    0  ');
lineno := 0;

open_file;
while (not eof(config)) do
      begin
      lineno := lineno +1;
      readln (config, x, y);
      if ((x >= 1) and (x <= MAXROW) and (y >= 1) and (y <= MAXCOL))
         then begin
              universe[x,y] := alive;
              gotoxy (x,y);
              write ('*');
              end
         else begin
              writeln ('Input values are not within range');
              writeln ('At line ', lineno:3, ' values are ', x:2, ',', y:2);
              stop_with_message(2);
              end;
      end;
for x := 1 to MAXROW do
      for y := 1 to MAXCOL do
            begin
            no_neighbors[x,y] := neighborcount (universe, x, y);
            if (universe[x,y] = alive) and ((no_neighbors[x,y] < 2)
                                             or (no_neighbors[x,y] > 3))
               then begin
                    cell.x := x;
                    cell.y := y;
                    add (deaths, cell);
                    end;
            if (universe[x,y] = dead) and (no_neighbors[x,y] = 3)
               then begin
                    cell.x := x;
                    cell.y := y;
                    add (births, cell);
                    end;
            end;
end;

procedure writemap (var universe: grid; generation: integer;
                    var births, deaths: ptr);
  { Display the current generation of a LIFE sequence by putting a * where
  { a cell is borne and a blank where a cell dies.  This involves marching
  { down both the birth and death lists and getting the coordinates and
  { printing the character.  }
  const
    full = '*';
    empty = ' ';
  var
    cell : ptr;
    i,
    j    : integer;

begin
home;
write ('The map at generation', generation:5 );
cell := first (births);
while cell <> nil do
  begin { while }
  with cell^.entry do
    gotoxy (x,y);
  write (full);
  cell := next (cell);
  end; { while }

cell := first (deaths);
while cell <> nil do
  begin { while }
  with cell^.entry do
    gotoxy (x,y);
  write (empty);
  cell := next (cell);
  end; { while }

gotoxy (1,1);
for i := 1 to t_delay do
  for j := 1 to t_delay do
     gotoxy (1,1);
end; { writemap }

procedure thisgeneration (var map:grid; var births,deaths:ptr;
                          var no_neighbors:intarray);
  { Given the "map" of the universe after the previous generation,
  { and lists of the births and deaths that should occur, this
  { procedure updates the map to create the "new generation"
  }

        procedure givebirth (var map:grid; var births:ptr;
                             var no_neighbors:intarray);
          { This is the procedure 'vivify' in Kruse, but now
          { it 'merely' works through "births" eliminating duplicates!
          }
        var  x, y : integer;
             baby : ptr;
        begin
        baby := first(births);          { Get the first baby on births list }
        while baby <> nil do
                begin
                x := baby^.entry.x;
                y := baby^.entry.y;
                if (map[x,y] = dead) and (no_neighbors[x,y] = 3)
                   then begin
                        map[x,y] := alive;
                        baby := next(baby);
                        end
                   else begin           { Spurious "birth entry" delete it }
                        delete (baby);
                        end;
                end;
        end;    { givebirth }

        procedure kill (var map:grid; var deaths:ptr;
                        var no_neighbors:intarray);
          { This is the procedure 'kill' in Kruse }
        var  x, y : integer;
             corpse : ptr;
        begin
        corpse := first(deaths);        { Get the first corpse on deaths list }
        while corpse <> nil do
                begin
                x := corpse^.entry.x;
                y := corpse^.entry.y;
                if (map[x,y] = alive) and ((no_neighbors[x,y] <> 3)
                                      and  (no_neighbors[x,y] <> 2))
                   then begin
                        map[x,y] := dead;
                        corpse := next(corpse);
                        end
                   else begin           { Spurious "death entry" delete it }
                        delete (corpse);
                        end;
                end;
        end;    { kill }

begin
givebirth (map, births, no_neighbors);    { Reflect births and deaths     }
kill (map, deaths, no_neighbors);         { from last generation          }
end;

procedure nextgeneration (var map : grid; var births,deaths:ptr;
                          var no_neighbors:intarray);
  { Given a "map" of the universe and two list of the "births" and
  { "deaths" that were recorded in the last generation, this procedure
  { first creates lists of the births and deaths that should occur in
  { the next_generation, and then updates "map" to reflect them.
  }
   var
        newbirths, newdeaths : ptr;

        procedure birtheffects (var universe:grid; births:ptr;
                                var nextbirths, nextdeaths:ptr;
                                var no_neighbors:intarray);
           { This is the procedure "addneighbors" in Kruse }
        var   cell : ptr;
              i, xlow, xhigh : row;
              j, ylow, yhigh : col;
              nbr : coord;
        begin
        cell := first(births);
        while cell <> nil do
                with cell^.entry do
                begin           { Determine the limits of the neighborhood }
                xlow  := xmin(x);
                xhigh := xmax(x);
                ylow  := ymin(y);
                yhigh := ymax(y);
                for i := xlow to xhigh do
                        for j := ylow to yhigh do
                                if (i <> x) or (j <> y)
                                   then begin
                                        nbr.x := i;
                                        nbr.y := j;
                                        no_neighbors[i,j] := no_neighbors[i,j]+1;
                                        case no_neighbors[i,j] of
                                          0: stop_with_message(3);
                                          1,2: ;
                                          3: if map[i,j] = dead
                                                then add (nextbirths, nbr);
                                          4: if map[i,j] = alive
                                                then add (nextdeaths, nbr);
                                          5,6,7,8: ;
                                          end;
                                        end;
                cell := next(cell);
                end;
        end;    { of birtheffects }

        procedure deatheffects (var universe:grid; deaths:ptr;
                                var nextbirths, nextdeaths:ptr;
                                var no_neighbors:intarray);
           { This is the procedure "subtractneighbors" in Kruse }
        var   cell : ptr;
              i, xlow, xhigh : row;
              j, ylow, yhigh : col;
              nbr : coord;
        begin
        cell := first(deaths);
        while cell <> nil do
                with cell^.entry do
                begin           { Determine the limits of the neighborhood }
                xlow  := xmin(x);
                xhigh := xmax(x);
                ylow  := ymin(y);
                yhigh := ymax(y);
                for i := xlow to xhigh do
                        for j := ylow to yhigh do
                                if (i <> x) or (j <> y)
                                   then begin
                                        nbr.x := i;
                                        nbr.y := j;
                                        no_neighbors[i,j] := no_neighbors[i,j]-1;
                                        case no_neighbors[i,j] of
                                          0,1: if map[i,j] = alive
                                                  then add (nextdeaths, nbr);
                                          2: ;
                                          3: if map[i,j] = dead
                                                then add (nextbirths, nbr);
                                          4,5,6,7,8: ;
                                          end;
                                        end;
                cell := next(cell);
                end;
        end;    { of deatheffects }

begin   { - - - - - - - BODY OF NEXTGENERATION - - - - - - - - }
emptylist (newbirths);
emptylist (newdeaths);
birtheffects (map, births, newbirths, newdeaths, no_neighbors);
deatheffects (map, deaths, newbirths, newdeaths, no_neighbors);
copylist (newbirths, births);
copylist (newdeaths, deaths);
end;

procedure main;
  {  This "main" procedure, drives the entire simulation of
  {  the game of LIFE
  }
var
      universe : grid;
      no_neighbors : intarray;
      generation, lastgeneration: integer;
      births, deaths : ptr;
      next : char;
begin
clearscreen;
home;
emptylist (births);
emptylist (deaths);
initialize (universe, lastgeneration, births, deaths, no_neighbors);
generation := 0;
for generation := 1 to lastgeneration do
     begin
     gotoxy (2,1);
     thisgeneration (universe, births, deaths, no_neighbors);
     writemap (universe, generation, births, deaths);
     nextgeneration (universe, births, deaths, no_neighbors);
     end;
end;

begin           { Dummy "program" that invokes "main" }
main;
end.