Mathematica: Removing graphics primitives - wolfram-mathematica

Given that g is a graphics object with primitives such as Lines and Polygons, how do you remove some of them? To add more primitives to an existing graphics object we can use Show, for instance: Show[g, g2] where g2 is another graphics object with other primitives. But how do you remove unwanted primitive objects? Take a look at the following
ListPlot3D[{{0, 0, 1}, {1, 0, 0}, {0, 1, 0}, {1, 1, 0}}, Mesh -> {1, 1}]
Now, for the input form:
InputForm[
ListPlot3D[{{0, 0, 1}, {1, 0, 0}, {0, 1, 0}, {1, 1, 0}}, Mesh -> {1, 1}]
]
To create a wire frame from this object all we have to do is remove the polygons. As an extra we can also remove the vertex normals since they don't contribute to the wireframe.
Notice that to make a wireframe we can simply set PlotStyle -> None as an option in ListPlot3D. This gets rid of the Polygons but doesn't remove the VertexNormals.
To clarify the question. Given that
g = ListPlot3D[{{0, 0, 1}, {1, 0, 0}, {0, 1, 0}, {1, 1, 0}}, Mesh -> {1, 1}]
How do you remove some of the of the graphics primitives from g and how do you remove some of the options, i.e. VertexNormals? Note: option VertexNormals is an option of GraphicsComplex.
If this is not possible then maybe the next question would be, how do you obtain the data used to generate g to generate a new graphics object with some of the data obtained from g.

One way is to use transformation rules. Given your
im = ListPlot3D[{{0, 0, 1}, {1, 0, 0}, {0, 1, 0}, {1, 1, 0}}, Mesh -> {1, 1}]
You can do
newim = im /. {_Polygon :> Sequence[], (VertexNormals -> _) :> Sequence[]}
or, more compactly using Alternatives:
newim = im /. _Polygon | (VertexNormals -> _) :> Sequence[]
You could also use DeleteCases to get a similar effect:
newim = DeleteCases[im, (_Polygon | (VertexNormals -> _)), Infinity]

Related

How to output custom polygon coordinates in Mathematica?

I am trying to make either a nested manipulate or just a manipulate with two windows: I need one window which functions as:
Manipulate[Graphics[Polygon[pt],
PlotRange -> 2], {{pt, {{0, 0}, {1, 0}, {1, 1}, {0, 1}, {1, -1}}},
Locator, LocatorAutoCreate -> True}]
but outputs its coordinates to another window which uses these coordinates to plot a specified graph. I am not sure if Manipulate is even the best option for this, but essentially I am trying to make a visual interface where a user can specify a polygon and then the program uses the information of those coordinates to plot a specified 3D plot.
I think I could figure out how to do this if I knew how to output the coordinates from the manipulate or how to make something that does.
For Example:
GraphicsRow[{
Manipulate[
Graphics[Polygon[rs = pt], PlotRange -> 2],
{{pt, {{0, 0}, {1, 0}, {1, 1}, {0, 1}, {1, -1}}},
Locator, LocatorAutoCreate -> True}],
Dynamic#
ParametricPlot3D[Through[(Interpolation /#
First#(Transpose /# {Append[#, 0] & /# rs}))[t]], {t, 1, Length#rs},
PlotRange -> 2]}]

How can I select one out of several Graphics3D objects and change its coordinates in Mathematica?

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]
]

Effect of change in Viewpoint->{x,y,z} on the size of graphic objects is not what I expected. How to fix?

If you run the following code snippet:
Manipulate[
Graphics3D[
{Cuboid[{{-1, -1, -1}, {1, 1, 1}}], Sphere[{5, 5, 5}, 1]},
ViewPoint -> {1, 1, a}, AxesOrigin -> {0,0,0}
],
{a, 1, 100}
]
and move the viewpoint from (1,1,1) to (1,1,100) with the slider you will see that after a while the objects remain fixed in size.
Questions.
1. When I move the viewpoint further away from the scene I want the objects to become smaller. How should this be done in Mathematica?
( EDIT: )
2. What is the position of the 'camera' in relation to Viewpoint?
See ViewAngle. Under "More Information", note that the default setting ViewAngle -> Automatic is effectively equivalent to ViewAngle -> All when you zoom far enough out.
You just need to add an explicit setting for ViewAngle:
Manipulate[
Graphics3D[{Cuboid[{{-1, -1, -1}, {1, 1, 1}}], Sphere[{5, 5, 5}, 1]},
ViewPoint -> {1, 1, a}, AxesOrigin -> {0, 0, 0},
ViewAngle -> 35 Degree], {a, 1, 100}]
As far as I know, the camera viewpoint really coincides with the position given by ViewPoint. Because Mathematica scales the result to fit in about the same image you don't see much changes but they are there. The perspective changes considerably. Try, for instance, to move away from a semi-transparant square and you'll see that the farther you go, the more the projection becomes an orthogonal projection:
If you want to scale your image according to distance you can use ImageSize. SphericalRegion is good to stabilize the image.
Manipulate[
vp = {1, 1, a};
Graphics3D[{Cuboid[{{-1, -1, -1}, {1, 1, 1}}], Sphere[{5, 5, 5}, 1]},
ViewPoint -> vp,
AxesOrigin -> {0, 0, 0},
SphericalRegion -> True,
ImageSize -> 500/Norm[vp]],
{a, 1, 100}
]
[animation made with some ImagePadding to keep object in the center. I stopped the animation at a = 10, the image gets pretty small after that]

How to create 2D (3D) animation in Wolfram Mathematica with the camera following the object?

