 PROGRAM life (input,output);

CONST
maxrows     = 15;
maxcols     = 15;
offset      = 5;
cross       = '+';
line        = '-';
bar         = '|';
occupied    = '*';
empty       = '.';

TYPE
universe    = ARRAY [0..16,0..16] OF boolean;

VAR
colony      : universe;
oldcolony   : universe;
step        : integer;
nosteps     : integer;

FUNCTION escape (code:integer):char;

BEGIN
   CASE code OF
      1: write (CHR(27),'~K');   { Erase to EOLN }
      2: write (CHR(27),'~k');   { Erase to end of screen }
      3: write (CHR(27),'~E');   { Enable transparent mode }
      4: write (CHR(27),'~D');   { Disable teansparent mode }
      5: write (CHR(1));         { Cursor home }
      6: write (CHR(6));         { Cursor forward }
      7: write (CHR(7));         { Bell }
      8: write (CHR(11));        { Cursor up }
      9: write (CHR(12));        { Clear screen }
      10:write (CHR(21));        { Cursor back }
   END;
   escape := CHR(0);
END; {ESCAPE}

FUNCTION cls:char;

BEGIN
                       cls := escape(9);
END; {CLS}

FUNCTION home:char;

BEGIN
   home := escape(5);
END; {HOME}

FUNCTION bell:char;

BEGIN
   bell := CHR(7);
END; {BELL}

FUNCTION at (row,collumn:integer):char;

BEGIN
   write (CHR(27),'Y',CHR(row+32),CHR(collumn+32));
   at := CHR(0);
END; {AT}

FUNCTION keyboard:char;

VAR
data        : char;

BEGIN
   data := CHR(0);
   REPEAT
      read(data);
   UNTIL data <> CHR(0);
   keyboard := data;
END; {KEYBOARD}

FUNCTION yes (prompt:string):boolean;

VAR
choice      : char;

BEGIN
   write (at(22,0),escape(2));
   REPEAT
      BEGIN
         write (at(22,0),prompt,' (Y/N) ',escape(1));
         choice := keyboard;
      END;
   UNTIL (choice='Y')OR(choice='N')OR(choice='y')OR(choice='n');
   CASE choice OF
      'Y','y' : yes := TRUE;
      'N','n' : yes := FALSE;
   END;
   write (at(22,0),escape(1));
END; {YES}

PROCEDURE wait;

BEGIN
   write (at(22,0),escape(1));
   write (at(22,0),'Please press the <RETURN> key to continue');
   REPEAT
               UNTIL keyboard = ' ';
   write (at(22,0),escape(1));
END; {WAIT}

PROCEDURE error (message:string);

VAR
count       : integer;

BEGIN
   write (bell);
   write (at(22,0),escape(2));
   FOR count := 1 to 25 DO
      write (at(22,0),'*** ERROR *** - ',message);
END;

PROCEDURE draw;

VAR
row         : integer;
col         : integer;

BEGIN
   write (at(4,offset),cross);
   FOR col := 1 TO maxcols DO
      write (line);
   write (cross);
   FOR row := 1 TO maxrows DO
      BEGIN
         write (at(4+row,offset),bar);
         FOR col := 1 TO maxcols DO
            BEGIN
               IF colony[row,col] THEN
                  write (occupied)
               ELSE
                  write (empty);
            END;
         write (bar);
      END;
   write (at(5+maxrows,offset),cross);
   FOR col := 1 TO maxcols DO
      write (line);
   write (cross);
END; {DRAW}

PROCEDURE setup;

VAR
row         : integer;
col         : integer;
letter      : char;

BEGIN
   write (at(1,0),escape(2));
   write (at(2,0),'Set up a new colony');
   FOR row := 0 TO maxrows+1 DO
                                    FOR col := 0 TO maxcols+1 DO
         colony[row,col] := FALSE;
   draw;
   FOR row := 1 TO maxrows DO
      FOR col := 1 TO maxcols DO
         BEGIN
            REPEAT
               BEGIN
                  write (at(4+row,offset+col));
                  letter := keyboard;
                  IF not((letter = empty)OR(letter = occupied)) THEN
                     BEGIN
                        write (at(4+row,offset+col),empty);
                        write (bell);
                     END;
               END;
            UNTIL (letter = empty)OR(letter = occupied);
            CASE letter OF
               empty: colony[row,col] := FALSE;
               occupied: colony[row,col] := TRUE;
            END;
         END;
END; {SETUP}

PROCEDURE next;

VAR
row         : integer;
col         : integer;
joining     : integer;

PROCEDURE update;

VAR
row         : integer;
col         : integer;

PROCEDURE adjoint;

VAR
rowinc      : integer;
colinc      : integer;

BEGIN
   joining := 0;
   FOR rowinc := row-1 TO row+1 DO
      FOR colinc := col-1 TO col+1 DO
         BEGIN
            IF (oldcolony[rowinc,colinc]) THEN
               IF not((rowinc = row)AND(colinc = col)) THEN
                  joining := joining +1;
         END;
END; {ADJOINT}
 
BEGIN
   oldcolony := colony;
   FOR row := 1 TO maxrows DO
      FOR col := 1 TO maxcols DO
         BEGIN
            adjoint;
            CASE joining OF
               0,1:       colony[row,col] := FALSE;
               2:         colony[row,col] := oldcolony[row,col];
               3:         colony[row,col] := TRUE;
               4,5,6,7,8: colony[row,col] := FALSE;
            END;
         END;
END; {UPDATE}

BEGIN
   write (at(2,0),'Symulation in progress',escape(1));
   update;
   step := step +1;
   write (at(20,40),'Generation number : ',step:3,escape(1));
END; {NEXT}

BEGIN {LIFE}
   write (cls,'GAME OF LIFE');
   REPEAT
      BEGIN
         REPEAT
            setup;
         UNTIL yes ('OK to do sumulation');
         step := 0;
         write (at(20,40),'Number of generations : ',escape(1));
         readln (nosteps);
         REPEAT
            BEGIN
               next;
               draw;
            END
         UNTIL (step = nosteps)OR(colony = oldcolony);
         IF step <> nosteps THEN
            write (at(20,40),'Stable after ',step:3,' generations ');
      END;
   UNTIL not yes ('Examine another colony');
   write (cls);
END. {LIFE}
                                                          