{*
 * @(#) land.pas - 2D/3D graphic demonstration program (landscape painting).
 * (c) 1994 Ivan Maidanski <ivmai@chat.ru> http://ivmai.chat.ru
 * Freeware program source. All rights reserved.
 **
 * Language: Turbo Pascal
 * Tested with: Turbo Pascal v7.0
 * Last modified: 1994-08-13 18:40:00 GMT+04:00
 *}

program LandScape;

{$A-,B-,D+,E-,F-,G-,I-,L+,N-,O-,R-,S-,V-,X-}
{$M 1024,0,32768}
uses Graph;
const MaxX= 254;
const MaxY= 254;
const MaxH= 100;
var H: Byte;
var Map: Boolean;
var Diff: Real;
procedure InitScreen;
 var Driver,Mode: Integer;
 begin
   Driver:=Detect;
   InitGraph(Driver,Mode,'');
   Driver:=GraphResult;
   if Driver<>GrOk
     then begin
            WriteLn('Graphics Error: ',GraphErrorMsg(Driver));
            Halt
          end
 end;
function TestInput(Cond: Boolean): Boolean;
 begin
   Cond:=(IOResult=0) and Cond;
   if not Cond
     then WriteLn(' Bad Value!');
   TestInput:=Cond
 end;
procedure AskMap;
 var C :Char;
 begin
   WriteLn;
   repeat
     Write('Drawing (3D or 2D) ? ');
     ReadLn(C)
   until TestInput((C='2') or (C='3'));
   Map:=C='2'
 end;
procedure AskDiff;
 begin
   repeat
     Write('Enter Height Differensation: ');
     ReadLn(Diff)
   until TestInput((Diff>=0.01) and (Diff<=5))
 end;
procedure AskHeight;
 begin
   repeat
     Write('Enter Maximal Height: ');
     ReadLn(H)
   until TestInput((H>=0) and (H<=MaxH))
 end;
function Average(A,B: Byte): Byte;
 begin
   Average:=(Word(A)+Word(B)) div 2
 end;
function PutColor(H: Byte): Byte;
 const Sea= 15;
 const Lake= 25;
 const Bush= 30;
 const Wood= 40;
 const Peak= 80;
 begin
   if H>Lake
     then PutColor:=H-Lake
     else PutColor:=0;
   if H>Lake
     then if H>Wood
            then if H>Peak
                   then SetColor(White)
                   else SetColor(Brown)
            else if H>Bush
                   then SetColor(Green)
                   else SetColor(LightGreen)
     else if H>Sea
            then SetColor(LightBlue)
            else SetColor(Blue)
 end;
procedure DrawLand(X,Y: Word; H: Byte);
 var YL: Word;
 begin
   YL:=Y;
   X:=(GetMaxX-MaxX) div 2+X;
   Y:=(GetMaxY-MaxY) div 2+Y;
   if Map
     then H:=0
     else begin
            X:=MaxY div 2+X-YL;
            Y:=MaxH div 4+Y-YL div 2
          end;
   Line(X,Y,X,Y-H)
 end;
procedure NewHeight(Xmin,Ymin,Xmax,Ymax: Byte; var H: Byte);
 var D: Integer;
 begin
   Dec(Xmax,Xmin);
   Dec(Ymax,Ymin);
   D:=Trunc(Sqrt(Sqr(Word(Xmax))+Sqr(Word(Ymax)))*Diff);
   D:=H+Integer(Random(D))-Integer(Random(D));
   if D<0
     then H:=0
     else if D>MaxH
            then H:=MaxH
            else H:=D
 end;
procedure Land(Xmin,Ymin,Xmax,Ymax,H1,H2,H3,H4: Byte);
 var H,CX,CY,N1,N2,N3,N4: Byte;
 begin
   H:=Average(Average(H1,H2),Average(H3,H4));
   if (Xmin=Xmax) and (Ymin=Ymax)
     then DrawLand(Xmin,Ymin,PutColor(H))
     else if (Xmin<=Xmax) and (Ymin<=Ymax)
            then begin
                   CX:=Average(Xmin,Xmax);
                   CY:=Average(Ymin,Ymax);
                   N1:=Average(H1,H2);
                   N2:=Average(H3,H4);
                   N3:=Average(H1,H3);
                   N4:=Average(H2,H4);
                   NewHeight(Xmin,Ymin,Xmax,Ymax,H);
                   Land(Xmin,Ymin,CX,CY,H1,N1,N3,H);
                   Land(Succ(CX),Ymin,Xmax,CY,N1,H2,H,N4);
                   Land(Xmin,Succ(CY),CX,Ymax,N3,H,H3,N2);
                   Land(Succ(CX),Succ(CY),Xmax,Ymax,H,N4,N2,H4)
                 end
 end;
function AskQuit: Boolean;
 var C: Char;
 begin
   WriteLn;
   repeat
     Write('Continue (Y/N) ? ');
     ReadLn(C);
     C:=UpCase(C)
   until TestInput((C='Y') or (C='N'));
   AskQuit:=C='N'
 end;
procedure DoneScreen;
 begin
   CloseGraph;
   RestoreCRTMode;
   WriteLn('The End.')
 end;
begin
  Randomize;
  InitScreen;
  repeat
    AskMap;
    AskDiff;
    AskHeight;
    ClearDevice;
    Land(0,0,MaxX,MaxY,Random(H),Random(H),Random(H),Random(H))
  until AskQuit;
  DoneScreen
end.