I have a graphical object which is moving along a trajectory. How can I make the camera follow the object?
Let's draw a planet and its satellite, with the camera following the moon from a view directed toward the Earth. For example:
a = {-3.5, 3.5};
Animate[
Show[
Graphics3D[
Sphere[3 {Cos#t, Sin#t, 0}, .5],
ViewPoint -> 3.5 {Cos#t, Sin#t, 0},
SphericalRegion -> True,
PlotRange -> {a, a, a}, Axes -> False, Boxed -> False],
myEarth],
{t, 0, 2 Pi}]
Where myEarth is another 3D Graphics (for reference).
Static vertical view:
a = {-3.5, 3.5};
Animate[
Show[
Graphics3D[
Sphere[3 {Cos#t, Sin#t, 0}, .5],
ViewPoint -> 3.5 {0,0,1},
SphericalRegion -> True,
PlotRange -> {a, a, a}, Axes -> False, Boxed -> False],
myEarth],
{t, 0, 2 Pi}]
The trick is SphericalRegion -> True, without it the image perspective "moves" from frame to frame.
Edit
With two static objects:
Since the question asks about 2D, here's how you can emulate a camera in 2D Graphics.
First, let's get the stackoverflow favicon.ico:
so = First#Import["http://sstatic.net/stackoverflow/img/favicon.ico"]
Well put this on top of some overlapping circles and make the "camera" follow the icon around by adjusting the PlotRange
Manipulate[Graphics[{
Table[Circle[{j, 0}, i], {i, 0, 1, .1}, {j, {-.5, .5}}],
Inset[so, pos, {0, 0}, .2]},
PlotRange -> {{-.5, .5}, {-.5, .5}} + pos],
{{pos, {0, 0}, ""}, {-1.4, -1}, {1.4, 1}, ControlPlacement -> Left}]
To show how it works (with out putting the above into Mathematica), we need to animate it.
Originally I chose a variable step random walk drunk = Accumulate[RandomReal[{-.1, .1}, {200, 2}]] but it was a unpredictable! So instead, we'll make the icon follow the ABC logo
drunk = Table[{1.5 Sin[t], Cos[3 t]}, {t, 0, 2 Pi, .1}];
Animate[Graphics[{
Table[Circle[{j, 0}, i], {i, 0, 1, .1}, {j, {-.5, .5}}],
Inset[so, drunk[[pos]], {0, 0}, .2]},
PlotRange -> {{-.5, .5}, {-.5, .5}} + drunk[[pos]]],
{pos, 1, Length[drunk], 1}]

How can I constrain locators to a limited (but not regular) set of positions?

In Mathematica, locators can be constrained to certain screen regions via the parameters of LocatorPane (See LocatorPane documentation.)
A list of three ordered pairs {{{minX, minY}, {maxX, maxY}, {dX, dY}}} is usually the key to determining the behavior of locators. {minX, minY} and {maxX, maxY} set the region. {dX, dY} sets the jump size: zero for unrestrained, any other positive number for the size of each hop.
In the code below, {{{-.9, 0}, {1, 0}, {0, 0}}} sets the region and jumps for the locator pts. The first two ordered pairs limit the locators to the interval [-9, 1] on the number line. The ordered pair {0, 0} imposes no additional constraints on either of the locators. However, because the y values can only be zero, due to the region defined by the first two items, neither locator is free to leave the x-axis.
I'd like to confine each locator to x-values in myTicks. (In the full program, myTicks will change over time depending on decisions made by the user.) Because the ticks are not uniformly spaced along x, the issue cannot be solved by setting a constant value for the x-jump. And if the value were take into account the current position of the locator, the next left hop might be different size than the right hop.
myTicks = {-.9, 0, .1, .2, .45, .79, 1};
pts = {{.25, 0}, {.75, 0}};
LocatorPane[Dynamic[pts],
Graphics[{},
Axes -> {True, False},
PlotLabel -> Row[{"locators at: " , Dynamic[pts[[1, 1]]], " and ",
Dynamic[pts[[2, 1]]]}],
Ticks -> {myTicks, Automatic}],
{{{-.9, 0}, {1, 0}, {0, 0}}}]
Any suggestions would be appreciated!
This appears to work.
myTicks = {-.9, 0, .1, .2, .45, .79, 1};
DynamicModule[{p = {.25, 0}, p2 = {.75, 0}},
LocatorPane[Dynamic[{p, p2}],
Graphics[{}, Axes -> {True, False},
PlotLabel ->
Row[{"locators at: ",
Dynamic[p[[1]] = Nearest[myTicks, p[[1]]][[1]]], " and ",
Dynamic[p2[[1]] = Nearest[myTicks, p2[[1]]][[1]]]}],
Ticks -> {myTicks, Automatic}], {{{-.9, 0}, {1, 0}}}, ContinuousAction -> False]
]
Let's try this:
pts = {{0, 0}, {10, 0}};
myTics = Table[{x, 0}, {x, 0, 10, 5}];
LocatorPane[Dynamic[pts],
ListPlot[myTics, PlotRange -> {{-1, 11}, {-1, 1}},
PlotStyle -> Directive[PointSize[.07], Red],
Epilog -> {PointSize[.05], Blue, h = Point[Dynamic[{Nearest[myTics, pts[[1]]]}]],
PointSize[.03], Yellow, j = Point[Dynamic[{Nearest[myTics, pts[[2]]]}]],
Black,
Text[{"locators at: ", Dynamic[h[[1, 1]]], " and ",Dynamic[j[[1, 1]]]},
{5, .5}]}],
Appearance -> None]

Resources