Skip to content

Instantly share code, notes, and snippets.

@codemonkey-uk

codemonkey-uk/LANDCAP.PAS

Created December 31, 2013 12:08
Show Gist options
  • Save codemonkey-uk/8195836 to your computer and use it in GitHub Desktop.
Save codemonkey-uk/8195836 to your computer and use it in GitHub Desktop.
Download ZIP
Landcap is a Fractal Landscape Generator for DOS/VGA PC's, that I wrote when I was in college, circa 1993. It was originally released as shareware, and got 1 (one) £10 registration for my efforts. It was reviewed in PC-Format magazine in the same issue as Alta-Vista, which was/is a much better commercial application that does the same thing. At …
Raw
LANDCAP.PAS
Program MakeTrue3DFract;
uses dos,crt;
const
ver : string = '1';
update : string = '1';
Ysize : WORD = 512;
Xsize : WORD = 512;
ColourSet : Char = 'G';
Type colorvalue = record rvalue,gvalue,bvalue : byte; end;
paltype = array [0..255] of colorvalue;
Scape = array[1..512] of byte;
River = array[0..64] of byte;
Zline = array[0..319] of Integer;
var
Zbuf : Array[0..199] of ^Zline;
Land : array[1..512] of ^Scape;
Bed : array[1..512] of ^River;
seed : longint;
Filename : String[8];
Mode : Byte;
Jitter,
Water : Byte;
h_jitter,
SunY,
SunX,
SunZ : ShortInt;
eyeX,
eyeZ,
eyeY : Integer;
gourad,
Polyview,
City,
Interactive,
falloff : Boolean;
f : Real;
Angle,
HowmanyStars : Word;
Function ISVGA : boolean;
var
r : registers;
begin
R.AX:=$1a00;
Intr($10,r);
ISVGA:=(r.al=$1a);
end;
{$I-}
Function Exist(name : String) : boolean;
var
f : File;
begin
assign(f,name+'.raw');
reset(f);
if IOresult=0 then exist:=TRUE
else exist:=FALSE;
end;
{$I+}
Procedure Defalts;
begin
randomize;
seed:=Random(65535);
f:=(Random*3)+0.5;
PolyView:=FALSE;
Gourad:=FALSE;
Filename:='LANDCAP';
SunY:=1;
sunX:=1;
SunZ:=-1;
eyeZ:=20;
eyeY:=50;
eyeX:=256;
Water:=90;
Jitter:=2;
h_jitter:=jitter div 2;
Mode:=2;
City:=False;
Falloff:=False;
Interactive:=False;
If Falloff then
begin
Suny:=2;
SunX:=0;
SunZ:=1;
end;
HowmanyStars:=350;
angle:=0;
end;
{$I-}
Procedure save;
var
f : File;
key : Char;
result : word;
begin
assign(f,Filename+'.RAW');
Repeat
Repeat
result:=2;
rewrite(f,1);
if IOresult<>0 then
begin
Sound(500);
Delay(500);
nosound;
key:=readkey;
result:=0;
end;
until result<>0;
blockwrite(f,mem[$A000:0],$FA00,result);
if (IOresult<>0) or (result<>$FA00) then
begin
Sound(500);
Delay(500);
nosound;
key:=readkey;
result:=0;
end;
until result<>0;
close(f);
end;
{$I+}
Procedure FindMem;
var
count : Integer;
kK : Integer;
begin
for count:=1 to Ysize do
begin
if maxavail<XSIZE then
begin
Writeln('You will need more base memory to use Landcap');
Halt;
end;
New(Land[count]);
for kk:=1 to xsize do
Land[count]^[kk]:=0;
end;
for count:=1 to Ysize do
begin
if maxavail<XSIZE div 8 then
begin
Writeln('You will need more base memory to use Landcap');
Halt;
end;
New(bed[count]);
for kk:=0 to xsize div 8 do
bed[count]^[kk]:=0;
end;
for count:=0 to 199 do
begin
if maxavail<640 then
begin
Writeln('You will need more base memory to use Landcap');
Halt;
end;
new(Zbuf[count]);
end;
end;
Procedure ClearMem;
var
count : Integer;
Begin
for count:=1 to Ysize do
Dispose(Land[count]);
for count:=1 to Ysize do
Dispose(Bed[count]);
for count:=0 to 199 do
Dispose(Zbuf[count]);
end;
Procedure DrawScreen;
var
X,Y : Word;
num : Byte;
pal : Paltype;
regs: Registers;
begin
Inline($B8/$13/0/$CD/$10);
pal[0].rvalue:=0;
pal[0].gvalue:=0;
pal[0].bvalue:=0;
pal[1].rvalue:=0;
pal[1].gvalue:=0;
pal[1].bvalue:=45;
for num:=2 to 63 do
With pal[num] do
begin
Rvalue:=0;
Bvalue:=0;
Gvalue:=16;
end;
for num:=64 to 128 do
With pal[num] do
begin
Rvalue:=0;
Bvalue:=0;
Gvalue:=32;
end;
for num:=129 to 192 do
With pal[num] do
begin
Rvalue:=0;
Bvalue:=0;
Gvalue:=48;
end;
for num:=192 to 255 do
With pal[num] do
begin
Rvalue:=0;
Bvalue:=0;
Gvalue:=63;
end;
with regs do
begin
AX:=$1012;
BX:=0;
CX:=256;
ES:=seg(pal);
DX:=ofs(pal);
end;
intr($10,regs);
for x:= 8 to 111 do
begin
Mem[$A000:320*8+x]:=254;
Mem[$A000:320*111+x]:=254;
end;
for y:= 8 to 111 do
begin
Mem[$A000:320*y+8]:=254;
Mem[$A000:320*y+111]:=254;
end;
for y:=115 to 125 do
for x:=10 to 20 do
mem[$a000:320*y+x]:=1;
for y:=115 to 125 do
for x:=25 to 35 do
mem[$a000:320*y+x]:=63;
for y:=115 to 125 do
for x:=40 to 50 do
mem[$a000:320*y+x]:=128;
for y:=115 to 125 do
for x:=55 to 65 do
mem[$a000:320*y+x]:=192;
for y:=115 to 125 do
for x:=70 to 80 do
mem[$a000:320*y+x]:=255;
directvideo:=false;
gotoxy(2,17);
Write('1 6 1 1 2');
gotoxy(2,18);
Write(' 4 2 9 5');
gotoxy(2,19);
Write(' 9 2 5');
directvideo:=false;
gotoXY(18,2);
Write('Seed Value :',seed:8);
gotoXY(18,3);
if not Interactive then
Write('Grain :',f:8:3)
else
Write('Interactive Method');
gotoXY(18,4);
Write('Water Level :',water:8);
gotoXY(18,5);
if Gourad=True
then
Write('Full detail mode.')
else
if PolyView then
Write('Polygon mode. ')
else
Write('Quick view mode. ');
gotoxy(18,6);
Write('Eye Level :',eyey+Water:8);
gotoXY(18,7);
Write('Jitter :',Jitter:8);
gotoXY(18,8);
If Falloff then
Write('Night Time')
else
Write('Day Time');
gotoXY(18,9);
Write('Light vectors');
gotoXY(20,10);
Write('X :',SunX:8);
gotoXY(20,11);
Write('Y :',SunZ:8);
gotoXY(20,12);
Write('Elivation :',SunY:8);
gotoXY(18,13);
Write('Filename :',FileName);
gotoXY(18,14);
Write('Eye Pos X :',eyeX:8);
gotoXY(18,15);
Write('Eye Pos Y :',eyeZ:8);
gotoXY(18,16);
Write('Angle :',Angle:8);
gotoXY(18,17);
Write('Create Map');
gotoXY(18,18);
Write('Render LandScape');
gotoXY(18,19);
Write('Save Setup');
gotoXY(18,20);
Write('Quit');
gotoXY(2,22);
Write('L : Load Picture');
gotoXY(2,23);
Write('P : Prepare data');
end;
Procedure CreatePal;
var
pal : Paltype;
x : Byte;
regs : Registers;
begin
pal[0].rvalue:=0;
pal[0].gvalue:=0;
pal[0].bvalue:=0;
case upcase(ColourSet) of
'G' : Begin { Grass Landscape Pal }
for x:=1 to 32 do { Water ... }
with pal[x] do
begin
Rvalue:=0;
bvalue:=8+x;
Gvalue:=x div 2;
end;
for x:=33 to 42 do { smooth Blue to green }
with pal[x] do
begin
Rvalue:=(x-33) div 2;
Bvalue:=(42-x)*4;
Gvalue:=10+((42-x) div 2);
end;
for x:=43 to 105 do { Grass }
with pal[x] do
begin
Rvalue:=5;
bvalue:=0;
Gvalue:=(x-20) div 2;
end;
for x:=106 to 110 do { Smooth grass to greys }
with pal[x] do
begin
Rvalue:=5-(x-106);
bvalue:=0;
gvalue:=39-((x-106)*8);
end;
for x:=111 to 166 do { Greys }
with pal[x] do
begin
Gvalue:=x-100;
Bvalue:=x-100;
Rvalue:=x-100;
end;
for x:=167 to 255 do { Red filler }
with pal[x] do
begin
gvalue:=0;
rvalue:=60;
bvalue:=0;
end;
end;
end;
with regs do
begin
AX:=$1012;
BX:=0;
CX:=256;
ES:=seg(pal);
DX:=ofs(pal);
end;
intr($10,regs);
end;
Procedure DrawMap;
var
Rx,Ry : Word;
X,y : Word;
begin
for x:=1 to 100 do
for y:=1 to 100 do
begin
Rx:=x+9;
Ry:=y+9;
mem[$a000:WORD(320*ry+rx)]:=land[y*5]^[x*5];
end;
rx:=WORD(EyeX);
ry:=WORD(EyeZ);
x:=WORD(10+((100*rx) div Xsize));
y:=WORD(10+((100*ry) div Ysize));
mem[$a000:WORD(320*y+x)]:=eyeY+Water;
end;
Procedure MakeScape;
var
num : Integer;
x,
y,
c : Integer;
Procedure adjust(xa,ya,x,y,xb,yb: Word);
var
d : integer;
v : real;
begin
if (not city) and (Land[y]^[x]<>0) then exit;
d:=Abs(xa-xb)+Abs(ya-yb);
if interactive then f:=(Land[ya]^[xa]+Land[yb]^[xb]) div 50;
v:=(Land[ya]^[xa]+Land[yb]^[xb])/2+(random-0.5)*d*F;
if v<1 then v:=1;
if v>=250 then v:=249-(v-250);
Land[y]^[x]:=Trunc(v);
end;
Procedure subDivide(x1,y1,x2,y2: Word);
var
x,y : Word;
v : integer;
rx,ry : Word;
begin
if KeyPressed then exit;
if (x2-x1<2) and (y2-y1<2) then exit;
x:=(x1+x2) div 2;
y:=(y1+y2) div 2;
adjust(x1,y1,x,y1,x2,y1);
adjust(x2,y1,x2,y,x2,y2);
adjust(x1,y2,x,y2,x2,y2);
adjust(x1,y1,x1,y,x1,y2);
if Land[y]^[x]=0 then
begin
v:=(Land[y1]^[x1]+Land[y1]^[x2]+Land[y2]^[x2]+Land[y2]^[x1]) div 4;
Land[y]^[x]:=v;
end;
subDivide(x1,y1,x,y);
subDivide(x,y,x2,y2);
subDivide(x1,y,x,y2);
subDivide(x,y1,x2,y);
Rx:=WORD(10+((100*x) div Xsize));
Ry:=WORD(10+((100*y) div Ysize));
mem[$a000:WORD(320*ry+rx)]:=land[y]^[x];
end;
Begin
for num:=1 to Ysize do
for c:=1 to xsize do
Land[num]^[c]:=0;
Randseed:=seed;
Land[1]^[1]:=1+Random(230);
Land[Ysize]^[1]:=1+Random(230);
Land[Ysize]^[Xsize]:=1+Random(230);
Land[1]^[Xsize]:=1+Random(230);
subDivide(1,1,Xsize,Ysize);
end;
Procedure PrepData;
var
x,y : Word;
c : Integer;
begin
for x:=1 to Xsize do
for y:=1 to Ysize do
begin
c:=Land[y]^[x];
dec(c,water);
if c<1 then Land[y]^[x]:=1
else Land[y]^[x]:=c;
end;
end;
Procedure DoStars;
var
kount : Word;
begin
for kount:=0 to HowManyStars do
mem[$A000:random(35000)+3000]:=random(56)+110;
end;
Function FindPolyColor(x,z : Integer) : Byte;
var
Water : Boolean;
Xpos, Ypos ,Zpos : integer;
temp : Integer;
shaddow : Byte;
depth : LongInt;
D_on_X,
D_on_Z : Integer;
begin
water:=(land[z]^[x]=1);
water:=Water or odd((bed[z]^[(X-1) div 8] shr ((X-1) mod 8)));
Xpos:=x;
Ypos:=Land[z]^[x];
zPos:=z;
If NOT Falloff Then
Begin
shaddow:=16;
repeat
Dec(Xpos,SunX);
dec(Zpos,SunZ);
inc(Ypos,SunY);
if (YPos<Land[Zpos]^[Xpos]) then dec(shaddow);
until (Xpos<2) or (Zpos<2) or (Xpos>Xsize-2) or (Zpos>Ysize-2) or (shaddow=2);
end
else
begin
if water
then shaddow:=15
else shaddow:=4;
depth:=abs(z-eyeZ);
depth:=(depth*depth)+(abs(x-EyeX)*abs(x-EyeX));
if depth<1 then depth:=1;
depth:=Trunc(sqrt(depth));
if depth<100 then depth:=100;
end;
if Water then
begin
if Falloff then temp:=100*shaddow div depth
else temp:=Shaddow;
if (temp<1) then temp:=8
else temp:=8+((temp*3) div 4);
if temp>32 then temp:=32;
findpolycolor:=temp;
end
else
begin
d_on_X:=land[z]^[x]-land[z]^[x+1];
d_on_X:=d_on_X+land[z-1]^[x]-land[z-1]^[x+1];
d_on_Z:=land[z]^[x]-land[z-1]^[x];
d_on_Z:=d_on_Z+land[z]^[x+1]-land[z-1]^[x+1];
d_on_X:=d_on_X*-sunX;
d_on_Z:=d_on_Z*SunZ;
temp:=(2*(d_on_X+d_on_Z)) div 3;
if temp<-18 then temp:=-18;
if temp>18 then temp:=18;
if falloff then
temp:=17+(100*(23+temp+((Shaddow div 5)*5)+random(jitter)-h_jitter) div depth)
else
temp:=40+temp+((Shaddow div 5)*5)+random(jitter)-h_jitter;
temp:=temp+28;
if temp<43 then temp:=43;
if temp>105 then temp:=105;
findpolycolor:=temp;
end;
end;
Function FindColor(x,z : Integer) : Byte;
var
Water : Boolean;
Xpos, Ypos ,Zpos : integer;
temp : Byte;
shaddow : Byte;
depth : LongInt;
begin
water:=(land[z]^[x]=1);
water:=Water or odd((bed[z]^[(X-1) div 8] shr ((X-1) mod 8)));
Xpos:=x;
Ypos:=Land[z]^[x];
zPos:=z;
shaddow:=16;
if not falloff then
repeat
Dec(Xpos,SunX);
dec(Zpos,SunZ);
inc(Ypos,SunY);
if (YPos<Land[Zpos]^[Xpos]) then dec(shaddow);
until (Xpos<2) or (Zpos<2) or (Xpos>Xsize-2) or (Zpos>Ysize-2) or (shaddow=2);
if falloff then
begin
depth:=abs(z-eyeZ);
depth:=(depth*depth)+(abs(x-EyeX)*abs(x-EyeX));
if depth<1 then depth:=1;
depth:=Trunc(sqrt(depth));
if depth<100 then depth:=100;
end;
if Water then
begin
if Falloff then temp:=100*shaddow div depth
else temp:=Shaddow;
if (temp<4) then findcolor:=4
else findcolor:=4+((temp*2) div 3);
end;
if Not water then
begin
Temp:=(land[z]^[x]+((shaddow) div 5)*5)+random(jitter);
if Falloff then findcolor:=46+((100*Temp div depth) div 4)
else findcolor:=46+(Temp div 4);
end;
end;
Procedure ShowscapePoly;
var
polyq : array [1..4,0..199] of Word;
miny,
maxy : word;
count,
countb : integer;
zVal,
xVal,
x1,x2,x3,x4,
y1,y2,y3,y4,
X,Y,
Z,C : LongInt;
col,col2,
col3,col4 : Byte;
k : Char;
Procedure ClearZbuff;
var
X,Y : Word;
begin
for x:=0 to 319 do
for y:=0 to 199 do
Zbuf[y]^[x]:=MaxInt;
end;
procedure SwapInt( var i1, i2: Longint );
var dummy : integer;
begin
dummy := i2;
i2 := i1;
i1 := dummy;
end;
procedure GPolypoint(x,y : Longint;col : word);
begin
if x<0 then x:=0;
if x>319 then x:=319;
if y>199 then y:=199;
if y<0 then y:=0;
if x>polyq[2,y] then
begin
polyq[2,y]:=WORD(x);
polyq[4,y]:=col;
end;
if x<polyq[1,y] then
begin
polyq[1,y]:=WORD(x);
polyq[3,y]:=col;
end;
if y>maxy then maxy:=y;
if y<miny then miny:=y;
end;
procedure GLine( x1, y1, x2, y2 : LongInt;Firstcol,lastcol : LongInt);
var
biggest,
smallest,
d, dx, dy,
aincr, bincr,
xincr, yincr,
cincr,col,
dd,dc,c_jmp,
x, y : integer;
begin
if ( abs(x2-x1) < abs(y2-y1) ) then { X- or Y-axis overflow? }
begin { Check Y-axis }
if ( y1 > y2 ) then { y1 > y2? }
begin
SwapInt( x1, x2 ); { Yes --> Swap X1 with X2 }
SwapInt( y1, y2 ); { and Y1 with Y2 }
SwapInt( Firstcol,lastcol);
end;
if ( x2 > x1 ) then xincr := 1 { Set X-axis increment }
else xincr := -1;
dy := y2 - y1;
dx := abs( x2-x1 );
d := 2 * dx - dy;
aincr := 2 * (dx - dy);
bincr := 2 * dx;
x := x1;
y := y1;
if Firstcol<Lastcol then
begin
biggest:=Lastcol;
smallest:=Firstcol;
dc:=abs(Lastcol-Firstcol);
cincr:=1
end
else
begin
biggest:=Firstcol;
smallest:=Lastcol;
dc:=abs(Firstcol-Lastcol);
cincr:=-1;
end;
if dc=0 then dc:=1;
dd:=y2-y1; { Also changed as below}
if dd=0 then dd:=1;
if dd>dc then
begin
c_jmp:=dd div dc;
dc:=cincr;
end
else
begin
c_jmp:=1;
dc:=(dc div dd)*cincr;
end;
col:=Firstcol;
if firstcol=lastcol then dc:=0;
dd:=0;
Gpolypoint( x, y ,col); { Set first pixel }
for y:=y1+1 to y2 do { Execute line on Y-axes }
begin
inc(dd);
if dd=c_jmp then
begin
inc(col,dc);
if col>biggest then col:=biggest;
if col<smallest then col:=smallest;
dd:=0;
end;
if ( d >= 0 ) then
begin
inc( x, xincr );
inc( d, aincr );
end
else
inc( d, bincr );
Gpolypoint( x, y,col);
end;
end
else { Check X-axes }
begin
if ( x1 > x2 ) then { x1 > x2? }
begin
SwapInt( x1, x2 ); { Yes --> Swap X1 with X2 }
SwapInt( y1, y2 ); { and Y1 with Y2 }
SwapInt( Firstcol,lastcol);
end;
if ( y2 > y1 ) then yincr := 1 { Set Y-axis increment }
else yincr := -1;
dx := x2 - x1;
dy := abs( y2-y1 );
d := 2 * dy - dx;
aincr := 2 * (dy - dx);
bincr := 2 * dy;
x := x1;
y := y1;
if Firstcol<Lastcol then
begin
biggest:=Lastcol;
smallest:=firstcol;
dc:=abs(Lastcol-Firstcol);
cincr:=1
end
else
begin
biggest:=firstcol;
smallest:=lastcol;
dc:=abs(Firstcol-Lastcol);
cincr:=-1;
end;
if dc=0 then dc:=1;
dd:=x2-x1; { Changed from dd:=x2-(x1+1); }
if dd=0 then dd:=1;
if dd>dc then
begin
c_jmp:=dd div dc;
dc:=cincr;
end
else
begin
c_jmp:=1;
dc:=(dc div dd)*cincr;
end;
if firstcol=lastcol then dc:=0;
col:=Firstcol;
dd:=0;
Gpolypoint( x, y ,col); { Set first pixel }
for x:=x1+1 to x2 do { Execute line on X-axes }
begin
inc(dd);
if dd=c_jmp then
begin
inc(col,dc);
if col>biggest then col:=biggest;
if col<smallest then col:=smallest;
dd:=0;
end;
if ( d >= 0 ) then
begin
inc( y, yincr );
inc( d, aincr );
end
else
inc( d, bincr );
Gpolypoint( x, y,col );
end;
end;
end;
procedure DispGPoly(z : Integer);
var
biggest,
smallest,
cx,cy : Integer;
col : byte;
aincr,
cincr,
dc,dx : Integer;
begin
for cy:=miny to maxy do
if polyq[1,cy]<>400 then
begin
if polyq[3,cy]<polyq[4,cy] then
begin
biggest:=polyq[4,cy];
smallest:=polyq[3,cy];
dc:=1+abs(polyq[4,cy]-polyq[3,cy]);
cincr:=1
end
else
begin
biggest:=polyq[3,cy];
smallest:=polyq[4,cy];
dc:=abs(polyq[3,cy]-polyq[4,cy]);
cincr:=-1;
end;
dx:=polyq[2,cy]-(polyq[1,cy]+1);
if dx>dc then
begin
if dc<1 then begin
dc:=1;
cincr:=0; { <----- I changed this bit }
end;
aincr:=(dx div dc);
dc:=cincr;
end
else
begin
if dx=0 then dx:=1;
aincr:=1;
dc:=(dc div dx)*cincr;
end;
col:=polyq[3,cy];
dx:=0;
if polyq[3,cy]=polyq[4,cy] then dc:=0;
for cx:=polyq[1,cy] to polyq[2,cy] do
begin
if (cx>0) and (cx<319) and (cy>-1) and (cy<199) then
if Zbuf[cy]^[cx]>Z then
begin
Zbuf[cy]^[cx]:=Z;
if col<1 then col:=1;
if col>166 then col:=1;
Mem[$a000:320*cy+cx]:=col;
end;
inc(dx);
if dx=aincr then
begin
inc(col,dc);
dx:=0;
if col>biggest then col:=biggest;
if col<smallest then col:=smallest;
inc(col,dc);
dx:=0;
end;
end;
end;
end;
procedure Polypoint(x,y : Longint);
begin
if x<0 then x:=0;
if x>319 then x:=319;
if y>199 then y:=199;
if y<0 then y:=0;
if x>polyq[2,y] then polyq[2,y]:=WORD(x);
if x<polyq[1,y] then polyq[1,y]:=WORD(x);
if y>maxy then maxy:=y;
if y<miny then miny:=y;
end;
procedure BLine( x1, y1, x2, y2 : Longint);
var d, dx, dy,
aincr, bincr,
xincr, yincr,
x, y : integer;
begin
if ( abs(x2-x1) < abs(y2-y1) ) then { X- or Y-axis overflow? }
begin { Check Y-axis }
if ( y1 > y2 ) then { y1 > y2? }
begin
SwapInt( x1, x2 ); { Yes --> Swap X1 with X2 }
SwapInt( y1, y2 ); { and Y1 with Y2 }
end;
if ( x2 > x1 ) then xincr := 1 { Set X-axis increment }
else xincr := -1;
dy := y2 - y1;
dx := abs( x2-x1 );
d := 2 * dx - dy;
aincr := 2 * (dx - dy);
bincr := 2 * dx;
x := x1;
y := y1;
polypoint( x, y ); { Set first pixel }
for y:=y1+1 to y2 do { Execute line on Y-axes }
begin
if ( d >= 0 ) then
begin
inc( x, xincr );
inc( d, aincr );
end
else
inc( d, bincr );
polypoint( x, y);
end;
end
else { Check X-axes }
begin
if ( x1 > x2 ) then { x1 > x2? }
begin
SwapInt( x1, x2 ); { Yes --> Swap X1 with X2 }
SwapInt( y1, y2 ); { and Y1 with Y2 }
end;
if ( y2 > y1 ) then yincr := 1 { Set Y-axis increment }
else yincr := -1;
dx := x2 - x1;
dy := abs( y2-y1 );
d := 2 * dy - dx;
aincr := 2 * (dy - dx);
bincr := 2 * dy;
x := x1;
y := y1;
polypoint( x, y ); { Set first pixel }
for x:=x1+1 to x2 do { Execute line on X-axes }
begin
if ( d >= 0 ) then
begin
inc( y, yincr );
inc( d, aincr );
end
else
inc( d, bincr );
polypoint( x, y );
end;
end;
end;
procedure DispPoly(col : byte;Z : Integer);
var
cx,cy : Integer;
begin
for cy:=miny to maxy do
if polyq[1,cy]<>400 then
for cx:=polyq[1,cy] to polyq[2,cy] do
if (cx>0) and (cx<319) and (cy>-1) and (cy<199) then
if Zbuf[cy]^[cx]>Z
then
begin
Zbuf[cy]^[cx]:=Z;
Mem[$a000:320*cy+cx]:=col;
end;
end;
Procedure ClearPolyQ;
var
kount : Integer;
begin
maxy:=0;
miny:=400;
for kount:=0 to 199 do
begin
polyq[1,kount]:=400;
polyq[2,kount]:=0;
end;
end;
begin
ClearZBuff;
clearpolyq;
Inline($B8/$13/0/$CD/$10);
CreatePal;
DirectVideo:=False;
case sunx of
-2 : begin
x:=5;
y:=20;
end;
-1 : begin
x:=10;
y:=20;
end;
0 : begin
x:=15;
y:=15;
end;
1 : begin
x:=20;
y:=10;
end;
2 : begin
x:=20;
y:=5;
end;
end;
x2:=32;
y2:=32;
if sunz=-1 then
begin
x2:=x;
y2:=y;
x:=32;
y:=32;
end;
zval:=(ysize-2)-eyeZ;
y3:=100-(80*(0-eyeY) div Zval);
if Falloff then DoStars
else
begin
Gline(0,0,319,0,x,y);
Gline(319,0,319,y3,y,y2);
Gline(319,y3,0,y3,y2,x2);
Gline(0,y3,0,0,x2,x);
DispGPoly(800);
end;
for z:=Ysize-2 downto 2 do
begin
zval:=Z-eyeZ;
xval:=(2-eyeX)+1;
if zval>2 then
begin
x2:=160+LONGINT(310*xval div Zval);
x3:=160+LONGINT(310*xval div (Zval-1));
y2:=100-(80*(land[z]^[3]-eyeY) div Zval);
y3:=100-(80*(land[z-1]^[3]-eyeY) div (Zval-1));
end;
for x:=2 to Xsize-2 do
begin
zval:=Z-eyeZ;
xval:=(X-eyeX)+1;
If Keypressed then Exit;
x1:=x2;
y1:=y2;
if Zval>4 then
begin
x2:=160+LONGINT(310*xval div Zval);
y2:=100-(80*(land[z]^[x+1]-eyeY) div Zval);
x4:=x3;
y4:=y3;
x3:=160+LONGINT(310*xval div (Zval-1));
y3:=100-(80*(land[z-1]^[x+1]-eyeY) div (Zval-1));
if ((x1>0) and (x1<320)) or
((x2>0) and (x2<320)) or
((x3>0) and (x3<320)) or
((x4>0) and (x4<320)) or
((y1>0) and (y1<200)) or
((y2>0) and (y2<200)) or
((y3>0) and (y3<200)) or
((y4>0) and (y4<200)) then
begin
ClearPolyQ;
col:=FindPolyColor(x,z);
If NOT GOURAD then
begin
Bline(x1,y1,x2,y2);
Bline(x2,y2,x3,y3);
Bline(x3,y3,x4,y4);
Bline(x4,y4,x1,y1);
DispPoly (col,Integer(Zval));
end
else
begin
col2:=FindPolycolor(x+1,z);
col3:=FindPolycolor(x+1,z-1);
col4:=FindPolycolor(x,z-1);
Gline(x1,y1,x2,y2,col,col2);
Gline(x2,y2,x3,y3,col2,col3);
Gline(x3,y3,x4,y4,col3,col4);
Gline(x4,y4,x1,y1,col4,col);
DispGPoly(Integer(Zval)) ;
end;
if Zval>MaxInt then Zval:=MaxInt;
if Zval<-MaxInt then Zval:=-MaxInt;
DispPoly (col,Integer(Zval));
end;
end;
end;
end;
save;
end;
Procedure ShowScape;
Var
mul,
count,
Lx,
Fx,
Fy,
Ly,
Rx,
Ry,
X,Y,
Z,C : LongInt;
col : Byte;
k : Char;
MinScreenx,
MaxScreenX : Integer;
begin
Inline($B8/$13/0/$CD/$10);
CreatePal;
DirectVideo:=False;
GotoXY(1,1);
if Falloff then DoStars
else
for z:=1 to 18 do
fillchar(mem[$a000:(z*10)*320],320*10,z+5);
mul:=round(320/(Xsize/(Ysize+eyeZ)));
MinScreenX:=2;
MaxScreenX:=Xsize-2;
for z:=Ysize downto EyeZ+2 do
begin
for x:=MinScreenX to MaxScreenX do
begin
If Keypressed then Exit;
Lx:=INTEGER(160+(Mul*(x-eyeX) div (z-eyeZ)));
Fx:=INTEGER(160+(Mul*((x-eyeX)-1) div (z-eyeZ)));
Fy:=100-(80*((land[z]^[x] div mode)-eyeY) div (z-eyeZ));
Ly:=100-(80*(land[z]^[x]-eyeY) div (z-eyeZ));
col:=FindColor(x,z);
for ry:=Ly to Fy do
for Rx:=Fx to Lx do
if (rx>-1) and (rx<320) and (ry>-1) and (ry<200) then
mem[$a000:320*ry+rx]:=col
else
begin
if (rx<0) and (x>MinscreenX) then minscreenX:=x;
if (rx>319) and (x<MaxscreenX) then maxscreenX:=x;
end;
end;
end;
save;
end;
Procedure load;
var
f : File;
key : Char;
begin
{$I-}
assign(f,Filename+'.RAW');
reset(f,1);
If IOResult=0 then
begin
blockread(f,mem[$A000:0],$FA00);
close(f);
createPal;
key:=readkey;
end
else
begin
sound(500);
delay(500);
nosound;
end;
Drawscreen;
DrawMap;
end;
Procedure Menu;
var
ex,ey,
x,y : Longint;
Line : Byte;
Quit : Boolean;
key : char;
golly,
Click : Boolean;
NegClick : Boolean;
Procedure VectorMenu;
begin
line:=10;
Repeat
click:=False;
NegClick:=False;
gotoXY(19,line);
Write('�');
if keypressed then
begin
GotoXY(19,line);
Write(' ');
key:=readkey;
if key=#0 then
begin
key:=readkey;
case key of
#72 : Dec(Line);
#77 : Click:=True;
#75 : NegClick:=True;
#80 : Inc(line);
end;
end
else
case key of
'+' : Click:=True;
'-' : NegClick:=True;
' ' : NegClick:=True;
#13 : Click:=True;
end;
if Click=True then
case Line of
10 : inc(sunX);
11 : inc(SunZ);
12 : inc(SunY);
end
else
if NegClick=True then
case Line of
10 : dec(sunX);
11 : dec(SunZ);
12 : dec(SunY);
end;
if SunX<-2 then SunX:=2;
if SunX>2 then SunX:=-2;
if SunY<1 then SunY:=3;
if SunY>3 then SunY:=1;
if SunZ<-2 then SunZ:=2;
if SunZ>2 then SunZ:=-2;
if Line=9 then line:=12;
if Line=13 then line:=10;
gotoXY(20,10);
Write('X :',SunX:8);
gotoXY(20,11);
Write('Y :',SunZ:8);
gotoXY(20,12);
Write('Elivation :',SunY:8);
end;
Until key=#27
end;
begin
Golly:=False;
Line:=2;
Repeat
Click:=False;
NegClick:=False;
key:=#255;
gotoXY(17,Line);
Write('�');
if keypressed then
begin
GotoXY(17,line);
Write(' ');
key:=readkey;
if key=#0 then
begin
key:=readkey;
case key of
#72 : Dec(Line);
#77 : Click:=True;
#75 : NegClick:=True;
#80 : Inc(line);
end;
end
else
Case upcase(key) of
'L' : Load;
'P' : Begin
PrepData;
DrawMap;
end;
#13 : Click:=True;
#32 : Click:=True;
#27 : If Line<>20 then
Line:=20
else
Click:=True;
end;
end;
if Line=1 then line:=20;
if Line=21 then line:=2;
if NegClick then
case line of
4 : Begin
Dec(Water,10);
gotoXY(18,4);
Write('Water Level :',water:8);
end;
6 : Begin
if eyeY>5 then
dec(EyeY);
gotoxy(18,6);
Write('Eye Level :',eyey+Water:8);
end;
7 : Begin
if jitter>0 then
dec(Jitter);
gotoXY(18,7);
Write('Jitter :',Jitter:8);
end;
14 : Begin
dec(eyeX,5);
if EyeX<5 then EyeX:=Xsize-5;
drawmap;
gotoXY(18,14);
Write('Eye Pos X :',eyeX:8);
end;
15 : Begin
dec(eyeZ,5);
if EyeZ<5 then EyeZ:=YSize-5;
drawmap;
gotoXY(18,15);
Write('Eye Pos Y :',eyeZ:8);
end;
end;
if Click then
case line of
2 : begin
seed:=Random(65535);
gotoXY(18,2);
Write('Seed Value :',seed:8);
end;
3 : Begin
f:=(Random*3)+0.5;
Interactive:=Not Interactive;
gotoXY(18,3);
if not Interactive then
Write('Grain :',f:8:3)
else
Write('Interactive Method ');
end;
4 : begin
Inc(Water,10);
gotoXY(18,4);
Write('Water Level :',water:8);
end;
5 : Begin
if Gourad=True then
begin
PolyView:=False;
Gourad:=False;
end
else
If PolyView=True then
Gourad:=True
else
PolyView:=True;
gotoXY(18,5);
if Gourad=True
then
Write('Full detail mode.')
else
if PolyView then
Write('Polygon mode. ')
else
Write('Quick view mode. ');
end;
6 : Begin
if eyeY<300 then
inc(EyeY);
gotoxy(18,6);
Write('Eye Level :',eyey+Water:8);
end;
7 : Begin
if jitter<15 then
inc(Jitter);
gotoXY(18,7);
Write('Jitter :',Jitter:8);
end;
8 : Begin
Falloff:=NOT Falloff;
If Falloff then
begin
Suny:=2;
SunX:=0;
SunZ:=1;
end;
gotoXY(18,8);
If Falloff then
Write('Night Time')
else
Write('Day Time ');
gotoXY(18,9);
Write('Light vectors');
gotoXY(20,10);
Write('X :',SunX:8);
gotoXY(20,11);
Write('Y :',SunZ:8);
gotoXY(20,12);
Write('Elivation :',SunY:8);
end;
9,10,11,12 : if not falloff then VectorMenu;
13 : Begin
gotoXY(18,13);
Write(' ');
gotoXY(18,13);
Write('Filename :');
Readln(Filename);
if NOT Exist(Filename)
then save
else load;
end;
14 : Begin
inc(eyeX,5);
if EyeX>(Xsize-5) then EyeX:=5;
drawmap;
gotoXY(18,14);
Write('Eye Pos X :',eyeX:8);
end;
15 : Begin
inc(eyeZ,5);
if eyez>500 then eyez:=5;
drawmap;
gotoXY(18,15);
Write('Eye Pos Y :',eyeZ:8);
end;
17 : Begin
MakeScape;
DrawMap;
Golly:=True;
end;
18 : If Golly Then
begin
case PolyView of
TRUE : ShowScapePoly;
FALSE : ShowScape;
end;
DrawScreen;
DrawMap;
While KeyPressed do
key:=ReadKey;
key:=#255;
end;
20 : Quit:=True;
END;
until Quit=True;
end;
begin
Writeln('Landcap v',ver,'.',update,' (c) T.Frogley 1993');
Writeln('Loading...');
If ISVGA then
begin
FindMem;
Defalts;
DrawScreen;
Menu;
ClearMem;
Textmode(lastmode);
Writeln('Thanks for using LANDCAP v',ver,'.',update,' - Fractal landscape generator.');
Writeln(' T.Frogley (c) 1993');
Writeln('You may freely distribute this program on condition that you do not change it.');
Writeln(#10#13'If you enjoyed using it please consider sending me �10 as it has taken');
Writeln('many months to complete, and is all my own work. ');
Writeln(' Thad,');
Writeln(' 38 Bentfield Causeway');
Writeln(' Stansted');
Writeln(' Essex, CM24 8HU');
Writeln(#10#13'In return for sending me �10 I will send you an extended copy of LANDCAP');
Writeln('Which will include:');
Writeln(' Set up save option,');
Writeln(' Animation module,');
Writeln(' Controled GRAIN and SEED adustment,');
Writeln(' PCX File save,');
Writeln(' Cloud backdrops,');
Writeln(' Rock, Ice ,Mars palettes & palette editor');
Writeln(' I also hope to have natural rivers and full rotation working by March ''94');
end
else
Writeln('Sorry, you will need a VGA compatable card and monitor to run Landcap.');
end.
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment