home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload / ShartewareOverload.cdr / games / life_lab.zip / LIFE_LAB.PAS < prev    next >
Pascal/Delphi Source File  |  1989-02-27  |  15KB  |  623 lines
  1. {$N-,R-,E-}
  2. {Kenneth L. Kubos, Ph.D.}
  3. PROGRAM LIFELAB;
  4.  
  5. uses
  6.   Crt, Graph;
  7.  
  8. const
  9.   MaxWidth  = 476;
  10.   MaxLines  = 476;
  11.   Xmin      = 1;
  12.   Ymin      = 1;
  13.   NormColor = 14; {Yellow}
  14.   HeadColor = 11; {LightCyan}
  15.   SubColor  = 10; {LightGreen}
  16.   EntColor  = 12; {LightRed}
  17.   zcolor    = 13; {LightMagenta}
  18.   TriplexFont = 2;
  19.  
  20.  
  21.   { The five predefined line styles supported }
  22.   LineStyles : array[0..4] of string[9] =
  23.   ('SolidLn', 'DottedLn', 'CenterLn', 'DashedLn', 'UserBitLn');
  24.  
  25.   { The two text directions available }
  26.   TextDirect : array[0..1] of string[8] = ('HorizDir', 'VertDir');
  27.  
  28.   { The Horizontal text justifications available }
  29.   HorizJust  : array[0..2] of string[10] = ('LeftText', 'CenterText', 'RightText');
  30.  
  31.   { The vertical text justifications available }
  32.   VertJust   : array[0..2] of string[10] = ('BottomText', 'CenterText', 'TopText');
  33.  
  34.  
  35. type
  36.  
  37.   ScanLine        = array[0..MaxWidth] of byte;   {Set up for Pointer use}
  38.   ScanLinePointer = ^ScanLine;
  39.   scanlinetype    = array[0..MaxLines] of scanlinepointer;
  40.  
  41.   MaxString = String[255];
  42.   CharSet   = set of Char;
  43.   Prompt    = String[80];
  44.   seedtype  = string[8];
  45.  
  46. var
  47.   Screen        : scanlinetype;
  48.   scanfile      : file of ScanLine;
  49.   SeedFile      : Text;
  50.  
  51.   X,Y,I, State, gen, count,
  52.   Xcenter, Ycenter, Xmax, Ymax,
  53.   xLeft, xRight, yTop, yBottom : Integer;
  54.  
  55.   border   : boolean;
  56.   Line     : String[80];
  57.   SeedName : seedtype;
  58.   g, Seedcode, Seed, Isol, StateNumber : Char;
  59.  
  60.  
  61.   GraphDriver : integer;  { The Graphics device driver }
  62.   GraphMode   : integer;  { The Graphics mode value }
  63.   MaxX, MaxY  : word;     { The maximum resolution of the screen }
  64.   ErrorCode   : integer;  { Reports any graphics errors }
  65.   MaxColor    : word;     { The maximum color value available }
  66.  
  67. procedure Initialize;
  68. { Initialize graphics and report any errors that may occur }
  69. var
  70.   InGraphicsMode : boolean; { Flags initialization of graphics mode }
  71.   PathToDriver   : string;  { Stores the DOS path to *.BGI & *.CHR }
  72. begin
  73.   { when using Crt and graphics, turn off Crt's memory-mapped writes }
  74.   DirectVideo := False;
  75.   PathToDriver := 'C:\TP\BGI';
  76.   repeat
  77.  
  78.   GraphDriver := Detect;
  79.  
  80.     InitGraph(GraphDriver, GraphMode, PathToDriver);
  81.     ErrorCode := GraphResult;             { preserve error return }
  82.     if ErrorCode <> grOK then             { error? }
  83.     begin
  84.       Writeln('Graphics error: ', GraphErrorMsg(ErrorCode));
  85.       if ErrorCode = grFileNotFound then  { Can't find driver file }
  86.       begin
  87.         Writeln('Enter full path to BGI driver or type <Ctrl-Break> to quit:');
  88.         Readln(PathToDriver);
  89.         Writeln;
  90.       end
  91.       else
  92.         Halt(1);                          { Some other error: terminate }
  93.     end;
  94.   until ErrorCode = grOK;
  95.  
  96.   MaxColor := GetMaxColor;  { Get the maximum allowable drawing color }
  97.   MaxX := GetMaxX;          { Get screen resolution values }
  98.   MaxY := GetMaxY;
  99.  
  100. end; { Initialize }
  101.  
  102. function Int2Str(L : LongInt) : string;
  103. { Converts an integer to a string for use with OutText, OutTextXY }
  104. var
  105.   S : string;
  106. begin
  107.   Str(L, S);
  108.   Int2Str := S;
  109. end; { Int2Str }
  110.  
  111. procedure DrawBorder;
  112. { Draw a border around the current view port }
  113. var
  114.   ViewPort : ViewPortType;
  115. begin
  116.   SetLineStyle(SolidLn, 0, NormWidth);
  117.   GetViewSettings(ViewPort);
  118.   with ViewPort do
  119.     Rectangle(0, 0, x2-x1, y2-y1);
  120. end; { DrawBorder }
  121.  
  122. procedure FullPort;
  123. { Set the view port to the entire screen }
  124. begin
  125.   SetViewPort(0, 0, MaxX, MaxY, ClipOn);
  126. end; { FullPort }
  127.  
  128. {---- COLORS ---}
  129.  
  130. procedure colors;
  131. begin
  132.   SetPalette(0, black);
  133.   SetPalette(1, lightblue);
  134.   SetPalette(2, lightred);
  135.   SetPalette(3, brown);
  136. end; {colors)
  137.  
  138. {---- ZERO ----}
  139.  
  140. procedure zero;
  141. begin
  142.   for y := 0 to maxlines do
  143.     for x := 0 to maxwidth do
  144.       screen[y]^[x] := 0;
  145. end; {zero}
  146.  
  147. {---- SetUp ----}
  148.  
  149. procedure SetUp;
  150. begin
  151.   for y := 0 to MaxLines do     {Allocate Screen to HEAP}
  152.     NEW(Screen[y]);
  153.  
  154.     zero;
  155.     ClearDevice;
  156.     colors;
  157.  
  158.     Xmax := MaxY;
  159.     Ymax := MaxY;
  160.  
  161. end; {SetUp}
  162.  
  163. {------ D -------}
  164. procedure D(c : char);
  165. var
  166.   yy : integer;
  167. begin
  168.   yy := 10;
  169.   SetColor(14);
  170.   OutTextxy(5, yy, 'x = '+ Int2Str(x));
  171.   yy := TextHeight('M') + 3;
  172.   OutTextxy(5, yy, 'y = ' + Int2Str(y));
  173.   yy := yy + TextHeight('M') + 3;
  174.   OutTextxy(5, yy, 'cmd = ' + c);
  175. end; {D}
  176.  
  177. {---- SEEDREAD ----}
  178.  
  179. procedure seedread(sn : seedtype);
  180. begin
  181.   zero;
  182.   assign(SeedFile, sn);
  183.   reset(SeedFile);
  184.   while not EOF(SeedFile) do
  185.     readln(seedfile, x, y, screen[y]^[x]);
  186.   Close(SeedFile);
  187. end; {SeedRead}
  188.  
  189.  
  190. {---- SEEDWRITE ----}
  191.  
  192. procedure seedwrite(sn : seedtype);
  193. begin
  194.   assign(SeedFile, sn);
  195.   Rewrite(SeedFile);
  196.   for y := ymin to maxlines do
  197.     for x := xmin to maxwidth do
  198.       if screen[y]^[x] > 0 then writeln(seedfile, x:4, y:4, screen[y]^[x]:3);
  199.  
  200.   Flush(SeedFile);
  201.   Close(SeedFile);
  202. end; {SeedWrite}
  203.  
  204. {---- CELL ----}
  205.  
  206. procedure Cell;
  207.  
  208. const
  209.   x = 5;
  210.   space = 5;
  211.   bigspace = 50;
  212.  
  213. begin
  214.   FullPort;
  215.   Colors;
  216.   setcolor(15);
  217.   DrawBorder;
  218.   Rectangle(0, 0, Xmax, Ymax);
  219.   SetFillStyle(1, 9);
  220.   Bar(Xmax+1, 1, MaxX-1, MaxY-1);
  221.   SetViewPort(Xmax+1, 1, MaxX-1, MaxY-1, ClipOn);
  222.  
  223.   SetColor(0);
  224.   SetTextStyle(1, 0, 3);
  225.   y := 3;
  226.   OutTextXY(x, y, 'CELLULAR');
  227.   inc(y, TextHeight('M')+space);
  228.   OutTextXY(x, y, 'AUTOMATON');
  229.   inc(y, TextHeight('M')+space);
  230.   OutTextXY(x, y, 'RUNNING...');
  231.   SetColor(15);
  232.   inc(y, TextHeight('M')+bigspace);
  233.   OutTextXY(x, y, 'Isol: '); OutTextxy(x + TextWidth('Isol: '), y, Isol);
  234.   inc(y, TextHeight('M')+space);
  235.   OutTextXY(x, y, 'State: '); OutTextxy(x + TextWidth('State: '), y, StateNumber);
  236.   OutTextXY(x, y, '                    ');
  237. end; {CELL}
  238.  
  239. {---- SEEDY ----}
  240.  
  241. procedure SEEDY;
  242. const
  243.   ds = 'Define Seed';
  244.   qs = '(Q)uit Entry (S)ave';
  245.   SeedColor = 2;
  246.   BlankColor = 0;
  247.   EmptyFill = 0; {Fill with background color}
  248. var
  249.   Done : Boolean;
  250.   cmd  :  Char;
  251.   gx, gy : word;
  252.  
  253. begin
  254.   zero;
  255.   SetViewPort(xmin, ymin, xmax, ymax, clipon);
  256.   Done := False;
  257.   SetColor(2);
  258.   SetTextStyle(1, 0, 4);
  259.   x := Succ((MaxY - TextWidth(ds)) div 2);
  260.   y := 14;
  261.   gy := 0;
  262.   OutTextXY(x ,y , ds);
  263.   inc(gy,y);
  264.   x := Succ((MaxY - TextWidth(qs)) div 2);
  265.   y := TextHeight('M') + 20;
  266.   OutTextXY(x, y, qs);
  267.   inc(gy, y + TextHeight('M'));
  268.   gx := gy;
  269.   x := trunc(Xmax div 2);
  270.   y := trunc(Ymax div 2);
  271.   SetColor(2);
  272.  
  273.   while not Done do
  274.    if Keypressed then
  275.    begin
  276.      cmd := UpCase(ReadKey);
  277.      case cmd of
  278.             'Q' : begin
  279.                     Done := true;
  280.                     SetFillStyle(EmptyFill, BlankColor);
  281.                     Bar(1, 1, Xmax-2, gy);
  282.                   end;
  283.            #13  :  begin
  284.                      PutPixel(x, y, BlankColor);
  285.                      Screen[y]^[x] := 0;
  286.                    end;
  287.             'S' :  begin
  288.                      OutTextXY(3, 23, '                    ');
  289.                      RestoreCrtMode;
  290.                      gotoxy(5, 12);
  291.                      write('File Name: ');
  292.                      Readln(SeedName);
  293.                      seedwrite(seedname);
  294.                      SetGraphMode(graphmode);
  295.                      cell;
  296.                      SetViewPort(xmin, ymin, xmax, ymax, clipon);
  297.                      colors;
  298.                      Done := true;
  299.                    end;
  300.      end; {CASE}
  301.  
  302.      if (cmd = #0) and KeyPressed then  {SECOND KEY}
  303.      begin
  304.        cmd := ReadKey;
  305.        case cmd of
  306.           #75:  begin                {L ARROW - W}
  307.                   dec(x);
  308.                   PutPixel(x,y,SeedColor);
  309.                   Screen[y]^[x] := 1;
  310.                 end;
  311.           #77:  begin                {R ARROW - E}
  312.                   inc(x);
  313.                   PutPixel(x,y,SeedColor);
  314.                   Screen[y]^[x] := 1;
  315.                 end;
  316.           #72:  begin                {U ARROW - N}
  317.                   dec(y);
  318.                   PutPixel(x,y,SeedColor);
  319.                   Screen[y]^[x] := 1;
  320.                   end;
  321.           #80:  begin                {D ARROW - S}
  322.                   inc(y);
  323.                   PutPixel(x,y,SeedColor);
  324.                   Screen[y]^[x] := 1;
  325.                 end;
  326.           #71:  begin                {HOME - NW}
  327.                   dec(x);
  328.                   dec(y);
  329.                   PutPixel(x,y,SeedColor);
  330.                   Screen[y]^[x] := 1;
  331.                 end;
  332.           #79:  begin                {END - SW}
  333.                   dec(x);
  334.                   inc(y);
  335.                   PutPixel(x,y,SeedColor);
  336.                   Screen[y]^[x] := 1;
  337.                 end;
  338.           #73:  begin                {PG UP - NE}
  339.                   inc(x);
  340.                   dec(y);
  341.                   PutPixel(x,y,SeedColor);
  342.                   Screen[y]^[x] := 1;
  343.                 end;
  344.           #81:  begin                {PG DOWN - SE}
  345.                   inc(x);
  346.                   inc(y);
  347.                   PutPixel(x,y,SeedColor);
  348.                   Screen[y]^[x] := 1;
  349.                 end;
  350.        end; {case}
  351.      end;  {sec. key}
  352.    end; {while}
  353. end; {seedy)
  354.  
  355. {------ SEEDSIZE ------}
  356. procedure SeedSize;
  357. begin
  358.   xLeft    := Xmax;
  359.   xRight   := Xmin;
  360.   yTop     := Ymax;
  361.   yBottom  := Ymin;
  362.  
  363.   for x := Xmin to maxwidth do
  364.     for y := Ymin to maxlines do
  365.       if Screen[y]^[x] > 0 then
  366.         begin
  367.           if x < xLeft then xLeft := x;
  368.           if x > xRight then xRight := x;
  369.           if y < yTop then yTop := y;
  370.           if y > yBottom then yBottom := y;
  371.         end;
  372. {  seedwrite('AA');}
  373. end;  {SeedSize}
  374.  
  375. {---- theRULE ----}
  376.  
  377. procedure THERULE;
  378. var
  379.   count : byte;
  380. begin
  381.   for X := xLeft to xRight do
  382.     for Y := yTop to yBottom do
  383.     begin
  384.       count := 0;
  385.       if (Screen[y]^[x-1] > State) then inc(count);  {W}
  386.       if (Screen[y-1]^[x-1] > State) then inc(count);  {SW}
  387.       if (Screen[y-1]^[x] >  State) then inc(count);  {S}
  388.       if (Screen[y-1]^[x+1] >  State) then inc(count);  {SE}
  389.       if (Screen[y]^[x+1] > State) then inc(count);  {E}
  390.       if (Screen[y+1]^[x+1] > State) then inc(count);  {NE}
  391.       if (Screen[y+1]^[x] > State) then inc(count);  {N}
  392.       if (Screen[y+1]^[x-1] > State) then inc(count);  {NW}
  393.  
  394.       case count of
  395.         0 :  if (Screen[y]^[x]=3) and ((Isol = 'O') or (Isol = 'Z')) then
  396.              Screen[y]^[x] := 2;
  397.  
  398.         1 :  if (Screen[y]^[x] = 3) and (Isol = 'O') then
  399.              Screen[y]^[x] := 2;
  400.  
  401.         2 :  if Screen[y]^[x] = 3 then
  402.              Screen[y]^[x] := 3 else Screen[y]^[x] := 0;
  403.  
  404.         3 :  if Screen[y]^[x] = 0 then
  405.              Screen[y]^[x] := 1 else Screen[y]^[x] := 3;
  406.  
  407. 4,5,6,7,8 :  if Screen[y]^[x] = 3 then
  408.              Screen[y]^[x] := 2;
  409.  
  410.       end;  {case}
  411.     end; {loops}
  412. end; {THERULE}
  413.  
  414. {---- RIFFLE ----}
  415.  
  416. procedure RIFFLE;
  417. begin
  418.   for x := xLeft to xRight do
  419.     for y := yTop to yBottom do
  420.     begin
  421.       case Screen[y]^[x] of
  422.         1:  Screen[y]^[x] := 3;
  423.         2:  Screen[y]^[x] := 0;
  424.       end;
  425.     end;
  426. end; {RIFFLE}
  427.  
  428.  
  429. {---- PLOTTER ----}
  430.  
  431. procedure PLOTTER;
  432. begin
  433.   for x := xLeft to xRight do
  434.     for y := yTop to yBottom do
  435.       PutPixel(x, y, Screen[y]^[x]);
  436.  {outtext(Int2str(MemAvail));}
  437. end;{PLOTTER}
  438.  
  439. {---- CheckBORDER ----}
  440. procedure CheckBorder;
  441. begin
  442.   Border := false;
  443.     for x := Xmin+1 to Xmax-1 do
  444.     begin
  445.       if Screen[Ymin+1]^[x] > 0 then Border := true;
  446.       if Screen[Ymax-1]^[x] > 0 then Border := true;
  447.     end;
  448.     for y := Ymin+1 to Ymax-1 do
  449.     begin
  450.       if Screen[y]^[Xmin+1] > 0 then Border := true;
  451.       if Screen[y]^[Xmax-1] > 0 then Border := true;
  452.     end;
  453. end;  {CheckBorder}
  454.  
  455.  
  456. {---- Xpand ----}
  457.  
  458. procedure Xpand;
  459.  
  460. begin
  461.   Border := false;
  462.   if xLeft > xMin + 1 then dec(xLeft);
  463.   if xRight < xMax - 1 then inc(xRight);
  464.   if yTop > yMin +1 then dec(yTop);
  465.   if yBottom < yMax - 1 then inc(yBottom);
  466. end;  {Xpand}
  467.  
  468.  
  469. {---- ABORT ----}
  470.  
  471. procedure Abort;
  472. { Exit from the program }
  473. begin
  474.   ClearDevice;
  475.   Window(1, 1, 80, 25);
  476.   GotoXY(1, 24);
  477.   Halt;
  478. end; { Abort }
  479.  
  480.  
  481. {---- WrGen ----}
  482.  
  483. procedure WrGen;
  484. begin
  485.   GoToXY(67,14); Write('Generation:');
  486.   GoToXY(72,19); Write(gen);
  487. end;
  488.  
  489. {---- LINER ----}
  490.  
  491. procedure LINER;
  492. begin
  493.   for I := 1 to 10 do Write('--------');
  494. end;
  495.  
  496.  
  497. {---- WriteCommand ----}
  498.  
  499. procedure WriteCommand(S : MaxString);
  500. { Highlights the first letter of S }
  501.  
  502. begin
  503.   TextColor(NormColor);
  504.   Write(S[1]);
  505.   TextColor(NormColor - 8);
  506.   WriteLn(Copy(S, 2, Length(s) - 1));
  507. end; { WriteCommand }
  508.  
  509. {---- GETCHAR ----}
  510.  
  511. procedure GetChar(A : Integer; B : Integer; var Ch : Char; Msg : Prompt;
  512.                   OKset : CharSet);
  513. begin
  514.   repeat
  515.     GoToXY(A, B);Write('                                                   ');
  516.     GoToXY(A,B); Write(Msg); ReadLn(Ch);
  517.     Ch := UpCase(Ch);
  518.   until (Ch in OKset);
  519. end; {GetChar}
  520.  
  521. {---- HEADER ----}
  522.  
  523. procedure HEADER;
  524.  
  525. begin
  526.   ClearDevice;
  527.   TextColor(HeadColor);
  528.   GotoXY(20, 1);
  529.   Write('C E L L U L A R  A U T O M A T O N');
  530.   GoToXY(1, 2); Liner;
  531.  
  532.   TextColor(SubColor);
  533.   GoToXY(1,4);
  534.   Write('Seed Entry Mode:');
  535.   GotoXY(1, 6);
  536.   WriteCommand('Freehand Seed With Cursor, "Q" to Run Generations. ');
  537.   WriteCommand('Select Seed From Disk, Automatic Run. ');
  538.  
  539.   TextColor(SubColor);
  540.   GoToXY(1,12);
  541.   Write('Survival in Isolation Characteristics:');
  542.   GoToXY(1,14);
  543.   WriteCommand('Survival with Either 0 or 1 Neighbors. ');
  544.   WriteCommand('Zero Neighbors Extinguishes Cell. ');
  545.   WriteCommand('One OR Zero  Neighbors Extinguishes Cell.');
  546.  
  547.   TextColor(SubColor);
  548.   GoToXY(1,20); Write('CHOOSE "State NUMBER"');
  549.   GoToXY(1, 22); WriteCommand('Zero.');
  550.   GoToXY(10, 22); WriteCommand('One.');
  551.   GoToXY(20, 22); WriteCommand('Two.');
  552.  
  553.   TextColor(EntColor);
  554.   GetChar(1, 9, Seed, 'Enter Letter ( F or S ): ', ['F','S']);
  555.   GetChar(1, 18, Isol, 'Enter Letter ( S, Z or O ): ', ['S','Z','O']);
  556.   GetChar(1, 24, StateNumber, 'Enter Letter ( Z, O or T ): ',['Z', 'O', 'T']);
  557.  
  558.  { seed := 'F';  isol := 'Z';  StateNumber := 'O';}
  559.  
  560.   case StateNumber of
  561.     'Z'  :  State := 0;
  562.     'O'  :  State := 1;
  563.     'T'  :  State := 2;
  564.   end;
  565.  
  566.   ClearDevice;
  567. end;  {Header}
  568.  
  569.  
  570. {---- CONTROL -----}
  571.  
  572. procedure Control;
  573.  
  574. begin
  575.   Header;
  576.   if seed = 'S' then
  577.     begin
  578.       textcolor(zcolor);
  579.       gotoxy(5,12);
  580.       write('Enter Seed File Name: ');
  581.       readln(seedname);
  582.       seedread(seedname);
  583.       cleardevice;
  584.     end;
  585.   Cell;
  586.   SetViewPort(xmin, ymin, xmax, ymax, clipon);
  587.   if seed = 'F' then Seedy;
  588.   SeedSize;
  589.   SetViewPort(xmin, ymin, xmax, ymax, clipon);
  590.   plotter;
  591.   gen := 0;
  592.   repeat
  593.     if (gen mod 15 = 0) then SeedSize;
  594.     Xpand;
  595.     Riffle;
  596.     theRULE;
  597.     inc(gen);
  598.     WrGen;
  599.     Plotter;
  600.   until (Keypressed) or (gen = 500) or (Border = true);
  601. end;  {Control}
  602.  
  603.  
  604.  
  605. {----------- MAIN PROGRAM ---------------}
  606.  
  607. Begin;
  608.   initialize;
  609.   setup;
  610.   while g <> 'X' do
  611.   begin
  612.     repeat
  613.       Control;
  614.       if keypressed then g := upcase(readkey);
  615.     until (g = #13) or (g = 'X');
  616.     Window(0,0,80,25);
  617.     cleardevice;
  618.   end;
  619.   restorecrtmode;
  620.   Window(0,0,80,25);
  621.   cleardevice;
  622. End.
  623.