Нарисовать шестигранную пирамиду в 3d пространстве

{$n+}
uses graph;
 
type
  TPoint = record
    X, Y, Z: double;
  end;
  PTArr = ^TArr;
  TArr = array[1 .. pred(maxint div sizeof(TPoint))] of TPoint;
 
const
  R2D = 180 / Pi;
 
const
  rPyrBig   = 50;
  hPyr = 140;
 
 
var
  centerX, centerY: integer;
 
const
  sqrt2 = 1.414213562;
function CoordX(X, Z: double): integer;
begin
  CoordX := trunc((X + CenterX) - Z);
end;
function CoordY(Y, Z: double): integer;
begin
  CoordY := Trunc(CenterY - Y + Z);
end;
 
procedure draw3DPnt(P: TPoint);
var
  NewZ: integer;
begin
  NewZ := trunc(P.Z / sqrt2);
  putpixel( CoordX(P.X, NewZ), CoordY(P.Y, NewZ), White);
end;
 
procedure Draw3DLine(P1, P2: TPoint);
var Z1, Z2: integer;
begin
  Z1 := trunc(P1.Z / sqrt2);
  moveto( CoordX(P1.X, Z1), CoordY(P1.Y, Z1) );
  Z2 := trunc( P2.Z / Sqrt2 );
  lineto( CoordX(P2.X, Z2), CoordY(P2.Y, Z2) );
end;
 
procedure Axis(Color: integer);
begin
  cleardevice;
  setcolor(Color);
  line(1, CenterY, GetMaxX, CenterY);
  line(CenterX, 1, CenterX, GetMaxY);
  line(CenterX - CenterY, GetMaxY,
       CenterX + CenterY, 1);
  setcolor(White);
  rectangle(1, 1, GetMaxX, GetMaxY)
end;
 
procedure Pyramide(R, H, N, color: integer);
var
  curr_angle, DAngle: double;
  below: PTArr;
  i: integer;
const
  P : TPoint = (X:0; Y:0; Z:0);
begin
  getmem(below, N * sizeof(TPoint));
 
  DAngle := (360 div n) / R2D;
  curr_angle := 0.1; i := 0;
  repeat
    inc(i);
    below^[i].X := R*sin(curr_angle);
    below^[i].Z := R*cos(curr_angle);
    below^[i].Y := 0;
    curr_angle := curr_angle + DAngle;
  until i = n;
 
  p.Y := H;
  for i := 1 to n do begin
    if i > 1 then draw3dLine(below^[pred(i)], below^[i]);
    draw3dLine(below^[i], P);
  end;
  draw3dLine(below^[n], below^[1]);
 
  freemem(below, N * sizeof(TPoint));
end;
 
var
  Gd, Gm  : Integer;
 
begin
  Gd:= Detect;
  InitGraph(Gd, Gm, '');
  if GraphResult <> grOk then Halt;
 
  centerx := GetMaxX div 2; centery := GetMaxY div 2;
 
  Axis(Red);
  Pyramide(rPyrBig, hPyr, 6, 15);
 
  ReadLn;
  CloseGraph;
end.

{$n+}
uses graph;
 
type
  TPoint = record
    X, Y, Z: double;
  end;
  PTArr = ^TArr;
  TArr = array[1 .. pred(maxint div sizeof(TPoint))] of TPoint;
 
const
  R2D = 180 / Pi;
 
const
  rPyrBig   = 50;
  rPyrSmall = 20;
  hPyr = 140;
 
 
var
  centerX, centerY: integer;
 
const
  sqrt2 = 1.414213562;
function CoordX(X, Z: double): integer;
begin
  CoordX := trunc((X + CenterX) - Z);
end;
function CoordY(Y, Z: double): integer;
begin
  CoordY := Trunc(CenterY - Y + Z);
end;
 
procedure draw3DPnt(P: TPoint);
var
  NewZ: integer;
begin
  NewZ := trunc(P.Z / sqrt2);
  putpixel( CoordX(P.X, NewZ), CoordY(P.Y, NewZ), White);
end;
 
procedure Draw3DLine(P1, P2: TPoint);
var Z1, Z2: integer;
begin
  Z1 := trunc(P1.Z / sqrt2);
  moveto( CoordX(P1.X, Z1), CoordY(P1.Y, Z1) );
  Z2 := trunc( P2.Z / Sqrt2 );
  lineto( CoordX(P2.X, Z2), CoordY(P2.Y, Z2) );
end;
 
procedure Axis(Color: integer);
begin
  cleardevice;
  setcolor(Color);
  line(1, CenterY, GetMaxX, CenterY);
  line(CenterX, 1, CenterX, GetMaxY);
  line(CenterX - CenterY, GetMaxY,
       CenterX + CenterY, 1);
  setcolor(White);
  rectangle(1, 1, GetMaxX, GetMaxY)
end;
 
procedure Pyramide(RBig, RSmall, H, N, color: integer);
var
  curr_angle, DAngle: double;
  below, above: PTArr;
  i: integer;
begin
  getmem(below, N * sizeof(TPoint));
  getmem(above, N * sizeof(TPoint));
 
  DAngle := (360 div n) / R2D;
  curr_angle := 0.0; i := 0;
  repeat
    inc(i);
    below^[i].X := RBig*sin(curr_angle);
    below^[i].Z := RBig*cos(curr_angle);
    below^[i].Y := 0;
 
    above^[i].X := Rsmall*sin(curr_angle);
    above^[i].Z := Rsmall*cos(curr_angle);
    above^[i].Y := H;
 
    curr_angle := curr_angle + DAngle;
  until i = n;
 
  for i := 1 to n do begin
    if i > 1 then begin
      draw3dLine(below^[pred(i)], below^[i]);
      draw3dLine(above^[pred(i)], above^[i]);
    end;
    draw3dLine(below^[i], above^[i]);
  end;
  draw3dLine(below^[n], below^[1]);
  draw3dLine(above^[n], above^[1]);
 
  freemem(above, N * sizeof(TPoint));
  freemem(below, N * sizeof(TPoint));
 
end;
 
var
  Gd, Gm  : Integer;
 
begin
  Gd:= Detect;
  InitGraph(Gd, Gm, '');
  if GraphResult <> grOk then Halt;
 
  centerx := GetMaxX div 2; centery := GetMaxY div 2;
 
  Axis(Red);
  Pyramide(rPyrBig, rPyrSmall, hPyr, 6, 15);
 
  ReadLn;
  CloseGraph;
end.