home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Shareware Overload
/
ShartewareOverload.cdr
/
games
/
life_lab.zip
/
LIFE_LAB.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1989-02-27
|
15KB
|
623 lines
{$N-,R-,E-}
{Kenneth L. Kubos, Ph.D.}
PROGRAM LIFELAB;
uses
Crt, Graph;
const
MaxWidth = 476;
MaxLines = 476;
Xmin = 1;
Ymin = 1;
NormColor = 14; {Yellow}
HeadColor = 11; {LightCyan}
SubColor = 10; {LightGreen}
EntColor = 12; {LightRed}
zcolor = 13; {LightMagenta}
TriplexFont = 2;
{ The five predefined line styles supported }
LineStyles : array[0..4] of string[9] =
('SolidLn', 'DottedLn', 'CenterLn', 'DashedLn', 'UserBitLn');
{ The two text directions available }
TextDirect : array[0..1] of string[8] = ('HorizDir', 'VertDir');
{ The Horizontal text justifications available }
HorizJust : array[0..2] of string[10] = ('LeftText', 'CenterText', 'RightText');
{ The vertical text justifications available }
VertJust : array[0..2] of string[10] = ('BottomText', 'CenterText', 'TopText');
type
ScanLine = array[0..MaxWidth] of byte; {Set up for Pointer use}
ScanLinePointer = ^ScanLine;
scanlinetype = array[0..MaxLines] of scanlinepointer;
MaxString = String[255];
CharSet = set of Char;
Prompt = String[80];
seedtype = string[8];
var
Screen : scanlinetype;
scanfile : file of ScanLine;
SeedFile : Text;
X,Y,I, State, gen, count,
Xcenter, Ycenter, Xmax, Ymax,
xLeft, xRight, yTop, yBottom : Integer;
border : boolean;
Line : String[80];
SeedName : seedtype;
g, Seedcode, Seed, Isol, StateNumber : Char;
GraphDriver : integer; { The Graphics device driver }
GraphMode : integer; { The Graphics mode value }
MaxX, MaxY : word; { The maximum resolution of the screen }
ErrorCode : integer; { Reports any graphics errors }
MaxColor : word; { The maximum color value available }
procedure Initialize;
{ Initialize graphics and report any errors that may occur }
var
InGraphicsMode : boolean; { Flags initialization of graphics mode }
PathToDriver : string; { Stores the DOS path to *.BGI & *.CHR }
begin
{ when using Crt and graphics, turn off Crt's memory-mapped writes }
DirectVideo := False;
PathToDriver := 'C:\TP\BGI';
repeat
GraphDriver := Detect;
InitGraph(GraphDriver, GraphMode, PathToDriver);
ErrorCode := GraphResult; { preserve error return }
if ErrorCode <> grOK then { error? }
begin
Writeln('Graphics error: ', GraphErrorMsg(ErrorCode));
if ErrorCode = grFileNotFound then { Can't find driver file }
begin
Writeln('Enter full path to BGI driver or type <Ctrl-Break> to quit:');
Readln(PathToDriver);
Writeln;
end
else
Halt(1); { Some other error: terminate }
end;
until ErrorCode = grOK;
MaxColor := GetMaxColor; { Get the maximum allowable drawing color }
MaxX := GetMaxX; { Get screen resolution values }
MaxY := GetMaxY;
end; { Initialize }
function Int2Str(L : LongInt) : string;
{ Converts an integer to a string for use with OutText, OutTextXY }
var
S : string;
begin
Str(L, S);
Int2Str := S;
end; { Int2Str }
procedure DrawBorder;
{ Draw a border around the current view port }
var
ViewPort : ViewPortType;
begin
SetLineStyle(SolidLn, 0, NormWidth);
GetViewSettings(ViewPort);
with ViewPort do
Rectangle(0, 0, x2-x1, y2-y1);
end; { DrawBorder }
procedure FullPort;
{ Set the view port to the entire screen }
begin
SetViewPort(0, 0, MaxX, MaxY, ClipOn);
end; { FullPort }
{---- COLORS ---}
procedure colors;
begin
SetPalette(0, black);
SetPalette(1, lightblue);
SetPalette(2, lightred);
SetPalette(3, brown);
end; {colors)
{---- ZERO ----}
procedure zero;
begin
for y := 0 to maxlines do
for x := 0 to maxwidth do
screen[y]^[x] := 0;
end; {zero}
{---- SetUp ----}
procedure SetUp;
begin
for y := 0 to MaxLines do {Allocate Screen to HEAP}
NEW(Screen[y]);
zero;
ClearDevice;
colors;
Xmax := MaxY;
Ymax := MaxY;
end; {SetUp}
{------ D -------}
procedure D(c : char);
var
yy : integer;
begin
yy := 10;
SetColor(14);
OutTextxy(5, yy, 'x = '+ Int2Str(x));
yy := TextHeight('M') + 3;
OutTextxy(5, yy, 'y = ' + Int2Str(y));
yy := yy + TextHeight('M') + 3;
OutTextxy(5, yy, 'cmd = ' + c);
end; {D}
{---- SEEDREAD ----}
procedure seedread(sn : seedtype);
begin
zero;
assign(SeedFile, sn);
reset(SeedFile);
while not EOF(SeedFile) do
readln(seedfile, x, y, screen[y]^[x]);
Close(SeedFile);
end; {SeedRead}
{---- SEEDWRITE ----}
procedure seedwrite(sn : seedtype);
begin
assign(SeedFile, sn);
Rewrite(SeedFile);
for y := ymin to maxlines do
for x := xmin to maxwidth do
if screen[y]^[x] > 0 then writeln(seedfile, x:4, y:4, screen[y]^[x]:3);
Flush(SeedFile);
Close(SeedFile);
end; {SeedWrite}
{---- CELL ----}
procedure Cell;
const
x = 5;
space = 5;
bigspace = 50;
begin
FullPort;
Colors;
setcolor(15);
DrawBorder;
Rectangle(0, 0, Xmax, Ymax);
SetFillStyle(1, 9);
Bar(Xmax+1, 1, MaxX-1, MaxY-1);
SetViewPort(Xmax+1, 1, MaxX-1, MaxY-1, ClipOn);
SetColor(0);
SetTextStyle(1, 0, 3);
y := 3;
OutTextXY(x, y, 'CELLULAR');
inc(y, TextHeight('M')+space);
OutTextXY(x, y, 'AUTOMATON');
inc(y, TextHeight('M')+space);
OutTextXY(x, y, 'RUNNING...');
SetColor(15);
inc(y, TextHeight('M')+bigspace);
OutTextXY(x, y, 'Isol: '); OutTextxy(x + TextWidth('Isol: '), y, Isol);
inc(y, TextHeight('M')+space);
OutTextXY(x, y, 'State: '); OutTextxy(x + TextWidth('State: '), y, StateNumber);
OutTextXY(x, y, ' ');
end; {CELL}
{---- SEEDY ----}
procedure SEEDY;
const
ds = 'Define Seed';
qs = '(Q)uit Entry (S)ave';
SeedColor = 2;
BlankColor = 0;
EmptyFill = 0; {Fill with background color}
var
Done : Boolean;
cmd : Char;
gx, gy : word;
begin
zero;
SetViewPort(xmin, ymin, xmax, ymax, clipon);
Done := False;
SetColor(2);
SetTextStyle(1, 0, 4);
x := Succ((MaxY - TextWidth(ds)) div 2);
y := 14;
gy := 0;
OutTextXY(x ,y , ds);
inc(gy,y);
x := Succ((MaxY - TextWidth(qs)) div 2);
y := TextHeight('M') + 20;
OutTextXY(x, y, qs);
inc(gy, y + TextHeight('M'));
gx := gy;
x := trunc(Xmax div 2);
y := trunc(Ymax div 2);
SetColor(2);
while not Done do
if Keypressed then
begin
cmd := UpCase(ReadKey);
case cmd of
'Q' : begin
Done := true;
SetFillStyle(EmptyFill, BlankColor);
Bar(1, 1, Xmax-2, gy);
end;
#13 : begin
PutPixel(x, y, BlankColor);
Screen[y]^[x] := 0;
end;
'S' : begin
OutTextXY(3, 23, ' ');
RestoreCrtMode;
gotoxy(5, 12);
write('File Name: ');
Readln(SeedName);
seedwrite(seedname);
SetGraphMode(graphmode);
cell;
SetViewPort(xmin, ymin, xmax, ymax, clipon);
colors;
Done := true;
end;
end; {CASE}
if (cmd = #0) and KeyPressed then {SECOND KEY}
begin
cmd := ReadKey;
case cmd of
#75: begin {L ARROW - W}
dec(x);
PutPixel(x,y,SeedColor);
Screen[y]^[x] := 1;
end;
#77: begin {R ARROW - E}
inc(x);
PutPixel(x,y,SeedColor);
Screen[y]^[x] := 1;
end;
#72: begin {U ARROW - N}
dec(y);
PutPixel(x,y,SeedColor);
Screen[y]^[x] := 1;
end;
#80: begin {D ARROW - S}
inc(y);
PutPixel(x,y,SeedColor);
Screen[y]^[x] := 1;
end;
#71: begin {HOME - NW}
dec(x);
dec(y);
PutPixel(x,y,SeedColor);
Screen[y]^[x] := 1;
end;
#79: begin {END - SW}
dec(x);
inc(y);
PutPixel(x,y,SeedColor);
Screen[y]^[x] := 1;
end;
#73: begin {PG UP - NE}
inc(x);
dec(y);
PutPixel(x,y,SeedColor);
Screen[y]^[x] := 1;
end;
#81: begin {PG DOWN - SE}
inc(x);
inc(y);
PutPixel(x,y,SeedColor);
Screen[y]^[x] := 1;
end;
end; {case}
end; {sec. key}
end; {while}
end; {seedy)
{------ SEEDSIZE ------}
procedure SeedSize;
begin
xLeft := Xmax;
xRight := Xmin;
yTop := Ymax;
yBottom := Ymin;
for x := Xmin to maxwidth do
for y := Ymin to maxlines do
if Screen[y]^[x] > 0 then
begin
if x < xLeft then xLeft := x;
if x > xRight then xRight := x;
if y < yTop then yTop := y;
if y > yBottom then yBottom := y;
end;
{ seedwrite('AA');}
end; {SeedSize}
{---- theRULE ----}
procedure THERULE;
var
count : byte;
begin
for X := xLeft to xRight do
for Y := yTop to yBottom do
begin
count := 0;
if (Screen[y]^[x-1] > State) then inc(count); {W}
if (Screen[y-1]^[x-1] > State) then inc(count); {SW}
if (Screen[y-1]^[x] > State) then inc(count); {S}
if (Screen[y-1]^[x+1] > State) then inc(count); {SE}
if (Screen[y]^[x+1] > State) then inc(count); {E}
if (Screen[y+1]^[x+1] > State) then inc(count); {NE}
if (Screen[y+1]^[x] > State) then inc(count); {N}
if (Screen[y+1]^[x-1] > State) then inc(count); {NW}
case count of
0 : if (Screen[y]^[x]=3) and ((Isol = 'O') or (Isol = 'Z')) then
Screen[y]^[x] := 2;
1 : if (Screen[y]^[x] = 3) and (Isol = 'O') then
Screen[y]^[x] := 2;
2 : if Screen[y]^[x] = 3 then
Screen[y]^[x] := 3 else Screen[y]^[x] := 0;
3 : if Screen[y]^[x] = 0 then
Screen[y]^[x] := 1 else Screen[y]^[x] := 3;
4,5,6,7,8 : if Screen[y]^[x] = 3 then
Screen[y]^[x] := 2;
end; {case}
end; {loops}
end; {THERULE}
{---- RIFFLE ----}
procedure RIFFLE;
begin
for x := xLeft to xRight do
for y := yTop to yBottom do
begin
case Screen[y]^[x] of
1: Screen[y]^[x] := 3;
2: Screen[y]^[x] := 0;
end;
end;
end; {RIFFLE}
{---- PLOTTER ----}
procedure PLOTTER;
begin
for x := xLeft to xRight do
for y := yTop to yBottom do
PutPixel(x, y, Screen[y]^[x]);
{outtext(Int2str(MemAvail));}
end;{PLOTTER}
{---- CheckBORDER ----}
procedure CheckBorder;
begin
Border := false;
for x := Xmin+1 to Xmax-1 do
begin
if Screen[Ymin+1]^[x] > 0 then Border := true;
if Screen[Ymax-1]^[x] > 0 then Border := true;
end;
for y := Ymin+1 to Ymax-1 do
begin
if Screen[y]^[Xmin+1] > 0 then Border := true;
if Screen[y]^[Xmax-1] > 0 then Border := true;
end;
end; {CheckBorder}
{---- Xpand ----}
procedure Xpand;
begin
Border := false;
if xLeft > xMin + 1 then dec(xLeft);
if xRight < xMax - 1 then inc(xRight);
if yTop > yMin +1 then dec(yTop);
if yBottom < yMax - 1 then inc(yBottom);
end; {Xpand}
{---- ABORT ----}
procedure Abort;
{ Exit from the program }
begin
ClearDevice;
Window(1, 1, 80, 25);
GotoXY(1, 24);
Halt;
end; { Abort }
{---- WrGen ----}
procedure WrGen;
begin
GoToXY(67,14); Write('Generation:');
GoToXY(72,19); Write(gen);
end;
{---- LINER ----}
procedure LINER;
begin
for I := 1 to 10 do Write('--------');
end;
{---- WriteCommand ----}
procedure WriteCommand(S : MaxString);
{ Highlights the first letter of S }
begin
TextColor(NormColor);
Write(S[1]);
TextColor(NormColor - 8);
WriteLn(Copy(S, 2, Length(s) - 1));
end; { WriteCommand }
{---- GETCHAR ----}
procedure GetChar(A : Integer; B : Integer; var Ch : Char; Msg : Prompt;
OKset : CharSet);
begin
repeat
GoToXY(A, B);Write(' ');
GoToXY(A,B); Write(Msg); ReadLn(Ch);
Ch := UpCase(Ch);
until (Ch in OKset);
end; {GetChar}
{---- HEADER ----}
procedure HEADER;
begin
ClearDevice;
TextColor(HeadColor);
GotoXY(20, 1);
Write('C E L L U L A R A U T O M A T O N');
GoToXY(1, 2); Liner;
TextColor(SubColor);
GoToXY(1,4);
Write('Seed Entry Mode:');
GotoXY(1, 6);
WriteCommand('Freehand Seed With Cursor, "Q" to Run Generations. ');
WriteCommand('Select Seed From Disk, Automatic Run. ');
TextColor(SubColor);
GoToXY(1,12);
Write('Survival in Isolation Characteristics:');
GoToXY(1,14);
WriteCommand('Survival with Either 0 or 1 Neighbors. ');
WriteCommand('Zero Neighbors Extinguishes Cell. ');
WriteCommand('One OR Zero Neighbors Extinguishes Cell.');
TextColor(SubColor);
GoToXY(1,20); Write('CHOOSE "State NUMBER"');
GoToXY(1, 22); WriteCommand('Zero.');
GoToXY(10, 22); WriteCommand('One.');
GoToXY(20, 22); WriteCommand('Two.');
TextColor(EntColor);
GetChar(1, 9, Seed, 'Enter Letter ( F or S ): ', ['F','S']);
GetChar(1, 18, Isol, 'Enter Letter ( S, Z or O ): ', ['S','Z','O']);
GetChar(1, 24, StateNumber, 'Enter Letter ( Z, O or T ): ',['Z', 'O', 'T']);
{ seed := 'F'; isol := 'Z'; StateNumber := 'O';}
case StateNumber of
'Z' : State := 0;
'O' : State := 1;
'T' : State := 2;
end;
ClearDevice;
end; {Header}
{---- CONTROL -----}
procedure Control;
begin
Header;
if seed = 'S' then
begin
textcolor(zcolor);
gotoxy(5,12);
write('Enter Seed File Name: ');
readln(seedname);
seedread(seedname);
cleardevice;
end;
Cell;
SetViewPort(xmin, ymin, xmax, ymax, clipon);
if seed = 'F' then Seedy;
SeedSize;
SetViewPort(xmin, ymin, xmax, ymax, clipon);
plotter;
gen := 0;
repeat
if (gen mod 15 = 0) then SeedSize;
Xpand;
Riffle;
theRULE;
inc(gen);
WrGen;
Plotter;
until (Keypressed) or (gen = 500) or (Border = true);
end; {Control}
{----------- MAIN PROGRAM ---------------}
Begin;
initialize;
setup;
while g <> 'X' do
begin
repeat
Control;
if keypressed then g := upcase(readkey);
until (g = #13) or (g = 'X');
Window(0,0,80,25);
cleardevice;
end;
restorecrtmode;
Window(0,0,80,25);
cleardevice;
End.