home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / MBUG / MBUG130.ARC / LIFE.PAS < prev    next >
Pascal/Delphi Source File  |  1979-12-31  |  13KB  |  372 lines
  1. program life;
  2.  
  3. { LIFE.PAS - Game of life
  4.   Written by Keith Wood         03/09/89 }
  5.  
  6. type   area = array [0..1049] of byte;
  7.  
  8. const  init_pcg   : array [1..2,0..15] of byte =
  9.                   { bee = '(' and ')' }
  10.                   ((60,67,68,36,28,99,132,137,114,28,7,0,0,0,0,0),
  11.                   (240,8,8,16,32,240,152,44,76,184,224,0,0,0,0,0));
  12.  
  13. var    board : array [0..24,0..41] of byte;
  14.        board2 : area absolute board;
  15.        x_curs, y_curs : byte;
  16.        num_gen : integer;
  17.        finished, stepping : boolean;
  18.        load_pcg : byte absolute $FA80;
  19.  
  20. {$I JOYSTICK.INC}
  21.  
  22. procedure draw_board;
  23. type   screen = array [1..23,1..80] of byte;
  24. const  full1  = $A8;
  25.        full2  = $A9;
  26.        empty  = $20;
  27. var    x, y : byte;
  28.        scr_ram : screen absolute $F000;
  29.        scr_set : screen;
  30. begin
  31.   for y := 1 to 23 do
  32.   begin
  33.     board[y,0] := 0; board[y,41] := 0;
  34.     for x := 1 to 40 do
  35.       if board[y,x]=0 then
  36.       begin
  37.         scr_set[y,2*x-1] := empty; scr_set[y,2*x] := empty
  38.       end
  39.       else
  40.       begin
  41.         scr_set[y,2*x-1] := full1; scr_set[y,2*x] := full2
  42.       end
  43.   end;
  44.   scr_ram := scr_set;
  45.   lowvideo; gotoxy(24,24); write(num_gen:5); normvideo;
  46.   gotoxy(1,25)
  47. end;
  48.  
  49. procedure next_generation;
  50. var    n : byte;
  51.        m, ul, up, ur, lf, rt, dl, dn, dr : integer;
  52.        next : area;
  53. begin
  54.   next := board2;
  55.   ul := 0; up := 1; ur := 2; lf := 42; rt := 44; dl := 84; dn := 85; dr := 86;
  56.   for m := 43 to 1006 do
  57.   begin
  58.     n := next[ul]+next[up]+next[ur]+next[lf]+next[rt]+next[dl]+next[dn]+next[dr];
  59.     case n of
  60.     0,1,4..8 : board2[m] := 0;  { loneliness or overcrowding }
  61.     3        : board2[m] := 1   { birth }
  62.     end;
  63.     ul := ul+1; up := up+1; ur := ur+1; lf := lf+1;
  64.     rt := rt+1; dl := dl+1; dn := dn+1; dr := dr+1
  65.   end;
  66.   num_gen := num_gen+1;
  67.   draw_board
  68. end;
  69.  
  70. procedure write_options(placing : boolean);
  71. begin
  72.   gotoxy(36,24);
  73.   if placing then
  74.   begin
  75.     write('ASDFEX'); lowvideo; write(' Move '); normvideo; write(' ');
  76.     lowvideo; write(' Select '); normvideo; write('0');
  77.     lowvideo; write(' Clear '); normvideo; write('P');
  78.     lowvideo; write('attern '); normvideo; write('B');
  79.     lowvideo; write('egin  '); normvideo
  80.   end
  81.   else
  82.   begin
  83.     lowvideo; write('            '); normvideo; write('S');
  84.     lowvideo; write('tep    '); normvideo; write('R');
  85.     lowvideo; write('un    '); normvideo; write('P');
  86.     lowvideo; write('lace    '); normvideo; write('Q');
  87.     lowvideo; write('uit    '); normvideo
  88.   end;
  89.   gotoxy(1,25)
  90. end;
  91.  
  92. procedure clear_board;
  93. begin
  94.   fillchar(board,1050,0);
  95.   num_gen := 1;
  96.   draw_board
  97. end;
  98.  
  99. procedure patterns;
  100. const  glider      : array [1..3,1..3] of byte =
  101.                    ((0,1,0),(0,0,1),(1,1,1));
  102.        blinker     : array [1..3,1..9] of byte =
  103.                    ((1,0,0,0,0,0,0,0,1),(1,0,0,1,1,1,0,0,1),(1,0,0,0,0,0,0,0,1));
  104.        rocker      : array [1..4,1..4] of byte =
  105.                    ((0,1,0,0),(0,0,1,1),(1,1,0,0),(0,0,1,0));
  106.        conveyor    : array [1..9,1..9] of byte =
  107.                    ((1,1,0,0,0,0,0,0,0),(1,0,1,0,0,0,0,0,0),(0,0,0,0,0,0,0,0,0),
  108.                    (0,0,1,0,1,0,0,0,0),(0,0,0,0,0,0,0,0,0),(0,0,0,0,1,0,1,0,0),
  109.                    (0,0,0,0,0,0,0,0,0),(0,0,0,0,0,0,1,0,1),(0,0,0,0,0,0,0,1,1));
  110.        distributor : array [1..12,1..12] of byte =
  111.                    ((0,0,0,0,0,0,1,1,0,0,0,0),(0,0,0,0,0,0,1,1,0,0,0,0),
  112.                    (0,0,0,0,0,0,0,0,0,0,0,0),(0,0,0,0,1,1,1,1,0,0,0,0),
  113.                    (1,1,0,1,0,0,0,0,1,0,0,0),(1,1,0,1,0,0,0,1,1,0,0,0),
  114.                    (0,0,0,1,0,1,0,0,1,0,1,1),(0,0,0,1,0,0,1,0,1,0,1,1),
  115.                    (0,0,0,0,1,1,1,1,0,0,0,0),(0,0,0,0,0,0,0,0,0,0,0,0),
  116.                    (0,0,0,0,1,1,0,0,0,0,0,0),(0,0,0,0,1,1,0,0,0,0,0,0));
  117.        heart       : array [1..13,1..13] of byte =
  118.                    ((0,0,0,0,1,1,0,1,1,0,0,0,0),(0,0,0,0,1,0,0,0,1,0,0,0,0),
  119.                    (0,0,0,0,0,1,1,1,0,0,0,0,0),(0,0,0,0,0,0,0,0,0,0,0,0,0),
  120.                    (1,1,0,0,0,1,1,1,0,0,0,1,1),(1,0,1,0,1,0,0,0,1,0,1,0,1),
  121.                    (0,0,1,0,1,0,0,0,1,0,1,0,0),(1,0,1,0,1,0,0,0,1,0,1,0,1),
  122.                    (1,1,0,0,0,1,1,1,0,0,0,1,1),(0,0,0,0,0,0,0,0,0,0,0,0,0),
  123.                    (0,0,0,0,0,1,1,1,0,0,0,0,0),(0,0,0,0,1,0,0,0,1,0,0,0,0),
  124.                    (0,0,0,0,1,1,0,1,1,0,0,0,0));
  125.        bounce      : array [1..11,1..14] of byte =
  126.                    ((0,0,0,0,0,1,1,0,0,0,0,0,0,0),(0,0,0,0,0,1,1,0,0,0,0,0,0,0),
  127.                    (0,0,0,0,0,0,0,0,0,0,0,0,0,0),(1,1,0,0,0,1,1,1,1,0,0,0,1,1),
  128.                    (1,0,1,0,1,0,0,0,0,1,0,1,0,1),(0,0,1,0,1,1,0,0,0,1,0,1,0,0),
  129.                    (1,0,1,0,1,0,0,0,0,1,0,1,0,1),(1,1,0,0,0,1,1,1,1,0,0,0,1,1),
  130.                    (0,0,0,0,0,0,0,0,0,0,0,0,0,0),(0,0,0,0,0,0,0,1,1,0,0,0,0,0),
  131.                    (0,0,0,0,0,0,0,1,1,0,0,0,0,0));
  132.        jays        : array [1..6,1..9] of byte =
  133.                    ((0,0,1,1,0,1,1,0,0),(0,0,0,0,0,0,0,0,0),
  134.                    (0,0,0,1,0,1,0,0,0),(0,0,0,1,0,1,0,0,0),
  135.                    (1,1,0,1,0,1,0,1,1),(0,1,1,0,0,0,1,1,0));
  136.        diamond     : array [1..8,1..8] of byte =
  137.                    ((0,0,0,1,1,0,0,0),(0,0,1,0,0,1,0,0),
  138.                    (0,1,0,0,0,0,1,0),(1,0,0,0,0,0,0,1),
  139.                    (1,0,0,0,0,0,0,1),(0,1,0,0,0,0,1,0),
  140.                    (0,0,1,0,0,1,0,0),(0,0,0,1,1,0,0,0));
  141.        cycle1      : array [1..8,1..8] of byte =
  142.                    ((0,0,0,0,1,0,0,0),(1,1,1,1,0,1,0,0),
  143.                    (1,1,1,0,1,0,1,0),(0,0,0,0,0,1,0,1),
  144.                    (0,0,0,0,0,0,1,0),(0,0,0,0,0,1,1,0),
  145.                    (0,0,0,0,0,1,1,0),(0,0,0,0,0,1,1,0));
  146.        cycle2      : array [1..7,1..7] of byte =
  147.                    ((0,0,0,1,1,0,0),(0,1,0,1,0,0,0),(1,0,0,0,0,0,1),
  148.                    (0,1,0,0,0,1,1),(0,0,0,0,0,0,0),
  149.                    (0,0,0,1,0,1,0),(0,0,0,0,1,0,0));
  150.        cycle3      : array [1..13,1..13] of byte =
  151.                    ((0,0,1,1,1,0,0,0,1,1,1,0,0),(0,0,0,0,0,0,0,0,0,0,0,0,0),
  152.                    (1,0,0,0,0,1,0,1,0,0,0,0,1),(1,0,0,0,0,1,0,1,0,0,0,0,1),
  153.                    (1,0,0,0,0,1,0,1,0,0,0,0,1),(0,0,1,1,1,0,0,0,1,1,1,0,0),
  154.                    (0,0,0,0,0,0,0,0,0,0,0,0,0),(0,0,1,1,1,0,0,0,1,1,1,0,0),
  155.                    (1,0,0,0,0,1,0,1,0,0,0,0,1),(1,0,0,0,0,1,0,1,0,0,0,0,1),
  156.                    (1,0,0,0,0,1,0,1,0,0,0,0,1),(0,0,0,0,0,0,0,0,0,0,0,0,0),
  157.                    (0,0,1,1,1,0,0,0,1,1,1,0,0));
  158. var    x, y : byte;
  159.        ch : char;
  160.        scr_ram : byte absolute $F000;
  161. begin
  162.   fillchar(scr_ram,23*80,' ');
  163.   gotoxy(32,2); write('A  Glider');
  164.   gotoxy(32,3); write('B  Blinker');
  165.   gotoxy(32,4); write('C  Rocker');
  166.   gotoxy(32,5); write('D  Conveyor');
  167.   gotoxy(32,6); write('E  Distributor');
  168.   gotoxy(32,7); write('F  Heart');
  169.   gotoxy(32,8); write('G  Bounce');
  170.   gotoxy(32,9); write('H  Jays');
  171.   gotoxy(32,10); write('I  Diamond');
  172.   gotoxy(32,11); write('J  Cycle 1');
  173.   gotoxy(32,12); write('K  Cycle 2');
  174.   gotoxy(32,13); write('L  Cycle 3');
  175.   gotoxy(32,20); write('Select pattern');
  176.   gotoxy(1,25);
  177.   repeat
  178.     read(kbd,ch); ch := upcase(ch)
  179.   until ch in ['A'..'L','Q'];
  180.   if ch<>'Q' then
  181.   begin
  182.     fillchar(board,1050,0);
  183.     case ch of
  184.     'A' : for y := 1 to 3 do for x := 1 to 3 do
  185.             board[y+1,x+1] := glider[y,x];
  186.     'B' : for y := 1 to 3 do for x := 1 to 9 do
  187.             board[y+10,x+15] := blinker[y,x];
  188.     'C' : for y := 1 to 4 do for x := 1 to 4 do
  189.             board[y+10,x+18] := rocker[y,x];
  190.     'D' : for y := 1 to 9 do for x := 1 to 9 do
  191.             board[y+7,x+15] := conveyor[y,x];
  192.     'E' : for y := 1 to 12 do for x := 1 to 12 do
  193.             board[y+5,x+14] := distributor[y,x];
  194.     'F' : for y := 1 to 13 do for x := 1 to 13 do
  195.             board[y+5,x+13] := heart[y,x];
  196.     'G' : for y := 1 to 11 do for x := 1 to 14 do
  197.             board[y+6,x+13] := bounce[y,x];
  198.     'H' : for y := 1 to 6 do for x := 1 to 9 do
  199.             board[y+8,x+15] := jays[y,x];
  200.     'I' : for y := 1 to 8 do for x := 1 to 8 do
  201.             board[y+8,x+16] := diamond[y,x];
  202.     'J' : for y := 1 to 8 do for x := 1 to 8 do
  203.             board[y+8,x+16] := cycle1[y,x];
  204.     'K' : for y := 1 to 7 do for x := 1 to 7 do
  205.             board[y+8,x+16] := cycle2[y,x];
  206.     'L' : for y := 1 to 13 do for x := 1 to 13 do
  207.             board[y+5,x+13] := cycle3[y,x]
  208.     end;
  209.     num_gen := 1
  210.   end;
  211.   draw_board
  212. end;
  213.  
  214. procedure move_up;
  215. begin
  216.   if y_curs>1 then y_curs := y_curs-1
  217. end;
  218.  
  219. procedure move_down;
  220. begin
  221.   if y_curs<23 then y_curs := y_curs+1
  222. end;
  223.  
  224. procedure move_left;
  225. begin
  226.   if x_curs>1 then x_curs := x_curs-1
  227. end;
  228.  
  229. procedure move_right;
  230. begin
  231.   if x_curs<40 then x_curs := x_curs+1
  232. end;
  233.  
  234. procedure move_left_lots;
  235. begin
  236.   if x_curs<5 then x_curs := 1 else x_curs := x_curs-4
  237. end;
  238.  
  239. procedure move_right_lots;
  240. begin
  241.   if x_curs>36 then x_curs := 40 else x_curs := x_curs+4
  242. end;
  243.  
  244. procedure select;
  245. begin
  246.   board[y_curs,x_curs] := 1-board[y_curs,x_curs]; gotoxy(2*x_curs-1,y_curs);
  247.   if board[y_curs,x_curs]=0 then write('  ')
  248.   else begin lowvideo; write('()'); normvideo end;
  249.   gotoxy(1,25)
  250. end;
  251.  
  252. procedure placement;
  253. var    ch : char;
  254.        j : byte;
  255. begin
  256.   write_options(true);
  257.   repeat
  258.     repeat
  259.       gotoxy(2*x_curs-1,y_curs); lowvideo; write('  ');
  260.       normvideo; gotoxy(1,25); delay(30);
  261.       gotoxy(2*x_curs-1,y_curs); write('  '); gotoxy(1,25); delay(30);
  262.       gotoxy(2*x_curs-1,y_curs);
  263.       if board[y_curs,x_curs]=0 then write('  ')
  264.       else begin lowvideo; write('()'); normvideo end;
  265.       gotoxy(1,25); delay(30);
  266.       j := joystick
  267.     until keypressed or (j>0);
  268.     if keypressed then
  269.     begin
  270.       read(kbd,ch); ch := upcase(ch)
  271.     end
  272.     else
  273.     begin
  274.       ch := #$00;
  275.       if (j and $80)>0 then ch := ' '
  276.       else if (j and $08)>0 then ch := 'D'
  277.       else if (j and $04)>0 then ch := 'S'
  278.       else if (j and $02)>0 then ch := 'X'
  279.       else if (j and $01)>0 then ch := 'E'
  280.     end;
  281.     case ch of
  282.     'E',^E : move_up;
  283.     'X',^X : move_down;
  284.     'S',^S : move_left;
  285.     'D',^D : move_right;
  286.     'A'    : move_left_lots;
  287.     'F'    : move_right_lots;
  288.     ' '    : select;
  289.     '0'    : clear_board;
  290.     'P'    : patterns
  291.     end
  292.   until ch = 'B';
  293.   write_options(false)
  294. end;
  295.  
  296. procedure initialise;
  297. var    ch : char;
  298. begin
  299.   clrscr;
  300.   check_joy;
  301.   init_joystick;
  302.   move(init_pcg,load_pcg,32);
  303.   gotoxy(30,2); write('Conway''s Game of Life');
  304.   gotoxy(15,4); write('The board consists of an array of 40 by 23 cells,');
  305.   gotoxy(15,5); write('each of which can be either occupied or empty.');
  306.   gotoxy(15,7); write('New generations are formed by examining each cell :');
  307.   gotoxy(15,9); write('If it is occupied and has less than two neighbours');
  308.   gotoxy(15,10); write('(including diagonals) then it will die from loneliness.');
  309.   gotoxy(15,12); write('It it is occupied and has more then three neighbours');
  310.   gotoxy(15,13); write('then it will die from overcrowding.');
  311.   gotoxy(15,15); write('If it is empty and has exactly three neighbours');
  312.   gotoxy(15,16); write('then it will become occupied (a birth).');
  313.   gotoxy(15,18); write('Several patterns are defined for your use.');
  314.   gotoxy(29,20); write('Press any key to start.');
  315.   repeat until keypressed or (joystick>$80);
  316.   if keypressed then read(kbd,ch)
  317.   else init_joystick;
  318.   clrscr;
  319.   lowvideo;
  320.   gotoxy(2,24); write('  LIFE   Generation :',' ':57);
  321.   normvideo;
  322.   write_options(false);
  323.   clear_board;
  324.   x_curs := 20; y_curs := 12;
  325.   finished := false; stepping := true;
  326.   placement
  327. end;
  328.  
  329. procedure finalise;
  330. var    m : integer;
  331.        pcg_rom : byte absolute $F000;
  332.        pcg_ram : array [1..2048] of byte absolute $F800;
  333. begin
  334.   clrscr;
  335.   port[11] := 1;
  336.   move(pcg_rom,pcg_ram,2048);
  337.   port[11] := 0;
  338.   for m := 1 to 2048 do pcg_ram[m] := not pcg_ram[m]
  339. end;
  340.  
  341. procedure process_actions;
  342. var    ch : char;
  343. begin
  344.   next_generation;
  345.   if stepping then
  346.   begin
  347.     gotoxy(33,24); write('Press key'); gotoxy(1,25);
  348.     repeat until keypressed;
  349.     gotoxy(33,24); lowvideo; write('         ');
  350.     normvideo; gotoxy(1,25)
  351.   end;
  352.   if keypressed then
  353.   begin
  354.     read(kbd,ch); ch := upcase(ch)
  355.   end
  356.   else ch := #$00;
  357.   case ch of
  358.   'S' : stepping := true;
  359.   'R' : stepping := false;
  360.   'P' : placement;
  361.   'Q' : finished := true
  362.   end
  363. end;
  364.  
  365. begin
  366.   initialise;
  367.   repeat
  368.     process_actions
  369.   until finished;
  370.   finalise
  371. end.
  372.