标题: 3d 凸包 ghx已传上 [打印本页] 作者: panhao1 时间: 2010-1-21 03:02 标题: 3d 凸包 ghx已传上 本帖最后由 panhao1 于 2010-1-22 17:04 编辑
3000ms
扫描算法是网上的 请高人指点
基本上没有用处
算法相当蛮力
弄出几乎可能出现的所有的面 然后逐面进行判定
19个点就存在16*16*16=4096个面 判定4096次 很恐怖的
{:3_63:}
以前2d hull的算法也很糟糕 请高手指点
这里贴上2d hull的代码
Private Sub RunScript(ByVal x As List(Of On3dPoint), ByRef A As Object)
'your code goes here…
Dim list As New List (Of On3dPoint)
Dim firstPt As New On3dPoint(x(0))
Dim j As Integer = 0
For i As Integer = 1 To x.count - 1
If x(i).x < firstPt.x Then
firstPt = x(i)
j = i
End If
Next
list.Add(firstpt)
Dim firstPt1 As New On3dPoint(firstpt)
'first is correct
Dim listPt As New List (Of On3dPoint)(x)
listPt.RemoveRange(j, 1)
Dim sign As Integer = 0
While sign = 0
'print(jj)
For ii As Integer=0 To listpt.Count - 1
If ispt(firstPt, listpt(ii), listpt, ii) = True Then
If listpt(ii) = firstpt1 Then
sign = 1
Exit For
Else
print(ispt(firstPt, listpt(ii), listpt, ii))
Dim newlistpt As New List (Of On3dPoint)(x)
newlistpt = removeitem(firstpt, newlistpt)
print(newlistpt.count)
firstPt = listpt(ii)
list.Add(firstpt)
newlistpt = removeitem(firstpt, newlistpt)
print(newlistpt.count)
listpt = newlistpt
Exit For
End If
End If
Next
End While
a = list
End Sub
'<Custom additional code>
Function ispt(first, second, list, i)
Dim list1 As New list(Of On3dpoint)
list1 = list
Dim second1 As New On3dpoint
second1 = second
Dim vector As New On3dVector
vector = first - second
Dim v As New On3dVector(0, 0, 1)
vector.Rotate(1.5708, v)
Dim third As New list(Of On3dPoint)(list1)
third.removerange(i, 1)
Dim sign As Double = 0
'____________________________________________
For j As Integer=0 To third.count - 1
Dim forth As New On3dVector
forth = first - third(j)
Dim v1 As New On3dVector(vector)
Dim v2 As New On3dVector(forth)
v1.unitize()
v2.unitize()
Dim dot As Double
dot = OnUtil.ON_DotProduct(v1, v2)
If (dot > 1) Then dot = 1
If (dot < -1) Then dot = -1
dot = math.Acos(dot)
If dot < 1.571 Then
sign = 1
Exit For
End If
Next
'______________________________
If sign = 0 Then
ispt = True
Else
ispt = False
End If
End Function
Function removeitem(item, list)
Dim newlist As New list(Of On3dPoint)
For i As Integer=0 To list.count - 1
If list(i) <> item Then
newlist.add(list(i))
End If
Next
removeitem = newlist
End Function
这是3d hull的伪码
输入 L(3d 点）
for (i=0 ，i<L.length-2,i++){
for (j=i ，i<L.length-1,j++){
for (k=j ，i<L.length-,k++){
if（L（i),L（j),L（k)组成的面否符合hull的边界条件){
添加L（i),L（j),L（k)组成的面到集合M中
}
}
}
}
算法太囧 不好意思贴出来作者: renn 时间: 2010-1-21 16:38
O'Rourke (1998) gives a robust two-dimensional implementation as well as an three-dimensional implementation. Qhull works efficiently in 2 to 8 dimensions (Barber et al. 1996).作者: gzblake 时间: 2010-1-21 23:09
提示: 作者被禁止或删除 内容自动屏蔽作者: panhao1 时间: 2010-1-21 23:18 7#gzblake
其他算发有退化的bug的 2级循环算法是很烂
一般都是通过 向量朝一个方向的转角的大小 找点
Function ispt(first, second, list, i)
是很笨的方法 但bug最少