Версия для печати темы

Автор: bairt 23.04.2006 16:07

В трехмерном пространстве задано N шаров. Найти шар минимального радиуса, охватывающий все заданные

Автор: Altair 23.04.2006 16:25

Есть задача решенная - найти окружность, в которую вместяться все точки на плоскости.
Расширяем задачу на 3d , получаем найти шар....
И потом добавляем к точкам уловие того, что они имеют размер.
Таким образом задача решается.

Автор: volvo 23.04.2006 16:26

<...>

Автор: lapp 23.04.2006 16:45

volvo, давай рассмотрим частный стучай.
Две сферы, одна с центром в точке (-1,-1,-1), а другая в (1,1,1). Радиусы обеих сфер нулевые. Твой алгоритм даст диаметр, равный 2. На самом же деле он равен Sqrt(3).

Автор: volvo 23.04.2006 16:55

Ну, во-первых, не Sqrt(3), а 2*Sqrt(3)

Если уже взялся что-то опровергать, то делай это ПРАВИЛЬНО.

Автор: lapp 23.04.2006 16:59

Извиняюсь. Ошибся. 2*Sqrt(3). И вовсе незачем кричать.

Автор: klem4 23.04.2006 22:25

А есть данные для теста ? А то вот накатал кое что а проверить не могу ;)

Автор: klem4 23.04.2006 23:36

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

{$N+}
uses crt;
const
  n = 5;
type

  TSphere = record
    x, y, z, r : word;
  end;

  TSArr   = array [1..n] of TSphere;

procedure Fill(var s : TSArr);
var
  i : word;
begin
  for i := 1 to n do
   with s[i] do begin
     write(i , ').');
     readln(x, y, z, r);
  end;
end;

function Len(P1, P2 : TSPhere) : single;
begin
  Len := sqrt
               (
               (P2.x - P1.x) * (P2.x - P1.x) +
               (P2.y - P1.y) * (P2.y - P1.y) +
               (P2.z - P1.z) * (P2.z - P1.z)
               );
end;

function IsIncludeAll(s : TSArr; m : word) : boolean;
var
  i : word;
begin
  i := 1;
  while (i <= n) and (Len(s[i], s[m]) + s[i].r <= s[m].r)
   do inc(i);
  IsIncludeAll := (i > n);
end;


function Find(s : TSArr) : word;
var
  i, min : word;
begin
  min := 0;
  i := 1;
  while (i <= n) do begin
    if IsIncludeAll(s, i) then
     min := i;
    inc(i);
  end;
  Find := min;
end;

var
  Sp : TSArr;

begin
  clrscr;
  Fill(Sp);
  writeln(Find(Sp));
  readln;
end.

гыя вообще не то что надо решил )))

Volvo, ага тока щас понял ) Еще ведь долго думал как это может быть минимальная среди имеющихся, которая охватыет все остальные :D

Автор: volvo 23.04.2006 23:41

klem4, ты, если я не ошибаюсь, решаешь несколько другую задачу? Ты пытаешься найти сферу из тех, что заданы?

Автор: klem4 24.04.2006 0:02

Вот такой вариант ... но опятьже нужен тестовые данные ... Вариант годится для случая елси центр хотябы одной сферы не совпадает с центрами остальных, в противном случае берем просто наибольший радиус + 1 ...

{$N+}
uses crt;
const
  n = 2;
type

  TSphere = record
    x, y, z, r : word;
  end;

  TSArr   = array [1..n] of TSphere;

procedure Fill(var s : TSArr);
var
  i : word;
begin
  for i := 1 to n do
   with s[i] do begin
     write(i , ').');
     readln(x, y, z, r);
  end;
end;

function Len(P1, P2 : TSPhere) : word;
begin
  Len := round(sqrt
               (
               (P2.x - P1.x) * (P2.x - P1.x) +
               (P2.y - P1.y) * (P2.y - P1.y) +
               (P2.z - P1.z) * (P2.z - P1.z)
               ));
end;

function GetRadius(s : TSArr) : word;
var
  i, j, p1, p2, L: word;
  maxL : integer;
