Uses Crt,VGAE;

Const
 cMax3DPoints = 3000;
 cMaxFaces = 7000;
 cMaxMVs = 6280;

Type
 T3DPoint = Record
             x,y,z : Real;
            end;
 TFace = Record
          pn : Array[1..4] of Word;
          d : Byte;
         end;
 TPointsArray = Array[1..cMax3DPoints] of T3DPoint;
 TFacesArray = Array[1..cMaxFaces] of TFace;
 TSFArray = Array[1..cMaxFaces] of Word;
 TMA = Array[0..cMaxMVs] of Real;

Var
 P : ^TPointsArray;
 F : ^TFacesArray;
 SF : ^TSFArray;
 MP,MF : Word;
 fMainExit : Boolean;
 Angle : Real;
 SinT,CosT : ^TMA;

Function CosF(Angle:Real):Real;
Var
 t : LongInt;
begin
 t:=Trunc(Angle*1000);

  If t>cMaxMVs then t:=t-cMaxMVs;

  If t<0 then t:=t+cMaxMVs;
 CosF:=CosT^[t];
end;

Function SinF(Angle:Real):Real;
Var
 t : LongInt;
begin
 t:=Trunc(Angle*1000);

  If t>cMaxMVs then t:=t-cMaxMVs;

  If t<0 then t:=t+cMaxMVs;
 SinF:=SinT^[t];
end;

Procedure AddPoint(nx,ny,nz:Real);
begin
  If MP+1>cMax3DPoints then Exit;
 Inc(MP);
  With P^[MP] do
   begin
    x:=nx;
    y:=ny;
    z:=nz;
   end;
end;

Procedure InsertPoint(pn:Word; nx,ny,nz:Real);
begin
  If pn+1>cMax3DPoints then Exit;
  If pn>MP then MP:=pn;
  With P^[MP] do
   begin
    x:=nx;
    y:=ny;
    z:=nz;
   end;
end;

Procedure AddFace(np1,np2,np3,np4:Word; nd:Byte);
begin
  If MF+1>cMaxFaces then Exit;
 Inc(MF);
  With F^[MF] do
   begin
    pn[1]:=np1;
    pn[2]:=np2;
    pn[3]:=np3;
    pn[4]:=np4;
    d:=nd;
   end;
end;

Procedure InsertFace(fn,np1,np2,np3,np4:Word; nd:Byte);
begin
  If fn+1>cMaxFaces then Exit;
  If fn>MF then MF:=fn;
  With F^[MF] do
   begin
    pn[1]:=np1;
    pn[2]:=np2;
    pn[3]:=np3;
    pn[4]:=np4;
    d:=nd;
   end;
end;

Procedure Init;
Var
 c : Word;
begin
 Randomize;
 MP:=0;
 MF:=0;
 New(P);
 New(F);
 New(SF);
 New(CosT);
 New(SinT);
  For c:=0 to cMaxMVs do
   begin
    CosT^[c]:=Cos(c/1000);
    SinT^[c]:=Sin(c/1000);
   end;
 fMainExit:=False;
 InitVGA;
 ClearScreen(0);
 DrawScreen;
end;

Procedure Done;
begin
 DoneVGA;
 Dispose(SinT);
 Dispose(CosT);
 Dispose(SF);
 Dispose(F);
 Dispose(P);
end;

Procedure RotateX(Var x,y,z:Real; Angle:Real);
Var
 ty,tz : Real;
begin
 ty:=y*CosF(Angle)+z*SinF(Angle);
 tz:=-y*SinF(Angle)+z*CosF(Angle);
 y:=ty;
 z:=tz;
end;

Procedure RotateY(Var x,y,z:Real; Angle:Real);
Var
 tx,tz : Real;
begin
 tx:=x*CosF(Angle)-z*SinF(Angle);
 tz:=x*SinF(Angle)+z*CosF(Angle);
 x:=tx;
 z:=tz;
end;

Procedure RotateZ(Var x,y,z:Real; Angle:Real);
Var
 tx,ty : Real;
begin
 tx:=x*CosF(Angle)+y*SinF(Angle);
 ty:=-x*SinF(Angle)+y*CosF(Angle);
 x:=tx;
 y:=ty;
end;

