https://community.wolfram.com RSS Feed for Wolfram Community showing ideas tagged with Astronomy sorted by most viewed. https://community.wolfram.com/groups/-/m/t/498246 ![Animation showing movement of a rigid body according to Dzhanibekov effect or tennis racket theorem][1] &[Wolfram Notebook][2] [1]: /c/portal/getImageAttachment?filename=fg546ukuhjfgvg5.gif&userId=11733 [2]: https://www.wolframcloud.com/obj/61fabce7-3d2f-4042-8e61-9fe54c4c353e Mariusz Iwaniuk 2015-05-18T11:39:33Z https://community.wolfram.com/groups/-/m/t/790989 ![enter image description here][1] With all of the rumors and excitement about the gravity wave press release tomorrow, I was reminded of this code I've had lying around for years for creating a gravity wave visualization (seen above) for illustrative purposes. You can find also a [video here][2]. It was inspired by an interaction I had years ago (unfortunately I can't find the interaction in my email) with someone on the [LISA][3] project wanting to use Mathematica to re-create a visualization they had. This code was the result of that interaction. First, the primary goal was to generate a "space-time" surface and mesh that had a double-armed spiral wave on it. The following code generates that. Its dependent on a rotation angle Theta which is not specified here: Plot3D[(60 Cos[ 2 ArcTan[y/(x + 0.00001)] - \[Theta] + 0.544331 Sqrt[x^2 + y^2]])/( 20 + Sqrt[x^2 + y^2]), {x, -45, 45}, {y, -45, 45}, PlotPoints -> 100, Mesh -> 20, MeshStyle -> {RGBColor[.5, .5, .5, .5]}, Boxed -> False, BoxRatios -> Automatic, Axes -> False, PlotStyle -> {RGBColor[.3, .3, .8]}, ImageSize -> {1024, 768}, Lighting -> {{"Directional", White, ImageScaled[{0, 0, 2.}]}}, ViewPoint -> {-0.011, -3.043, 1.479}, Background -> Black, BoundaryStyle -> RGBColor[.5, .5, .5, .5]] I wanted to overlay 2 stars or black holes on top of the surface. Combining the above with this overlay and giving a value to the angle Theta we get: With[{\[Theta] = 0}, Show[Plot3D[( 60 Cos[2 ArcTan[y/(x + 0.00001)] - \[Theta] + 0.544331 Sqrt[x^2 + y^2]])/( 20 + Sqrt[x^2 + y^2]), {x, -45, 45}, {y, -45, 45}, PlotPoints -> 100, Mesh -> 20, MeshStyle -> {RGBColor[.5, .5, .5, .5]}, Boxed -> False, BoxRatios -> Automatic, Axes -> False, PlotStyle -> {RGBColor[.3, .3, .8]}, ImageSize -> {1024, 768}, Lighting -> {{"Directional", White, ImageScaled[{0, 0, 2.}]}}, ViewPoint -> {-0.011, -3.043, 1.479}, Background -> Black, BoundaryStyle -> RGBColor[.5, .5, .5, .5]], Graphics3D[{Directive[Hue[.58, 0, 1], Lighting -> Join[{{"Ambient", Black}}, Table[{"Directional", Hue[.58, .5, 1], ImageScaled[{Sin[x], Cos[x], -.5}]}, {x, 0, 2 Pi - 2 Pi/8, 2 Pi/8}]]], Sphere[{2 Cos[\[Theta] - \[Pi]/2], 2 Sin[\[Theta] - \[Pi]/2], 3}, 1], Sphere[{Cos[\[Theta] + \[Pi]/2], Sin[\[Theta] + \[Pi]/2], 3}, 1]}], PlotRange -> All]] ![enter image description here][4] Next, I wanted to animate this to give the effect that the spiral arms are rotating outwards. That's done by incrementing the angle Theta and generating a list of frames that can then be exported. anim = Table[ Rasterize[ Show[Plot3D[( 60 Cos[2 ArcTan[y/(x + 0.00001)] - \[Theta] + 0.544331 Sqrt[x^2 + y^2]])/( 20 + Sqrt[x^2 + y^2]), {x, -45, 45}, {y, -45, 45}, PlotPoints -> 100, Mesh -> 20, MeshStyle -> {RGBColor[.5, .5, .5, .5]}, Boxed -> False, BoxRatios -> Automatic, Axes -> False, PlotStyle -> {RGBColor[.3, .3, .8]}, ImageSize -> {800, 450}, Lighting -> {{White, ImageScaled[{0, 0, 2.}]}}, ViewPoint -> {-0.011, -3.043, 1.479}, Background -> RGBColor[0, 0, 0], BoundaryStyle -> Gray], Graphics3D[{Directive[Hue[.58, 0, 1], Lighting -> Join[{{"Ambient", Black}}, Table[{"Directional", Hue[.58, .5, 1], ImageScaled[{Sin[x], Cos[x], -.5}]}, {x, 0, 2 Pi - 2 Pi/8, 2 Pi/8}]]], Sphere[{2 Cos[\[Theta] - \[Pi]/2], 2 Sin[\[Theta] - \[Pi]/2], 3}, 1], Sphere[{Cos[\[Theta] + \[Pi]/2], Sin[\[Theta] + \[Pi]/2], 3}, 1]}], PlotRange -> All]], {\[Theta], 0, 2 \[Pi], .1}]; And then to export it to an animated GIF: Export["GravityWave.gif", anim] The result is the animation at the top of this post. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ezgif.com-optimize%283%29.gif&userId=20103 [2]: https://www.youtube.com/watch?v=WiNKulqt0SE [3]: http://lisa.nasa.gov/ [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=gravitywave60.png&userId=25355 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=GravityWave.gif&userId=25355 Jeffrey Bryant 2016-02-10T19:35:05Z https://community.wolfram.com/groups/-/m/t/1207400 ![found constellations][9] ## Story Time ## At its first meeting in 1922, the International Astronomical Union (IAU), officially adopted the list of 88 constellations that we use today. These include 14 men and women, 9 birds, two insects, 19 land animals, 10 water creatures, two centaurs, one head of hair, a serpent, a dragon, a flying horse, a river and 29 inanimate objects. As many of us have (frustratingly) witnessed first hand while star-gazing - most of these bear little resemblance to their supposed figures. Instead, it is more likely that the ancient constellation-makers meant them to be symbolic, a kind of celestial "Hall of Fame" for their favorite animals or heroes. This begs two questions I sought to answer with this project: 1. Can we 'do better' now with the WL's StarData[] curated data and Machine Learning functionality? 2. What if the ancient constellation-makers were slightly more creative? Say they looked up at the sky, and only saw yoga-poses! Some examples of the found yoga-pose constellations, projected on images of the night sky are shown here, with a walk-through of the code below: [![example yoga-pose constellations][1]][2] ## Yoga Poses ## First things first, finding images for yoga poses. Turns out, the WL has a built in YogaPose Entity Class with 216(!) available entities and their schematics. A lot of these are very similar (e.g. palms facing up/down) and we therefore only select a subset of them, which differ substantially from each other: yogaposes = EntityClass["YogaPose", All] // EntityList; chosenPoses = List /@ {4, 6, 7, 8, 11, 14, 23, 25, 28, 35, 38, 43, 51, 54, 56, 59, 63, 65, 71, 72, 76, 77, 78, 84, 88, 90, 98, 100, 102, 103, 110, 111, 112, 113, 116, 118, 119, 125, 126, 133, 139, 142, 149, 152, 153, 154, 155, 156, 160, 164, 165, 167, 172, 177, 178, 180, 182, 183, 184, 190, 193, 194, 195, 197, 202, 204, 206, 207, 209, 210, 212, 215, 216}; Shallow[Extract[yogaposes, chosenPoses]] We write a wrapper to ensure the schematics are padded to give a square image and visualize our 73 constellations: makeSquare[gr_, size_, bool_: False] := Block[{range, magnitudes, order, padding, newRanges, res}, range = AbsoluteOptions[gr, PlotRange][[1, 2]]; magnitudes = Abs[Subtract @@@ range]; order = Ordering[magnitudes, 2, Greater]; padding = Subtract @@ magnitudes[[order]]/2; newRanges = {{-1, 1} padding + Last[range[[order]]], First[range[[order]]]}; res = Show[gr, PlotRange -> Reverse@newRanges[[order]], ImageSize -> size]; If[bool, Rasterize[res], res]] Multicolumn[ makeSquare[#["SimplifiedSchematic"], 64] & /@ Most[Extract[yogaposes, chosenPoses]], 9, Frame -> All] ![constellations graphic][3] ## Neural Network ## Our problem now can be worded as a classification one: *given 5-10 stars, classify them as one of the 73 yoga-poses constellations* The problem with that formulation of-course is that 5-10 randomly selected points inside the constellation region isn't specific enough to differentiate between constellations. The image below shows that although 1000 sets of 10 points will define the shape, 10 points alone fall short: ![pointsInMesh][4] Instead, we compute the Voronoi diagram of the points, using DistanceTransform to leverage already-optimized convolutional neural nets used for classifying images. Note that, even if (naturally) the results are less clear with fewer points (left to right) - the result with only 10 points at the far right is still quite recognizable to a human eye: ![distanceTransforms][5] With this in-mind, we create a neural network similar to the [VGG16][6] neural network, with successive 5x5 convolutions, ReLu activation functions and Max pooling layers. Finally note that we use an average pooling instead of fully connected layers to reduce the number of parameters and the use of dropout layers. conv[output_] := ConvolutionLayer[output, {5, 5}, "PaddingSize" -> 2] pool[size_] := PoolingLayer[{size, size}, "Stride" -> size] lenet = NetChain[ {conv[32], Ramp, conv[32], Ramp, pool[2], conv[64], Ramp, conv[64], Ramp, pool[2], conv[128], Ramp, conv[128], Ramp, conv[128], Ramp, PoolingLayer[{9, 9}, "Stride" -> 9, "Function" -> Mean], FlattenLayer[], DropoutLayer[], 73, SoftmaxLayer[]}, "Output" -> NetDecoder[{"Class", Extract[yogaposes, chosenPoses]}], "Input" -> NetEncoder[{"Image", {64, 64}, ColorSpace -> "Grayscale"}] ] The training set then consists of generating 10-15 points inside the constellation region (resized and padded to allow for rotations later), and taking their DistanceTransform: meshes[n_] := meshes[n] = ImagePad[ColorNegate@ makeSquare[ yogaposes[[chosenPoses[[n, 1]]]]["SimplifiedSchematic"], 44], 10] trainingSet[n_, m_, iter_] := With[{reg = ImageMesh[meshes[n], CornerNeighbors -> False, Method -> "MarchingSquares"]}, Thread[ColorConvert[ ImageAdjust[ DistanceTransform[Image[SparseArray[# -> 0, {64, 64}, 1]]]], "Grayscale"] & /@ Clip[Round@RandomPoint[reg, {iter, m}], {1, 64}] -> yogaposes[[chosenPoses[[n, 1]]]]]] exampleTrainingSet = Flatten[trainingSet[#, 10, 1] & /@ RandomInteger[{1, 73}, 10], 1] The net took a couple of hours to train on ~100,000 examples on my CPU. Here we import the trained net: lenetTrained = Import["constellationsNet.wlnet"] ## Night Sky ## We're almost ready to classify the night sky. We first need the location of the 10,000 brightest stars along with their Right Ascension and Declination: brightest = StarData[EntityClass[ "Star", {EntityProperty["Star", "ApparentMagnitude"] -> TakeSmallest[10000]}], {"RightAscension", "Declination", "ApparentMagnitude"}] We can plot these on the night sky using no projection (i.e. RA Vs Dec), using the sinusoidal projection (taken by Kuba's excellent [answer][7] in SE) or on the celestial sphere given by the following transformations respectively: $$sinusoidal:\{(\alpha -\pi ) \cos (\delta ),\delta \}$$ $$map to3D:\{\cos (\alpha ) \cos (\delta ),\sin (\alpha ) \cos (\delta ),\sin (\delta )\}$$ ![brightestStarsProjections][8] ## Classification ## Finally, we use these 10,000 brightest stars to compute a multivariate smooth kernel distribution out of which to sample from and a Nearest function to compute neighboring stars. We need to of-course use our own distance function on the celestial sphere: wrap[list_] := Block[{xs, ys}, {xs, ys} = Transpose[list]; Thread[{Mod[xs, 2 \[Pi]], Mod[ys, \[Pi], -\[Pi]/2]}]] mapTo3D[\[Alpha]_, \[Delta]_] = {Cos[\[Alpha]] Cos[\[Delta]], Cos[\[Delta]] Sin[\[Alpha]], Sin[\[Delta]]}; dist[{u_, v_}, {x_, y_}] := (#1[[1]] - #2[[1]])^2 + (#1[[2]] - #2[[2]])^2 + (#1[[ 3]] - #2[[3]])^2 & @@ mapTo3D @@@ {{u, v}, {x, y}} pts = wrap@QuantityMagnitude[UnitConvert[brightest[[6 ;;, ;; 2]]]]; nf = Nearest[pts, DistanceFunction -> dist] sm = SmoothKernelDistribution[pts] Our search algorithm is therefore defined as follows: 1. Pick a random position from the night sky distribution 2. Compute its 5-10 nearest neighbors 3. Classify those stars and their rotations by $\frac{2 \pi }{15}$ 4. Select the rotation which gives the highest accuracy 5. Associate constellation to running association and repeat rescale[list_] := Block[{xs, ys}, {xs, ys} = Thread[list]; Thread[Rescale[#, MinMax[#], {11, 54}] & /@ {xs, ys}]] rotate[\[Alpha]_, pts_] := ImageAdjust@ DistanceTransform[ Image@SparseArray[ Round@RotationTransform[\[Alpha] , {65/2, 65/2}][rescale[pts]] -> 0, {64, 64}, 1]] sky = <||>; accumulate[] := Block[{pts = nf[Mod[RandomVariate[sm] + {0, \[Pi]}, 2 \[Pi]] - {0, \[Pi]}, RandomInteger[{5, 10}]], \[Alpha], pred}, {\[Alpha], pred} = Last[SortBy[ First /@ Table[Thread[{\[Alpha], lenetTrained[rotate[\[Alpha], pts], "TopProbabilities"]}], {\[Alpha], 0, 2 \[Pi], (2 \[Pi])/ 15}], Last]]; If[Not[KeyExistsQ[sky, pred[[1]]]] || TrueQ[sky[pred[[1]], "Accuracy"] < pred[[2]]], AssociateTo[sky, pred[[1]] -> <|"Accuracy" -> pred[[2]], "Image" -> HighlightImage[ makeSquare[pred[[1]]["SimplifiedSchematic"], 64], {PointSize[Medium], Red, Round[RotationTransform[\[Alpha], 65/2 {1, 1}][rescale@pts], 0.5]}], "Points" -> pts, "Angle" -> \[Alpha]|>], Nothing];] We can import a precomputed association with 20 such constellations: selectedAsc = Import["skyAsc.m.gz"] ## Results ## Finally, we orient the schematic based on the optimally found angle and (manually) connect the dots. orient[pts_, \[Alpha]_] := Round[RotationTransform[\[Alpha], 65/2 {1, 1}][rescale@pts], 0.5] lines = {{{10, 7, 3, 1, 4, 9, 2, 5, 8}, {2, 6}}, {{7, 3, 1, 9, 6}, {10, 2, 1, 8}, {4, 3, 5}}, {{7, 8, 9, 4, 3, 2, 10}, {1, 2, 6, 5}}, {{10, 2, 1, 3, 9, 5}, {7, 1, 4, 6, 8}}, {{5, 4, 1, 2, 3}}, {{10, 4, 5, 7, 9, 3, 8}, {6, 1, 2, 3}}, {{9, 5, 6, 3, 1, 2, 7}, {7, 4, 8}}, {{7, 6, 2, 3, 5, 8}, {9, 5, 4}, {3, 1}}, {{6, 2, 1, 3, 4}, {2, 5}}, {{5, 6, 4, 1, 2, 8, 3, 7}}, {{10, 6, 3, 2, 7}, {5, 2, 1, 4, 9, 8}}, {{9, 5, 1, 2, 4, 8, 7}, {6, 3, 8}}, {{6, 10, 4, 2, 1, 3, 9, 7, 5, 8}}, {{6, 7, 3, 2, 1, 4, 5}}, {{10, 8, 3, 6, 7, 2, 5, 9}, {5, 1, 4, 3}}, {{6, 5, 2, 1, 3}, {1, 4}}, {{5, 1, 2, 3}, {1, 4}}, {{6, 3, 2, 1, 4}, {3, 5}, {2, 7}}, {{3, 6, 8, 2, 4, 5, 1, 7}}, {{3, 1, 2, 6, 5}}}; makeSquareAndScale[gr_, \[Alpha]_, size_, opacity_] := Block[{range, magnitudes, order, padding, newRanges, s}, range = AbsoluteOptions[gr, PlotRange][[1, 2]]; magnitudes = Abs[Subtract @@@ range]; order = Ordering[magnitudes, 2, Greater]; padding = Subtract @@ magnitudes[[order]]/2; s = size/First[magnitudes[[order]]]; newRanges = {{-1, 1} padding + Last[range[[order]]], First[range[[order]]]}; Graphics[{Opacity[opacity], GeometricTransformation[ GeometricTransformation[ gr[[1]], {ScalingMatrix[{s, s}], -1 First /@ (s Reverse@newRanges[[order]])}], RotationTransform[\[Alpha], (size + 1)/2 {1, 1}]]}, ImageSize -> size]] With[{l = Map[Line, lines, {2}]}, Multicolumn[ Table[Show[ makeSquareAndScale[ Keys[selectedAsc][[i]][ "SimplifiedSchematic"], -selectedAsc[[i, -1]], 64, 0.25], Graphics[ GraphicsComplex[ rescale[selectedAsc[[i, -2]]], {l[[i]], Red, PointSize[Large], Point /@ Sort /@ Flatten /@ lines[[i]]}]], ImageSize -> 150], {i, 20}], 5, Frame -> All, Appearance -> "Horizontal"]] ![found constellations][9] These can also be superimposed on the full night-sky: Graphics[{With[{l = Map[Line, lines, {2}]}, Table[GraphicsComplex[ selectedAsc[[i, -2]], {Orange, Thickness[Large], l[[i]], Red, PointSize[Medium], Point /@ Sort /@ Flatten /@ lines[[i]]}], {i, 20}]], Opacity[0.25], PointSize[Small], Point[Complement[pts, Flatten[Values@selectedAsc[[All, -2]], 1]]]}, ImageSize -> 750] ![found overlay][10] sinusoidal[\[Alpha]_, \[Delta]_] = {(\[Alpha] - \[Pi]) Cos[\[Delta]], \ \[Delta]} Graphics[{With[{l = Map[Line, lines, {2}]}, Table[GraphicsComplex[ sinusoidal @@@ selectedAsc[[i, -2]], {Orange, Thickness[Large], l[[i]], Red, PointSize[Medium], Point /@ Sort /@ Flatten /@ lines[[i]]}], {i, 20}]], Opacity[0.25], PointSize[Small], Point[sinusoidal @@@ Complement[pts, Flatten[Values@selectedAsc[[All, -2]], 1]]]}, ImageSize -> 750] ![found sinusoidal][11] It is then a matter of Overlaying these found constellations to existing images of night skies to produce the images at the beginning of the post: overlay[{img_, constellation_}, {size_, loc_, opac_}] := ImageCompose[imgs[[img]], ImageResize[ Show[makeSquareAndScale[ Keys[selectedAsc][[constellation]][ "SimplifiedSchematic"], -selectedAsc[[constellation, -1]], 64, opac], Graphics[ GraphicsComplex[ rescale[selectedAsc[[constellation, -2]]], {White, Thickness[0.0075], Line /@ lines[[constellation]], White, PointSize[.025], Point /@ Sort /@ Flatten /@ lines[[constellation]]}]], ImageSize -> 1000], size], Scaled[loc]] ## Conclusions / Lessons Learned ## - It IS possible to find collections of stars in the night sky matching all sorts of shapes. Other built-in entities to try are Pokemons, Dinosaurs etc - Not all the found constellation work 'perfectly' - Machine Learning is a powerful tool, and the WL implementation makes it easy to get started - Reformulating the problem to an easier, already solved problem (e.g. points -> 2D image input) can help Classification Accuracy - Perhaps the most interesting aspect of neural networks now, is diversifying its applications - so be creative This work was presented at the 2017 WTC (as part of a larger talk entitled "(De)Generative Art"). <br> I look forward to any comments/suggestions. <br> <br>George <br> <br> PS The editor doesn't seem to let me attach the .wlnet and .m.gz files. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=exampleImages.png&userId=11733 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=exampleImages.png&userId=616023 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=4214constellationsGraphic.png&userId=616023 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=randomPointsInmesh.png&userId=616023 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=distanceTransforms.png&userId=616023 [6]: https://arxiv.org/pdf/1409.1556v6.pdf [7]: https://mathematica.stackexchange.com/questions/89668/geoprojection-for-astronomical-data-wrong-ticks/89792#89792 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=maps.png&userId=616023 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=foundConstellations.png&userId=616023 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=overlaidConstellations.png&userId=616023 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=overlaidConstellationsSinusoidal.png&userId=616023 George Varnavides 2017-10-24T04:17:44Z https://community.wolfram.com/groups/-/m/t/852052 ![enter image description here][1] &[Wolfram Notebook][2] [older image]: https://community.wolfram.com//c/portal/getImageAttachment?filename=VisualizingInterstellar%27sWormholefromarticletoprogramming.gif&userId=20103 [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=__ezgif.com-optimize%283%29.gif&userId=11733 [2]: https://www.wolframcloud.com/obj/0af902b9-3280-4f3d-9272-454eb63c7fcd Jason Biggs 2016-05-06T13:44:35Z https://community.wolfram.com/groups/-/m/t/1306910 ![Saturn Flyby: Detailed Simulation][1] Creating a flyby simulation of a planetary scene in 3D involves multiple steps. This post walks you through the steps used to create the [final animation][2] (click this link or image below to play). I strongly recommend you watch the video in **full screen mode** with low lights so that all of the detail is visible. Some of it is subtle. [![enter image description here][3]][4] The Vimeo video hosting service has a habit of auto-advancing to the next video, but what it chooses as the next one is often strange in my opinion, so be prepared to click the back button to replay it. **Creating the Planet** Saturn can be treated as an oblate spheroid which we can model in the Wolfram Language using [ParametricPlot3D][5] and textures. [EntityValue][6] can give us a few pointers to get things scaled properly. First, we need to know the equatorial radius of the planet and its oblateness (e.g. how flattened it is at the poles compared to the equator). saturnradius = QuantityMagnitude[Entity["Planet", "Saturn"]["EquatorialRadius"], "Kilometers"]; saturnoblateness = Entity["Planet", "Saturn"]["Oblateness"]; texture = ImageReflect[EntityValue[Entity["Planet", "Saturn"], "CylindricalEquidistantTexture"], Bottom]; With the data above, we can construct a ParametericPlot3D of an oblate spheroid scaled to the dimensions of Saturn. We use the curated data from above to perform the scaling. planet = ParametricPlot3D[{saturnradius Cos[t] Sin[p], saturnradius Sin[t] Sin[ p], (1 - saturnoblateness) saturnradius Cos[p]}, {t, 0, 2 Pi}, {p, 0, \[Pi]}, Mesh -> None, PlotStyle -> Texture[texture], Lighting -> "Neutral", Boxed -> False, Axes -> False, PlotPoints -> 100] ![enter image description here][7] **Creating the Rings** The rings of Saturn lie along a plane and can be modeled as an annulus with radial color and opacity variation. We make use of a texture obtained from https://www.classe.cornell.edu/~seb/celestia/hutchison/saturn-rings.png and stored as a [CloudObject][8] in the Wolfram Cloud and use ParametricPlot3D to apply this color and opacity texture to the annulus. ringalpha = Import[ CloudObject[ "https://www.wolframcloud.com/objects/4e39f856-1c09-44d1-b2a9-\ 00ffd480b6dd"]]; ringinnerradius = 74510; ringouterradius = 140390; rings = ParametricPlot3D[{r Cos[t], r Sin[t], 0}, {r, ringinnerradius, ringouterradius}, {t, 0, 2 Pi}, Mesh -> None, PlotStyle -> Texture[ringalpha], PlotPoints -> 100] ![enter image description here][9] **Creating a Star Backdrop** To give some additional subtle detail, we can provide more sense of motion and context for the opacity variations in the rings by providing a backdrop of stars. We make use of EntityValue to obtain position and brightness data for stars visible to the naked-eye (nearly 9,000 stars). This takes a couple minutes depending on your network connection. In[9]:= stardata = EntityValue[ EntityClass["Star", "NakedEyeStar"], {"RightAscension", "Declination", "ApparentMagnitude"}]; In[10]:= stardata // Length Out[10]= 8910 To make use of the previous data in a graphical setting, we need to convert the [Quantity][10] objects to numbers in radians and also rescale the apparent magnitude brightness values to [GrayLevel][11] values between 0 and 1. We round the values of apparent magnitude since we want to optimize the rendering to make use of multi-point primitives later. Takes about a minute to convert the data into the necessary format. In[11]:= triples = With[{magrange = MinMax[stardata[[All, 3]]]}, {-QuantityMagnitude[#[[1]], "Radians"], QuantityMagnitude[#[[2]], "Radians"], Rescale[Round[#[[3]]], magrange, {1, .1}]} & /@ stardata]; Next, we group the stars based on their rounded values. In[12]:= gb = GatherBy[triples, #[[3]] &]; We construct the star background primitives by converting the right ascension and declination values into Cartesian spherical coordinates and place them far enough outside of the Saturn system, 8 ring radii, that they can serve as a spherical backdrop assuming our camera stays inside this distance. Each magnitude value gets a specific GrayLevel and set of points with a single [Point][12] head. In[13]:= stars = With[{r = 8 ringouterradius}, {GrayLevel[#[[1, 3]]], Point[{-r Cos[#[[1]]] Sin[#[[2]] + Pi/2], r Sin[#[[1]]] Sin[#[[2]] + Pi/2], -r Cos[#[[2]] + Pi/2]} & /@ #]}] & /@ gb; We can then assemble the star backdrop and assign a specific [PointSize][13] to all stars, using GrayLevel, not size, to represent brightness variations. In[14]:= starscene = Graphics3D[{PointSize[.004], stars}]; **Defining the Flight Path** The flightpath is a simple straight line. Its starts "in front" of Saturn at 4 ring radii out, and always keeps the camera pointed at the planet. The position of the camera changes with time. We construct the path using [Interpolation][14], one for each Cartesian coordinate. As time progresses, the y-coordinate extends out to the side of Saturn so we don't hit it. We also modify the z-coordinate to start above the ring plane and drop below it at the end. xfun = Interpolation[{4 ringouterradius, 3 ringouterradius, 2 ringouterradius, ringouterradius, 0, -ringouterradius}]; yfun = Interpolation[{0, ringouterradius, 2 ringouterradius, 3 ringouterradius, 4 ringouterradius, 4 ringouterradius}]; zfun = Interpolation[{4 saturnradius, 3 saturnradius, 2 saturnradius, 1 saturnradius, 0, -1 saturnradius}]; **Assembling the Scene and Generating Frames** We can render an initial scene to get a sense of how it will look. We specify a point light source to look as if the system is being illuminated by the Sun from the "front". gr = Show[{planet, Graphics3D[{Lighting -> {{"Ambient", GrayLevel[.33]}}, rings[[1]]}], starscene}, Background -> Black, ImageSize -> .4 {1920, 1080}, SphericalRegion -> True, ViewAngle -> Pi/10, ViewVector -> {{4 ringouterradius, 0, 1 saturnradius}, {0, 0, 0}}, PlotRange -> All, Lighting -> {{"Ambient", GrayLevel[0]}, {"Point", White, {3 ringouterradius, 0, 3 saturnradius}}}] ![enter image description here][15] The first step in animating the scene is to generate a list of frames. The elements are all static, but the camera position changes in time using [ViewVector][16] and making use of the interpolating functions created earlier. The time step is small so that we can obtain enough frames (600) to make the animation play back smoothly. The [ImageSize][17] is set to standard HD resolution. In[19]:= frames = Table[ Show[gr, ViewVector -> {{xfun[t], yfun[t], zfun[t]}, {0, 0, 0}}, ImageSize -> {1920, 1080}], {t, 1, 6 - 1/120, 1/120}]; In[20]:= frames // Length Out[20]= 600 The initial frame can be seen, scaled down, using the following. Stars are more easily seen at full resolution. In[21]:= Show[frames[[1]], ImageSize -> .4 {1920, 1080}] ![enter image description here][18] We need to export the frames to a directory for later assembly. The first step is to set the working directory to the same directory as the notebook. SetDirectory[NotebookDirectory[]]; Finally, we export the frames as PNG files. File names are of the form FrameXXX.png. This step of rasterizing each frame and exporting takes awhile due to the polygon count and opacity in the scene so you will need to be patient. Using [Export][19] to export individual frames, as opposed to generating a Table of frames to be exported in one pass, has at least one major advantage. It allows you to stop, at any point, and see how far you have progressed. You can monitor the directory you are exporting to to see the progress. You can abort the process and continue where you left off later. Do[ Export["Frame" <> ToString[PaddedForm[i - 1, 3, NumberPadding -> "0", NumberSigns -> {"", ""}]] <> ".png", frames[[i]], "PNG"];, {i, 1, 600, 1} ] Once you have the directory of images, you can combine these into whatever video format you prefer. You can even re-import all the frames and export them from the Wolfram Language. Modern video formats are not standardized so leaves you open to a number of choices. I tend to prefer MPEG-4 with an H.264 codec for best quality and compression. Some may prefer a Quicktime animation. The choice is up to you. There are multiple tools available for combining such image sequences that range from command line tools like FFMPEG or packages like Blender. After combining the frames, you can upload the video to your favorite video sharing service such as Vimeo or YouTube. I prefer Vimeo since the compression algorithm they apply seems more optimal for quality. The final animation was already linked in the opening statement, but [here it is again][20]. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=SaturnFlyby-ezgif.com-optimize.gif&userId=11733 [2]: https://vimeo.com/260948024 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Vimeo.png&userId=25355 [4]: https://vimeo.com/260948024 [5]: http://reference.wolfram.com/language/ref/ParametricPlot3D.html [6]: http://reference.wolfram.com/language/ref/EntityValue.html [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=5996Planet.png&userId=25355 [8]: http://reference.wolfram.com/language/ref/CloudObject.html [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=7558Rings.png&userId=25355 [10]: http://reference.wolfram.com/language/ref/Quantity.html [11]: http://reference.wolfram.com/language/ref/GrayLevel.html [12]: http://reference.wolfram.com/language/ref/Point.html [13]: http://reference.wolfram.com/language/ref/PointSize.html [14]: http://reference.wolfram.com/language/ref/Interpolation.html [15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=5763init.png&userId=25355 [16]: http://reference.wolfram.com/language/ref/ViewVector.html [17]: http://reference.wolfram.com/language/ref/ImageSize.html [18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=7032Frame1.png&userId=25355 [19]: http://reference.wolfram.com/language/ref/Export.html [20]: https://vimeo.com/260948024 Jeffrey Bryant 2018-03-22T16:09:27Z https://community.wolfram.com/groups/-/m/t/2017849 #Introduction One of the most thrilling parts in Nolan's movie "Interstellar" is the black hole Gargantua and its accretion disk. Its weird shape has surely attracted lots of attention. But do black holes and their accretion disks actually look like that? Not exactly. ![BH and accretion disk in Interstellar][1] In the paper "Gravitational lensing by spinning black holes in astrophysics, and in the movie Interstellar", the authors say that in the movie, redshift and blueshift, as well as the intensity difference is ignored to prevent confusion to the audience. So, although the outline of the accretion disk in "Interstellar" is accurate, the color and the intensity are not. Furthermore, even in the paper, effects brought by the time delay in the propagation of light are ignored, and the influence of gravity lensing on light intensity is simplified. Though I cannot easily render a spinning black hole (Kerr black hole), what I can do is try to render an accretion disk around a Schwarzschild black hole, and as physically correct as possible. The result would be something like this (observer static at 6 times the Schwarzschild radius): ![my rendering result, static observer][2] I strongly recommend you to see the videos at [Bilibili](https://www.bilibili.com/video/BV1Fp4y1S7EF) or [Youtube](https://www.youtube.com/watch?v=Dux1NkTaqwo) (Both have English subtitles) first to have a first impression, and it would be the best if you can click the vote up button XD. After that, If you would like to know more about the Mathematica realization and physical principles behind the scene, please continue. **A disclaimer first:** I know nothing about accretion disk physics, so the property of accretion disks are set arbitrarily. Furthermore, actual accretion disks are actually blazingly bright, and you would be blind instantly if you are looking at it from a short distance, so I have to make some modifications. #Analytics ###Physics Perspective First, we need to analyze this problem from the physics perspective, get to know about the problems we should consider. **For observers**, the intensity of light is determined by how much photons reached their eye in a certain angle range, and the color is determined by the spectrum of the light. However, the orientation, spectrum, and intensity of light beams can be influenced by the observer's movement, so we have to consider that. Naturally, the next question should be, where the light comes? Well, all the light must have come from some **light-emitting materials**, so we have to consider the light-emitting materials' property and movement. But the **light should travel** for some time and distance before reaching the observer's eye. This process involves tracing the light from the emitter to the observer to determine the direction of light the observer perceived, as well as how much portion of light can reach the observer's eyes. Till now, we have already listed out all effects, from the emission to the perception, which could influence our view, so I believe this rendering is "physically accurate". ### Programming Perspective But view from the programming perspective, the zeroth problem should be how lights travel around a black hole: we need the light path to calculate all other effects. Then, based on the light path, we can directly compute the equivalent of "brighter when closer" rule, as well as the time delay between light emission and observation. If combined with the movement of the light-emitting materials and the observer, we can compute the redshift and the blueshift. #Details, Theory, Coding and Results Now let's assume that we are stationary observers viewing from 6 times the Schwarzchild radius. ##Ray Tracing The first problem to solve is tracing the light beam. Light bends around black holes following the geodesics, and the most apparent consequence of this would be that the accretion disk we see would not be on a plane, but rather curved and bent. Fortunately for us, because Schwartzchild black holes are spherically symmetric, we can reduce the problem to 2D. The parametric equation of geodesics around a Schwarzschild black hole can be derived as follows: $$ \left\{ \begin{aligned} t''(\lambda)&=\frac{R_s r' t'}{R_s r-r^2}\\ r''(\lambda)&=\frac{-R_s r^2 r'^2-2r^3\theta'^2(R_s-r)^2+R_s(R_s-r)^2t'^2}{2r^3(R_s-r)}\\ \theta''(\lambda)&=-\frac{2r'\theta'}{r} \end{aligned} \right. $$ Where $\lambda$ is the ray parameter. Now we construct a set of light which originates from the observer, and trace them backward: ![Possible light paths][3] ![Definition of variables][4] ![How interpolation works][5] On each ray, we take some sample points and record the corresponding angle $\theta_0$, $\theta_1$, and time $\Delta T$. By interpolating them, we know about how a random object will look like in our eyes. (*Initial definitions*) Rs = 1; R0 = 6 Rs; Rmax = 6 Rs + 1.*^-6; (*Tracking the light*) parfunc = ParametricNDSolveValue[{{tt''[\[Tau]], rr''[\[Tau]], \[Theta]\[Theta]''[\[Tau]]} == {( Derivative[1][rr][\[Tau]] Derivative[1][tt][\[Tau]])/( rr[\[Tau]] - rr[\[Tau]]^2), ( rr[\[Tau]]^2 Derivative[1][ rr][\[Tau]]^2 - (-1 + rr[\[Tau]])^2 Derivative[1][ tt][\[Tau]]^2)/( 2 (-1 + rr[\[Tau]]) rr[\[Tau]]^3) + (-1 + rr[\[Tau]]) Derivative[1][\[Theta]\[Theta]][\[Tau]]^2, -(( 2 Derivative[1][rr][\[Tau]] Derivative[ 1][\[Theta]\[Theta]][\[Tau]])/rr[\[Tau]])}, {tt'[0], rr'[0], \[Theta]\[Theta]'[ 0]} == {1/(1 - Rs/R0), -Cos[\[Theta]0], Sqrt[1/(1 - Rs/R0)]/R0 Sin[\[Theta]0]}, {tt[0], rr[0], \[Theta]\[Theta][0]} == {0, R0, 0}, WhenEvent[ 1.01 Rs >= rr[\[Tau]] || rr[\[Tau]] >= Rmax || \[Theta]\[Theta][\[Tau]] >= 3.1 Pi, "StopIntegration"]}, {tt[\[Tau]], rr[\[Tau]], \[Theta]\[Theta][\[Tau]]}, {\[Tau], 0, 1000}, {\[Theta]0}]; (*data used in interpolation*) datp = Catenate@ Table[With[{pf = parfunc[\[Theta]]}, With[{\[Tau]max = pf[[1, 0, 1, 1, 2]], df = D[Rest@pf, \[Tau]], f = Rest@pf}, Block[{\[Tau] = Range[RandomReal[{0, \[Tau]max/500}], \[Tau]max, \[Tau]max/ 500]}, Select[ Thread[(Thread@f -> Thread@{\[Theta], ArcTan[-df[[1]], df[[2]] f[[1]] Sqrt[1 - Rs/f[[1]]]], pf[[1]]})], 2.4 Rs < #[[1, 1]] < 5.6 Rs && -0.05 Pi < #[[1, 1]] < 3.08 Pi &]]]], {\[Theta], Range[-2.5 Degree, 80 Degree, 1 Degree]~Join~ Range[20.2 Degree, 28.2 Degree, 0.5 Degree]~Join~ Range[23.025 Degree, 24.05 Degree, 0.05 Degree]~Join~ Range[23.2825 Degree, 23.4 Degree, 0.005 Degree]~Join~ Range[23.28525 Degree, 23.30025 Degree, 0.001 Degree]}]; datp = First /@ GatherBy[datp, Floor[#[[1]]/{0.01 Rs, 1 Degree}] &]; (*Construct InterpolatingFunctions*) ReceiveAngleFunction = Interpolation[Thread[{datp[[;; , 1]], datp[[;; , 2, 1]]}], InterpolationOrder -> 1]; EmitAngleFunction = Interpolation[Thread[{datp[[;; , 1]], datp[[;; , 2, 2]]}], InterpolationOrder -> 1]; DelayFunction = Interpolation[Thread[{datp[[;; , 1]], datp[[;; , 2, 3]]}], InterpolationOrder -> 1]; (*Angle vs time of observation*) GenerateAngleFunctions[R1_, \[Theta]1_] := Block[{\[Phi]1}, With[{interpol = Interpolation@ Table[{DelayFunction[R1, #] + Sqrt[2 R1^3] \[Phi]1, \[Phi]1}, {\[Phi]1, 0., 2 Pi, 10. Degree}]}, With[{ts = interpol[[1, 1, 1]], tperiod = 2. Pi Sqrt[2 R1^3]}, Function[t, interpol[t - Floor[t - ts, tperiod]]]]] & /@ ({#, 2 Pi - #, 2 Pi + #} &@ArcCos[Sin[\[Phi]1] Sin[\[Theta]1]])] If we only consider this effect, then we will have something like this: ![Light bending included][6] The inner two rings correspond to the light that rotates around the black hole for more than half a round. And if we consider the propagation time of light, the right side will be a bit brighter. ![Time correction included][7] This is because on the right, objects are moving away from you. So from your point of view, these particles will stay for a longer time on the right. (The reason is explained in the figure) ![Illustration of how velocity influence timing][8] ##"Brighter when Closer" The next question is about the "brighter when closer" rule. We all know that the further a bulb is, the dimmer it would appear to be. This is because the light from the bulb is approximately evenly distributed across solid angles, but as we move further, the solid angle corresponding to our eyes will be smaller. Mathematically, this is saying $I\propto S_0 \frac{d\Omega}{dS}$ where $S_0$ is the surface area of our eyes, $S$ is area, and $\Omega$ is the solid angle. !["Brighter when closer" rule in flat space][9] The same rules apply here in curved spacetime, except the light beams are weirder. !["Brighter when closer" rule in curved space][10] We know that $\frac{d\Omega}{dS}=(\frac{dx}{d\theta_x}\frac{dy}{d\theta_y})^{-1}$. While $\frac{dy}{d\theta_y}=\frac{R_0 \sin \alpha}{\sin \theta_1}$ can be derived using basic solid geometry, $\frac{dx}{d\theta_x}$ must be calculated numerically by tracing the light from the object to the observer. Similarly, we use interpolating function to generalize the result from a set of sample points to the whole space. (*Reverse ray tracing*) parfuncrev = ParametricNDSolveValue[{{tt''[\[Tau]], rr''[\[Tau]], \[Theta]\[Theta]''[\[Tau]]} == {( Derivative[1][rr][\[Tau]] Derivative[1][tt][\[Tau]])/( rr[\[Tau]] - rr[\[Tau]]^2), ( rr[\[Tau]]^2 Derivative[1][ rr][\[Tau]]^2 - (-1 + rr[\[Tau]])^2 Derivative[1][ tt][\[Tau]]^2)/( 2 (-1 + rr[\[Tau]]) rr[\[Tau]]^3) + (-1 + rr[\[Tau]]) Derivative[1][\[Theta]\[Theta]][\[Tau]]^2, -(( 2 Derivative[1][rr][\[Tau]] Derivative[ 1][\[Theta]\[Theta]][\[Tau]])/rr[\[Tau]])}, {tt'[0], rr'[0], \[Theta]\[Theta]'[0]} == {1/(1 - Rs/R1), Cos[\[Theta]0], -Sqrt[1/(1 - Rs/R1)]/R1 Sin[\[Theta]0]}, {tt[0], rr[0], \[Theta]\[Theta][0]} == {0, R1, \[Theta]1}, WhenEvent[\[Theta]\[Theta][\[Tau]] == 0, "StopIntegration"]}, {tt[\[Tau]], rr[\[Tau]], \[Theta]\[Theta][\[Tau]]}, {\[Tau], 0, 100}, {\[Theta]0, R1, \[Theta]1}]; (*data used in interpolation*) \[CapitalDelta]\[Phi] = 1.*^-5; intensity = Catenate@Table[{{R, \[Theta]}, R0^2 With[{\[Theta] = Abs[\[Theta]]}, Abs[Sin[EmitAngleFunction[ R, \[Theta]]]/(R0 \ Sin[\[Theta]])]*(\[CapitalDelta]\[Phi]/(Sin[ ReceiveAngleFunction[R, \[Theta]]]* Subtract @@ (With[{f = parfuncrev[ EmitAngleFunction[ R, \[Theta]] + # \[CapitalDelta]\[Phi], R, \[Theta]][[2, 0]]}, f@f[[1, 1, -1]]] & /@ {-1, 1})))]}, {R, 2.45 Rs, 5.55 Rs, 0.02 Rs}, {\[Theta], -3 Degree, 543 Degree, 2 Degree}]; (*Construct InterpolatingFunction*) IntensityFunction1 = Interpolation[intensity]; ![With intensity correction 1][11] The figure will be much more realistic in the aspect of intensity after we added this effect. The inner two rings are much dimmer because light bent dramatically is rare after all. ##Doppler Effect and Headlight Effect Now its time for Doppler effect and headlight effect. These two effects are related to the movement of light-emitting objects and observers. Though the names of these effects can be forbidding, these effects are quite common in everyday life. Blueshift refers to the phenomenon that when a car is approaching you, the noise made by the car would be more acute and loud, and redshift means when the car is leaving you, the noise would quieter and be of lower frequency. ![Doppler effect][12] The equation for the relativistic Doppler effect is: $$ f'=f\frac{\sqrt{1-\beta^2}}{1-\beta \cos \theta} $$ where $\beta=\frac{v}{c}$ and $\theta$ is the angle between the velocity direction of the light-emitting object and the light emitted, as observed by an external observer. In this case, we should further add a coefficient of $$ f''=f'\sqrt{\frac{1 - R_s/R_1}{1 - R_s/R_0}} $$ due to general relativistic effects. Headlight effect means when you are driving a car on rainy days, no matter how the wind blows, the raindrops will always run towards the windshield. But if you stop your vehicle, you can see how the wind influences the dropping direction of rain. ![Headlight effect][13] The equation for angle transformation is: $$ \cos \theta'= \frac{\cos \theta +\beta}{1+\beta \cos \theta} $$ and such, the intensity difference introduced by this can be written as: $$ \frac{dP'}{d\Omega}= \frac{dP}{d\Omega}\frac{\sin \theta}{\sin \theta'}\frac{d \theta}{d \theta'}=\frac{dP}{d\Omega}\frac{1 - \beta^2}{(1 -\beta \cos \theta)^2} $$ Except for the difference in timing brought by the curved spacetime, these two effects are purely in the special relativity regime. The only thing involved in coding is tedious coordinate transformation. (*Calculate moving speed*) Calc\[Beta][{R1_, \[Theta]_, \[Phi]_}, {vr_, v\[Theta]_, v\[Phi]_}] := Sqrt[vr^2/(1 - Rs/R1) + (R1 v\[Theta])^2 + (R1 Sin[\[Theta]] v\[Phi])^2]/ Sqrt[1 - Rs/R1] (*Calculate inner product between moving direction and light direction*) CalcCosAngle[{R1_, \[Theta]_, \[Phi]_}, {vr_, v\[Theta]_, v\[Phi]_}] := With[{v = {vr/Sqrt[1 - Rs/R1], R1 v\[Theta], R1 Sin[\[Theta]] v\[Phi]}}, MapThread[With[{\[Theta]0 = EmitAngleFunction[R1, #1]}, With[{vnormed = MapThread[Normalize@*List, v]}, MapThread[ Dot, {vnormed, Thread@{Cos[\[Theta]0], #2 Sin[\[Theta]0], 0}}, 1]]] &, {{\[Theta], 2 Pi - \[Theta], 2 Pi + \[Theta]}, {-1, 1, -1}}]] (*Frequency shift, Doppler effect + GR timing effects*) FrequencyMult[R1_, \[Beta]_, cos_] := Sqrt[(1 - Rs/R1)/(1 - Rs/R0)]*Sqrt[1 - \[Beta]^2]/(1 - \[Beta] cos) (*Intensity shift due to headlight effect only*) IntensityMult2[\[Beta]_, cos_] := (Sqrt[1 - \[Beta]^2]/(1 - \[Beta] cos))^2 Then we can put all these effects together and see how things works out! << PhysicalColor` IntensityFunctionScaling::usage = "Scale Intensity."; Protect@IntensityFunctionScaling; Options[RenderFunc] = {ColorFunction -> TemperatureColor, ColorFunctionScaling -> (# &), IntensityFunctionScaling -> (# &), "StaticObserver" -> True}; RenderFunc[R1_, {\[Theta]1_, t1_, \[Gamma]1_}, {T0_, I0_}, OptionsPattern[]] := Function[t, Through[#[t]]] &@Module[{ (*Velocity of observer*) vobs = N@Sqrt[(1 - Rs/R0) Rs/(2 R0)], (*list of \[Phi]1 parameters*) \[Phi]1l = Range[0., 2 Pi, 1 Degree], (*Polar coordinates \[Theta] and \[Phi]*) \[Theta]l0, \[Phi]l0, (*velocity of object and its norm*) vrl, v\[Theta]l, v\[Phi]l, vnorml }, (*Polar coordinate \[Theta]*) \[Theta]l0 = ArcCos[Sin[\[Phi]1l] Sin[\[Theta]1]]; (*Original \[Phi]*) \[Phi]l0 = ArcTan[Cos[\[Phi]1l], Sin[\[Phi]1l] Cos[\[Theta]1]] + \[Gamma]1; (*velocity of object*) vrl = ConstantArray[0, Length@\[Phi]1l]; v\[Theta]l = -(Cos[\[Phi]1l] Sin[\[Theta]1])/ Sqrt[1 - Sin[\[Theta]1]^2 Sin[\[Phi]1l]^2]*Sqrt[Rs/(2 R1^3)]; v\[Phi]l = 1/(Cos[\[Phi]1l]^2/Cos[\[Theta]1] + Cos[\[Theta]1] Sin[\[Phi]1l]^2)*Sqrt[Rs/(2 R1^3)]; (*velocity norm*) vnorml = Calc\[Beta][{R1, \[Theta]l0, 0}, {vrl, v\[Theta]l, v\[Phi]l}]; MapThread[Module[{ (*Observed \[Phi]1 parameter - t*) \[Phi]1t = #3, (*actual \[Theta] of object*) \[Theta]l = #1, (*angle between velocy and ray*) cosl = #4, (*Observed values - \[Phi]1*) (*Geometry*) \[Theta]obsl, \[Phi]obsl = \[Phi]l0 + #2, (*Frequency and intensity shift*) freqobsl, intobsl, (*helper function*) helpf }, \[Theta]obsl = ReceiveAngleFunction[R1, \[Theta]l]; (*Frequency*) freqobsl = FrequencyMult[R1, vnorml, cosl]; (*Process with the non-static observer*) If[OptionValue["StaticObserver"] =!= True, Module[{\[Theta]transl, \[Phi]transl, \[Delta] = ArcSin[vobs]}, (*Geometrics, static frame*) \[Theta]transl = ArcCos[Sin[\[Theta]obsl] Cos[\[Phi]obsl]]; \[Phi]transl = ArcTan[Sin[\[Theta]obsl] Sin[\[Phi]obsl], Cos[\[Theta]obsl]]; (*Frequency shift due to movement of observer, intensity shift is calculated together later*) freqobsl *= (1 + vobs Cos[\[Theta]transl])/Sqrt[1 - vobs^2]; (*Angle shift due to movement of observer*) \[Theta]transl = ArcCos[(vobs + Cos[\[Theta]transl])/(1 + vobs Cos[\[Theta]transl])]; (*Transform back*) (*Here we change the center of viewing angle so that the \ black hole's center is at {0,0}*) \[Theta]obsl = ArcCos[Sin[\[Delta]] Cos[\[Theta]transl] + Cos[\[Delta]] Sin[\[Theta]transl] Sin[\[Phi]transl]]; \[Phi]obsl = ArcTan[Cos[\[Delta]] Cos[\[Theta]transl] - Sin[\[Delta]] Sin[\[Theta]transl] Sin[\[Phi]transl], Sin[\[Theta]transl] Cos[\[Phi]transl]] ] ]; \[Phi]obsl = Catenate[ MapIndexed[#1 + 2 Pi #2[[1]] &, Split[\[Phi]obsl, Less]]]; (*Intensity*) intobsl = freqobsl^2*IntensityFunction1[R1, \[Theta]l]* IntensityMult2[vnorml, cosl]* TemperatureIntensity[freqobsl T0]/TemperatureIntensity[T0]/ freqobsl^4; (*Helper function to construct interpolating functions*) helpf[l_] := Interpolation[Thread[{\[Phi]1l, l}]]; With[{ cf = OptionValue[ColorFunction], (*Interpolating functions*) t11 = t1, \[Phi]1f = #3, \[Theta]func = helpf[\[Theta]obsl], \[Phi]func = helpf[\[Phi]obsl], freqfunc = helpf[OptionValue[ColorFunctionScaling][T0 freqobsl]], intfunc = helpf[OptionValue[IntensityFunctionScaling][I0 intobsl]] }, (*Final function*) Function[t, With[{\[Phi]11 = \[Phi]1f[t + t11]}, {Append[cf[freqfunc[\[Phi]11]], intfunc[\[Phi]11]], With[{\[Theta] = \[Theta]func[\[Phi]11], \[Phi] = \ \[Phi]func[\[Phi]11]}, (*Point[{Sin[\[Theta]]Cos[\[Phi]],Sin[\[Theta]]Sin[\[Phi]], Cos[\[Theta]]}]*) Point[Tan[\[Theta]] {Cos[\[Phi]], Sin[\[Phi]]}]]} ]] ] ] &, {{\[Theta]l0, 2 Pi - \[Theta]l0, 2 Pi + \[Theta]l0}, {0, Pi, 0}, GenerateAngleFunctions[R1, \[Theta]1], CalcCosAngle[{R1, \[Theta]l0, 0}, {vrl, v\[Theta]l, v\[Phi]l}]}]] (*My version of rasterize, which increase color precision in dimmer areas*) HDRRasterize[gr_Graphics, convertfunc_, opts : OptionsPattern[Rasterize]] := Module[{rasterl = Join[ColorSeparate[ColorConvert[Rasterize[gr, opts], "HSB"]], ColorSeparate[ ColorConvert[ Rasterize[ gr /. RGBColor[r_, g_, b_, op_] :> RGBColor[r, g, b, 16 op], opts], "HSB"]]], mask, invmask}, mask = Binarize[rasterl[[3]], 1/16]; invmask = 1 - mask; ColorCombine[{ mask*rasterl[[1]] + invmask*rasterl[[4]], mask*rasterl[[2]] + invmask*rasterl[[5]], mask*convertfunc[rasterl[[3]]] + invmask*convertfunc[rasterl[[6]]/16.]}, "HSB"] ] (*Preliminary computation*) npts = 5000; rflist = MapThread[ Function[{R1, \[Theta]1, t1, \[Gamma]1, T0, I0}, RenderFunc[R1, {\[Theta]1, t1, \[Gamma]1}, {T0, I0}, "StaticObserver" -> False(*, IntensityFunctionScaling\[Rule](.7(#/.5)^0.5&)*)]], {RandomReal[{3, 4.5}, npts], RandomReal[-{83, 86} Degree, npts], RandomReal[{0, 10000}, npts], RandomReal[15 Degree + {-2, 2} Degree, npts], RandomReal[{4000, 10000}, npts], RandomReal[{.03, .1}, npts] } ]; (*rendering!!!*) g = Graphics[{(*AbsolutePointSize@.1,White,Point[{Sin[20Degree]Cos[#], Sin[20Degree]Sin[#],Cos[20Degree]}&/@Range[0.,360.Degree, 60.Degree]],*)AbsoluteThickness@2, Map[Line[#[[;; , 2, 1]], VertexColors -> MapThread[ Function[{col, len, mult}, MapAt[mult^2*#*0.006/len &, col, 4]], {#[[;; , 1]], Prepend[#, #[[1]]] &@ BlockMap[Norm[#[[2]] - #[[1]]] &, #[[;; , 2, 1]], 2, 1], Subdivide[Length[#] - 1]}]] &, Reverse@Transpose[ Through[rflist[#]] & /@ (Range[0, 3, .1]), {3, 2, 1}], {2}]}, Background -> Black, ImageSize -> {500, Automatic}, PlotRange -> {{-1.28, 1.28}, {-0.72, 0.72}}]; HDRRasterize[g, #^(1/2.2) &, ImageSize -> {1920, 1080}] ![With all effects, static observer][14] Well, because objects at left are moving towards you, they will appear much brighter and blue-ish, while objects at right are much dimmer and red-ish. We can also consider the movement of the observer, which will make the image something like this: ![With all effects, observer moving][15] Hooray! The notebook can be found in the attachment or at [my github repo](https://github.com/wjxway/Realistic_Blackhole_Accretion_Disk). [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=bh10.png&userId=1340903 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=T_001.png&userId=1340903 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Path_4.png&userId=1340903 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=illus2.png&userId=1340903 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=illus1.png&userId=1340903 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=LightBending.png&userId=1340903 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=WithTimeCorrection.png&userId=1340903 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=illus3.png&userId=1340903 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=IntensityIllus.png&userId=1340903 [10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=illus4.png&userId=1340903 [11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=WithIntensity1.png&userId=1340903 [12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Doppler.jpg&userId=1340903 [13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=FrontLight.jpg&userId=1340903 [14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=WithAllEffects.png&userId=1340903 [15]: https://community.wolfram.com//c/portal/getImageAttachment?filename=WithObserverMoving.png&userId=1340903 Jingxian Wang 2020-07-02T11:26:03Z https://community.wolfram.com/groups/-/m/t/462064 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/dae2b70e-000e-4df5-968f-a9ae0f563eae Jeffrey Bryant 2015-03-18T19:34:05Z https://community.wolfram.com/groups/-/m/t/1732567 ![enter image description here][1] Abstract -------- The goal of this project was to simulate binary star systems and demonstrate the process of finding binary star systems and their populating planets. To accomplish this goal, I used a function called NBodySimulation, which describes the motions of a number of bodies subjected to predefined laws of motion. Simulating binary star systems, I produced a number of animations that describe the motions of these celestial bodies visually. After I succeeded in creating these animations, I moved to illustrate a practice called photometry, which astronomers use to detect binary star systems and exoplanets. I, following in the footsteps of these astronomers, produced a series of graphics describing the change in a binary star system's brightness over time. Introduction ------------ In 1929, Edwin Hubble discovered the Andromeda galaxy and destroyed our preexisting perceptions of the universe. The size of the universe expanded from 100 thousand light years across to 100 billion. The probability that there exists a planet that is similar to our own increases with every galaxy that is discovered. What was once a fantasy has become a near-reality. Consequently, the search for binary star systems and their populating planets has gained a great deal of attention. Astronomers everywhere are feverishly searching for binary star systems and their populating planets. Unfortunately, finding exoplanets is an incredibly difficult task, so dim and distant are they. Astronomers use photometry—the art of measuring changes in the intensity of light emitting from a defined area—to detect these celestial bodies. In this project, I demonstrate how astronomers detect binary star systems and their planets using photometry. Simulating Binary Star Systems ------------------------------ Here, I have created a simulation of a complete planetary system populated with a binary star and five planets. ExoDataF = NBodySimulation[ "Newtonian", {<|"Mass" -> SM1, "Position" -> SP1, "Velocity" -> SV1|>, <|"Mass" -> SM2, "Position" -> SP2, "Velocity" -> SV2|>, <|"Mass" -> PM1, "Position" -> PP1, "Velocity" -> PV1|>, <|"Mass" -> PM2, "Position" -> PP2, "Velocity" -> PV2|>, <|"Mass" -> PM3, "Position" -> PP3, "Velocity" -> PV3|>, <|"Mass" -> PM4, "Position" -> PP4, "Velocity" -> PV4|>, <|"Mass" -> PM5, "Position" -> PP5, "Velocity" -> PV5|>}, Quantity[10^30, "Years"]]; Manipulate[ Graphics3D[{White, Sphere[Values[ExoDataF["Position", t]][[1]], p*SR1], Sphere[Values[ExoDataF["Position", t]][[2]], p*SR2], Gray, Sphere[Values[ExoDataF["Position", t]][[3]], 2 p*PR1], Sphere[Values[ExoDataF["Position", t]][[4]], 2 p*PR2], Sphere[Values[ExoDataF["Position", t]][[5]], 2 p*PR3], Sphere[Values[ExoDataF["Position", t]][[6]], 2 p*PR4], Sphere[Values[ExoDataF["Position", t]][[7]], 2 p*PR5]}, Background -> Black, Boxed -> False, PlotRange -> {{-2*^12, 2*^12}, {-2*^12, 2*^12}, {-2*^12, 2*^12}}], {p, 10^5, 10^6}, {t, 0, ExoDataF["SimulationTime"]/4, 1}, SaveDefinitions -> True] ![enter image description here][1] To create this simulation, I pulled data from the Alpha Centauri system to generate the stars and data from our solar system to generate the planets. This simulation is not representative of an actual binary star system; it has been artificially generated. With that said, it can be used to demonstrate the difficult nature of detecting exoplanets. It is relatively easy to detect the two stars (represented as large, white spheres); however, it is much more difficult to detect their populating planets (represented as small, gray spheres). Despite access to state-of-the-art equipment, astronomers also struggle to detect exoplanets. They have to resort to other methods. Using Photometry to Detect Exoplanets ------------------------------------------------------------- One can detect binary star systems and exoplanets by plotting the intensity of the light that an area in space is emitting vs time. Here, I plot the intensity of the light that a single star in space that is unpopulated with planets is emitting vs time. ImageA = Table[ ImageResize[#, {75, 75}] & /@ (Binarize[Graphics3D[{ Glow[White], Black, Sphere[{0, 0, 0}, 500000 SR1]}, Background -> Black, Boxed -> False, PlotRange -> {{-3*^12, 3*^12}, {-3*^12, 3*^12}, {-3*^12, 3*^12}}]]), 40]; ImageAData = ImageData /@ ImageA; ListLinePlot[Count[1] /@ (Flatten /@ ImageAData), PlotLabel -> "Brightness Curve", AxesLabel -> {"Time", "Brightness"}] ![enter image description here][3] Unsurprisingly, the intensity of the light does not fluctuate over time. From this graph, one determines that there exists exactly one star and zero planets in this area. Here, I plot the intensity of the light that a binary star system emits over time. ImageB = Take[ Flatten[ Table[ImageResize[#, {75, 75}] & /@ (Binarize[Graphics3D[{ Glow[White], Black, Sphere[Values[ExoDataF["Position", t]][[1]], p*SR1], Sphere[Values[ExoDataF["Position", t]][[2]], p*SR2]}, Background -> Black, Boxed -> False, PlotRange -> {{-3*^12, 3*^12}, {-3*^12, 3*^12}, {-3*^12, 3*^12}}]]), {p, {500000}}, {t, 0, ExoDataF["SimulationTime"]/2, ExoDataF["SimulationTime"]/100}]], 40]; ImageBData = ImageData /@ ImageB; ListLinePlot[{Count[1] /@ (Flatten /@ ImageBData)}, PlotRange -> All, PlotLabel -> "Brightness Curve", AxesLabel -> {"Time", "Brightness"}] ![enter image description here][4] Notice that the intensity of the light dips periodically. These fluctuations indicate that there exist two celestial bodies. The intensity of the light is greatest when both bodies are visible: ![enter image description here][5] And least when one body eclipses the other: ![enter image description here][6] Here, I plot the intensity of the light that a binary star system populated with exactly one planet emits. ImageC = Take[ Flatten[ Table[ImageResize[#, {75, 75}] & /@ (Binarize[Graphics3D[{ Glow[White], Black, Sphere[Values[ExoDataF["Position", t]][[1]], p*SR1], Sphere[Values[ExoDataF["Position", t]][[2]], p*SR2], Glow[Black], Sphere[Values[ExoDataF["Position", t]][[4]], 3 p*PR2]}, Background -> Black, Boxed -> False, PlotRange -> {{-3*^12, 3*^12}, {-3*^12, 3*^12}, {-3*^12, 3*^12}}]]), {p, {500000}}, {t, 0, ExoDataF["SimulationTime"]/2, ExoDataF["SimulationTime"]/100}]], 40]; ImageCData = ImageData /@ ImageC; ListLinePlot[{Count[1] /@ (Flatten /@ ImageCData)}, PlotRange -> All, PlotLabel -> "Brightness Curve", AxesLabel -> {"Time", "Brightness"}] ![enter image description here][7] One determines that there exist two stars and at least one planet by observing the magnitude of each fluctuation. A change of 200 units indicates that one of the stars eclipses the other. A change of 30 units a planet. The planet is much smaller than both of the two stars; therefore, it has a much smaller impact on the intensity of the light emitting from the area. Notice that the planet covers but a small portion of the stars: ![enter image description here][8] Conclusions ----------- It is difficult to detect binary star systems and their populating planets; however, it is not impossible. Using photometry, astronomers can uncover small, dimly-lit bodies orbiting stars light years away. In this project, I explain how difficult it is to detect the planets populating a binary star system and demonstrate the methods used to do so. I had to learn how to use a function called NBodySimulation in order to produce the simulations shown in this notebook. Once I learned how to use this function effectively, I began generating data and creating visualizations depicting dots in a 2D plane. Most of the simulations that I created I made using data that I generated. After producing these simulations, I moved to create a complete planetary system populated with a binary star and five planets. Generating this simulation, I noticed that the planets are difficult to see, much smaller and dimmer than their parents. I began to wonder how astronomers detect binary star systems and their populating planets, which led me to investigate a practice used to detect these bodies called photometry. To demonstrate how one detects binary star systems and exoplanets using photometry, I produced a series of graphs that depict the changes in the intensity of the light emitting from the window. One should be able to detect the stars and planets in the simulation solely from these graphs. Future Works ------------ Allotted more time, I would design a function that would allow the user to alter the masses, radii, positions, velocities, and number of bodies present in the interface in real time. I attempted to apply Manipulate to NBodySimulation, but since NBodySimulation produces cooked data, such an approach is not applicable. I also would create a visualization describing what happens when a star expands beyond its Roche Lobe. Such a visualization would help illustrate the chaotic nature of these binary star systems. I also would produce a visualization depicting what one would see, standing on the surface of an exoplanet looking up. Imagine standing on the surface of a planet orbiting between a pair of stars. Everywhere is day; only along the planets prime meridian would you be able to experience twilight. It would have been a fun, engaging endeavor to try to create such a visualization. Definitions ----------- I generated the data to make the simulations shown here. However, I based these numbers on data that I pulled on the Alpha Centauri system and the planets present in our solar system. SM1 = Quantity[2.188*^32, "kg"]; SM2 = Quantity[2.80402*^31, "kg"]; PM1 = Quantity[2.00*^24, "kg"]; PM2 = Quantity[1.97*^26, "kg"]; PM3 = Quantity[3.35*^23, "kg"]; PM4 = Quantity[5.69*^24, "kg"]; PM5 = Quantity[2.777*^25, "kg"]; SR1 := 8.511*^5; SR2 := 6.005*^5; PR1 := 6.371*^4; PR2 := 6.991*^4; PR3 := 2.439*^4; PR4 := 6.371*^4; PR5 := 5.823*^4; SP1 = Quantity[{0, 0, 0}, "AstronomicalUnit"]; SP2 = Quantity[{0, 11.2, 0}, "AstronomicalUnit"]; PP1 = Quantity[{-11.2, 5.6, 0}, "AstronomicalUnit"]; PP2 = Quantity[{0, -5.2, 5.2}, "AstronomicalUnit"]; PP3 = Quantity[{5.2, -5.2, 13.5}, "AstronomicalUnit"]; PP4 = Quantity[{1, -11.2, 11.2}, "AstronomicalUnit"]; PP5 = Quantity[{1, 13.5, -5}, "AstronomicalUnit"]; SV1 = Quantity[{-21.4, 0, 0}, "km"]/sec; SV2 = Quantity[{20.6, 0, 0}, "km"]/sec; PV1 = Quantity[{20.5, 0, 0}, "km"]/sec; PV2 = Quantity[{0, 15.7, 0}, "km"]/sec; PV3 = Quantity[{-19.5, 0, 0}, "km"]/sec; PV4 = Quantity[{-21.5, 0, 0}, "km"]/sec; PV5 = Quantity[{0, 18.9, 0}, "km"]/sec; References ---------- “Transit Photometry: A Method for Finding Earths.” The Planetary Society, [www.planetary.org/explore/space-topics/exoplanets/transit-photometry.html][9]. Accessed 11 Jul. 2019. “Discovery: Other Galaxies Exist.” Amazing Space, amazing-[space.stsci.edu/resources/explorations/groundup/lesson/scopes/mt_wilson/discovery.php][10]. Accessed 11 Jul. 2019. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=10441PlanetarySystem.gif&userId=1724598 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=PlanetarySystem.gif&userId=1724598 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=BrightnessCurve.PNG&userId=1724598 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=BrightnessCurveB.PNG&userId=1724598 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=BinaryStarBAV.PNG&userId=1724598 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=BinaryStarOIV.PNG&userId=1724598 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=BrightnessCurveC.PNG&userId=1724598 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=BinaryStarE3.PNG&userId=1724598 [9]: http://www.planetary.org/explore/space-topics/exoplanets/transit-photometry.html [10]: http://space.stsci.edu/resources/explorations/groundup/lesson/scopes/mt_wilson/discovery.php Drake Hayes 2019-07-12T01:03:09Z https://community.wolfram.com/groups/-/m/t/463610 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/2fb30490-e074-40c2-99f3-80634810ef4d Vitaliy Kaurov 2015-03-20T17:02:11Z https://community.wolfram.com/groups/-/m/t/3398690 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/048a5e88-a763-4c00-9a1f-c24d4a57382f Jeffrey Bryant 2025-02-21T17:28:51Z https://community.wolfram.com/groups/-/m/t/465606 ![Path of the total 2017 solar eclipse across US][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=dsfq54wtrhywgtreadffa.gif&userId=20103 [2]: https://www.wolframcloud.com/obj/38d6ce56-a5c1-4b20-95ab-8458fe366f24 Vitaliy Kaurov 2015-03-23T22:47:35Z https://community.wolfram.com/groups/-/m/t/471232 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/dd8fb9a3-d593-4377-863e-8f4b75252b0c Jeffrey Bryant 2015-04-01T00:53:17Z https://community.wolfram.com/groups/-/m/t/934452 *NOTE*: see the **article below** about **making** this website or **click** on the image to go to the **actual website**. ---------- [![enter image description here][1]](https://wolfr.am/howoldplanet) Because WL has immense and constantly increasing vocabulary of functions and data (*THE only* language that has an ocean of built-in curated data), it is easy to come up with fun challenges or pack whole applications in a few lines of code. Below there are 3 examples that compute person's age on other planets in planet's days and years. Starting with very simple code-golfing exercises it is quite fast to build up to a whole beautiful interactive website and I will walk you through this. ---------- Code Golf: 74 characters ------------- *[Code golf][3] is a fun coding competition with participants aiming for the shortest possible code that implements an algorithm.* Can anyone come up with a shorter version version of the following code? f=PlanetData;Grid[{f[],(Now-DateObject[{1961, 8, 4}])/f[f[],"OrbitPeriod"]}] or prettified version: ![enter image description here][4] Here the date is assumed to be someone's birthday (for the curious - who's birthday is it?). The output should be in a nice readable table-like from. According to this little counter I got 74 characters: Framed[Column[{ Dynamic[Style["code length = "<>ToString[StringLength[StringDelete[x," "]]],20,Red]], InputField[Dynamic[x],String,ContinuousAction->True,FieldHint->"Enter code in InputForm"] }]] ![enter image description here][5] Tweet-a-Program --------------- Another challenge actually would be to make a nice tweet out of it for [Wolfram Tweet-a-Program][6] (TaP). Interesting thing is not to use just a date, but a ***famous person name***. Can you make this shorter? Code for Tap (note the syntax `=[...]` as it is the equivalent of CTRL+= in front end) and the [**actual tweet itself**][7]: f=PlanetData;TableForm[Transpose[{(Now- =[Obama bday])/f[f[],"OrbitPeriod"],f[]}],TableHeadings->{None,{"Obama age","Planet"}}] ![enter image description here][8] Interactive microsite --------- It is important to remember that due to planet's "OrbitPeriod" property we are considering age in years. We could consider planet's "RotationPeriod" around axis and so count the age in planet's days. Code will still stay so short that it is easy to build a whole microsite from it giving people interface to play with their birthday dates and astronomy facts. Here is a simple function that gets astronomical data and oranges them into a table. hoap[bd_,u_]:=Module[ {period,imgs, data=EntityValue["Planet", {"Name","Image","RotationPeriod","OrbitPeriod"}]}, period=(Now-bd)/data[[All,u]]; imgs=ConformImages[data[[All,2]],400]; Style[ Grid[{ data[[;;4,1]],period[[;;4]],imgs[[;;4]], data[[-4;;,1]],period[[-4;;]],imgs[[-4;;]]}, Alignment->Left], FontSize->20,Red] ] To design user interface via a microsite we will use FormPage function: CloudDeploy[ FormPage[ {"birthday"->"Date", "time" -> {"years" -> 4, "days" -> 3}}, hoap[#birthday,#time]&, AppearanceRules-><| "Title" -> "How old are you on another planet?", "Description" -> " Albert Einstein would now be 5 years old on Saturn and vampire-old on Mercury. See his BD below. Try it it yourself. Planet rotational period defines days, and its orbital period - years."|>, FormTheme -> "Black" ][<|"birthday" -> "March 14, 1879", "time" -> 4|>], "howoldplanet",Permissions->"Public"] Out[]= CloudObject["https://www.wolframcloud.com/objects/user-3c5d3268-040e-45d5-8ac1-25476e7870da/howoldplanet"] It gives us a URL if a cloud object where our microsite resides. To have a shorter version we compute: URLShorten[%[[1]], "howoldplanet"] https://wolfr.am/howoldplanet and following that URL you will arrive at a simple but stylish microsite shown at the top of this page. Hooray! [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-05at8.19.27AM2.png&userId=11733 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-05at6.30.41AM.png&userId=11733 [3]: https://en.wikipedia.org/wiki/Code_golf [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-04at5.40.52PM.png&userId=11733 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2904ScreenShot2016-10-04at5.44.31PM.png&userId=11733 [6]: https://twitter.com/wolframtap [7]: https://twitter.com/wolframtap/status/783450755743318016 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Ct9gT0VWgAAck8l.jpg&userId=11733 Vitaliy Kaurov 2016-10-04T22:46:17Z https://community.wolfram.com/groups/-/m/t/803953 This discussion is inspired by [the question from a Mathematica user][1]. The post involves decent vector calculus and Mathematica code so it deserves a designated page for the presentation. Besides the mathematical challenge, I also comprehensively use advanced Wolfram technologies such as [Wolfram Alpha with nature language processing][2], [geographic database][3], [real world entities][4] and Mathematica's powerful visualization capability ([like the gauge GUI][5]). Please download the attached notebook to run all the code snippets. Feel free to play around the technology here and hopefully you will learn more about how to use these great features of the Wolfram platform. The problem states the following > Find the location on the surface of earth where the moon sits at zenith, given the moon's position at the observer’s location (in terms of azimuth and altitude angle) Conclusion ------------- On *2/25/2016 at 23:30 Chicago time zone*, the people, who reside at the location shown on the map, see the moon right above their head. In scientific term, the altitude of the moon position at the location is 90 degree. ![enter image description here][6] Analysis ------------- Since the position of moon is changing as time goes by, I would like to use the following function to take a snapshot of the motion at dateObj = DateObject[{2016, 2, 25, 23, 30}] (* The moment that I started to write this blog *) The moon position from my view at the city of Champaign, IL: ![mp][7] You can check the result from [Daily Moon Position][8] as well. This is the screenshot of the result online at the given location and time spot. [The zip codes of Champaign IL includes 61821][9] ![mp2][10] We can visualize the above results using the Mathematica powerful UI controls. In the azimuth meter, 0 denotes the true north; 180 the sourth; 90 the east; 270 the west. You can imagine that this compass is put on the ground or on the tangential plane of the earth at a particular instance. In my case , it is Champaign, IL . This Mathematica GUI is more visually pleasant than the previous screenshot. ![gui1][11] The idea to solve this problem is to use the coordinate tranformation: convert the coordinate of the moon in the frame of the local observer to the space cartesian coordinate. Meanwhile, we convert, again, the coordinate of the moon from the earth's sperical coordicate to the same Cartesian system. We equate the two expressions to find the right values of the latitude and longitude of the location where the culmination of the moon is observed. Then we shall check the moon position at the output location to see if the altitude is 90 degree. The flow of analysis is ![diagram3][12] To solve the problem we also need the geo location of Champaign IL : ![chgp][13] I will use the (radius, arithmus, polar) convension that is applied throughout on this page: http://mathworld.wolfram.com/SphericalCoordinates.html. The convension is such that the cartesian center coincides with the center of the earth. Meanwhile, the x-axis of the coordinate passes through the intersection of prime meridian and equator. The y axis passes through the intersection of 90th meridan east and equator. The z-axis points to north pole. The diagram for longitude ($\lambda$) and latitude ($\phi$) is shown on the diagram ([Source][14]): ![enter image description here][15] Thus, given the geo position of my local spot, I can obtain the new coordinate by `CoordinateTransformData` function. The radius is simply the average radius of the earth. I can extract the value from the Wolfram Database for astronomy automatically ![er][16] Convert the result to pure number. One thing to mention here the polar angle used in `CoordinateTransformData ` function is the complementary angle of the latitude, aka ($\pi/2 - $ latitude) ![chcoor][17] We can also find the distance from the center of the earth to the center of the moon using the following query. If you query "distance from earth to moon " you might have a different result because Wolfram Alpha use the current time frame to retrieve the information or it simply return the average distance. ![lunardist][18] These are the bases in the Cartesian coordinate: basis = {e1, e2, e3}; By quite complicated spacial coordinate transformation, ![enter image description here][19] we have the following operator: trfM[\[Lambda]_, \[Phi]_] := {{-Sin[\[Lambda]], Cos[\[Lambda]], 0}, {-Sin[\[Phi]]*Cos[\[Lambda]], -Sin[\[Phi]]*Sin[\[Lambda]], Cos[\[Phi]]}, {Cos[\[Phi]] Cos[\[Lambda]], Cos[\[Phi]] Sin[\[Lambda]], Sin[\[Phi]]}} The conversion from observer's basis to the cartesian basis is the inner product we have below: trfM[a,b].basis {e2 Cos[a]-e1 Sin[a],e3 Cos[b]-e1 Cos[a] Sin[b]-e2 Sin[a] Sin[b],e1 Cos[a] Cos[b]+e2 Cos[b] Sin[a]+e3 Sin[b]} Now lets take a look at the coordinate of the moon in the observer's frame: ![moonCoord][20] where l is the distance between my location and the center of the moon, theta is local altitude and psi is the local azimuth angle.Use the conversion routine we have just discussed, we can obtain the cartesian coordinate of the moon: ![newCoord][21] Extract the coefficient of the e1, e2 and e3. These coefficient is exactly the so-called x-y-z component of the moon's position in space. rhs=Coefficient[newCoord,#,1]&/@basis (* {91.1542 +0.723664 l,-3024.4-0.685557 l,2549.3 -0.0795132 l} *) If we want to describe the coordinate of the moon in our Cartesian systems, we have to use `TransformationFunctionData` again: MoonCoord=lhs=CoordinateTransformData["Spherical"->"Cartesian", "Mapping", {lunarDist,Pi/2-moonLat,moonLon}] (* {251638. Cos[moonLat] Cos[moonLon],251638. Cos[moonLat] Sin[moonLon],251638. Sin[moonLat]}*) Back to the beginning of our solving scheme, the moon's spactial location is invariant regardless of where the cartesian description is transformed from. This is illustrated in the diagram below: ![diagram][22] Thus we have three equations: `x = x`, `y = y`, `z = z`. And three unknowns: `moonLat`, `moonLon` and `l` = *distance between Champaign IL and the center of the moon*. sol=FindRoot[Thread[rhs==lhs],{moonLat,0},{moonLon,0},{l,lunarDist}] (* {moonLat->-0.0688172,moonLon->-0.76686,l->249678.} units: {radian, radian, mile}*) Convert the result back to the geo location: location=GeoPosition[180/Pi*{moonLat,moonLon}/.sol] (* GeoPosition[{-3.94294,-43.9378}] *) MoonPosition[%,DateObject[{2016,2,25,23,30}]] (* {91.60 Degree ,89.02 Degree } *) Since the altitude is almost 90 degree, I think the result is fairly close. Visually verify the result with the sky chart generated from Wolfram Alpha. It shows that the moon is about at the zenith over the computed location. ![locationskc][23] One thing worth to mention here is that the equation we have solved. It could have two solutions. The geometric interpretation of the solutions is the location on the earth colinear both with the center of the earth and moon. This line connecting the center of both planets will touch the surface of earth twice. So you want to check if the moon is above head or beneath the foot. A few extra things with Wolfram Alpha ---------- - Where is the spot we have just found on the earth? ![inbrasil][24] - How far away is it from Champaign IL? 1/6 of earth circumference is not a short distance! WolframAlpha["distance between champaign and latitude = -3.943 longitude = -43.9378",{{"FractionOfEarthCircumference",1},"ComputableData"}] 0.17 ~~ 1 / 6 - Any popular place near the site? ![citynb][25] Further Readings ---------- - [Longitude from Moon Culminations][26] - [Wiki for lunar standstill][27] [1]: http://community.wolfram.com/groups/-/m/t/803034 [2]: https://www.wolframalpha.com [3]: https://reference.wolfram.com/language/guide/GeographicData.html [4]: http://www.wolfram.com/language/fast-introduction-for-programmers/real-world-entities/ [5]: https://reference.wolfram.com/language/guide/Gauges.html [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-02-26at12.35.27PM.png&userId=23928 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-02-26at12.30.54PM.png&userId=23928 [8]: http://www.dailymoonposition.com/default.aspx [9]: http://www.wolframalpha.com/input/?i=zip%20code%20of%20Champaign%20IL [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-02-26at12.39.43PM.png&userId=23928 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-02-26at1.45.29PM.png&userId=23928 [12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=diagram2.svg&userId=23928 [13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-02-26at12.47.05PM.png&userId=23928 [14]: https://en.wikipedia.org/wiki/Latitude#/media/File:Latitude_and_longitude_graticule_on_a_sphere.svg [15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=145px-Latitude_and_longitude_graticule_on_a_sphere.svg.png&userId=23928 [16]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-02-26at12.48.58PM.png&userId=23928 [17]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-02-26at12.49.19PM.png&userId=23928 [18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-02-26at12.51.49PM.png&userId=23928 [19]: http://community.wolfram.com//c/portal/getImageAttachment?filename=IMG_4793.jpg&userId=23928 [20]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-02-26at12.54.06PM.png&userId=23928 [21]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-02-26at12.54.52PM.png&userId=23928 [22]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-02-26at12.58.55PM.png&userId=23928 [23]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-02-26at1.04.20PM.png&userId=23928 [24]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-02-26at1.05.51PM.png&userId=23928 [25]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-02-26at1.07.32PM.png&userId=23928 [26]: http://articles.adsabs.harvard.edu//full/1899MNRAS..59..513P/0000514.000.html [27]: https://en.wikipedia.org/wiki/Lunar_standstill Shenghui Yang 2016-02-26T19:08:20Z https://community.wolfram.com/groups/-/m/t/578543 Hi, I just made a little Hertzsprung-Russell diagram for a class of mine. It's not quite perfect yet, but I wanted to post it anyway. Mathematica (wikipedia?) knows what that diagram is: WikipediaSearch["Hertzsprung Russell diagram"] gives: > <|"Title" -> "Hertzsprung-Russell diagram", > >"Snippet" -> "The > Hertzsprung-Russell diagram, abbreviated H-R diagram or HRD, is > a scatter graph of stars showing the relationship between the stars' > absolute magnitudes or luminosities versus their spectral > classifications or effective temperatures."| All the data I need is in Mathematica. stars = StarData[]; contains data for more than 107,000 stars. I will only download data for 10,000 stars as to not overload my final image. starChoice = RandomChoice[stars, 10000]; starData = StarData[starChoice, {"Luminosity", "EffectiveTemperature", "Mass", "Radius", "BVColorIndex", "Color"}]; I access luminosity, surface temperature, mass, radius, and color data for the stars. I will want to use BubbleChart to generate the diagram. The position of the bubbles will be given by (the logarithms of) the luminosity and the surface temperature; note that the x-asis is reversed. The size of the bubbles will encode the radius and I would like to color the bubbles in a way that relates to their BVColorIndex. The most difficult issue is the colour. As a matter of fact, I will cheat a bit to make the colour distribution clearer. I use some formulas from this [website][1] for the conversion of BV to RGB colour. {\[Lambda], x, y, z} = Import["http://www.cvrl.org/database/data/cmfs/ciexyzjv.csv"]//Transpose; XYZ[t_] := Module[{h = 6.62607*10^-34, c = 2.998*10^8, k = 1.38065*10^-23}, {x, y, z}.((2 h c^2)/((-1 + E^((h c/k)/(t \[Lambda]*10^-9))) (\[Lambda]*10^-9)^5)) // #/#[[2]] &] The plot is quite easy to generate from here: normsun = QuantityMagnitude[StarData["Sun", "Luminosity"]]; BubbleChart[ Style[{Log[10, QuantityMagnitude[#[[2]]]], QuantityMagnitude[#[[1]]]/normsun, QuantityMagnitude[#[[4]]]}, ColorConvert[XYZColor @@ XYZ[4600*((1/(0.92 #[[5]] + 1.7)^2.4 + 1/(0.92 #[[5]] + 0.62)^2.4))], "RGB"]] & /@ Select[starData, FreeQ[#, Missing] &], ScalingFunctions -> {"Reverse", "Log"}, Background -> Black, FrameLabel -> {"Log(Temperature)", "Log(Luminosity)"}, LabelStyle -> Directive[Bold, 15, White], ImageSize -> Full] Note that there is a "fudge exponent" of 2.4 which exaggerates the colours. This gives: ![enter image description here][2] If you compare this figure to the [corresponding images on the wikipedia page][3], you will note that is looks quite similar to the second figure. The first figure on that website, shows a fine structure of all the sequences Ia and Ib for the supergiants, II for the bright giants, III for giants, IV for subgiants, and V for the main sequence. Then there are the white dwarfs. It appears that our diagram shows a similar sub-structure, but I might be mistaken. Our own sun is on the main sequence at the intersection at a horizontal line of normalised Log-luminosity 1. (The axis is normalised to our sun's luminosity.) So our sun is "yellow-white". As we are already on it, we can also compare where our sun lies in terms of its mass. I therefore compute a SmoothHistogram of the masses of my 10000 stars. SmoothHistogram[ Select[QuantityMagnitude[starData[[All, 3]]], NumberQ], PlotRange -> {{0, 1.5*10^31}, All}, PlotTheme -> "Marketing", FrameLabel -> {"Mass", "Density"}, ImageSize -> Full, LabelStyle -> Directive[Bold, Medium], Epilog -> {Red, {PointSize[0.02], Point[{QuantityMagnitude[StarData["Sun", "Mass"]], 0}]}, Green, Line[{{Median[ Select[QuantityMagnitude[starData[[All, 3]]], NumberQ]], -0.1}, {Median[ Select[QuantityMagnitude[starData[[All, 3]]], NumberQ]], 7.5*10^-31}}], Yellow, Line[{{Mean[ Select[QuantityMagnitude[starData[[All, 3]]], NumberQ]], -0.1}, {Mean[ Select[QuantityMagnitude[starData[[All, 3]]], NumberQ]], 7.5*10^-31}}]}] ![enter image description here][4] Our sun's mass is marked by the red dot on the x-axis. The green vertical line shows the median of the distribution and the yellow line the mean. I have truncated the diagram at the large masses. The following plot shows mass vs radius: ListPlot[QuantityMagnitude /@ Select[starData[[All, {3, 4}]], FreeQ[#, Missing] &], PlotTheme -> "Marketing", LabelStyle -> Directive[Bold, 15, Black],FrameLabel -> {"Mass", "Radius"}] ![enter image description here][5] Cheers, Marco [1]: http://mathematica.stackexchange.com/questions/57389/convert-spectral-distribution-to-rgb-color [2]: /c/portal/getImageAttachment?filename=ScreenShot2015-10-09at23.18.53.png&userId=48754 [3]: https://en.wikipedia.org/wiki/Hertzsprung%E2%80%93Russell_diagram [4]: /c/portal/getImageAttachment?filename=ScreenShot2015-10-09at23.27.04.png&userId=48754 [5]: /c/portal/getImageAttachment?filename=ScreenShot2015-10-09at23.39.24.png&userId=48754 Marco Thiel 2015-10-09T22:45:44Z https://community.wolfram.com/groups/-/m/t/1732166 **Introduction** ![enter image description here][1] On September 14th, 2015, LIGO (the Laser Interferometer Gravitational-Wave Observatory), located in both Washington and Louisiana, detected a strange “ping” roughly 1.3 billion light years away from Earth. This “ping” was caused by gravitational waves as the result of a collision of two black holes which occurred just as Earth’s inner core began to form, only just reaching one billion years later. The purpose of this project was to visualize the relationship of a binary black hole system and the eventual collision between the two which marked a revolutionary event in the history of astrophysics. **Developing the Visualization** In order to develop the visualization, a set of differential equations had to be solved. Respectively, each equation modeled the average angular momentum magnitude along the Z-axis (seeing as the final result was to be three dimensional), the rate of change of the semi-major axis, the eccentricity, the radius, and the angular velocity about the center of inertia for the black holes—the result of which is shown here: ![enter image description here][2] ![enter image description here][3] ![enter image description here][4] After evaluating the differential equations, graphs could be determined from which the points representing the black holes could be plotted, a place from which the final visualization could be created. Initially, two rotating points were created using an animation on a circular plot orbiting parallel to each other around the center of mass, also known as a “barycenter”: ![enter image description here][5] Once this simple animation and the graphs were complete, the two were merged by a common function which allowed for the points plotted on the first animation to follow the path of the spiral graphs developed from various initial conditions provided alongside the differential equations. Initially, the animation was developed where one of the black holes remained stationary whilst the other one orbited around it following the path of the graph, but it was then changed so that both black holes would orbit around a barycenter, gradually getting closer and closer as the distance decreased but the acceleration increased, a relationship modeled by the proportionality ?r??t. ![enter image description here][6] For the final, polished animation, a star-field was created which served as the background for the polished visualization (the color of “space” was changed to a medium blue in order to see the orbit of the black holes). ![enter image description here][7] **Conclusion** In conclusion, this demonstration was able to successfully visualize a binary black hole merger as discovered by LIGO, and as predicted by Albert Einstein's General Theory of Relativity in 1916. Through this visualization, we can view this incredible phenomenon and are given a glimpse as to what may occur if seen in real life. In the future, a second part of the project will be added to determine the distance of the gravitational wave detector from the black holes, and the time the signal reached the detector. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=starryOrbit2.gif&userId=1381443 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=diffcalc1.jpg&userId=1381443 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=diffcalc2.jpg&userId=1381443 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-07-11at7.54.41PM.png&userId=1381443 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-07-11at7.55.20PM.png&userId=1381443 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=graphorbit.jpg&userId=1381443 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=starryorbit.jpg&userId=1381443 Macy Maurer Levin 2019-07-11T23:43:51Z https://community.wolfram.com/groups/-/m/t/882068 Awhile back, Stephen Wolfram suggested that I try to re-create, using modern calculations instead of observations, Galileo's observations of Jupiter's 4 largest moons. I thought I'd share the results here for fun, especially since its nice of have something about Jupiter given the arrival of the [Juno spacecraft][1] at Jupiter this past weekend. These moons are also known today as the [Galilean Satellites][2]. At the time, the prevailing view of the cosmos was that Earth was the center of the universe and everything moved around it. So, it came as a surprise when Galileo observed Jupiter through his primitive telescope that Jupiter has 4 "stars" that appeared to be orbiting it. In his diagrams, Jupiter was represented as a simple circle, and the new satellites as star-like figures. ![Illustrations of Galileo's observations of Jupiter in early 1610 from his publication Sidereus Nuncius][3] Using Astronomical Algorithms, by Jean Meeus, as a source, I used the low accuracy method (since we just need the results to look okay to the eye) to compute the positions of Jupiter's 4 big moons in 2D. Higher accuracy methods are also provided in the source, but those are used for things like transits, eclipses, etc. and is more than what is needed here. JovianMoonCoordinates[jd_] := Module[{A, B, d, DE, Delta, DS, du1, du2, du3, du4, G, H, J, KK, lambda, M, NN, psi, r, R, r1, r2, r3, r4, u1, u2, u3, u4, V, w1, w2}, d = jd - 2451545; V = 3.0148817498 + 0.000019475780 d; M = 6.2400582213 + 0.017201970 d; NN = 0.349414916249264 + 0.0014501120450072 d + 0.00574213323906134 Sin[V]; J = 1.15392443495605 + 0.0157519089131849 d - 0.005742133239061344 Sin[V]; A = 0.033423055175691 Sin[M] + 0.00034906585039886 Sin[2 M]; B = 0.096953039948 Sin[NN] + 0.0029321531433504 Sin[2 NN]; KK = J + A - B; R = 1.00014 - .01671 Cos[M] - .00014 Cos[2 M]; r = 5.20872 - .25208 Cos[NN] - .00611 Cos[2 NN]; Delta = Sqrt[r^2 + R^2 - 2 r R Cos[KK]]; psi = ArcSin[R/Delta Sin[KK]]; w1 = 3.68229565585763 + 15.3207952882387 d - 0.088559510336640 Delta + psi - B; w2 = 3.26777995850898 + 15.18762666631161 d - 0.087789749516252 Delta + psi - B; lambda = 0.599520598060052 + 0.001450211528774608 d + 0.005742133239061344 Sin[V] + B; DS = 0.0544542726622230 Sin[0.7470009198535 + lambda]; DE = DS - 0.02268928027592 (r - Delta)/Delta Sin[ lambda - 1.754055898254301] - 0.03874630939427 Sin[psi] Cos[lambda + 0.383972435438752]; u1 = 2.858969742485099 + 3.5501020551357 d - 0.0205208211279524 Delta + psi - B; u2 = 6.25550438524295 + 1.767872509298387 d - 0.01021891623871900 Delta + psi - B; u3 = 0.0997909453120277 + 0.876757737252356 d - 0.0050679637991465 Delta + psi - B; u4 = 3.923660728774436 + 0.3750360006026911 d - 0.00216783815377278 Delta + psi - B; G = 5.780181416754821 + 0.878083559165341 d - 0.00507562750962625 Delta; H = 1.526290430869041 + 0.37645409807322 d - 0.002176035248978202 Delta; du1 = 0.00825540736193317 Sin[2 (u1 - u2)]; du2 = 0.0185877565337396 Sin[2 (u2 - u3)]; du3 = 0.002879793265790643 Sin[G]; du4 = 0.01471312559431219 Sin[H]; r1 = 5.9057 - .0244 Cos[2 (u1 - u2)]; r2 = 9.3966 - .0882 Cos[2 (u2 - u3)]; r3 = 14.9883 - .0216 Cos[G]; r4 = 26.3627 - .1939 Cos[H]; u1 += du1; u2 += du2; u3 += du3; u4 += du4; MapThread[{# Sin[#2], -# Cos[#2] Sin[DE]} &, {{r1, r2, r3, r4}, {u1, u2, u3, u4}}, 1]] I created a star symbol to represent the moons using the following: star[{x_, y_}] := Line[{{{-.75/2 + x, -.75/2 + y}, {.75/2 + x, .75/2 + y}}, {{-.75/2 + x, .75/2 + y}, {.75/2 + x, -.75/2 + y}}, {{x, 1/2 + y}, {x, -1/2 + y}}}] Finally, the pieces are assembled to create an individual "frame" here: JupiterSatellites[date_] := Module[{jd = JulianDate[date]}, Graphics[{GrayLevel[.6], {{Black, star[#]}} & /@ JovianMoonCoordinates[jd]}, ImageSize -> 400, PlotRange -> {{-25, 25}, {-1, 1}}, PlotRangePadding -> 3, Epilog -> {White, EdgeForm[Black], Thickness[.003], Disk[{0, 0}, {1, 1/1.071}]}, PlotLabel -> Block[{$DateStringFormat = {"MonthNameShort", " ", "DayShort", " ", "Year", " ", "Hour12Short", ":", "Minute", "AMPM"}}, DateString[date]]]] A sequence of frames is easily created with a simple Table command: frames = Table[ JupiterSatellites[ DateObject[{1610, 1, 8, h, 0, 0}, TimeZone -> 1]], {h, 0, 120, 3}]; And you can view this list of frames as a stacked diagram as follows: Grid[List/@frames, Dividers -> All] ![enter image description here][4] You can also export the frames as an animation to see the positions change in time. ![enter image description here][5] [1]: http://www.wolframalpha.com/input/?i=Juno%20spacecraft [2]: http://www.wolframalpha.com/input/?i=Galilean%20Satellites [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Medicean_Stars.png&userId=25355 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=GalileanSatellitesGrid.png&userId=25355 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=8411GalileanSatellites.gif&userId=25355 Jeffrey Bryant 2016-07-05T20:43:29Z https://community.wolfram.com/groups/-/m/t/3438819 ![The stochastic mechanics of Hawking radiation. Black hole evaporation, thermal systems.][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Main23042025.png&userId=20103 [2]: https://www.wolframcloud.com/obj/9564cd48-8766-4446-8328-eadd5766e28f Noah MacKay 2025-04-03T13:37:23Z https://community.wolfram.com/groups/-/m/t/2222977 &[Wolfram Notebook][1] [Original]: https://www.wolframcloud.com/obj/8a8fbd01-b0d8-4798-beec-166e0898b2b1 [1]: https://www.wolframcloud.com/obj/5d2efdc4-f66c-486b-9f5a-298d70381d5d Jack Madden 2021-03-18T17:28:29Z https://community.wolfram.com/groups/-/m/t/1731612 <img src="https://community.wolfram.com//c/portal/getImageAttachment?filename=ThreeBody.gif&userId=1682328"/> # Abstract In this project, I analyze n-body simulations outputs and their patterns by utilizing different statistical methods, visualization algorithms, and feature extraction techniques. Using an n-body simulation random generation technique, a sample of 5000 different outputs could be generated. By performing feature extraction processes, some interesting visualizations about the different outcomes from the simulations were plotted on a two-dimensional feature space plot. Additional conclusions were made using the distribution of the center-of-mass, and a two-body mass visualization. # Introduction In physics and astronomy, an N-body simulation is a simulation of a dynamical system of particles, usually under the influence of physical forces, such as gravity. Currently, computing power is sufficient for processing some classes of N-Body simulations, with a small number of bodies, and with a short lapse time. For cases of realistic units such as astronomical units and gigayears, computers can't handle their complexity. A way to prevent this computational complexity difficulty, systems such as "InverseSquare" relativistically treat metric units and unitless quantities mathematically equivalent. Here are some cases of random n-body simulations, they have an extraordinarily chaotic behavior, and are vulnerable to having their outputs changed with just a few tweaks on their initial states. CreateRandomBody[] := Block[{}, <|"Mass" -> RandomReal[{0.01, 0.99}], "Position" -> RandomReal[{-1, 1}, 2], "Velocity" -> RandomReal[{-1, 1}, 2]|> ] CreateRandomPivot[] := Block[{}, <|"Mass" -> 1, "Position" -> {0, 0}, "Velocity" -> RandomReal[{-0.25, 0.25}, 2]|> ] NBodyPlot[data_] := ParametricPlot[Evaluate[data[All, "Position", t]],{t, 0, data["SimulationTime"]}, AspectRatio -> Automatic, Axes -> False, PlotStyle -> {Thickness[0.025], Thickness[0.025], Thickness[0.025]}] Table[Rasterize[ NBodyPlot[ NBodySimulation[ "InverseSquare", {CreateRandomPivot[], CreateRandomBody[], CreateRandomBody[]}, 10]], ImageSize -> Small], 8] // Quiet <img src="https://community.wolfram.com//c/portal/getImageAttachment?filename=Selection_222.png&userId=1682328" /> For performing the same visualizations and procedures, download the notebook available on this post. The notebook contains all the datasets and files you will need. HeuristicData = "..."; NBParameters = "..."; NBDPaths = "..."; The "HeuristicData" list contains lists of the heuristic results generated by the "NBodyHeuristics" function (see "Data Generation Procedure"), the "NBParameters" list contains lists of initial parameters, and the "NBDPaths" list contains lists of the final paths of the bodies. Every list is uniform and contains 5000 elements each. NBParametersDataset = Dataset@NBParameters; {NBPBodyA, NBPBodyB, NBPBodyC} = Table[NBParametersDataset[[All, t]], {t, 1, 3}]; {allDoubleFalse, allSingleFalse, pivotDiverged, allContained, allDivergent} = Table[Join@@Position[HeuristicData, t], {t, { {False, True, False} | {False, False, True} | {True, False, False}, {False, True, True} | {True, False, True} | {True, True, False}, {False, True, True}, {True, True, True}, {False, False, False} }}]; {allDoubleFalsePoints, allSingleFalsePoints, allContainedPoints, allDivergentPoints, pivotDivergedPoints} = Table[Thread[{Normal[NBPBodyB[x, "Mass"]], Normal[NBPBodyC[x, "Mass"]]}], {x, {allDoubleFalse, allSingleFalse, allContained, allDivergent, pivotDiverged}}]; ListPlot[{allContainedPoints, allDivergentPoints, pivotDivergedPoints, allDoubleFalsePoints},PlotStyle -> {RGBColor[0.9, 0.9, 0.9], {PointSize[0.01], Blue}, {PointSize[0.01], Red}, {PointSize[0.01], Orange}}, AspectRatio -> Automatic, PlotTheme -> "Detailed", PlotLegends -> {"All Bodies Contained", "All Bodies Diverged", "Pivot Diverged", "Two Bodies Diverged"}, PlotLabel -> "Masses of the Lightest Objects and Stability", LabelStyle -> {16, GrayLevel[0]}, ImageSize -> {500, 500}] <img src="https://community.wolfram.com//c/portal/getImageAttachment?filename=ScatterPlot.png&userId=1682328" /> With this plot, we can visualize that there's is a correlation between the lighter bodies masses and the stability of the systems. The lightest bodies have the most stability in their simulations, which means that they are not "catapulted" from the system. Now, let's calculate the distances between the center of masses using $\frac{\sum _{i=j}^n m_i x_i}{\sum _{i=j}^n m_i}$ as $m_i$ being the mass of the individual bodies and $x_i$ as the positions in space. centerOfMass = Thread[{Normal@NBParametersDataset[[All, All, "Mass"]], NBDPaths}]; centerOfMasses = Table[(centerOfMass[[n]][[1]]*centerOfMass[[n]][[2]] // Total)/Total[centerOfMass[[n, 1]]], {n, 1, Length[NBParametersDataset]}]; distancesCOM = MapThread[Table[EuclideanDistance[#1, #2[[n]]], {n, 1, 3}] &, {centerOfMasses, NBDPaths}]; Histogram[Flatten@distancesCOM, PlotLabel -> "Sum of Distances from the Center of Mass to the Bodies [Unitless]", LabelStyle -> {16, GrayLevel[0]}, PlotTheme -> "Detailed", ColorFunction -> Function[{height}, RGBColor[0, 1 * height, 1]], ImageSize -> {750, 500}] <img src="https://community.wolfram.com//c/portal/getImageAttachment?filename=Histogram_A.png&userId=1682328" /> This histogram clearly shows that there's a logarithmic curve of the distances from the center of mass and the objects, in fact, a **LogNormalDistribution[]** distribution can be matched using **FindDistribution[]**. And, by plotting the histogram with a logarithmic scale, we obtain a normal distribution. Histogram[Flatten@distancesCOM, {"Log", 20}, PlotLabel -> "Sum of Distances from the Center of Mass to the Bodies \ [Logarithmically Scaled, Unitless]", LabelStyle -> {16, GrayLevel[0]}, PlotTheme -> "Detailed", ColorFunction -> Function[{height}, RGBColor[0, 1*height, 1]], ImageSize -> {850, 500}] <img src="https://community.wolfram.com//c/portal/getImageAttachment?filename=Histogram_B.png&userId=1682328"> One fascinating visualization is to FeatureSpacePlot all the rasterizations of the simulations. This should give us an interesting view of the bigger picture of the simulations. rasterizeList = Rasterize[NBodyPlot[NBodySimulation["InverseSquare", #, 10]]] &/@ Normal[RandomSample[NBParametersDataset, 250]] // Quiet; FeatureSpacePlot[rasterizeList[[1;;200]], LabelingSize -> 30, ImageSize -> {800, 800}, PlotLabel -> "Feature Space of 250 Three Body Simulations", LabelStyle -> {16, GrayLevel[0]}] <img src="https://community.wolfram.com//c/portal/getImageAttachment?filename=FeatureSpacePlot.png&userId=1682328"> Based on this **FeatureSpacePlot[]**, we can infer that the most caotic simulations are located in the borders, and the divergent simulations are always on the side of where is the body diverging. # Conclusion In this project, I conclude that the applicability of algorithms such as neural networks and clustering classification is hard due to the chaotic nature of the n-body simulations, the volatility of such systems do not allow such thing as classification. Some inference could be achieved in the graphics and distributions, such as stability in lower masses, and the close center of mass from the systems. An interesting expansion to research is to produce the same analysis on larger systems, such as a five body problem. In a more robust computer, more simulations can be done, and clearer correlations and curves should be likely to conceive. # [Optional] How to Generate the Data For generating all the data used in this project, these cells can be executed, note that this section is an appendix, and not necessary since 5000 sample data are already included in this post notebook. batchPath = NotebookDirectory[] {generatedData, heuristicData, nbdpathsData, bodyData, bodiesData} = Table[{}, {5}]; NBodyHeuristics[positionsList_,maxSpace_:8] := Block[{ emptyList = {}, bodyA = positionsList[[1]], bodyB = positionsList[[2]], bodyC = positionsList[[3]] }, If[maxSpace >= bodyA[[1]] >= -maxSpace \[And] maxSpace >= bodyA[[2]] >= -maxSpace, emptyList = Join[emptyList, {True}], emptyList = Join[emptyList, {False}] ]; If[maxSpace >= bodyB[[1]] >= -maxSpace \[And] maxSpace >= bodyB[[2]] >= -maxSpace, emptyList = Join[emptyList, {True}], emptyList = Join[emptyList, {False}] ]; If[maxSpace >= bodyC[[1]] >= -maxSpace \[And] maxSpace >= bodyC[[2]] >= -maxSpace, emptyList = Join[emptyList, {True}], emptyList = Join[emptyList, {False}] ]; Return[emptyList]; ] GenerateNBodySimulations[nsimulations_,time_] := Do[AbortProtect[ PrintTemporary[Style["\[DoubleRightArrow]", 15, Orange], " ", "Generated ", Dynamic[Length[heuristicData]], " ", Style["NBodySimulations", Orange], " ", ProgressIndicator[Appearance -> "Percolate", ImageSize -> {60, 20}] ]; bodyData = {CreateRandomPivot[], CreateRandomBody[], CreateRandomBody[]}; generatedData = NBodySimulation["InverseSquare", bodyData, time] // Quiet; heuristicData = Append[heuristicData, NBodyHeuristics[generatedData[All, "Position", generatedData["SimulationTime"]]]];nbdpathsData = Append[nbdpathsData, generatedData[All, "Position", generatedData["SimulationTime"]]]];bodiesData = Append[bodiesData, bodyData]; ClearAll[generatedData, bodyData], nsimulations ]; GenerateNBodySimulations[100, 10] Export[batchPath <> "HeuristicData_" <> ToString[batchCounter] <> ".mx", heuristicData]; Export[batchPath <> "NBDPaths_" <> ToString[batchCounter] <> ".mx", nbdpathsData]; Export[batchPath <> "NBParameters_" <> ToString[batchCounter] <> ".mx", bodiesData]; {generatedData,heuristicData,nbdpathsData,bodyData,bodiesData}=Table[{},{5}]; batchCounter++; Pedro Cabral 2019-07-11T16:26:10Z