Viewing a city's coordinates from above - wolfram-mathematica

As a little project I've been thinking to create a little Google Earth-like animation. I want to play back a timeline while rotating the globe to center over various cities. At present I can use the default view settings to render a globe with the cities indicated by points.
When I try to orient the camera with a view vector looking down on a city (for example Denver), I end up with the following:
The ViewVector needs to be computed for some point out in space above the globe. However my trial and error has not arrived on any sort of coherent viewpoint with most looking like they're "inside" the globe.
What I need help with is a function which given the latitude and longitude of a city choses a ViewVector placing the city at the "center" of the camera view. The code which produced the "inside the globe" view follows:
SC[{lat_, lon_}] := {Cos[lon \[Degree]] Cos[lat \[Degree]],
Sin[lon \[Degree]] Cos[lat \[Degree]], Sin[lat \[Degree]]};
Graphics3D[{
Opacity[0.75],
Sphere[{0, 0, 0}, 0.99 ],
Map[Line[
Map[SC,
CountryData[#, "SchematicCoordinates"], {-2}]] &,
CountryData["Countries"]], {Yellow, PointSize[Medium],
Point[SC[CityData["Denver", "Coordinates"]]]
}
},
Boxed -> False,
SphericalRegion -> True,
ViewVector -> {{0, 0, 0}, SC[CityData["Denver", "Coordinates"]]}
]

When using ViewVector in the form ViewVector->{v1, v2}, the camera is sitting in point v1 and is pointed in the direction of v2. So in your example, the camera would be sitting in the origin and is pointed in the direction of Denver, which produces the "inside globe" view. To have the camera looking down at Denver the camera should be sitting in a point directly above the city, e.g. in 2 SC[CityData["Denver", "Coordinates"] and be pointed at the origin, so ViewVector would be something like
ViewVector -> {2 SC[CityData["Denver", "Coordinates"]], {0, 0, 0}}
With this setting for ViewVector the view becomes something like

Related

Graphics3D refinement for intersection of cone and line

Encouraged by this question, I dare to ask something similar.
I am trying to plot with mathematica a cone which is intersected by a line. The start point of the line is on the lateral surface of the cone and its endpoint inside of the cone.
As long as the endpoint of the line is far away from the tip of the cone, everything looks quite nice (use e.g. endpointOfLine = 0.007 in my example). But if the endpoint approaches the tip (endpointOfLine < 0.007 in my example), it seems that a big part of the line would be on the surface of the cone.
Sure, for endpoint values which are very close to the cone tip, the line is almost parallel to the surface so that this effect has probably to appear. But the effect appears also if the endpoint is not so close to cone tip.
Here the example:
totalLength = 10^-2;(*length of the cone*)
theta = 17*10^-3;(*half opening angle of the cone*)
radius[theta_, l_] := Tan[theta]*l;(*radius of the cone as function of its length*)
endpointOfLine = 0.0015;(*endpoint of the test line, to be varied*)
testLine = Line[{{radius[theta, totalLength], 0, totalLength},{0, 0, endpointOfLine}},
VertexColors -> {Orange, Orange}
];
Graphics3D[
{
{
RevolutionPlot3D[{radius[theta, l], 0, l}, {l, 0, totalLength},
Mesh -> None,
PlotStyle -> Directive[Opacity[0.5], Gray],
PlotPoints -> 60][[1]]
},
{testLine}
},
Boxed -> True,BoxRatios -> {1, 1, 3},
Lighting -> None(*ugly, but makes the problem well visible*)
]
Is there any way to reduce this effect? Increasing the PlotPoints to 60 has reduced the effect a bit, but I would be happy if I could reduce it more. Any ideas?
Try to place the endpoint at the base of the cone close but not on the radius like:
testLine =
Line[{{0.97 radius[theta, totalLength], 0, totalLength}, {0, 0, endpointOfLine}},
VertexColors -> {Orange, Orange}
];
I feel this is not a problem fundamentally different from the one you were referring to.

ViewVector transition between two spherical coordinates on a globe

Continuing with the project I previously described I am currently building an animation showing movement between a list of cities. My current code renders a list of cities and makes a set of great circle arcs connecting the cities. The list of cities are part of a timeline so after visiting one city the animation will transition to be centered upon the next.
To my mind this means the ViewVector should be adjusted to show points between a starting city and an ending city. The resulting would probably look like an in-flight map for a long-haul flight sped up considerably. A single frame might look like the following manually produced still:
I now understand how to position the ViewVector above the most recent city but I am quite unsure about how to move the camera smoothly between two spherical coordinate points. My current code is below:
SC[{lat_, lon_}] := {Cos[lon \[Degree]] Cos[lat \[Degree]],
Sin[lon \[Degree]] Cos[lat \[Degree]], Sin[lat \[Degree]]};
GreatCircleArc[{lat1_, lon1_}, {lat2_, lon2_}] :=
Module[{u = SC[{lat1, lon1}], v = SC[{lat2, lon2}], a},
a = VectorAngle[u, v];
Table[Evaluate[RotationTransform[\[Theta], {u, v}][u]], {\[Theta],
0, a, a/Ceiling[10 a]}]]
CityGraphic[name_] := {Opacity[0.85], Black, PointSize[Medium], White,
PointSize[0.045], Point[1.01 SC[CityData[name, "Coordinates"]]]}
CityGraph[places_, age_] :=
Graphics3D[{
Opacity[0.75],
Sphere[{0, 0, 0}, 0.99 ],
Map[Line[
Map[SC,
CountryData[#, "SchematicCoordinates"], {-2}]] &,
CountryData["Countries"]],
Map[CityGraphic, places],
Text[Style[age, FontFamily -> "Helvetica"],
1.02 SC[CityData[First[places], "Coordinates"]]],
White, Line
[Apply[GreatCircleArc,
Partition[Map[CityData[#, "Coordinates"] &, places], 2, 1], {1}]]
},
ViewVector -> {
4 SC[CityData[First[places], "Coordinates"]], {0, 0, 0}},
Boxed -> False,
SphericalRegion -> True,
ImageSize -> {640, 480}
];
CityGraph[{"Tokyo", "Dublin", "Cape Town", "Seattle", "Denver"}, "04"]
In computer graphics people often use Quaternions to smoothly interpolate between various camera viewing directions. Mathematica has a Quaternion package which you could use for basic Quaternion arithmetic. A conversion between Quaternions and Euler angles is described here.
The interpolation process is described here.

Shadows in mathematica Graphics3D

If I understood the Mathematica documentation correct ( haven't found examples either ) Graphics3D does not produce shadows of 3D objects, although Graphics3D has a Lighting-> option.
Question: Have you ever tried to produce Mathematica 3D objects with shadows? If so have you solved this in Mathematica? Or have you exported the graphics to other 3D ( scene-graph ) viewers like for example J-Reality?
The shading model used by MMA, the so-called Phong shading, determines the pixel intensities based on a simple relationship between local surface orientation, light source direction(s), camera direction and diffuse and specular properties of the surface. No other aspect of the geometry is taken into account, which means that objects do not influence the pixel values of other objects even if they are between the object and the light source.
This means that the model doesn't generates shadows. It is not able to.
You could simulate shadows yourself by projecting your object's polygons on the ground plane or wall planes as applicable. That shouldn't be too difficult, but shadows on non-planar surfaces will be pretty hard.
Example:
polys = (PolyhedronData["GreatRhombicTriacontahedron", "Faces"] //
Normal // N) /. {x_, y_, z_}?VectorQ -> {x, y, z + 6};
(* raise it slightly above ground plane*)
shadow = polys /. {x_, y_, z_}?VectorQ -> {x - z, y, 0};
(* projection from a directional light source at 45 deg elevation *)
Graphics3D[{polys, EdgeForm[], FaceForm[Darker#Gray], shadow},
Lighting -> {{"Directional", White, {{1, 0, 1}, {0, 0, 0}}}},
Boxed -> False]
Of course, you need to make sure that the lighting sources (point, spot, directional...) and your shadow projection are consistent.

Mathematica: Help me understand Mathematica 3D coordinates system

I gave up trying to understand Mathematica 3D axes configuration.
When I make 3D plot, and label the 3 axes to identify which axes is which, and then make points on these axes, the points appear on different axes than what I expect them to show at using the Point command, which takes {x,y,z} coordinates.
Here is an example
g=Graphics3D[
{
{PointSize[0],Point[{0,0,0}]}
},
AxesOrigin->{0,0,0}, PlotRange->{{-3,3},{-3,3},{-3,3}},
Axes->True, AxesLabel->{"X","Y","Z"},
LabelStyle->Directive[Bold,Red,16],
PreserveImageOptions->False, Ticks->None,Boxed->False]
The above results in
So, now I added a point at at end of the x-axis, and at the end of the y-axis, and at the end of the z-axis. I make each point different color to help identify them on the plot.
g=Graphics3D[
{
{Red,PointSize[.03],Point[{3,0,0}]},
{Black,PointSize[.03],Point[{0,3,0}]},
{Blue,PointSize[.03],Point[{0,0,3}]}
},
AxesOrigin->{0,0,0},PlotRange->{{-3,3},{-3,3},{-3,3}},
Axes->True,AxesLabel->{"X","Y","Z"},
LabelStyle->Directive[Bold,Red,16],PreserveImageOptions->False,
Ticks->None,Boxed->False]
The result is this:
You can see, the RED point, which I expected it to go to end of the x-axis, shows up at the end of the Z axis. And the Black point, instead of showing up at the end of the Y-axis, shows up at X-axis, and the blue point, instead of showing at the end of the Z axis, shows up at the end of the Y-axis.
May be the labels are wrong? May be I am looking at the image in wrong way?
I am really confused, as I am clearly not understanding something. I looked at documentation, and I could not find something to help me see what I am doing wrong. I am just starting to learn Mathematica 3D graphics.
EDIT:
add image with Ticks on it, reply to Simon, I did not know how to do it the comment box:
g=Graphics3D[
{
Cuboid[{-.1,-.1,-.1},{.1,.1,.1}],
{Red,PointSize[.03],Point[{2,0,0}]},
{Black,PointSize[.03],Point[{0,2,0}]},
{Blue,PointSize[.03],Point[{0,0,2}]}
},
AxesOrigin->{0,0,0},
PlotRange->{{-2,2},{-2,2},{-2,2}},
Axes->True,
AxesLabel->{"X","Y","Z"},
LabelStyle->Directive[Bold,Red,16],
PreserveImageOptions->False,
Ticks->True, TicksStyle->Directive[Black,8],
Boxed->False
]
here is the result:
EDIT: OK, I decided to forget about using AxesLabels, and I put them myself . Much more clear now
m=3;
labels={Text[Style["X",16],{1.2 m,0,0}],Text[Style["Y",16],{0,1.2 m,0}],
Text[Style["Z",16],{0,0,1.2 m}]};
g=Graphics3D[
{
{Red,PointSize[.03],Point[{m,0,0}]},
{Black,PointSize[.03],Point[{0,m,0}]},
{Blue,PointSize[.03],Point[{0,0,m}]},
labels
},
AxesOrigin->{0,0,0},
PlotRange->{{-m,m},{-m,m},{-m,m}},
Axes->True,
AxesLabel->None,
LabelStyle->Directive[Bold,Red,16],
PreserveImageOptions->False,
Ticks->True, TicksStyle->Directive[Black,8],
Boxed->False
]
I agree with you that AxesLabel for 3D graphics is next to worthless. Look at the effects of a small interactive viewpoint change on your figure:
IMHO WRI should really improve the operation of this option, and preferably provide some more placement control too (end/mid of axes etc.).
I believe the labels are being placed in unintuitive spots. Replacing your dots with colored lines of different length is clearer to me. I've also removed the explicit plot range which helps Mathematica put the labels in much clearer places.
g=Graphics3D[
{
{Red,Thick, Line[{{0, 0, 0}, {1, 0, 0}}]},
{Black,Thick, Line[{{0, 0, 0}, {0, 2, 0}}]},
{Blue,Thick, Line[{{0, 0, 0}, {0, 0, 3}}]}
},
AxesOrigin->{0,0,0},
Axes->True,AxesLabel->{"X","Y","Z"},
LabelStyle->Directive[Bold,Red,16],PreserveImageOptions->False,
Ticks->None,Boxed->False]

animate 3d plot with some further requirements in mathematica

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.

Resources