Задача
Изобразить линию сечения правильной шестигранной пирамиды плоскостью, заданной коэффициентами своего уравнения(Основание пирамиды лежит в плоскости XOY, высота совпадает с осью Z)
----------------------------------------------------------
Проблема
Подскажите, как лучше потроить усечённую пирамиду, если я знаю взаимное расположение плоскости и каждой грани(точку пересечения или то, что они параллельны или, что грань лежит в плоскости).
----------------------------------------------------------
Программа
Рисует пирамиду(DrawPyr), оси координат(DrawAxes), может находить взаимное расположение граней и плоскости(Interception).
(См. Pyramid.pas).

art88, погоди... Ты же написал, что, и в то же время у тебя... Так рисует или НЕ рисует?

Процедура DrawPyr рисует пирамиду(не усечённую) с заданными параметрами.

Ну, попробуй вот это глянуть... Я только что выдрал это из своей старой программы, рисующей 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;
  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.

volovo, насколько я понял твоя программа строит пирамиду с задаными радиусами верхнего и нижнего основания.
Дело в том, что мне не известен радиус вверхнего основания, да и ввобще в сечении плоскостью может получится и не шестиугольник вовсе(например если плоскость совпадает с YOZ).
В задаче же требуется изобразить пирамиду и ЛИНИЮ, по которой плоскость пересекает пирамиду.
-------------------------------
Я немного доделал программу и теперь она рисует один из частных случаев расположения пирамиды и плоскости, но не могу понять, почему требуемая линия лежит вне пирамиды(кроме случая совпадения секущей плоскости и XOY)??? (Видимо дело в процедуре Interception)

Я нашёл ошибку в Interception, обобщил задачу, решаемую программой(до требуемой), но всё равно кроме случая, когда плоскость проходит через все боковые рёбра(типа A=0 B=0 C=1 D=50) программа работает не корректно(например A=0 B=1 C=0 D=0 - вертикальная плоскость).
Принцып работы программы такой: идём по ребрам, ищем точки пересеченя, соединяем.
-------------------------------------------------
Помогите пожалуйста найти ошибку/и, а то у меня две задачи осталось сдать(эта и освещённый шар), а время поджимает!

art88, я очень глубоко не разбирался, просто сразу бросилось в глаза: почему ты сразу же после отрисовки пирамиды ставишь указатель (MoveTo) на ее вершину? Ты что, заранее уверен, что сечение пойдет через вершину? Тогда расскажи, почему?

Ну надо же его куда-нибудь поставить. Да и вообще, когда мы будем проводить сечение оно пройдёт или через вершину или через одно из боковых рёбер(в большинстве случаев), ну а если так, то мы сделаем LineTo и линия, соединяющая вершину с первой точкой совпадёт с боковым ребром.

Вообще хорошо бы делать MoveTo сразу в первую точку сечения, если она есть, этого можно добиться например заведя, какую-нибудь Булеву пременную, потавить на её истинность проверку и после перого перемещения сделать её FALSE, ну или что-нибудь в этом духе.
--------------------------
Для меня главное построить линию сечения.

art88, кажется я понял, в чем ошибка... Я бы на твоем месте попробовал сделать вот так (читай комментарии):

var
  j: integer; 
  curr_intr: integer; { здесь будет храниться количество точек пересечения секущей с гранями }
  arrIntr: array[1 .. 20] of tPoint; { здесь - соответственно - сами эти точки ... }

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;
  { До этого места - никаких изменений }
  curr_intr := 0; 

  { А теперь - the main stuff }

  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 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 not paral then begin
      inc(curr_intr); arrIntr[curr_intr] := pInt;
    end;
  end;

  { Вот теперь - самое интересное !!! }
  ...
  ReadLn;
  CloseGraph;
end.

А самое интересное - это то, что у тебя есть после всех этих операций список точек пересечения секущей плоскости с пирамидой... НО этого недостаточно. Чтобы правильно отрисовать нужную тебе кривую, ты должен построить из этих точек выпуклый полигон, то есть определить порядок соединения точек... И когда ты найдешь этот порядок, просто в соединяй точки... Все.

Алгоритмы построения полигона были где-то, по-моему, даже на форуме... Попробуй это реализовать.

volovo, следуя твоим указаниям я переделал программу(см. Pyramida.pas), добавил поцедуру, рисующую замкнутую кривую(DrawCut), добавил в процедуре Intrception проверку на принадлежность точки отрезку(intercept), но точки пересечения находятся не правильно,точнее находится одна точка, являющаяся центром основания пирамиды.

Нет, ты не следовал моим указаниям, а посему ошибки у себя будешь искать сам... Я что написал?По-твоему это для красоты? Ты не заметил, что СНАЧАЛА строится пирамида - я же написал:
(причем я основывался на СТАРОМ методе ее построения, а ты взял и все перепахал!!!) Я же в алгоритме считал, что массив Pyr к началу работы МОЕЙ части уже заполнен вершинами, лежащими в основании пирамиды, и I содержит увеличенное на 1 количество точек в основании пирамиды, именно на этом все построено, а ты что сделал? У тебя же это вообще не работает, при I = 0...

