program Pyramid;
uses
	Graph;
const
	rPyr = 100;  { Радиус основания пирамиды }
   hPyr = 240;  { Высота пирамиды }
   A 	  = 0;
   B 	  = 0;
   C 	  = 1;
   D 	  = 50;
   n 	  = 7;
   eps  = 0.25; { Погрешность }
type
	tPoint = record  { Точка }
   	x, y, z: real
   end;
   tLine = record   { Прямая }
   	bol, eol: tPoint
   end;
   tPlane = record  { Плоскость }
   	A, B, C, D: real
   end;
   tVector = record { Вектор }
   	x, y, z: real
   end;

   tTriangle = record  { Плоскость }
   	a, b, c: tPoint;
   end;

var
	Gd, Gm    : Integer;  { Графика }
   Radius    : Integer;  { Радиус }
   pInt      : tPoint;   { Точка пересечения }
   angle  	 : real;
   lin	 	 : tLine;
   plane	 	 : tPlane;
   match  	 : Boolean;
   paral  	 : Boolean;
   intercept : Boolean;
   pyr	  	 : array[1..7] of tPoint;
   tri		 : tTriangle;

procedure Interception(l: tLine; s: tPlane);
var
	p: tVector;
   M, N, t: real;
begin
   p.x:= (l.bol.x - l.eol.x);
   p.y:= (l.bol.y - l.eol.y);
   p.z:= (l.bol.z - l.eol.z);
   M:= s.A*p.x + s.B*p.y + s.C*p.z;
   N:= s.A*l.eol.x + s.B*l.eol.y + s.C*l.eol.z + s.D;
   if M <> 0 then begin
   	t:= (N)/M;
      if (0 <= t) and (t <= 1) then begin
         intercept:= true;
		   pInt.x:= (l.eol.x + p.x*t);
		   pInt.y:= (l.eol.y + p.y*t);
         pInt.z:= (l.eol.z - p.z*t);
      end
   end;
end;

procedure Proection(var p: tPoint); {Проекция (кабинетная)}
const
	two = 2;
var
	k: real;
begin
   k:= two*sqrt(two);
	p.x:= GetMaxX div 2 + p.x + p.y/k;
   p.y:= GetMaxY div 2 + p.z + p.y/k;
end;

procedure DrawAxes(c: integer); {Рисование осей}
const
	indent = 10;
begin
   SetColor(c);
   Line(GetMaxX div 2, GetMaxY div 2, GetMaxX, GetMaxY div 2); {X}
   OutTextXY(GetMaxX - indent, GetMaxY div 2 + indent, 'X');
   Line(GetMaxX div 2, GetMaxY div 2, 0, GetMaxY); 				{Y}
   OutTextXY(0, GetMaxY - 2*indent, 'Y');
   Line(GetMaxX div 2, GetMaxY div 2, GetMaxX div 2, 0); 		{Z}
   OutTextXY(GetMaxX div 2 +indent, indent, 'Z');
end;

procedure DrawPyr(r, h, c: integer); {Рисование пирамиды}
var
	angle: real;   {Угол}
   p	  : tPoint; {Точка}
   i    : integer;
begin
	angle:= -pi/3;
   p.x:= Round(r*Cos(0));
   p.y:= Round(r*Sin(0));
   p.z:= 0;
   i:= 1;
   MoveTo(GetMaxX div 2 + Round(p.x), GetMaxY div 2+ Round(p.y));
	while (i <= n) and (angle <= 2*pi) do begin
      p.x:= Round(r*Cos(angle));
      p.y:= Round(r*Sin(angle));
      pyr[i]:= p;
      Proection(p);
      SetColor(c);
   	LineTo(Round(p.x), Round(p.y));
      Line(Round(p.x), Round(p.y), GetMaxX div 2, GetMaxY div 2 - h );
      angle:= angle + pi/3;
      i:= i + 1;
    end;
    pyr[n].x:= 0; pyr[n].y:= 0; pyr[n].z:= hPyr;
end;

procedure PlaneTri(p: tPlane; t: tTriangle);
var
	c	 : integer;
   l	 : tLine;
   aInt: array[1..2] of tPoint;
begin
   c:= 0;
	l.bol:= t.a;
   l.eol:= t.b;
   Interception(l, p);
   if intercept then begin
   	c:= c + 1;
      aInt[c]:= pInt;
   end;
   l.bol:= t.b;
   l.eol:= t.c;
   Interception(l, p);
   if intercept then begin
   	c:= c + 1;
      aInt[c]:= pInt;
   end;
   l.bol:= t.c;
   l.eol:= t.a;
   Interception(l, p);
   if intercept then begin
   	c:= c + 1;
      aInt[c]:= pInt;
   end;
   if c > 0 then begin
   	Proection(aInt[1]);
      Proection(aInt[2]);
      SetLineStyle(0, 0, 3);
      SetColor(green);
      Line(Round(aInt[1].x), Round(aInt[1].y), Round(aInt[2].x), Round(aInt[1].y));
   end;
end;

procedure GenTri(var t: tTriangle);
var
	i: integer;
begin
	for i:= 1 to n - 1 do
   	if i = n - 1 then begin
      	t.b:= pyr[i];
         t.c:= pyr[2];
         PlaneTri(plane, t);
         end
      else begin
      	t.b:= pyr[i];
         t.c:= pyr[i + 1];
         PlaneTri(plane, t);
      end;
end;

begin
   {Инициализация графики}
      Gd:= Detect;
      InitGraph(Gd, Gm, '');
      if GraphResult <> grOk then
   	   Halt;
   {Рисование осей}
   	DrawAxes(green);
   {Генерация вершин и рисование пирамиды}
   	DrawPyr(rPyr, hPyr, white);
   {Расчет точек и построение сечения}
      plane.A:= A; plane.B:= B; plane.C:= C; plane.D:= D;
   {Триангуляция основания}
      tri.a.x:= 0; tri.a.y:= 0; tri.a.z:= 0;
      GenTri(tri);
   {Триангуляция боковой поверхности}
      tri.a:= pyr[n];
      GenTri(tri);
   ReadLn;
   CloseGraph;
end.