Related
I am trying to parametrize a 3D geometry for shape optimization. The structure looks like the following. Another real example is here.
Currently I am using BSplines to create the lower part and using symmetry to create the whole down part of the foil. Here is what I get.
Now I have many control points to take care in order to run a shape optimization. I also don't know how to join the upper part with the bottom hydrofoil part in a sensible way. I don't know how to design a good middle part of the foil (fat nose part of the foil) where the upper part is linked to. I also need to accompany a flap with in the geometry.
Please offer some suggestion for parametrization of such a surface so that we can manipulate the geometry from MMA. The less control points are there better the situation is for optimization. May be combination of some analytic function in 3D. But I doubt if that is possible.
BR
I think you have two choices: 1) create the second part of the geometry and then write a face-face intersection algorithm to merge them. 2) create the second part of the geometry and write two functions that return -1 if a query point is inside the geometry and +1 if it is out side (other values will do). Then use RegionPlot3D[ f1[x,y,z]<0 || f2[x,y,z]<0,....]. The idea is the to extract the GraphicsComplex and use that. The question is going to be how well you can approximate the corners with that. Here is an illustration of what I mean.
if1[x_, y_, z_] := If[x^2 + y^2 + z^2 <= 1, -1, 1]
if2[x_, y_, z_] := If[(x - 1)^2 + y^2 <= 1 && -1.5 <= z <= 1.5, -1, 1]
res = RegionPlot3D[
if1[x, y, z] < 0 || if2[x, y, z] < 0, {x, -2, 2}, {y, -2,
2}, {z, -2, 2}, PlotPoints -> 100, Boxed -> False, Axes -> False]
Then extract the coords and the polygons.
coords = res[[1, 1]];
poly = Cases[res[[1]], _Polygon, Infinity];
Graphics3D[GraphicsComplex[coords, poly], Boxed -> False]
Hope this helps.
I am doing this:
ClearAll[matrix];
matrix[p_,q_,nu_:0]:=Module[{sigma},
sigma=p/q;
N#SparseArray[
{{m_,m_}\[Rule]2Cos[2\[Pi]*m*p/q+nu],{i_,j_}/;
Abs[i-j]\[Equal]1\[Rule]1},{q,q}]]
ClearAll[attachsigma]
attachsigma[sigma_,lst_]:={sigma,#}&/#lst
and then execute
fracs = Table[p/q, {q, 2, 30}, {p, 2, q}] // Flatten // DeleteDuplicates;
pq = {Numerator##, Denominator##} & /# fracs;
(ens = Eigenvalues[#] & /#
Normal /# (matrix[#[[1]], #[[2]]] & /# pq);) // Timing
pts = Flatten[#, 1] &#MapThread[attachsigma, {fracs, ens}];
and finally I plot the points as follows (here is the real point of the question):
plot = ListPlot[pts,
PlotMarkers \[Rule] Graphics[{PointSize[Tiny], Point[{0, 0}]}]]
Calculating all the points takes around around 2.6s on my machine, but the plot takes around 25s. If, on the other hand, I plot it like this
ListPlot[pts]
then it is almost instantaneous, as it should (it's just 5256 points). So, it seems PlotMarkers slows things down immensely.
Could anybody
a) explain why (this much I vaguely understand, in analogy with what happens to Sort if you give it custom ordering function) and, more importantly,
b) explain how to avoid this slowdown? I am trying to create plots with quite a bit more points than this so they're really slow; in addition, I am creating lots of them (a movie actually).
One solution would be to not plot all of them, but as I vary parameters it becomes nontrivial to find out which I should include and which not (this would of course work if I only needed this one frame). So, I'd like to speed up the plot creation without removing points.
EDIT: Answered after hints from Sjoerd:
ListPlot[pts] /. Point[List[x___]] \[RuleDelayed] {PointSize[Tiny], Point[List[x]]}
produces the right thing instantaneously. This simply replaces the Points inside the Graphics structure by smaller points by hand.
Now one can increase the upper limit in the table in fracs = Table[p/q, {q, 2, 30}, {p, 2, q}] // Flatten // DeleteDuplicates to 80 or so to get many more points (this thing is the Hofstadter butterfly, and it's a fractal):
PlotMarkers is meant for data plots that contain relatively few points. It is very useful in plots in which you use the markers to identify various conditions. Each individual marker is an Inset as follows:
Inset[Graphics[List[Hue[0.67`,0.6,0.6`],PointSize[Tiny],Point[List[0, 0]]]],10512].
You can imagine this takes up some time and memory.
I also found what seems to be a bug. The plot with PlotMarkers is structured as GraphicsComplex[pointlist,graphicsinstructions]. This point list seems to contain the points in the plot twice!
In[69]:= pts // Length
Out[69]= 5256
In[66]:= plot[[1, 1]] // Length
Out[66]= 10512
In[64]:= Union[plot[[1, 1]]] == Union[pts]
Out[64]= True
In[68]:= Tally[plot[[1, 1]]][[All, 2]] // Mean (*the average number each point occurs*)
Out[68]= 2
Personally, I prefer Graphics to ListPlot, especially when the number of points is large.
Graphics[{Hue[{2/3, 1, 1, .5}], AbsolutePointSize[1.5], Point#pts},
PlotRange -> {{0, 1}, {-4, 4}}, Axes -> False,
AspectRatio -> 1/GoldenRatio]
gives, for example:
Length#pts
102969
I believe the solution you appended to your question can be simplified:
ListPlot[pts] /. x_Point :> {PointSize[Tiny], x}
I voted for both prior answers, but I agree with TomD on the direct use of Graphics.
When saving graphics in Mathematica, is it possible to save figures with opacity in EPS format? For example,
Plot[Evaluate[Table[BesselJ[n, x], {n, 4}]], {x, 0, 10},
Filling -> Axis]
gives the following figure which saves neatly in any format other than EPS.
If I try saving to EPS (in Mathematica 7), the result looks like
In Mathematica 8 it looks like
Does anyone know how to get opacity in EPS plots (or if that is even possible)? The 'use rasterization for transparency' option doesn't look as impressive as a true EPS on zooming.
I usually Rasterize my graphics in this situation. Try
Rasterize[Plot[Evaluate[Table[BesselJ[n, x], {n, 4}]],
{x, 0, 10}, Filling -> Axis], RasterSize -> 600, ImageSize -> 400]
Of course, the result will not be scalable and can take up more memory. You can partially solve the scalability problem by setting the RasterSize larger than the ImageSize, as I have done here.
OK, so EPS can not support true transparency/opacity - but that doesn't mean that Mathematica 7 is excused for doing such a bad job. As evidenced my Mathematica 8, it is possible to make it look better.
The problem with Mathematica 7's output is that it uses the same color for the fill as for the curves, when you really want a lighter color. EPS is a plain text format, so it's quite easy to write a quick hack. Here's a quick tute on PS graphics.
In PS graphics, you define a path then you say whether you want it stroked (lines) or filled (areas) - or other things we don't need to worry about. Colors are set and stay there until they are reset. So I simply import the EPS produced by Mma7 and find all filled paths. For each filled path you find the previous color and reset the color just above the fill command to be something lighter.
So here's an example (I haven't bothered packaging it up into a single script/module).
All output is from Mathematica 7.0.1
p = Plot[Evaluate[Table[BesselJ[n, x], {n, 4}]], {x, 0, 10}, Filling -> Axis]
Export to an EPS file using Export["BesselJs7.eps", p]. This produces a horrible graphic like
OK, now the "fix"
pList = Import["BesselJs7.eps", "List"]; (* Import image as a list of strings *)
FList = Flatten#Position[pList, "F"]; (* find all fill commands *)
Note that the EPS file has the line /F { fill} bind def that defines the shortcut F.
Also, you can check that pList[[FList - 1]] yields a list of "closepath"s.
FColorList = {}; (* get list of colors associated with fills *)
Catch[Do[
i = 0; rgb = True; newpath = True;
While[rgb || newpath,
(*Print[{f,i,f-i,rgb,newpath,pList[[f-i]]}];*)
If[rgb && StringMatchQ[pList[[f - i]], __ ~~ "r"], rgb = False;
AppendTo[FColorList, pList[[f - i]]]];
If[newpath && StringMatchQ[pList[[f - i]], "newpath" ~~ __],
newpath = False; np[f] = f - i];
If[f - i == 1, Throw[{f, rgb, newpath}]];
i++],
{f, FList}]]
Now a hack to create the new colors - all I do is add .5 to each rgb value. This can definitely be made better:
FColorListNew = Table[Most#ToExpression#StringSplit[f] + .5,
{f, FColorList}] /. _?(# > 1 &) -> 1.;
FColorListNew = Table[StringJoin[{Riffle[ToString /# f, " "], " r"}],
{f, FColorListNew}];
Finally, insert the new colors and write it back out:
Do[pList = Insert[pList, FColorListNew[[i]], np[FList[[i]]] + i],
{i, Length[FList]}]
Export["BesselJsFixed.eps", pList, "List"]
Some things, like finding the newpath locations, are unnecessary and the whole thing can probably be tidied up. But I've spent enough time on it for now!
Building on Mark's answer, to export a PNG with transparency, use:
Export[
"testfile.png",
Plot[Evaluate[Table[BesselJ[n, x], {n, 4}]], {x, 0, 10}, Filling -> Axis],
ImageSize -> 600,
Background -> None
]
I am trying to use computer to show some planar geometry plots. I donot know what software can do this, or whether mathematica can produce such plots easily.
For example, I have the following plot to show.
Given any triangle ABC, let AD be the line bisecting angle BAC and intersecting BC at D. Let M be the midpoint of AD. Let the circle whose diameter is AB intersects CM at F.
How to produce these plots and show the relevant labeling of the points in mma? Is it easy to do? Could someone please give an example, or give some recommendation as to what software is best suited for this purposes?
Many thanks.
Here you have your graph done with Geometry Expressions in two minutes. It has many nice features, including elemental geometry calculations and an interface for exporting formulas to Mathematica.
The formula in the drawing was calculated by the program.
Free to use, $79 - $99 to be able to save.
Here's a very quick solution using GeoGebra to the problem you described.
It is the first time I've used GeoGebra and this took me about 20mins to make - so the program is quite well made and intuitive.
What's more, it can export to dynamic, java based, webpages. Here's the one for the problem you specified: TriangleCircle.
Edit
For Mathematica demonstrations, there are lots of good examples at Plane Geometry.
From this page, I found other software such as Cabri Geometry and The Geometer's Sketchpad.
I thought I'd show how one might approach this in Mathematica. While not the simplest thing to code, it does have flexibility. Also bear in mind that the author is fairly inept when it comes to graphics, so there might be easier and/or better ways to go about it.
offset[pt_, center_, eps_] := center + (1 + eps)*(pt - center);
pointfunc[{pt_List, center_List, ptname_String}, siz_,
eps_] := {PointSize[siz], Point[pt],
Inset[ptname, offset[pt, center, eps]]};
Manipulate[Module[
{plot1, plot2, plot3, siz = .02, ab = bb - aa, bc = cc - bb,
ac = cc - aa, cen = (aa + bb)/2., x, y, soln, dd, mm, ff, lens,
pts, eps = .15},
plot1 = ListLinePlot[{aa, bb, cc, aa}];
plot2 = Graphics[Circle[cen, Norm[ab]/2.]];
soln = NSolve[{Norm[ac]*({x, y} - aa).ab -
Norm[ab]*({x, y} - aa).ac ==
0, ({x, y} - cc).({-1, 1}*Reverse[bc]) == 0}, {x, y}];
dd = {x, y} /. soln[[1]];
mm = (dd + aa)/2;
soln = NSolve[{({x, y} - cen).({x, y} - cen) - ab.ab/4 ==
0, ({x, y} - cc).({-1, 1}*Reverse[mm - cc]) == 0}, {x, y}];
ff = {x, y} /. soln;
lens = Map[Norm[# - cc] &, ff];
ff = If[OrderedQ[lens], ff[[1]], ff[[2]]];
pts = {{aa, cen, "A"}, {bb, cen, "B"}, {cc, cen, "C"}, {dd, cen,
"D"}, {ff, cen, "F"}, {mm, cen, "M"}, {cen, ff, "O"}};
pts = Map[pointfunc[#, siz, eps] &, pts];
plot3 = Graphics[Join[pts, {Line[{aa, dd}], Line[{cc, mm}]}]];
Show[plot1, plot2, plot3, PlotRange -> {{-.2, 1.1}, {-.2, 1.2}},
AspectRatio -> Full, Axes -> False]],
{{aa, {0, 0}}, {0, 0}, {1, 1}, Locator},
{{bb, {.8, .7}}, {0, 0}, {1, 1}, Locator},
{{cc, {.1, 1}}, {0, 0}, {1, 1}, Locator},
TrackedSymbols :> None]
Here is a screen shot.
Daniel Lichtblau
Wolfram Research
Mathematica isn't the best software for this, although it will work out.
http://demonstrations.wolfram.com/DrawingATriangle/ has source code for a really nice triangle, and following that example you can add a bisecting line to the code.
As already stated, Mathematica is not the best software for this. There are several better options that you can use, depending on your exact purpose. To generate such figures programatically, there are several languages especially adapted for such tasks. I would recommend to try eukleides or GCLC. If you have any experience with TeX/LaTeX, you may want to look at metapost or asymptote, or even a LaTeX package such as tkz-euklide.
If you on the other hand prefer to create you drawings in an interactive way, there are number of programs available. Search the web for "dynamic geometry software", you should get a number of hits. Of those I would most recommend geogebra.
I thought that I should really attempt this problem in Mathematica (only once I finished did I see Daniel's solution). It took me about half an hour - which is longer than my GeoGebra solution, despite the fact that I'd never used GeoGebra before.
The code is not as fast as it could be. This is because I was too lazy to code up proper code for finding intersections of lines and circles, so I just used the slower but more general FindInstance.
A quite comprehensive plane geometry package can be found as part of Eric Weinstein's MathWorld packages. It includes all the intersection, bisection etc... code that you could possibly want, but it would take a little bit of time to learn it all.
angleBisector[A_,{B_,C_}]:=Module[{ba=Norm[B-A],ca=Norm[C-A],m},
m=A+((B-A)/ba+(C-A)/ca)]
intersect[Line[{A_,B_}],Line[{C_,D_}]]:=Module[{s,t},
A + s(B-A)/.First#FindInstance[A + s(B-A) == C + t(D-C), {s,t}]]
intersect[Line[{A_,B_}],Circle[p0:{x0_,y0_},r_]]:=Module[{s,x,y},
A + s(B-A)/.FindInstance[A + s(B-A) == {x,y}
&& Norm[p0-{x,y}] == r, {s,x,y}, Reals, 2]]
Manipulate[Module[{OO,circ,tri,angB,int,mid,FF},
OO=(AA+BB)/2;
circ=Circle[OO,Norm[AA-BB]/2];
tri=Line[{AA,BB,CC,AA}];
angB=angleBisector[AA,{BB,CC}];
int=intersect[Line[{BB,CC}],Line[{AA,angB}]];
mid=(AA+int)/2;
FF=intersect[Line[{CC,mid}],Circle[OO,Norm[AA-BB]/2]];
Graphics[{PointSize[Large],Point[{OO,int,mid}],Point[FF],tri,circ,
Line[{AA,AA+3(angB-AA)}],Line[{CC,CC+3(mid-CC)}],
Text["A",AA,{2,-2}],Text["B",BB,{-2,-2}],Text["C",CC,{2,2}],
Text["O",OO,{0,-2}],Text["D",int,{-2,-1}],Text["M",mid,{-2,-1}]},
PlotRange->{{-2,2},{-2,2}}]],
{{AA,{-1,1}},Locator},
{{BB,{1,1}},Locator},
{{CC,{0,-1}},Locator}]
I posted at this post before, but I still could not solve the following problem completely. As an example:
{pA, pB, pC, pD} = {{0, 0, Sqrt[61/3]}, {Sqrt[7], 4*Sqrt[2/3], 0}, {0, -5*Sqrt[2/3], 0}, {-Sqrt[71], 4*Sqrt[2/3], 0}};
axis={1,0,0};pt={0,1,0};
plotPolygon[{a_, b_, c_}] := {Opacity[.4], Polygon[{a, b, c}]};
graph=Graphics3D[{plotPolygon[{pA, pB, pC}], plotPolygon[{pA, pB, pD}],
plotPolygon[{pB, pC, pD}], plotPolygon[{pA, pC, pD}]},
Axes -> True, AxesOrigin->pt];
Animate[graph/.gg : Graphics3D[___] :> Rotate[gg, theta, axis], {theta, 0., 2.*Pi}]
I want to rotate along an axis axis={1,0,0} which passes the point pt={0,1,0}. But I don't know how to specify the point information. Also the rotation animation seems very chaotic in the sense that I would expect at least one point (in this case, the origin?) is not rotating.
You need to first change the origin of vertices of your polygon, rotate, and translate back. You can do this by hand
(RotationMatrix[theta,axis].(#-pt) + pt)& /# {pA, pB, pC, pD}
Or, you can combine the transformations using Composition
Composition[
AffineTransform[{RotationMatrix[theta,axis],pt}],TranslationTransform[-pt]
] /# {pA, pB, pC, pD}
Or, you can take the previous composition and apply it directly to your Graphics object
GeometricTransformation[ <graphics>, Composition[ ... ]]
This documentation gives a thorough list of what can be done.
Edit: Here's a working animation script
Animate[
graph /. Graphics3D[prims__, opts : OptionsPattern[]] :>
Graphics3D[
GeometricTransformation[prims,
Composition[
AffineTransform[{RotationMatrix[theta, axis], pt}],
TranslationTransform[-pt]
]
],
opts
],
{theta, 0., 2.*Pi}
]
There's a couple of things to note here. First, GeometricTransformation only appears to work on the primitives themselves, so I had to split out the primitives from the options in Graphics3D via the rule Graphics3D[prims__, opts : OptionsPattern[]]. Also, the transformation itself needs to be within Animate to use the local version of theta.