Modificación de un objeto Graphics3D generado por ParametricPlot3D

Question

Aquí hay un conjunto de 3D points estructurado. Ahora podemos formar un BSpline usando estos puntos como nudos.

dat=Import["3DFoil.mat", "Data"] 
fu=BSplineFunction[dat] 

Aquí podemos hacer un ParametricPlot3D con estos puntos.

pic=ParametricPlot3D[fu[u,v],{u, 0, 1}, {v, 0, 1}, Mesh -> All, AspectRatio -> 
Automatic,PlotPoints->10,Boxed-> False,Axes-> False] 

Pregunta

Si miramos cuidadosamente la geometría 3D que sale de la spline podemos ver que se trata de una estructura hueca. Este agujero aparece en ambos lados del perfil simétrico. ¿Cómo podemos perfectamente (no visualmente!) Llene este agujero y cree un objeto unificado Graphics3D donde los agujeros en ambos lados están parcheados.

Lo que yo soy capaz de conseguir hasta ahora es la siguiente. Los agujeros no están completamente reparados.

Estoy haciendo demasiadas preguntas recientemente y lo siento por eso. Pero si alguno de ustedes se interesa, espero que ayude.

actualización

Aquí está el problema con el método de Belisario. Genera triángulos con áreas casi insignificantes.

dat = Import[NotebookDirectory[] <> "/3DFoil.mat", "Data"]; 
(*With your points in "dat"*) 
fd = First@Dimensions@dat; 
check = ParametricPlot3D[{BSplineFunction[dat][u, v], 
BSplineFunction[{dat[[1]], Reverse@dat[[1]]}][u, v], 
BSplineFunction[{dat[[fd]], Reverse@dat[[fd]]}][u, v]}, {u, 0, 
1}, {v, 0, 1}, Mesh -> All, AspectRatio -> Automatic, 
PlotPoints -> 10, Boxed -> False, Axes -> False] 

salida es aquí

Export[NotebookDirectory[]<>"myres.obj",check]; 
cd=Import[NotebookDirectory[]<>"myres.obj"]; 
middle= 
check[[1]][[2]][[1]][[1(* Here are the numbers of different Graphics group*)]][[2,1,1,1]]; 
sidePatch1=check[[1]][[2]][[1]][[2]][[2,1,1,1]]; 
sidePatch2=check[[1]][[2]][[1]][[3]][[2,1,1,1]]; 

Hay tres grupos Graphics descansar están vacíos. Ahora veamos el área de los triángulos en esos grupos.