Кроме того, мое замечание о построении выпуклой оболочки ты тоже предпочел не заметить?
Ну, так пеняй на себя, потому что ты можешь даже получить правильные точки, но вот соединяться они будут в неверном порядке, как результат на экране будет бред...

Извини, но я умываю руки... Если ты все делаешь не так, как тебе советуют - зачем советовать?

И снова здраствуйте....
Вот уже которую неделю, я тщетно пытаюсь написать программу, изображающую сечение пирамиды.
Профессор сказал, что решение этой задачи с отысканием точек пересечения и последующим построением их оболочки(полигона) слишком сложно.
Поэтому пришлось начинать всё заново и вот, что получилось(см. Inter.pas)
-------------------------
Принцип такой:
Рисуем пирамиду, заполняем массив её вершинами(procedure DrawPyr)
Разбиваем основание на треугольники(общая вершина - щентр основания)(procedure GenTri).
Находим пересечение плоскоти с каждой стороной треугольника.
Если нашли две точки соединяем.
Аналогично для боковых граней(общей вершиной треугольников будет вершина пирамиды).
-------------------------
Принцип новый проблеммы старые: сечение не рисуется.
-------------------------
Помогите, пожалуйста, найти ошибку.
P.S.:
Обещаю следвать всем советам.

Неужели, ни у кого руки не доходят проверить мою программу?
Очень надо!!!!!!!!!!!!!!

art88, ну НЕ НАХОДИТ твоя процедура Interception пересечений отрезка с плоскостью... Я только что попробовал чуть ли не вручную разбить на треугольники... Разбивается нормально, пересечений НЕТ! Ищи ошибку в Interception...

Поменял пару знаков в процедуре interception, убрал проверку на кол-во точек пересечения и программа строит
6 точек пересечения плоскости (0,0,1,50) и пирамиды, но линиями их не соединяет.(т.е программа находит по одной точке пересечения плоскости и треугольника).

Знаешь, почему это происходит? Программа-то может и находила бы больше, НО !!!
1.

procedure Interception(l: tLine; s: tPlane);
var
  p: tVector;
  M, N, t: real;
begin
  intercept := false; { <--- У тебя этого не было !!!}
  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;

А если эту строку НЕ добавить, то после того, как хотя бы один раз intercept будет True, значение False он уже никогда не примет... Это первое.
2.

procedure PlaneTri(p: tPlane; t: tTriangle);
var
  c: integer;
  l: tLine;
  aInt: array[1..3] of tPoint; { <--- У тебя стояло 1 .. 2 }

Если оставить 1 .. 2, то возможна порча значений, хранящихся в стеке ПОСЛЕ aInt (это могут быть данные или код программы)...
3. Измени направление вектора AC в треугольнике (процедура PlaneTree):

 { вместо }
  l.bol:= t.c;
  l.eol:= t.a;
  { поставь }
  l.bol:= t.a;
  l.eol:= t.c;

После внесения изменений ЧЕГО-ТО чертится, но я не уверен, что именно то, что нужно. Проверь... Кстати, можно внести еще несколько мелких улучшений, чтобы сократить объем программы. Нужно?

Внёс все изменения, действительно что-то чертится, но это явно не линия пересечения. В случае горизонтальной плоскости(0,0,1,50) построенные отрезки действительно содержат точки пересечения плоскости и рёбер, но во-первых эти отрезки выходят за пирамиду а во-вторых не соединяются друг с другом.

Опять начинается... Я же сказал, без Intercept := False не будет у тебя ничего чертиться !!!

Volvo, извини запостил не ту программу(она вообще без изменений).

art88,
В процедуре PlaneTri:

У меня отработало нормально, сечение чертится...

Volvo, прошу прощения за столь тупую ошибкку.
Но у меня всё равно линия сечения не правильная(не замыкается, т.е. приходит не в ту точку).
А если поменять плоскость, то вообще какая-то ерунда получается!

Да, совсем забыл ... Я еще кое-что поменял:

procedure GenTri(var t: tTriangle);
var
  i: integer;
begin
  for i:= 1 to n - 1 do begin

    if i = n - 1 then t.c:= pyr[1] { <--- Здесь у тебя было pyr[ 2 ]...  Почему? }
    else t.c:= pyr[i + 1];

    t.b:= pyr[i];
    PlaneTri(plane, t);

  end;
end;

Вот результат работы программы:

Спасибо, Volvo!
Просто раньше у меня вершина хранилась в превой ячейке массива.
У меня ещё пара вопросов:
при пересечении с плоскостью 1,1,1,0 не строится линия, лежащая в основании.
сечение плоскостью 1,0,0,0 вообще не строится.

Перебрал много плоскотей и пришёл к выводу:
если D<>0 всё нормально строится, кроме плоскостей параллельных(1,0,1,0).
Почему?

Вобщем теперь я тупо прибавляю eps(некоторая маленькая контсанта) к D и всё нормально.
Всё равно не понимаю, в чём осбенность ситуации, когда D=0(плоскоть проходит через центр основания).
Volvo, ты ещё предлагал какие-то улучшения, уменьшающие объём программы, выложи пожалуйста.

Не особенно-то программа сократилась
Ну, ладно, посмотри, может чего и пригодится... Не здесь, так в других проектах

Volvo, спасибо большое за помощь!
Кстати о других проектах, мне ведь ещё надо было шарик нарисовать...