Помощь - Поиск - Пользователи - Календарь
Полная версия: трехмерное пространство
Форум «Всё о Паскале» > Pascal, Object Pascal > Задачи
bairt
В трехмерном пространстве задано N шаров. Найти шар минимального радиуса, охватывающий все заданные
Altair
Есть задача решенная - найти окружность, в которую вместяться все точки на плоскости.
Расширяем задачу на 3d , получаем найти шар....
И потом добавляем к точкам уловие того, что они имеют размер.
Таким образом задача решается.
volvo
<...>
Lapp
volvo, давай рассмотрим частный стучай.
Две сферы, одна с центром в точке (-1,-1,-1), а другая в (1,1,1). Радиусы обеих сфер нулевые. Твой алгоритм даст диаметр, равный 2. На самом же деле он равен Sqrt(3).
volvo
Ну, во-первых, не Sqrt(3), а 2*Sqrt(3)

Если уже взялся что-то опровергать, то делай это ПРАВИЛЬНО.
Lapp
Цитата(volvo @ 23.04.2006 12:55) *

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

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

Извиняюсь. Ошибся. 2*Sqrt(3). И вовсе незачем кричать.
klem4
А есть данные для теста ? А то вот накатал кое что а проверить не могу ;)
klem4
В общем вот что пока есть.На соклько я вижу отличается от того что предложил вольво, но возможно тоже имеет место быть smile.gif ... и всетаки было-бы не плохо увидеть тестовый пример smile.gif

{$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.




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

Volvo, ага тока щас понял smile.gif) Еще ведь долго думал как это может быть минимальная среди имеющихся, которая охватыет все остальные :D
volvo
klem4, ты, если я не ошибаюсь, решаешь несколько другую задачу? Ты пытаешься найти сферу из тех, что заданы?
klem4
Вот такой вариант ... но опятьже нужен тестовые данные ... Вариант годится для случая елси центр хотябы одной сферы не совпадает с центрами остальных, в противном случае берем просто наибольший радиус + 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.



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

Наша же задача сводится к задаче "найти окружность, охватывающую множество окружностей" (2D перевести в 3D не представится сложным). Так вот вопрос: как найти точки A, B и C на прилагаемом мной рисунке?

Генерал, мне кажется, что ты ошибаешься с утверждением "перевести в 3D не представится сложным". Нахождение окружности, касающейся трех заданных, называется "задачей Апполония". Решение ее не очень простое, но существует. Но я не уверен, что оно есть для 3D. В 3D три заданных окружности превращаются в четыре заданных сферы..

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

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

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

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

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

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
а ты можешь выложить результат?
klem4
Цитата
а ты можешь выложить результат?


Извини, не понял тебя ...
bairt
я про данные она правильно работает? и ты можешь прислать решение я сравню его со своим...
klem4
Я же писал, у меня нету нормальных тестовых данных, сочинать их у меня нет ни малейшего желания, если у тебя они есть выложи их, кстате что тебе мешает самому проверить правильность моей программы ? Я не понимаю.
Lapp
Цитата(klem4 @ 25.04.2006 15:41) *

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

klem4, ты не обратил внимания на пост Бравого генерала, а он дело говорил. Вот простой пример, опровергающий твое решение.
Код
Сфера 1:  x=-10  y=0   z=0  r=1
Сфера 2:  x=10   y=0   z=0  r=1
Сфера 3:  x=0    y=12  z=0  r=1

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

Цитата(Бравый генерал @ 23.04.2006 23:20) *

чтобы найти окружность, охватывающую множество точек, нужно найти две максимально удаленные точки M и N, найти еще одну точку, максимально удаленную от отрезка MN, и построить по этим трем точкам окружность.

Бравый генерал, я сначала пропустил это, а сейчас перечитал и увидел: твое утверждение неверно. Вот опровергающий пример.
Код
Точка 1 x=-100  y=0
Точка 2 x=100   y=0
Точка 3 x=0     y=150
Точка 4 x=95    y=-6

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

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

PS
мужики (и дамы тоже!), давайте не прятать ничего и не скрывать. Дискуссия есть дискуссия. Возможны ошибки, возможны неверные рассуждения, неверные понимания - что ж с того? Но среди всего этого рождается Истина! smile.gif
klem4
lapp, а пост # 15 ты учел ?
bairt
Цитата(klem4 @ 26.04.2006 11:25) *
lapp, а пост # 15 ты учел ?

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

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
Цитата(klem4 @ 26.04.2006 7:25) *

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

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

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

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

Если, конечно, кто нибудь не выложит верное решение раньше (или klem4 или bairt не докажут, что они правы). smile.gif
Бравый генерал
Цитата
lapp, а пост # 15 ты учел ?

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

Во-во!
Цитата
и для наглядности сначала делал с окружностями, типа в 2D

Вобщем, чтобы с тем неправильным алгоритмом было все ясно, вот эта программа - тот же алгоритм только в 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.


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

Цитата
Бравый генерал, я сначала пропустил это, а сейчас перечитал и увидел: твое утверждение неверно. Вот опровергающий пример.
Да, прошу прощения, это я не то что-то сказал... smile.gif
(Ой, надо было в предыдущий пост добавить, а я случайно новым отправил.)
klem4
Да, теперь я понял, что был не прав, извиняюсь.

И всеже мне кажется что решение должно быть простым, еще одна идея есть, завтра сделаю.
Lapp
Цитата(klem4 @ 26.04.2006 19:40) *

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

И зачинатель темы куда-то делся.. sad.gif
Ау-у!
Это текстовая версия — только основной контент. Для просмотра полной версии этой страницы, пожалуйста, нажмите сюда.