Вершины пирамиды Опции

[samec]

Доброе время суток всем. Проблемка такая: дано множество точек в пространстве. Каким образом можно проверить - будут ли эти точки являться вершинами пирамиды?

Добавлено через 4 мин.
понятно, что для существования пирамиды, необходимо, чтобы из n точек, n-1 лежало в одной плоскости, а одна точка была бы вне этой плоскости - но вот как выделить эту точку если такая существует?

Сообщение отредактировано: samec - 10.11.2008 23:47

[Lapp]

необходимо, чтобы из n точек, n-1 лежало в одной плоскости, а одна точка была бы вне этой плоскости - но вот как выделить эту точку если такая существует?

Процесс долгий и нудный, а главное - к математике не имеет особого отношения.. Последовательная проверка условий по принадлежности точек плоскостям (если в конечном итоге имеется в виду программа, то нужно предусмотреть такую функцию).
Перенести тему в Алгоритмы? Там можно набросать блок-схемку..

[samec]

можно и в алгоритмы.

[Гость]

можно и в алгоритмы.

Okay, переношу.

Я начал было рисовать блок-схемку, но под рукой не оказалось ничего удобного для рисования. Зато FP всегда рядом, так что я просто настрочил прогу. Нужна она тебе? Выложить?..

[Lapp]

Выше был, кто не догадался, я..

[samec]

Я начал было рисовать блок-схемку, но под рукой не оказалось ничего удобного для рисования. Зато FP всегда рядом, так что я просто настрочил прогу. Нужна она тебе? Выложить?..

Буду премного благодарен

оффтоп: а если тема перенесена - то почему она теперь и в Алгоритмах и в Математике есть? Или это у меня в глазах двоится?

Сообщение отредактировано: samec - 11.11.2008 22:27

[Lapp]

Вот, кладу. Учти две вещи:
1. Нужно дописать проверку на то, что 3 точки расположены по одной линии, и на то, что 4 точки лежат в одной плоскости (рыбы для функций есть).
2. Поскольку функций для проперки у меня не было, полноценное тестирование я провести не мог - могут быть ошибки.

const
  n=8; // Number of points

type
  tPoint= record
    x,y,z: real
  end;

var
  a: array[1..n]of tPoint;

function Linear(i,j,k:integer):boolean;
begin
  // Here, insert test for linearity of 3 points
end;

function Planar(i,j,k,l:integer):boolean;
begin
  // Here, test for planarity of 4 points
end;

procedure Exchange(i,j:integer);
var
  b: tPoint;
begin
  b:=a[i];
  a[i]:=a[j];
  a[j]:=b
end;

var
  i,i1,i2,i3,i4,i30,Pass,m: integer;

begin
  Pass:=1;
  repeat
    i1:=1;
    i2:=2;
    i3:=3;
    while (i3<=n) and (i3<>i1) and (i3<>i2) and Linear(i1,i2,i3) do Inc(i3);
    if i3>n then begin
      WriteLn('All points are in one line');
      Exit
    end;
    if Pass=1 then begin
      Exchange(3,i3);
      i30:=i3;
      i3:=3
    end;
    m:=0;
    for i:=4 to n do if not Planar(i1,i2,i3,i) then begin
      Inc(m);
      i4:=i
    end;
    if m=0 then begin
      WriteLn('All points are in one plane');
      Exit
    end
    else if m=1 then begin
      if Pass=2 then begin
        Exchange(1,4);
        Exchange(2,5);
        Exchange(3,6);
        if i4<=6 then Dec(i4,3)
      end;
      Exchange(i30,3);
      if i4=i30 then i4:=3;
      WriteLn('The top is #',i4)
    end
    else if Pass=2 then WriteLn('Not a piramid')
    else begin
      Exchange(1,4);
      Exchange(2,5);
      Exchange(3,6)
    end;
    Inc(Pass)
  until Pass=3
end.

По поводу раздваивания: главное не расстраиваться .
В старом разделе остается сслыка на эту тему. Я их оставляю, чтоб проще было найти в первое время. Потом удаляю (если не забываю ).

[samec]

Спасибо большое!
Код хороший. Алгоритм я понял.
Что то мне подсказывает, что при количестве точек 5 (n=5) написанный код может не сработать.
Ведь если в первом проходе (Pass=1) в любую из точек попадает вершина, то вот в этом моменте:

    if m=0 then begin
      WriteLn('All points are in one plane');
      Exit
    end
    else if m=1 then begin
      if Pass=2 then begin
        Exchange(1,4);
        Exchange(2,5);
        Exchange(3,6);
        if i4<=6 then Dec(i4,3)
      end;
      Exchange(i30,3);
      if i4=i30 then i4:=3;
      WriteLn('The top is #',i4)
    end
    else if Pass=2 then WriteLn('Not a piramid')
    else begin
      Exchange(1,4);
      Exchange(2,5);
      Exchange(3,6)         { <- вот тут}
    end;