Function ProjectPoint(x,y,z:Real; Var sx,sy:Integer):Boolean;
Var
 t : Real;
begin
 ProjectPoint:=False;
  If z<=0 then Exit;
 t:=x*cMaxY/z;
{  If Abs(t)>cMaxX*2 then Exit;}
  If Abs(t)>cMaxX div 2 then Exit;
{!} { Здесь нужно придумать правильные границы выхода за экран }
    { Что лучше: cMaxX*2 (рисовать с "запасом") или
                 cMaxX div 2 (присекать любые попытки выхода за экран)? }
 sx:=160+Trunc(t);
 t:=y*cMaxY/z;
{  If Abs(t)>cMaxY*2 then Exit;}
  If Abs(t)>cMaxY div 2 then Exit;
 sy:=100+Trunc(t);
 ProjectPoint:=True;
end;

Procedure DrawPoints;
Var
 c : Word;
 sx,sy : Integer;
begin
  For c:=1 to MP do
   With P^[c] do
    If ProjectPoint(x,y,z,sx,sy) then PutPixel(sx,sy,15);
end;

Procedure DPolygon(x1,y1,x2,y2,x3,y3,x4,y4:Integer; d:Byte);
begin
 Line(x1,y1,x2,y2,d);
 Line(x2,y2,x3,y3,d);
 Line(x3,y3,x4,y4,d);
 Line(x4,y4,x1,y1,d);
end;

Function CenterZ(fn:Word):Real;
begin
 CenterZ:=(P^[F^[fn].pn[1]].z+P^[F^[fn].pn[2]].z+
           P^[F^[fn].pn[3]].z+P^[F^[fn].pn[4]].z)/4;
end;

Procedure SortFaces;

Var
 c,w,t : Word;
 x1,y1,z1,x2,y2,z2 : Real;

Procedure Sort(l,r:Integer);
Var
 i,j : Integer;
 y : Word;
 x : Real;
begin
 i:=l;
 j:=r;
 x:=CenterZ(SF^[(l+r) div 2]);
  Repeat
    While CenterZ(SF^[i])>x do i:=i+1;
    While x>CenterZ(SF^[j]) do j:=j-1;
    If i<=j then
     begin
      y:=SF^[i];
      SF^[i]:=SF^[j];
      SF^[j]:=y;
      i:=i+1;
      j:=j-1;
     end;
  Until i>j;
  If l<j then Sort(l,j);
  If i<r then Sort(i,r);
end;

begin
  For c:=1 to MF do SF^[c]:=c;
 Sort(1,MF);
{!} { Может быть можно сделать сортировку еще быстрее? }
{ Здесь закоментирован метод сортировки пузырьком :)
  For c:=1 to MF do
   For w:=1 to MF do
   begin
    CenterXYZ(SF^[c],x1,y1,z1);
    CenterXYZ(SF^[w],x2,y2,z2);
     If z2<z1 then
      begin
       t:=SF^[c];
       SF^[c]:=SF^[w];
       SF^[w]:=t;
      end;
   end;
}
end;

Procedure DrawFaces;
Var
 c,w : Word;
 sx,sy : Array[1..4] of Integer;
begin
 SortFaces;
  For c:=1 to MF do
   With F^[SF^[c]] do
    begin
     If (ProjectPoint(P^[pn[1]].x,P^[pn[1]].y,P^[pn[1]].z,sx[1],sy[1]) and
         ProjectPoint(P^[pn[2]].x,P^[pn[2]].y,P^[pn[2]].z,sx[2],sy[2]) and
         ProjectPoint(P^[pn[3]].x,P^[pn[3]].y,P^[pn[3]].z,sx[3],sy[3]) and
         ProjectPoint(P^[pn[4]].x,P^[pn[4]].y,P^[pn[4]].z,sx[4],sy[4])) then
{ Это, по крайней мере, не вешает/убивает задачу при выходе за экран
      DPolygon(sx[1],sy[1],sx[2],sy[2],sx[3],sy[3],sx[4],sy[4],d);
}
      Polygon(sx[1],sy[1],sx[2],sy[2],sx[3],sy[3],sx[4],sy[4],d);
    end;
end;

Procedure MoveMap(Step:Real);
Var
 c : Word;