polygonArea[pts_List? 
(Length[#]==3&)]:=Norm[Cross[pts[[2]]-pts[[1]],pts[[3]]-pts[[1]]]]/2 
TriangleMaker[{a_,b_,c_}]:={vertices[[a]],vertices[[b]],vertices[[c]]} 
tring=Map[polygonArea[TriangleMaker[#]]&,middle]; 
tring//Min 

Para la salida grupo grande medio es

0.000228007 

lo tanto, esta es una triangulación permisible. Pero para los parches laterales obtenemos cero áreas.

Map[polygonArea[TriangleMaker[#]] &, sidePatch1] // Min 
Map[polygonArea[TriangleMaker[#]] &, sidePatch2] // Min 

Cualquier salida aquí belisarius?

Mi solución parcial

primer lugar, descargue el paquete de simplificación poligonal compleja desde Wolfram archive.

fu = BSplineFunction[dat]; 
pic =(*ParametricPlot3D[fu[u,v],{u,0,1},{v,0,1},Mesh->None, 
AspectRatio->Automatic,PlotPoints->25,Boxed->False,Axes->False, 
BoundaryStyle->Red]*) 
ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1}, Mesh -> None, 
AspectRatio -> Automatic, PlotPoints -> 10, Boxed -> False, 
Axes -> False, BoundaryStyle -> Black]; 
bound = First@Cases[Normal[pic], Line[pts_] :> pts, Infinity]; 
corners = Flatten[Table[fu[u, v], {u, 0, 1}, {v, 0, 1}], 1]; 
nf = Nearest[bound -> Automatic]; {a1, a2} = 
Union@Flatten@(nf /@ corners); 
sets = {bound[[2 ;; a1]], bound[[a1 ;; a2]],bound[[a2 ;; a2 + a1]]}; 
CorrectOneNodeNumber = Polygon[sets[[{1, 3}]]][[1]][[1]] // Length; 
CorrectOneNodes1 = 
Polygon[sets[[{1, 3}]]][[1]][[1]]; CorrectOneNodes2 = 
Take[Polygon[sets[[{1, 3}]]][[1]][[2]], CorrectOneNodeNumber]; 
<< PolygonTriangulation`SimplePolygonTriangulation` 
ver1 = CorrectOneNodes1; 
ver2 = CorrectOneNodes2; 
triang1 = SimplePolygonTriangulation3D[ver1]; 
triang2 = SimplePolygonTriangulation3D[ver2]; 
Show[Graphics3D[{PointSize[Large], Point[CorrectOneNodes1]},Boxed -> False, 
BoxRatios -> 1], Graphics3D[{PointSize[Large], Point[CorrectOneNodes2]}, 
Boxed -> False, BoxRatios -> 1], 
Graphics3D[GraphicsComplex[ver1, Polygon[triang1]], Boxed -> False, 
BoxRatios -> 1], 
Graphics3D[GraphicsComplex[ver2, Polygon[triang2]], Boxed -> False, 
BoxRatios -> 1]] 

Aquí obtenemos bonitos triángulos.

picfin=ParametricPlot3D[fu[u,v],{u,0,1}, {v,0,1},Mesh->All,AspectRatio->Automatic,PlotPoints->10,Boxed->False,Axes->False,BoundaryStyle->None];pic3D=Show[Graphics3D[GraphicsComplex[ver1,Polygon[triang1]]],picfin,Graphics3D[GraphicsComplex[ver2,Polygon[triang2]]],Boxed->False,Axes->False] 

Ahora bien, esto tiene un solo problema. Aquí, independientemente del PlotPoints, siempre aparecen cuatro triángulos que solo comparten solo un borde con cualquier otro triángulo contiguo. Pero esperamos que todos los triángulos compartan al menos dos bordes con otros trangles. Eso sucede si usamos el método belisarius. Pero crea triángulos demasiado pequeños que mi solucionador de panel rechaza como hormigueo con área cero.

Se puede verificar aquí el problema de mi método. Aquí utilizaremos el método de la solución por Sjoerd.

Export[NotebookDirectory[]<>"myres.obj",pic3D]; 
cd=Import[NotebookDirectory[]<>"myres.obj"]; 
polygons=(cd[[1]][[2]]/.GraphicsComplex-> List)[[2]][[1]][[1,1]]; 
pt=(cd[[1]][[2]]/.GraphicsComplex-> List)[[1]]; 
vertices=pt; 
(*Split every triangle in 3 edges,with nodes in each edge sorted*) 
triangleEdges=(Sort/@Subsets[#,{2}])&/@polygons; 
(*Generate a list of edges*) 
singleEdges=Union[Flatten[triangleEdges,1]]; 
(*Define a function which,given an edge (node number list),returns the bordering*) 
(*triangle numbers.It's done by working through each of the triangles' edges*) 
ClearAll[edgesNeighbors] 
edgesNeighbors[_]={}; 
MapIndexed[(edgesNeighbors[#1[[1]]]=Flatten[{edgesNeighbors[#1[[1]]],#2[[1]]}]; 
edgesNeighbors[#1[[2]]]=Flatten[{edgesNeighbors[#1[[2]]],#2[[1]]}]; 
edgesNeighbors[#1[[3]]]=Flatten[{edgesNeighbors[#1[[3]]],#2[[1]]}];)&,triangleEdges]; 

(*Build a triangle relation table.Each'1' indicates a triangle relation*) 
relations=ConstantArray[0,{triangleEdges//Length,triangleEdges//Length}]; 
Scan[(n=edgesNeighbors[##]; 
If[Length[n]==2,{n1,n2}=n; 
relations[[n1,n2]]=1;relations[[n2,n1]]=1];)&,singleEdges] 
(*Build a neighborhood list*) 
triangleNeigbours=Table[Flatten[Position[relations[[i]],1]],{i,triangleEdges//Length}]; 
trires=Table[Flatten[{polygons[[i]],triangleNeigbours[[i]]}],{i,1,Length@polygons}]; 
Cases[Cases[trires,x_:>Length[x]],4] 

La salida muestra que siempre hay cuatro triángulos que comparten solo un borde con los demás.

{4,4,4,4} 

En el caso del método de Belisario no vemos que esto ocurra, pero no obtenemos triángulos con áreas numéricamente cero.

BR

Answer 1

Su conjunto de datos se ve así:

Graphics3D[Point@Flatten[dat, 1]] 

Consiste en 22 secciones de 50 puntos.

Adición de una línea media en cada sección de extremo (que en realidad es la sección del extremo aplanado):

dat2 = Append[Prepend[dat, 
         Table[(dat[[1, i]] + dat[[1, -i]])/2, {i, Length[dat[[1]]]}] 
       ], 
       Table[(dat[[-1, i]] + dat[[-1, -i]])/2, {i, Length[dat[[-1]]]}] 
     ]; 

Graphics3D[{Point@Flatten[dat, 1], Red, Point@dat2[[1]], Green, Point@dat2[[-1]]}] 

Ahora añadir algunos pesos al borde extremo del ala:

sw = Table[1, {24}, {50}]; 
sw[[2]] = 1000 sw[[1]]; 
sw[[-2]] = 1000 sw[[1]]; 
fu = BSplineFunction[dat2, SplineWeights -> sw]; 

Show[ 
    ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1}, Mesh -> All, 
         AspectRatio -> Automatic, PlotPoints -> 20, Boxed -> False, 
         Axes -> False, Lighting -> "Neutral" 
    ], 
    Graphics3D[{PointSize -> 0.025, Green, Point@dat2[[-1]], Red,Point@dat2[[-2]]}] 
] 

Tenga en cuenta que he aumentado el PlotPoints valor a 20.

Answer 2

Importe los datos y construir la función BSpline como antes:

dat = Import["Downloads/3DFoil.mat", "Data"]; 

fu = BSplineFunction[dat] 

Generar la superficie, asegurándose de incluir (solamente) la línea de límite, que seguirá a la borde de la superficie . Asegúrese de establecer Mesh en All o None.

pic = ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1}, Mesh -> None, 
    AspectRatio -> Automatic, PlotPoints -> 10, Boxed -> False, 
    Axes -> False, BoundaryStyle -> Red] 

Extracto de los puntos de la línea de límite:

bound = First@Cases[Normal[pic], Line[pts_] :> pts, Infinity] 

Encuentra las "esquinas", basado en el espacio de parámetros:

corners = Flatten[Table[fu[u, v], {u, 0, 1}, {v, 0, 1}], 1] 

Encuentra los puntos de borde mejor correspondientes a las esquinas , teniendo en cuenta que ParametricPlot3D no utiliza los límites exactamente, por lo que no podemos simplemente usar Position:

nf = Nearest[bound -> Automatic]; 
nf /@ corners 

Figura nuestro rango de puntos en el límite que corresponde a las áreas que necesita llenar. Este paso involucró alguna inspección manual.

sets = {bound[[2 ;; 22]], bound[[22 ;; 52]], bound[[52 ;; 72]], 
    bound[[72 ;;]]} 

construcción de nuevos polígonos correspondientes a los agujeros:

Graphics3D[Polygon[sets[[{1, 3}]]], Boxed -> False, BoxRatios -> 1] 

Show[pic, Graphics3D[Polygon[sets[[{1, 3}]]]]] 

Tenga en cuenta que es probable que haya todavía un agujero que no puede ser visto en el borde se extiende entre los agujeros que usted ha mencionado, y no he T intentó completarlo, pero debería tener suficiente información para hacerlo si fuera necesario.

Answer 3

(*With your points in "dat"*) 
fu = BSplineFunction[dat[[1 ;; 2]]]; 
Show[{ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1}, 
         Mesh -> All, AspectRatio -> Automatic, PlotPoints -> 30], 
     ListPlot3D[dat[[1]]]}] 

Y con

InputForm[%] 

que presentamos lo mejor el objeto gráfico "unificadas".

Editar

Otra forma, probablemente mejor:

(*With your points in "dat"*) 
fu = BSplineFunction[dat]; 
Show[ 

{ ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1}, 
         Mesh -> All, AspectRatio -> Automatic, 
         PlotPoints -> 10, Boxed -> False, Axes -> False], 
    ParametricPlot3D[ 
    BSplineFunction[{First@dat, Reverse@First@dat}][u, v], {u, 0, 1}, {v, 0, 1}, 
        Mesh -> None, PlotStyle -> Yellow], 
    ParametricPlot3D[ 
    BSplineFunction[{dat[[First@Dimensions@dat]], 
        Reverse@dat[[First@Dimensions@dat]]}] 
        [u, v], {u, 0, 1}, {v, 0, 1}]}] 

En tan sólo una estructura:

(*With your points in "dat"*) 
fd = First@Dimensions@dat; 
ParametricPlot3D[ 
{BSplineFunction[dat][u, v], 
    BSplineFunction[{dat[[1]], Reverse@dat[[1]]}] [u, v], 
    BSplineFunction[{dat[[fd]], Reverse@dat[[fd]]}][u, v]}, 
{u, 0, 1}, {v, 0, 1}, 
Mesh -> All, AspectRatio -> Automatic, 
PlotPoints -> 10, Boxed -> False, Axes -> False] 

Editar

Se puede comprobar que hay triángulos pequeños, pero son triángulos de hecho y no cero zona de polígonos:

fu = BSplineFunction[dat]; 
check = ParametricPlot3D[{BSplineFunction[{First@dat, Reverse@dat[[1]]}][u, v]}, 
         {u, 0, 1}, {v, 0, 1}, Mesh -> All, 
         PlotStyle -> Yellow, Mesh -> All, AspectRatio -> Automatic, 
         PlotPoints -> 10, Boxed -> False, Axes -> False]; 
pts = check /. Graphics3D[GraphicsComplex[a_, b__], ___] -> a; 
m = check[[1]][[2]][[1]][[1]] /. {___, GraphicsGroup[{Polygon[a_]}]} -> a; 
t = Replace[m, {a_, b_, c_} -> {pts[[a]], pts[[b]], pts[[c]]}, {1}]; 
polygonArea[pts_List?(Length[#] == 3 &)] := 
           Norm[Cross[pts[[2]] - pts[[1]], pts[[3]] - pts[[1]]]]/2; 

t[[Position[Ordering[polygonArea /@ t], 1][[1]]]] 

(* 
->{{{-4.93236, 0.0989696, -2.91748}, 
    {-4.92674, 0.0990546, -2.91748}, 
    {-4.93456, 0.100181, -2.91748}}} 
*)