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 …

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.