Related
I'm trying to write a program in Mathematica that will simulate the way charged ball bearings spread out when they are charged with like charges (they repel each other). My program so far keeps the ball bearings from moving off the screen, and counts the number of times they hit the side of the box. I have the ball bearings moving randomly around the box so far, but I need to know how to make them repel each other.
Here's my code so far:
Manipulate[
(*If the number of points has been reduced, discard points*)
If[ballcount < Length[contents],
contents = Take[contents, ballcount]];
(*If the number of points has been increased, generate some random points*)
If[ballcount > Length[contents],
contents =
Join[contents,
Table[{RandomReal[{-size, size}, {2}], {Cos[#], Sin[#]} &[
RandomReal[{0, 2 \[Pi]}]]}, {ballcount - Length[contents]}]]];
Grid[{{Graphics[{PointSize[0.02],
(*Draw the container*)
Line[size {{-1, -1}, {1, -1}, {1, 1}, {-1, 1}, {-1, -1}}],
Blend[{Blue, Red}, charge/0.3],
Point[
(*Start the main dynamic actions*)
Dynamic[
(*Reset the collision counter*)
collision = 0;
(*Check for mouse interaction and add points if there has been one*)
Refresh[
If[pt =!= lastpt, If[ballcount =!= 50, ballcount++];
AppendTo[
contents, {pt, {Cos[#], Sin[#]} &[
RandomReal[{0, 2 \[Pi]}]]}]; lastpt = pt],
TrackedSymbols -> {pt}];
(*Update the position of the points using their velocity values*)
contents = Map[{#[[1]] + #[[2]] charge, #[[2]]} &, contents];
(*Check for and fix points that have exceeded the box in Y
direction, incrementing the collision counter for each one*)
contents = Map[
If[Abs[#[[1, 2]]] > size,
collision++; {{#[[1, 1]],
2 size Sign[#[[1, 2]]] - #[[1, 2]]}, {1, -1} #[[
2]]}, #] &,
contents];
(*Check for and fix points that have exceeded the box in X
direction, incrementing the collision counter for each one*)
contents = Map[
If[Abs[#[[1, 1]]] > size,
collision++; {{2 size Sign[#[[1, 1]]] - #[[1, 1]], #[[1,
2]]}, {-1, 1} #[[2]]}, #] &,
contents];
hits = Take[PadLeft[Append[hits, collision/size], 200], 200];
Map[First, contents]]]},
PlotRange -> {{-1.01, 1.01}, {-1.01, 1.01}},
ImageSize -> {250, 250}],
(*Show the hits*)
Dynamic#Show
[
ListPlot
[
Take[MovingAverage[hits, smooth], -100
]
,
Joined -> True, ImageSize -> {250, 250}, AspectRatio -> 1,
PlotLabel -> "number of hits", AxesLabel -> {"time", "hits"},
PlotRange -> {0, Max[Max[hits], 1]}], Graphics[]
]
}}
]
,
{{pt, {0, 1}}, {-1, -1}, {1, 1}, Locator, Appearance -> None},
{{ballcount, 5, "number of ball bearings"}, 1, 50, 1},
{{charge, 0.05, "charge"}, 0.002, 0.3},
{smooth, 1, ControlType -> None, Appearance -> None},
{size, 1, ControlType -> None, Appearance -> None},
{hits, {{}}, ControlType -> None},
{contents, {{}}, ControlType -> None},
{lastpt, {{0, 0}}, ControlType -> None}
]
What you need for your simulation is a "collision detection algorithm". The field of those algorithms is widespread since it is as old as computer games (Pong) are and it is impossible to give a complete answer here.
Your simulation as it is now is very basic because you advance your charged balls every time step which makes them "jump" from position to position. If the movement is as simple as it is with the constant velocity and zero acceleration, you know the exact equation of the movement and could calculate all positions by simply putting the time into the equations. When a ball bounces off the wall, it gets a new equation.
With this, you could predict, when two balls will collide. You simply solve for two balls, whether they have at the same time the same position. This is called A Priori detection. When you take your simulation as it is now, you would have to check at every timestep, whether or not two balls are so close together, that they may collide.
The problem there is, that your simulation speed is not infinitely high and the faster your balls are, the bigger the jumps in your simulation. It is then not unlikely, that two balls over-jump each other and you miss a collision.
With this in mind, you could start by reading the Wikipedia article to that topic, to get an overview. Next, you could read some scientific articles about it or check out, how the cracks do it. The Chipmunk physics engine for instance is an amazing 2d-physics engine. To ensure that such stuff works, I'm pretty sure they had to put a lot thoughts in their collision detection.
I can't do the detection part since that is a project on its own. But it seems now the interaction is faster, you had few Dynamics which were not needed. (if you see the side of the cell busy all the time, this always mean a Dynamic is busy where it should not be).
I also added a STOP/START button. I could not understand everything you were doing, but enough to make the changes I made. You are also using AppendTo everything. You should try to allocate contents before hand, and use Part[] to access it, would be much faster, since you seem to know the maximum points allowed?
I like to spread the code out more, this helps me see the logic more.
Here is a screen shot, and the updated version code is below. Hope you find it faster.
Please see code below, in update (1)
Update (1)
(*updated version 12/30/11 9:40 AM*)
Manipulate[(*If the number of points has been reduced,discard points*)
\
Module[{tbl, rand, npt, ballsToAdd},
If[running,
(
tick += $MachineEpsilon;
If[ballcount < Length[contents],
contents = Take[contents, ballcount]];
(*If the number of points has been increased,
generate some random points*)
If[ballcount > Length[contents],
(
ballsToAdd = ballcount - Length[contents];
tbl =
Table[{RandomReal[{-size, size}, {2}], {Cos[#], Sin[#]} &[
RandomReal[{0, 2 \[Pi]}]]}, {ballsToAdd}];
contents = Join[contents, tbl]
)
];
image = Grid[{
{LocatorPane[Dynamic[pt], Graphics[{
PointSize[0.02],(*Draw the container*)
Line[size {{-1, -1}, {1, -1}, {1, 1}, {-1, 1}, {-1, -1}}],
Blend[{Blue, Red}, charge/0.3],
Point[(*Start the main dynamic actions*)
(*Reset the collision counter*)
collision = 0;
(*Check for mouse interaction and add points if there has \
been one*)
If[EuclideanDistance[pt, lastpt] > 0.001, (*adjust*)
(
If[ballcount < MAXPOINTS,
ballcount++
];
rand = RandomReal[{0, 2 \[Pi]}];
npt = {Cos[rand], Sin[rand]};
AppendTo[contents, {pt, npt} ];
lastpt = pt
)
];
(*Update the position of the points using their velocity \
values*)
contents =
Map[{#[[1]] + #[[2]] charge, #[[2]]} &, contents];
(*Check for and fix points that have exceeded the box in \
Y direction,incrementing the collision counter for each one*)
contents = Map[
If[Abs[#[[1, 2]]] > size,
(
collision++;
{{#[[1, 1]],
2 size Sign[#[[1, 2]]] - #[[1, 2]]}, {1, -1} #[[2]]}
),
(
#
)
] &, contents
];
(*Check for and fix points that have exceeded the box in \
X direction,
incrementing the collision counter for each one*)
contents =
Map[If[Abs[#[[1, 1]]] > size,
collision++; {{2 size Sign[#[[1, 1]]] - #[[1, 1]], #[[
1, 2]]}, {-1, 1} #[[2]]}, #] &, contents
];
hits = Take[PadLeft[Append[hits, collision/size], 200],
200];
Map[First, contents]
]
},
PlotRange -> {{-1.01, 1.01}, {-1.01, 1.01}},
ImageSize -> {250, 250}
], Appearance -> None
],(*Show the hits*)
Show[ListPlot[Take[MovingAverage[hits, smooth], -100],
Joined -> True, ImageSize -> {250, 250}, AspectRatio -> 1,
PlotLabel -> "number of hits", AxesLabel -> {"time", "hits"},
PlotRange -> {0, Max[Max[hits], 1]}
]
]
}
}
]
)
];
image
],
{{MAXPOINTS, 50}, None},
{pt, {{0, 1}}, None},
{{ballcount, 5, "number of ball bearings"}, 1, MAXPOINTS, 1,
Appearance -> "Labeled", ImageSize -> Small},
{{charge, 0.05, "charge"}, 0.002, 0.3, Appearance -> "Labeled",
ImageSize -> Small},
Row[{Button["START", {running = True; tick += $MachineEpsilon}],
Button["STOP", running = False]}],
{{tick, 0}, None},
{smooth, 1, None},
{size, 1, None},
{hits, {{}}, None},
{{contents, {}}, None},
{lastpt, {{0, 0}}, None},
{{collision, 0}, None},
{image, None},
{{running, True}, None},
TrackedSymbols -> { tick},
ContinuousAction -> False,
SynchronousUpdating -> True
]
Please consider:
Function[subID,
pointSO[subID] = RandomInteger[{1, 4}, {5, 2}]] /# {"subA", "subB"};
Manipulate[
Manipulate[
Graphics[{
Black, Rectangle[{0, 0}, {5, 5}],
White,Point#pointSO[subID][[i]]
},
ImageSize -> {400, 300}],
{i,Range[Length#pointSO[subID]]}],
{subID, {"subA", "subB"}}]
Provided that pointSO[subID] actually yields to lists of different length, is there a way to avoid having 2 Manipulate given that one of the manipulated variable depends on the other?
I am not sure that I got exactly what you are asking for, but I figured what you want is something like the following:
Given a UI with one variable, say an array that can change in size, and another (dependent) variable, which represents say an index into the current array that you want to use from the UI to index into the array.
But you do not want to fix the index variable layout in the UI, since it depends, at run time, on the size of the array, which can change using the second variable.
Here is a one manipulate, which has a UI that has an index control variable, which updates dynamically on the UI as the size of the array changes.
I used SetterBar for the index (the dependent variable) but you can use slider just as well. SetterBar made it more clear on the UI what is changing.
When you change the length of the array, the index control variable automatically updates its maximum allowed index to be used to match the current length of the array.
When you shrink the array, the index will also shrink.
I am not sure if this is what you want, but if it, you can adjust this approach to fit into your problem
Manipulate[
Grid[{
{Style[Row[{"data[[", i, "]]=", data[[i]]}], 12]},
{MatrixForm[data], SpanFromLeft}
},
Alignment -> Left, Spacings -> {0, 1}
],
Dynamic#Grid[{
{Text["select index into the array = "],
SetterBar[Dynamic[i, {i = #} &], Range[1, Length[data]],
ImageSize -> Tiny,
ContinuousAction -> False]
},
{
Text["select how long an array to build = "],
Manipulator[
Dynamic[n, {n = #; If[i > n, i = n];
data = Table[RandomReal[], {n}]} &],
{1, 10, 1}, ImageSize -> Tiny, ContinuousAction -> False]
, Text[Length[data]], SpanFromLeft
}
}, Alignment -> Left
],
{{n, 2}, None},
{{i, 2}, None},
{{data, Table[RandomReal[], {2}]}, None},
TrackedSymbols -> {n, i}
]
update 8:30 PM
fyi, just made a fix to the code above to add a needed extra logic.
To avoid the problem of i being too large when switching lists, you could add an If[] statement at the beginning of the Manipulate, e.g.
Clear[pointSO];
MapThread[(pointSO[#] = RandomInteger[{1, 4}, {#2, 2}]) &,
{{"subA", "subB"}, {5, 7}}];
Manipulate[
If[i > Length[pointSO[subID]], i = Length[pointSO[subID]]];
Graphics[{Black, Rectangle[{0, 0}, {5, 5}], White,
Point#pointSO[subID][[i]]}, ImageSize -> {400, 300}],
{{subID, "subA"}, {"subA", "subB"}, SetterBar},
{{i, {}}, Range[Length#pointSO[subID]], SetterBar}]
Maybe nicer is to reset i when switching between lists. This can be done by doing something like
Manipulate[
Graphics[{Black, Rectangle[{0, 0}, {5, 5}], White,
Point#pointSO[subID][[i]]}, ImageSize -> {400, 300}],
{{subID, "subA"},
SetterBar[Dynamic[subID, (i = {}; subID = #) &], {"subA", "subB"}] &},
{{i, {}}, Range[Length#pointSO[subID]], SetterBar}
]
An alternative implementation that preserves selection settings for each data set:
listlength["subA"] = 5; listlength["subB"] = 9;
Function[subID,
pointSO[subID] =
RandomInteger[{1, 4}, {listlength[subID], 2}]] /# {"subA", "subB"};
Manipulate[
Graphics[{Black, Rectangle[{0, 0}, {5, 5}],
Dynamic[If[subID == "subA", Yellow, Cyan]], PointSize -> .05,
Dynamic#Point#pointSO[subID][[k]]}, ImageSize -> {400, 300}],
Row[{Panel[
SetterBar[
Dynamic[subID,
(subID = #; k = If[subID == "subA", j, i]) &],{"subA", "subB"},
Appearance -> "Button", Background -> GrayLevel[.8]]], " ",
PaneSelector[{"subA" ->
Dynamic#Panel[
SetterBar[Dynamic[j, (k = j; j = #) &],
Range[Length#pointSO["subA"]], Appearance -> "Button",
Background -> Yellow]],
"subB" ->
Dynamic#Panel[
SetterBar[Dynamic[i, (k = i; i = #) &],
Range[Length#pointSO["subB"]], Appearance -> "Button",
Background -> Cyan]]}, Dynamic[subID]]}]]
Output examples:
In the accepted answer of question " Mathematica and MouseListener - developing interactive graphics with Mma " Sjoerd C de Vries demonstrates that it is possible to select an object in a 3D graphic and change its color.
I would like to know if it is possible (in a similar fashion as above) in a Graphics3D with two or more objects (e.g. two cuboids) to select one and change its coordinates (by moving or otherwise)?
I'm partly reusing Sjoerd's code here, but maybe something like this
DynamicModule[{pos10, pos11 = {0, 0, 0},
pos12 = {0, 0, 0}, pos20, pos21 = {0, 0, 0}, pos22 = {0, 0, 0}},
Graphics3D[{EventHandler[
Dynamic[{Translate[Cuboid[], pos11]}, ImageSize -> Tiny],
{"MouseDown" :> (pos10 = Mean#MousePosition["Graphics3DBoxIntercepts"]),
"MouseDragged" :> (pos11 =
pos12 + Mean#MousePosition["Graphics3DBoxIntercepts"] - pos10),
"MouseUp" :> (pos12 = pos11)}],
EventHandler[
Dynamic[{Translate[Cuboid[{1, 1, 1}], pos21]}, ImageSize -> Tiny],
{"MouseDown" :> (pos20 = Mean#MousePosition["Graphics3DBoxIntercepts"]),
"MouseDragged" :> (pos21 =
pos22 + Mean#MousePosition["Graphics3DBoxIntercepts"] - pos20),
"MouseUp" :> (pos22 = pos21)}]},
PlotRange -> {{-3, 3}, {-3, 3}, {-3, 3}}]]
Note that this just moves the cuboids in a plane so you would have to rotate the bounding box to move them perpendicular to that plane, but it shouldn't be too hard to introduce a third dimensions by adding modifier keys.
Edit
Thanks for the comments. Here's an updated version of the code above. In this version the cubes jump back to within the bounding box if they happen to move outside so that should solve the problem of the disappearing cubes.
DynamicModule[{init, cube, bb, restrict, generate},
init = {{0, 0, 0}, {2, 1, 0}};
bb = {{-3, 3}, {-3, 3}, {-3, 3}};
cube[pt_, scale_] :=
Translate[Scale[Cuboid[{-1/2, -1/2, -1/2}, {1/2, 1/2, 1/2}], scale], pt];
restrict[pt_] := MapThread[Min[Max[#1[[1]], #2], #1[[2]]] &, {bb, pt}];
generate[pos_, scale_] := Module[{mp, pos0, pos1, pos2},
mp := MousePosition["Graphics3DBoxIntercepts"];
pos1 = pos;
EventHandler[
Dynamic[{cube[pos1, scale]}, ImageSize -> Tiny],
{"MouseDown" :> (pos0 = LeastSquares[Transpose[mp], pos1].mp),
"MouseDragged" :>
((pos1 = #[[2]] + Projection[pos0 - #[[2]], #[[1]] - #[[2]]]) &#mp),
"MouseUp" :> (pos1 = restrict[pos1])}]];
Graphics3D[generate[#, 1] & /# init, PlotRange -> bb, PlotRangePadding -> .5]
]
Here is a set of structured 3D points. Now we can form a BSpline using these points as knots.
dat=Import["3DFoil.mat", "Data"]
fu=BSplineFunction[dat]
Here we can do a ParametricPlot3D with these points.
pic=ParametricPlot3D[fu[u,v],{u, 0, 1}, {v, 0, 1}, Mesh -> All, AspectRatio ->
Automatic,PlotPoints->10,Boxed-> False,Axes-> False]
Question
If we carefully look at the 3D geometry coming out of the spline we can see that it is a hollow structure. This hole appears in both side of the symmetric profile. How can we perfectly (not visually!) fill up this hole and create a unified Graphics3D object where holes in both sides are patched.
What I am able to get so far is the following. Holes are not fully patched.
I am asking too many questions recently and I am sorry for that. But if any of you get interested I hope you will help.
Update
Here is the problem with belisarius method.
It generates triangles with almost negligible areas.
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]
output is here
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]];
There are three Graphics groups rest are empty. Now lets see the area of the triangles in those groups.
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
For the middle large group output is
0.000228007
This is therefore a permissible triangulation. But for the side patches we get zero areas.
Map[polygonArea[TriangleMaker[#]] &, sidePatch1] // Min
Map[polygonArea[TriangleMaker[#]] &, sidePatch2] // Min
Any way out here belisarius ?
My partial solution
First download the package for simplifying complex polygon from 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]]
We get nice triangles here.
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]
Now this has just one problem. Here irrespective of the PlotPoints there are four triangles always appearing that just shares only one edge with any other neighboring triangle. But we expect all of the triangles to share at least two edges with other trangles. That happens if we use belisarius method. But it creates too small triangles that my panel solver rejects as tingles with zero area.
One can check here the problem of my method. Here we will use the method from the solution by 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]
Output shows always there are four triangles that shares only one edges with others.
{4,4,4,4}
In case of belisarius method we don't see this happening but there we get triangles with numerically zero areas.
BR
Import the data and construct the BSpline function as before:
dat = Import["Downloads/3DFoil.mat", "Data"];
fu = BSplineFunction[dat]
Generate the surface, making sure to include (only) the boundary line, which will follow the edge of the surface. Make sure to set Mesh to either All or None.
pic = ParametricPlot3D[fu[u, v], {u, 0, 1}, {v, 0, 1}, Mesh -> None,
AspectRatio -> Automatic, PlotPoints -> 10, Boxed -> False,
Axes -> False, BoundaryStyle -> Red]
Extract the points from the boundary line:
bound = First#Cases[Normal[pic], Line[pts_] :> pts, Infinity]
Find the "corners", based on your parameter space:
corners = Flatten[Table[fu[u, v], {u, 0, 1}, {v, 0, 1}], 1]
Find the edge points best corresponding to the corners, keeping in mind that ParametricPlot3D doesn't use the limits exactly, so we can't just use Position:
nf = Nearest[bound -> Automatic];
nf /# corners
Figure our which range of points on the boundary correspond to the areas you need to fill up. This step involved some manual inspection.
sets = {bound[[2 ;; 22]], bound[[22 ;; 52]], bound[[52 ;; 72]],
bound[[72 ;;]]}
Construct new polygons corresponding to the holes:
Graphics3D[Polygon[sets[[{1, 3}]]], Boxed -> False, BoxRatios -> 1]
Show[pic, Graphics3D[Polygon[sets[[{1, 3}]]]]]
Note that there is probably still a hole that can't be seen where the edge runs between the holes you mentioned, and I haven't tried to fill it in, but you should have enough information to do that if needed.
Your data set looks like this:
Graphics3D[Point#Flatten[dat, 1]]
It consists of 22 sections of 50 points.
Adding a mid-line in each end section (which is actually the end section flattened):
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]]}]
Now add some weights to the wingtip rim:
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]]}]
]
Note that I increased the PlotPoints value to 20.
(*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]]]}]
And with
InputForm[%]
you get the "unified" graphics object.
Edit
Another way, probably better:
(*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}]}]
In just one structure:
(*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]
Edit
You can check that there are small triangles, but they are triangles indeed and not zero area polygons:
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}}}
*)
Say I have three lists: a={1,5,10,15} b={2,4,6,8} and c={1,1,0,1,0}. I want a plot which has a as the x axis, b as the y axis and a red/black dot to mark 1/0. For. e.g. The coordinate (5,4) will have a red dot.
In other words the coordinate (a[i],b[i]) will have a red/black dot depending on whether c[i] is 1 or 0.
I have been trying my hand with ListPlot but can't figure out the options.
I suggest this.
a = {1, 5, 10, 15};
b = {2, 4, 6, 8};
c = {1, 1, 0, 1};
Graphics[
{#, Point#{##2}} & ###
Thread#{c /. {1 -> Red, 0 -> Black}, a, b},
Axes -> True, AxesOrigin -> 0
]
Or shorter but more obfuscated
Graphics[
{Hue[1, 1, #], Point#{##2}} & ### Thread#{c, a, b},
Axes -> True, AxesOrigin -> 0
]
Leonid's idea, perhaps more naive.
f[a_, b_, c_] :=
ListPlot[Pick[Transpose[{a, b}], c, #] & /# {0, 1},
PlotStyle -> {PointSize[Large], {Blue, Red}}]
f[a, b, c]
Edit: Just for fun
f[h_, a_, b_, c_, opt___] :=
h[Pick[Transpose[{a, b}], c, #] & /# {0, 1},
PlotStyle -> {PointSize[Large], {Blue, Red}}, opt]
f[ ListPlot,
Sort#RandomReal[1, 100],
Sin[(2 \[Pi] #)/100] + RandomReal[#/100] & /# Range[100],
RandomInteger[1, 100],
Joined -> True,
InterpolationOrder -> 2,
Filling -> Axis]
Here are your points:
a = {1, 5, 10, 15};
b = {2, 4, 6, 8};
c = {1, 1, 0, 1};
(I deleted the last element from c to make it the same length as a and b). What I'd suggest is to separately make images for points with zeros and ones and then combine them - this seems easiest in this situation:
showPoints[a_, b_, c_] :=
With[{coords = Transpose[{a, b}]},
With[{plotF = ListPlot[Pick[coords, c, #], PlotMarkers -> Automatic, PlotStyle -> #2] &},
Show[MapThread[plotF, {{0, 1}, {Black, Red}}]]]]
Here is the usage:
showPoints[a, b, c]
One possibility:
ListPlot[List /# Transpose[{a, b}],
PlotMarkers -> {1, 1, 0, 1} /. {1 -> { Style[\[FilledCircle], Red], 10},
0 -> { { Style[\[FilledCircle], Black], 10}}},
AxesOrigin -> {0, 0}]
Giving as output:
You could obtain similar results (to those of Leonid) using Graphics:
Graphics[{PointSize[.02], Transpose[{(c/. {1 -> Red, 0 -> Black}),
Point /# Transpose[{a, b}]}]},
Axes -> True, AxesOrigin -> {0, 0}]