program Pyramid;
uses
	Graph;
const
	rPyr = 75;  {Радиус основания пирамиды}
   hPyr = 240; {Высота пирамиды}
   A 	  = 0;
   B 	  = 1;
   C 	  = 0;
   D 	  = 0;
   n 	  = 7;
   k    = 20;
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;
var
	Gd, Gm : Integer;  {Графика}
   Radius : Integer;  {Радиус}
   pInt   : tPoint;   {Точка пересечения}
   angle  : real;
   lin	 : tLine;
   plane	 : tPlane;
   pOld	 : tPoint;
   match  : Boolean;
   paral  : Boolean;
   bok	 : Boolean;
   pyr	 : array [1..n] of tPoint;
   i, j   : integer;

   intercept: Boolean;
   curr_intr: integer;
  	arrIntr: array[1 .. k] of tPoint;

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.bol.x + s.B*l.bol.y + s.C*l.bol.z + s.D;
   if M <> 0 then begin
   	t:= (N)/M;
		pInt.x:= l.bol.x + p.x*t;
		pInt.y:= l.bol.y + p.y*t;
      pInt.z:= -(l.bol.z + p.z*t);
		intercept:= (((pInt.x <= lin.bol.x) and (lin.eol.x <= pInt.x)) or
                  ((pInt.x <= lin.eol.x) and (lin.bol.x <= pInt.x))) and
                  (((pInt.y <= lin.bol.y) and (lin.eol.y <= pInt.y)) or
                  ((pInt.y <= lin.eol.y) and (lin.bol.y <= pInt.y))) and
                  (((pInt.z <= lin.bol.z) and (lin.eol.z <= pInt.z)) or
                  ((pInt.z <= lin.eol.z) and (lin.bol.z <= pInt.z)))
      end
   else if M <> 0 then begin
   	if N = 0 then
         match:= true
      else
      	paral:= true;
	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; {Точка}
begin
	angle:= -pi/3;
   p.x:= Round(r*Cos(angle));
   p.y:= Round(r*Sin(angle));
   p.z:= 0;
   pyr[1].x:= 0;
   pyr[1].y:= 0;
   pyr[1].z:= hPyr;
   Proection(p);
   i:= 2;
   MoveTo(Round(p.x), Round(p.y));
	while (angle <= 5*pi/3) do begin
      p.x:= Round(r*Cos(angle));
      p.y:= Round(r*Sin(angle));
      if i <= n then
      	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;
end;

procedure DrawCut(var arr: array of tPoint; c: integer);
begin
	Proection(arrintr[1]);
   MoveTo(Round(arrintr[1].x), Round(arrintr[1].y));
   SetColor(c);
   for i:= 2 to curr_intr do begin
      Proection(arrintr[i]);
      LineTo(Round(arrintr[i].x), Round(arrintr[i].y));
   end;
   LineTo(Round(arrintr[1].x), Round(arrintr[1].y));
end;

begin
{Нахождение точек пересечения/ Finding interception points}
   plane.A:= A;
	plane.B:= B;
	plane.C:= C;
	plane.D:= D;
   curr_intr:= 0;
   for j:= 2 to i do begin
      lin.bol:= pyr[pred(j)];
      if j <> i then
			lin.eol:= pyr[j]
      else
			lin.eol:= pyr[1];
      Interception(lin, plane);
      if intercept and not paral then begin
         inc(curr_intr);
			arrIntr[curr_intr]:= pInt;
      end;
   end;
   lin.bol.x:= 0;
   lin.bol.y:= 0;
   lin.bol.z:= hPyr;
   for j:= 1 to pred(i) do begin
      lin.eol:= pyr[j];
      Interception(lin, plane);
      if intercept and not paral then begin
         inc(curr_intr);
			arrIntr[curr_intr]:= pInt;
      end;
   end;
{Инициализация графики/ Grpaphic initialisation}
	Gd:= Detect;
	InitGraph(Gd, Gm, 'C:\BP\BGI');
	if GraphResult <> grOk then
		Halt;
{Рисование/ Drawing}
   DrawAxes(green);
   DrawPyr(rPyr, hPyr, white);
   DrawCut(arrintr, green);
   ReadLn;
   CloseGraph;
end.