begin
  For c:=1 to MP do
   With P^[c] do z:=z+Step;
end;

Procedure RollMap(Step:Real);
Var
 c : Word;
begin
  For c:=1 to MP do
   With P^[c] do x:=x+Step;
end;

Procedure LiftMap(Step:Real);
Var
 c : Word;
begin
  For c:=1 to MP do
   With P^[c] do y:=y+Step;
end;

Procedure RotateXMap(Angle:Real);
Var
 c : Word;
begin
  For c:=1 to MP do
   With P^[c] do
    RotateX(x,y,z,Angle);
end;

Procedure RotateYMap(Angle:Real);
Var
 c : Word;
begin
  For c:=1 to MP do
   With P^[c] do RotateY(x,y,z,Angle);
end;

Procedure RotateZMap(Angle:Real);
Var
 c : Word;
begin
  For c:=1 to MP do
   With P^[c] do
    RotateZ(x,y,z,Angle);
end;

Procedure AddHut(tx,ty,tz,h,r:Real; c1,c2:Byte);
Var
 a : Real;
 OMP : Word;
begin
 a:=0;
 AddPoint(tx,ty-h*2,tz);
 OMP:=MP;
 AddPoint(tx+r*CosF(a),ty-h,tz-r*SinF(a));
 AddPoint(tx+r*CosF(a),ty,tz-r*SinF(a));
  Repeat
   a:=a+0.5;
    If a<=6.28 then
     begin
      AddPoint(tx+r*CosF(a),ty-h,tz-r*SinF(a));
      AddPoint(tx+r*CosF(a),ty,tz-r*SinF(a));
      AddFace(MP-3,MP-2,MP,MP-1,15+(MP-OMP) div 2);
       If ((MP-OMP) div 2) mod 2=0 then
        AddFace(MP-3,MP-1,OMP,OMP,c1) else
        AddFace(MP-3,MP-1,OMP,OMP,c2);
     end else
     begin
      AddFace(OMP+1,OMP+2,MP,MP-1,15+(MP-OMP) div 2);
       If ((MP-OMP) div 2) mod 2=0 then
        AddFace(MP-3,OMP+1,OMP,OMP,c1) else
        AddFace(MP-3,OMP+1,OMP,OMP,c2);
     end;
  Until a>6.28;
end;

Procedure Run;
Var
 Key : Char;
begin
{
 InsertPoint(1,-50,-50,50);
 InsertPoint(2,50,-50,50);
 InsertPoint(3,50,50,50);
 InsertPoint(4,-50,50,50);
 InsertPoint(5,0,0,0);

 InsertPoint(6,-50,-50,0);
 InsertPoint(7,50,-50,0);
 InsertPoint(8,50,50,0);
 InsertPoint(9,-50,50,0);

 InsertFace(1,1,2,3,4,1);
 InsertFace(2,1,2,5,5,2);
 InsertFace(3,2,3,5,5,3);
 InsertFace(4,3,4,5,5,4);
 InsertFace(5,4,1,5,5,5);
 InsertFace(6,6,7,8,9,7);
}
 AddHut(0,50,1000,Random(50)+100,Random(200)+200,2,10);
 AddHut(-1000,50,0,Random(50)+100,Random(200)+200,5,13);
 AddHut(1000,50,0,Random(50)+100,Random(200)+200,3,11);
 MoveMap(2000);
 LiftMap(700);
  Repeat
   ClearScreen(0);
   DrawFaces;
{   DrawPoints;}
   DrawScreen;
    If KeyPressed then
     begin
      Key:=ReadKey;
       Case UpCase(Key) of
         #0 : Case ReadKey of
               #75 : RotateYMap(-0.05);
               #77 : RotateYMap(0.05);
               #72 : RotateXMap(-0.05);
               #80 : RotateXMap(0.05);
               #68 : fMainExit:=True;
              end;
        'A' : MoveMap(-20);
        'Z' : MoveMap(20);
        'I' : LiftMap(10);
        'K' : LiftMap(-10);
        'U' : RotateZMap(0.05);
        'O' : RotateZMap(-0.05);
        'J' : RollMap(10);
        'L' : RollMap(-10);
       end;
     end;
  Until fMainExit;
end;

Begin
 Init;
 Run;
 Done;
End.