мы поменяем точку на что то неправильное (ведь всего их пять).

Сообщение отредактировано: samec - 12.11.2008 23:50

[Lapp]

Что то мне подсказывает, что при количестве точек 5 (n=5) написанный код может не сработать.

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

[samec]

То же самое для четырех.

а вот для 4-х помоему всё ок. Ведь если будет 4-е вершины, то до этого места не дойдёт
ведь в цикле:

for i:=4 to n do if not Planar(i1,i2,i3,i) then begin
      Inc(m);
      i4:=i
    end;

переменная m - либо увеличится на единицу (если точки составляют вершины пирамиды) либо не увеличится (если все точки лежат в одной плоскости).

[samec]

вот сделал свою процедурку

{проверка введенных точек, на то, составляют ли они пирамиду или нет
 и если введенные точки составляют пирамиду, то функция возвращает номер точки,
 в массиве точек, являющейся верхушкой пирамиды}
function Proverka:integer;
var
  i,j,k,l:integer;  {счетчики циклов}
  i2,{точка вершины пирамиды}
  n,{количиество точек}
  m: integer; {вспомогательная переменная}
  flag:boolean; {флаг}
begin
  n:=kol; {количество введенных точек}
  {проверяем, не лежат ли любые три точки (из всех введенных) на одной прямой}
  {перебор всех троек точек в массиве точек}
  for i:=1 to n do
   for j:=i+1 to n do
     for k:=j+1 to n do
        {если три точки лежат на однй прямой, то}
       if Linear(i,j,k) then
        begin {если любые три точки лежат на одной прямой, выводим сообщение}
         OutPoint(arPoint[i],''); {вывод точки на экран}
         OutPoint(arPoint[j],'');
         OutPoint(arPoint[k],'');
         WriteLn('лежат на одной прямой!');
         Proverka:=0;
         Exit {выход из процедуры проверки}
        end;
  {если точек всего 4 - то проверяем, не лежат ли они в одной плоскости}
  if(n=4) then
     if Planar(1,2,3,4) then
       begin    {лежат в одной плоскости}
         OutPoint(arPoint[1],'');
         OutPoint(arPoint[2],'');
         OutPoint(arPoint[3],'');
         OutPoint(arPoint[4],'');
         WriteLn('лежат в одной плоскости!');
         Proverka:=0;
         Exit {выход из процедуры проверки}
       end
     else
       begin  {не лежат в одной плоскости}
         WriteLn('Верхушка пирамиды находится в точке 1');
         Proverka:=1;
         Exit; {выход из процедуры проверки}
       end;
  {если точек более чем 4}
  {находим любые 4 точки в массиве точек, которые лежат в одной плоскости}
  flag:=false;
  for i:=1 to n do
   begin
    for j:=i+1 to n do
     begin
      for k:=j+1 to n do
       begin
        for l:=l+1 to n do
         begin
           flag:=Planar(i,j,k,l);
           if(flag) then Break;
         end; {end for l}
        if(flag) then Break;
       end; {end for k}
      if(flag) then Break;
     end; {end for i}
    if(flag) then Break;
   end; {end for i}
  {если не найдено четырех точек лежащих в одной плоскости}
  if not flag then
   begin
     WriteLn('Из введенных ',n,' точек не найдено ',n-1,' точек лежащих в одной плоскости');
     Proverka:=0;
     Exit; {выход из процедуры проверки}
   end;
   m:=0; {количество точек, не лежащих в одной плоскости
          с точками найденными на пердыдущем шаге.
          Для существования пирамиды m должно быть = 1}
   for i:=1 to n do
     if not Planar(j,k,l,i) then
      begin   {если такая точка нашлась}
       Inc(m); {увеличиваем счетчик точек}
       i2:=i; {запоминаем, какая это точка}
      end;
  {если все точки лежат в одной плоскости (m=0), то выводим соответствующее сообщение}
   if m=0 then
     begin
       WriteLn('Все точки лежат в одной плоскости!');
       Proverka:=0;
       Exit;
     end
    else
     if m=1 then {если все точки кроме одной (m=1) лежат в одной плоскости}
      begin
       WriteLn('Верхушка пирамиды находится в точке ',i2);
       Proverka:=i2;
       Exit;
      end
     else {если точек, не лежащих в одной плоскости
           с точками найденными на пердыдущем шаге больше чем 1, то}
      begin
       WriteLn('Из введенных ',n,' точек не найдено ',n-1,' точек лежащих в одной плоскости');
       Proverka:=0;
      end;
end;

вроде работает