begin
  maxL := -maxint;
  for i := 1 to n - 1 do
   for j := i + 1 to n do begin
     L := Len(s[i], s[j]);
     if L >= maxL then begin
        maxL := L;
        p1 := i;
        p2 := j;
     end;
   end ;

   GetRadius := maxL + s[p1].r + s[p2].r;
end;

var
  Sp : TSArr;

begin
  clrscr;
  Fill(Sp);
  writeln(GetRadius(Sp));
  readln;
end.

К сожалению решение не верное =(

Автор: Бравый генерал 24.04.2006 3:20

klem4, как видно из твоего кода, ты находил две сферы, которые расположены дальше всего друг от друга. Да, такой вариант неверен. Я сегодня долго думал над этой интересной задачкой и для наглядности сначала делал с окружностями, типа в 2D Так вот в таком варианте как у тебя бывают случаи (окружности задаются случайно), что какая-то окружность может даже ЦЕЛИКОМ выйти за "охватывающую" окружность. Ну, например, чтобы найти окружность, охватывающую множество точек, нужно найти две максимально удаленные точки M и N, найти еще одну точку, максимально удаленную от отрезка MN, и построить по этим трем точкам окружность. Наша же задача сводится к задаче "найти окружность, охватывающую множество окружностей" (2D перевести в 3D не представится сложным). Так вот вопрос: как найти точки A, B и C на прилагаемом мной рисунке?


Эскизы прикрепленных изображений

Автор: volvo 24.04.2006 3:25

<...>

Автор: lapp 24.04.2006 18:41

Генерал, мне кажется, что ты ошибаешься с утверждением "перевести в 3D не представится сложным". Нахождение окружности, касающейся трех заданных, называется "задачей Апполония". Решение ее не очень простое, но http://www.dep805.ru/education/ma/OldProblem/apollony.htm. Но я не уверен, что оно есть для 3D. В 3D три заданных окружности превращаются в четыре заданных сферы..

Но дело даже не в этом. Боюсь, что даже найдя "сферу Апполония" (экстраполяция моя), задачу мы не решим..

P.S.
А куда исчезли мои предыдущие посты из этой темы?..

Автор: GoodWind 24.04.2006 18:58

почему-то скрыты...

Я тоже не понял почему. Если я что-то не так понял, модераторы поправлят снова.
Пока посты все опубликовал. Altair

Автор: klem4 25.04.2006 19:41

Я скрыл решение просто по тому что оно не верное, точнее не то я решал что нужно (в общем смысла в них не было), может и не стоило скрывать ...

Вот поправил ф-ю, теперь больше похоже на правду ... ждем тестовые данные ...

function GetRadius(s : TSArr) : word;
var
  i, j, p1, p2, L: word;
  maxL : integer;
begin
  maxL := -maxint;
  for i := 1 to n - 1 do
   for j := i + 1 to n do begin
     L := Len(s[i], s[j]) + s[i].r + s[j].r;
     if L >= maxL then begin
        maxL := L;
        p1 := i;
        p2 := j;
     end;
   end ;

   GetRadius := maxL;
end;

Автор: bairt 25.04.2006 22:16

а ты можешь выложить результат?

Автор: klem4 25.04.2006 23:36

Извини, не понял тебя ...

Автор: bairt 26.04.2006 1:37

я про данные она правильно работает? и ты можешь прислать решение я сравню его со своим...

Автор: klem4 26.04.2006 11:02

Я же писал, у меня нету нормальных тестовых данных, сочинать их у меня нет ни малейшего желания, если у тебя они есть выложи их, кстате что тебе мешает самому проверить правильность моей программы ? Я не понимаю.

Автор: lapp 26.04.2006 11:16

klem4, ты не обратил внимания на пост Бравого генерала, а он дело говорил. Вот простой пример, опровергающий твое решение.

Твоя прога найдет 1 и 2 сферы, как наиболее удаленные, и проведет сферу радиусом 11 из начала координат. Сфера 3 в нее не попадет.


Бравый генерал, я сначала пропустил это, а сейчас перечитал и увидел: твое утверждение неверно. Вот опровергающий пример.

Точки 1 и 2 максимально удалены. Т 3 отстоит на максимальное растояние от отрезка 1-2. Окружность, проведенная через 1-2-3 оставит Т 4 снаружи.. (Извиняюсь за некрасивые числа - подбирал в уме)

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

PS
мужики (и дамы тоже!), давайте не прятать ничего и не скрывать. Дискуссия есть дискуссия. Возможны ошибки, возможны неверные рассуждения, неверные понимания - что ж с того? Но среди всего этого рождается Истина!

Автор: klem4 26.04.2006 11:25

lapp, а пост # 15 ты учел ?

Автор: bairt 26.04.2006 12:09

тогда можете проверить етот код

uses crt;
type InfoSphere=record
     x,y,z,r:real;
end;
const n=10;
var InfoSp:InfoSphere;
    f:text;
    i:integer;
    Spheri: array[1..n] of InfoSphere;
    Rnew,Xnew,Ynew,Znew:real;

function Lenght(x0,y0,z0,x1,y1,z1:real):real;
begin
     Lenght:=sqrt(sqr(x0-x1)+sqr(y0-y1)+sqr(z0-z1));
end;


procedure SearchMinSpher(x0,y0,z0,r0,x1,y1,z1,r1:real);
var L:real;
begin
   L:=Lenght(x0,y0,z0,x1,y1,z1);
   if (L=0) then
   begin
      Xnew:=x0;
      Ynew:=y0;
      Znew:=z0;
      if (r1>r0) then
      begin
         Rnew:=r1;
      end
      else
      begin
         Rnew:=r0;
      end;
   end
   else
   begin
      if (r1>r0) and ((r1-r0)>=L) then
      begin
            Rnew:=r1;
            Xnew:=x1;
            Ynew:=y1;
            Znew:=z1;
      end;
      if (r0>r1) and ((r0-r1)>=L) then
      begin
            Rnew:=r0;
            Xnew:=x0;
            Ynew:=y0;
            Znew:=z0;
      end;
      Rnew:=(r0+r1+L)/2;
      Xnew:=(Rnew-r0)*(x1-x0)/L+x0;
      Ynew:=(Rnew-r0)*(y1-y0)/L+y0;
      Znew:=(Rnew-r0)*(z1-z0)/L+z0;
     
   end;
end;

begin
   assign(f,'3_input.txt');
   reset(f); {otkrivaem file}
   with InfoSp do
   begin
      for i:=0 to 4*n do
      begin
         read(f,Spheri[i div 4].x);
         read(f,Spheri[i div 4].y);
         read(f,Spheri[i div 4].z);
         read(f,Spheri[i div 4].r);
      end;
      {
      zapolnili massiv iz file
      }
      Rnew:=Spheri[1].r;
      Xnew:=Spheri[1].x;
      Ynew:=Spheri[1].y;
      Znew:=Spheri[1].z;
      for i:=2 to n do
      begin
         SearchMinSpher(Xnew,Ynew,Znew,Rnew,Spheri[i].x,Spheri[i].x,Spheri[i].x,Spheri[i].x);
      end;

   end;
   close(f);
end.

Теги !

Автор: lapp 26.04.2006 17:06

Да, klem4, учел. Вообще-то хотя бы минимум комментариев, просто как жест вежливости и уважения к читающим, не помешал бы.. Да, я просмотрел программу, потом функцию из поста №15, сравнил, разобрался, что именно ты исправлял, и именно поэтому написал, что тебе следовало бы обратить чуть больше внимания на пост Бравого генерала. Ну и, кроме того - ты просил тестовые данные? Я тебе их дал. Ты проверил? Рекомендую проверить не только на программе, но и на листочке, с рисунком. Тогда ты поймешь, о чем говорил Бравый, и о чем я сейчас толкую. Ок?

bairt, тебя нельзя упрекнуть в отсутствии комментариев - в твоей проге есть один! Но этого все же недостаточно.. Я очень извиняюсь, но рыскать глазами, ослеживая переменные, даже не представляя сначала, что же хотел сказать автор - ну, согласитесь, это носненс. Ну ладно еще, если бы алгоритм был известен. Тут же задача именно на составление алгоритма, а не программы! А еще лучше - дать параллельно краткое описание алгоритма. Ну, кто со мной не согласится? Ладно унимаюсь..

Короче, одного взгляда близорукого человека издалека на обе проги достаточно, чтобы сказать, что они не могут быть верными. Алгоритм, насколько я сейчас понимаю, гораздо сложнее, и к тому же он включает громоздкие математические вычисления. Сейчас я налью себе чаю и попробую описать, чего мне удалось надумать..

Если, конечно, кто нибудь не выложит верное решение раньше (или klem4 или bairt не докажут, что они правы).

Автор: Бравый генерал 26.04.2006 19:38

klem4, ты так сказал, как будто после того поста решение КАРДИНАЛЬНО изменилось. Да, охватывающая сфера должна охватывать сферы, а не их центры, но сам костяк этого алгоритма неверен.

Во-во!

Вобщем, чтобы с тем неправильным алгоритмом было все ясно, вот эта программа - тот же алгоритм только в 2D, чтобы можно было проверить визуально. Бывают конечно случаи, когда охватывающая окружность охватывает ВСЕ окружности, но часто бывает, что сферы "вылазят" за охватывающую сферу, что и доказывает неправильность алгоритма.

Uses
 Crt, Graph;

Type
 Ball = record
	 x,y,r: Real
	end;

Const
 n = 10;

Var
 gd,gm: Integer;
 i,j,x,y,z: Byte;
 b: Array [1..n] of Ball;
 l,l0,d,dx,dy,x0,y0: Real;
 c: Ball;
 ch: char;

Function Ohvat(a,b: Ball): Real;
 var
  i: Byte;
 begin
  Ohvat:=sqrt(sqr(a.x-b.x)+sqr(a.y-b.y))+a.r+b.r
 end; {Ohvat}

{****************************************************************************}

Begin
 Randomize;

 for i:=1 to n
 do begin
     b[i].x:=Random(400)+120;
     b[i].y:=Random(300)+90;
     b[i].r:=Random(50);
    end;

 InitGraph(gd,gm,'');

 l:=0;
 for i:=1 to n-1
 do for j:=i+1 to n
    do begin
	l0:=Ohvat(b[i],b[j]);
	 if l0 > l
	 then begin
	       l:=l0;
	       x:=i;
	       y:=j
	      end
       end;
 dx:=b[y].x-b[x].x;
 dy:=b[y].y-b[x].y;
 d:=sqrt(sqr(dx)+sqr(dy));
 c.r:=Ohvat(b[x],b[y])/2;
 c.x:=b[x].x + (c.r-b[x].r)*(dx/d);
 c.y:=b[x].y + (c.r-b[x].r)*(dy/d);

 for i:=1 to n
 do Circle(Round(b[i].x),Round(b[i].y),Round(b[i].r));
 setcolor(2);
 Circle(Round(c.x),Round(c.y),Round(c.r));

 ReadKey;

 CloseGraph
End.

Добавлено позже:

Да, прошу прощения, это я не то что-то сказал...
(Ой, надо было в предыдущий пост добавить, а я случайно новым отправил.)

Автор: klem4 26.04.2006 23:40

Да, теперь я понял, что был не прав, извиняюсь.

И всеже мне кажется что решение должно быть простым, еще одна идея есть, завтра сделаю.

Автор: lapp 27.04.2006 17:02

Извиняться тут абсолютно не за что
O'kay, делай.
Я пока подожду постить свое решение.

Автор: lapp 28.04.2006 9:43

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

Сначала извинюсь перед Бравым Генералом: я сомневался в легкой масштабируемости этой задачи с двумерного случая на трехмерный, но потом убедился, что суть действительно не меняется, хотя математика усложняется.

Рассмотрим двумерный случай: ищем окружность минимального радиуса, охватывающую заданный конечный набор кругов. Проведем небольшое исследование, по традиции начинаемое словами: предположим, что задача решена, и минимальная охватывающая окружность построена...

В этом месте небольшое лирическое отступление. Два утверждения:

1. На плоскости в общем случае можно провести одну и только одну окружность, касающуюся трех данных (окружность Апполония, ОА) так, чтобы все три данные оказались внутри нее (в дальнейшем, кроме оговоренного, под "касанием" я буду понимать именно такое касание). Иногда такую окружность провести невозможно (вот пример: О о О ), но такие случаи нас волновать не будут, так как они охватываются пунктом 2.

2. Если даны две окружности, то можно провести много окружностей, касающихся их, но только одна при этом будет охватывать их обе с минимальным радиусом ее центр лежит на отрезке, соединяющем центры.

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

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

2. Найти два максимально отстоящие (дальними точками) круга, натянуть на них минимальную окружность и проверить, охватываются ли все остальные круги этой окружностью. Если да, то сравнить с радиусом, полученном в п.1 и выбрать минимальный.

По сути, тут два решения: одно - klem4'овское, только с добавленной проверкой на включение, второе - Бравого Генерала, с тем же самым дополнением.

Все! Казалось бы...

Но действительно ли все? Теоретически - да. А практически..
Выполнить п.2 сложности не представляет - klem4 уже сделал это. А вот п.1.. Хотя ОА принципиально и находима - этого достаточно для математика, для программера этого мало. Надо указать конкретный способ ее найти. Именно это и тормозило меня с самого начала: хотя описанные выше два пункта алгоритма нащупать было несложно, практический способ постороения ОА мне не давался. В указанной ссылке (см. мои предыдущие посты) способ построения геометрический, реализовать его в коде довольно сложно с моей точки зрения. Поэтому я продолжал думать.. Довольно долго все равно все мои усилия были вокруг простой геометрии типа циркулем и линейкой, хотя я понимал, что без инверсии тут не обойтись. В конце концов я на нее решился.

Все оказалось не так уж и страшно
Преобразование инверсии, как известно, переводит окружность в окружность, при этом сохраняя касание. Да, конечно - прямо то, что нужно! Только зачем? Зачем переводить окружности в другие? чем другие лучше?

А вот чем. Когда я написал уравнения, оказалось, что возможно провести одну инверсию, которая переведет три заданных окружности в три окружности одного заданного диаметра! Внизу, если останется время, приведу подтвеждающие выкладки.

Итак, общее правило такое:

1. По трем выбранным кругам (центры и радиусы) находим параметры (центр и радиус) того самого преобразования инверсии, которое переводит эти три окружности в три одинаковые.

2. Произвести инверсию.

3. Построить окружность, касающуюся трех полученных образов. Для этого просто строим окружность, проходящую через их центры, а потом увеличиваем ее радиус на величину радиуса образов.

4. Проводим обратную инверсию (то есть вторично применяем ее). Полученный образ построенной в п.3 окружности - это искомая кружность, касающаяся трех данных.

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

Вот теперь, кажется, все..
Ах, да! не все.. Осталось добавить, что, как показывают выкладки, инверсия применяется в трехмерном случае (теперь уже к четырем сферам) вполне аналогично, хотя вычисления усложняются. Далее, в 3D придется рассматривать не два случая, а три:
1. Касание четырех шаров.
2. Минимальное касание трех шаров.
3. Минимальное касание двух шаров.
Строгости ради, сюда (а также выше) надо добавить еще и случай, когда одна из данных сфер уже охватывает все остальные, но он настолько тривиален, что лень было упоминать. Хотя в программном продукте он должен быть учтен, разумеется.

Теперь совесм все!!
Ну, как вам решеньеце? Мне почему-то кажется, что с набором из сотни шаров современный Р4 за пару часов справится. Но о тысяче не стоит и говорить.. Хотя, простор для оптимизации тут немеряный..

Мужики (дамы так и не присоединились к обсуждению), не судите строго - я выложу вычисления on request - ладно? И так уже больше получаса пишу..

Всем спасибо за внимание! Жду критики (или опровержений )


P.S.
Перечитал - и обнаружил в своих рассуждениях ошибку, которая может иметь принципиальное значение. Или, по крайней мере, еще усложнит алгоритм..
Кто еще заметил?

Автор: lapp 1.05.2006 19:18

Похоже, я изрядно напугал народ своим ответом...
Неужели никого не заинтересовало? Все так активно говорили.. Мне кажется, там еще полно материала для обсуждения. Не исключаю, что все же может найтись более простое решение.

И зачинатель темы куда-то делся..
Ау-у!