https://community.wolfram.com RSS Feed for Wolfram Community showing ideas tagged with Physics sorted by most viewed. https://community.wolfram.com/groups/-/m/t/1034626 I recently watched "Arrival", and thought that some of the dialogue sounded Wolfram-esque. Later, I saw the following blog post: [Quick, How Might the Alien Spacecraft Work?][1] Along with many others, I enjoyed the movie. The underlying artistic concept for the alien language reminded me of decade old memories, a book by Stephen Addiss, [Art of Zen][2]. Asian-influenced symbolism is an interesting place to start building a sci-fi concept, even for western audiences. I also found Cristopher Wolfram's broadcast and the associated files: [Youtube Broadcast][3] [Github Files ( with image files ) ][4] Thanks for sharing! More science fiction, yes! I think the constraint of circular logograms could be loosened. This leads to interesting connections with theory of functions, which I think the Aliens would probably know about. The following code takes an alien logogram as input and outputs a deformation according to do-it-yourself formulation of the Pendulum Elliptic Functions: ![Human Animation][5] ## $m=2$ Inversion Coefficients ## MultiFactorial[n_, nDim_] := Times[n, If[n - nDim > 1, MultiFactorial[n - nDim, nDim], 1]] GeneralT[n_, m_] := Table[(-m)^(-j) MultiFactorial[i + m (j - 1) + 1, m]/ MultiFactorial[i + 1, m], {i, 1, n}, {j, 1, i}] a[n_] := With[{gt = GeneralT[2 n, 2]}, gt[[2 #, Range[#]]] & /@ Range[n] ] ## Pendulum Values : $2(1-\cos(x))$ Expansion Coefficients ## c[n_ /; OddQ[n]] := c[n] = 0; c[n_ /; EvenQ[n]] := c[n] = 2 (n!) (-2)^(n/2)/(n + 2)!; ## Partial Bell Polynomials ## Note: These polynomials are essentially the same as the "**BellY**" ( hilarious naming convention), but recursion optimized. See timing tests below. B2[0, 0] = 1; B2[n_ /; n > 0, 0] := 0; B2[0, k_ /; k > 0] := 0; B2[n_ /; n > 0, k_ /; k > 0] := B2[n, k] = Total[ Binomial[n - 1, # - 1] c[#] B2[n - #, k - 1] & /@ Range[1, n - k + 1] ]; ## Function Construction ## BasisT[n_] := Table[B2[i, j]/(i!) Q^(i + 2 j), {i, 2, 2 n, 2}, {j, 1, i/2}] PhaseSpaceExpansion[n_] := Times[Sqrt[2 \[Alpha]], 1 + Dot[MapThread[Dot, {BasisT[n], a[n]}], (2 \[Alpha])^Range[n]]]; AbsoluteTiming[CES50 = PhaseSpaceExpansion[50];] (* faster than 2(s) *) Fast50 = Compile[{{\[Alpha], _Real}, {Q, _Real}}, Evaluate@CES50]; ## Image Processing ## note: This method is a hack from ".jpg" to sort-of vector drawing. I haven't tested V11.1 vectorization functionality, but it seems like this could be a means to process all jpg's and output a file of vector polygons. Anyone ? LogogramData = Import["Human1.jpg"]; Logogram01 = ImageData[ColorNegate@Binarize[LogogramData, .9]]; ArrayPlot@Logogram01; Positions1 = Position[Logogram01[[5 Range[3300/5], 5 Range[3300/5]]], 1]; Graphics[{Disk[#, 1.5] & /@ Positions1, Red, Disk[{3300/5/2, 3300/5/2}, 10]}]; onePosCentered = N[With[{cent = {3300/5/2, 3300/5/2} }, # - cent & /@ Positions1]]; radii = Norm /@ onePosCentered; maxR = Max@radii; normRadii = radii/maxR; angles = ArcTan[#[[2]], #[[1]]] & /@ onePosCentered; Qs = Cos /@ angles; ## Constructing and Printing Image Frames ## AlienWavefunction[R_, pixel_, normRad_, Qs_, angles_] := Module[{ deformedRadii = MapThread[Fast50, {R normRad, Qs}], deformedVectors = Map[N[{Cos[#], Sin[#]}] &, angles], deformedCoords }, deformedCoords = MapThread[Times, {deformedRadii, deformedVectors}]; Show[ PolarPlot[ Evaluate[ CES50 /. {Q -> Cos[\[Phi]], \[Alpha] -> #/10} & /@ Range[9]], {\[Phi], 0, 2 Pi}, Axes -> False, PlotStyle -> Gray], Graphics[Disk[#, pixel] & /@ deformedCoords], ImageSize -> 500]] AbsoluteTiming[ OneFrame = AlienWavefunction[1, (1 + 1)* 1.5/maxR, normRadii, Qs, angles] ](* about 2.5 (s)*) ![Alien Pendulum][6] ## Validation and Timing ## In this code, we're using the magic algorithm to get up to about $100$ orders of magnitude in the half energy, $50$ in the energy. I did prove $m=1$ is equivalent to other published forms, but haven't found anything in the literature about $m=2$, and think that the proving will take more time, effort, and insight (?). For applications, we just race ahead without worrying too much, but do check with standard, known expansions: EK50 = Normal@ Series[D[ Expand[CES50^2/2] /. Q^n_ :> (1/2)^n Binomial[n, n/2], \[Alpha]], {\[Alpha], 0, 50}]; SameQ[Normal@ Series[(2/Pi) EllipticK[\[Alpha]], {\[Alpha], 0, 50}], EK50] Plot[{(2/Pi) EllipticK[\[Alpha]], EK50}, {\[Alpha], .9, 1}, ImageSize -> 500] Out[]:= True ![Approximation Validity][7] This plot gives an idea of approximation validity via the time integral over $2\pi$ radians in phase space. Essentially, even the time converges up to, say, $\alpha = 0.92$. Most of the divergence is tied up in the critical point, which is difficult to notice in the phase space drawings above. Also compare the time of function evaluation: tDIY = Mean[ AbsoluteTiming[Fast50[.9, RandomReal[{0, 1}]] ][[1]] & /@ Range[10000]]; tMma = Mean[AbsoluteTiming[JacobiSN[.9, RandomReal[{0, 1}]] ][[1]] & /@ Range[10000]]; tMma/tDIY In the region of sufficient convergence, Mathematica function **JacobiSN** is almost 20 times slower. The CES radius also requires a function call to **JacobiCN**, so an output-equivalent **AlienWavefunction** algorithm using built-in Mathematica functions would probably take at least 20 times as long to produce. When computing hundreds of images this is a noticeable slow down, something to avoid ! ! Also compare time to evaluate the functional basis via the Bell Polynomials: BasisT2[n_] := Table[BellY[i, j, c /@ Range[2 n]]/(i!) Q^(i + 2 j), {i, 2, 2 n, 2}, {j, 1, i/2}]; SameQ[BasisT2[20], BasisT[20]] t1 = AbsoluteTiming[BasisT[#];][[1]] & /@ Range[100]; t2 = AbsoluteTiming[BasisT2[#];][[1]] & /@ Range[25]; ListLinePlot[{t1, t2}, ImageSize -> 500] ![Series Inverse][8] The graph shows quite clearly that careful evaluation via the recursion relations changes the complexity of the inversion algorithm to polynomial time, $(n^2)$, in one special example where the forward series expansions coefficients have known, numeric values. ## Conclusion ## We show proof-of-concept that alien logograms admit deformations that preserve the cycle topology. Furthermore we provide an example calculation where the "human" logogram couples to a surface. Deformation corresponds to scale transformation of the logogram along the surface. Each deformation associates with an energy. Invoking the pendulum analogy gives the energy a physical meaning in terms of gravity, but we are not limited to classical examples alone. The idea extends to arbitrary surfaces in two, three or four dimensions, as long as the surfaces have local extrema. Around the extrema, there will exist cycle contours, which we can inscript with the Alien logograms. This procedure leads readily to large form compositions, especially if the surface has many extrema. Beyond Fourier methods, we might also apply spherical harmonics, and hyperspherical harmonics to get around the limitation of planarity. The missing proof... Maybe later. LOL! ~ ~ ~ ~ Brad And in the Fanfiction Voice: Physicist : "It should be no surprise that heptapod speech mechanism involves an arbitrary deformation of the spacetime manifold." Linguist : "Space-traveling aliens, yes, of course they know math and physics, but Buddhist symbology, where'd they learn that?" [1]: http://blog.stephenwolfram.com/2016/11/quick-how-might-the-alien-spacecraft-work/ [2]: https://books.google.com/books/about/Art_of_Zen.html?id=4jGEQgAACAAJ [3]: https://www.youtube.com/watch?v=8N6HT8hzUCA&t=4992s [4]: https://github.com/WolframResearch/Arrival-Movie-Live-Coding [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Deformation.gif&userId=234448 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=AlienPendulum.png&userId=234448 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=EllipticK.png&userId=234448 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=BellPolynomial.png&userId=234448 Brad Klee 2017-03-18T20:23:59Z https://community.wolfram.com/groups/-/m/t/418720 ## This is it. The perfectly centered billiards break. Behold: ![enter image description here][2] <h2>Setup</h2> This break was computed in *Mathematica* using a numerical differential equations model. Here are a few details of the model: * All balls are assumed to be perfectly [elastic][3] and almost perfectly rigid. * Each ball has a mass of 1 unit and a radius of 1 unit. * The cue ball has a initial speed of 10 units/sec. * The force between two balls is given by the formula $$F \;=\; \begin{cases}0 & \text{if }d \geq 2, \\ 10^{11}(2-d)^{3/2} & \text{if }d < 2, \end{cases}$$ where $d$ is the distance between the centers of the balls. Note that the balls overlap if and only if $d < 2$. The power of $3/2$ was [suggested by Yoav Kallus][4] on Math Overflow, because it follows [Hertz's theory of non-adhesive elastic contact](https://en.wikipedia.org/wiki/Contact_mechanics#Hertzian_theory_of_non-adhesive_elastic_contact). The initial speed of the cue ball is immaterial -- slowing down the cue ball is the same as slowing down time. The force constant $10^{11}$ has no real effect as long as it's large enough, although it does change the speed at which the initial collision takes place. <h2>The Collision</h2> For this model, the entire collision takes place in the first 0.2 milliseconds, and none of the balls overlap by more than 0.025% of their radius during the collision. (These figures are model dependent -- real billiard balls may collide faster or slower than this.) The following animation shows the forces between the balls during the collision, with the force proportional to the area of each yellow circle. Note that the balls themselves hardly move at all *during* the collision, although they do accelerate quite a bit. ![enter image description here][5] <h2>The Trajectories</h2> The following picture shows the trajectories of the billiard balls after the collision. ![enter image description here][6] After the collision, some of the balls are travelling considerably faster than others. The following table shows the magnitude and direction of the velocity of each ball, where $0^\circ$ indicates straight up. $\begin{array}{|c|c|c|c|c|c|c|c|c|c|c|} \hline \text{ball} & \text{cue} & 1 & 2,3 & 4,6 & 5 & 7,10 & 8,9 & 11,15 & 12,14 & 13 \\ \hline \text{angle} & 0^\circ & 0^\circ & 40.1^\circ & 43.9^\circ & 0^\circ & 82.1^\circ & 161.8^\circ & 150^\circ & 178.2^\circ & 180^\circ \\ \hline \text{speed} & 1.79 & 1.20 & 1.57 & 1.42 & 0.12 & 1.31 & 0.25 & 5.60 & 2.57 & 2.63 \\ \hline \end{array} $ For comparison, remember that the initial speed of the cue ball was 10 units/sec. Thus, balls 11 and 15 (the back corner balls) shoot out at more than half the speed of the original cue ball, whereas ball 5 slowly rolls upwards at less than 2% of the speed of the original cue ball. By the way, if you add up the sum of the squares of the speeds of the balls, you get 100, since kinetic energy is conserved. <h2>Linear and Quadratic Responses</h2> The results of this model are dependent on the power of $3/2$ in the force law -- other force laws give other breaks. For example, we could try making the force a linear function of the overlap distance (in analogy with springs and [Hooke's law][7]), or we could try making the force proportional to the *square* of the overlap distance. The results are noticeably different ![enter image description here][8] ![enter image description here][9] <h2>Stiff Response</h2> Glenn the Udderboat points out that "stiff" balls might be best approximated by a force response involving a higher power of the distance (although this isn't the [usual definition][10] of "stiffness"). Unfortunately, the calculation time in *Mathematica* becomes longer when the power is increased, presumably because it needs to use a smaller time step to be sufficiently accurate. Here is a simulation involving a reasonably "stiff" force law $$F \;=\; \begin{cases}0 & \text{if }d \geq 2, \\ 10^{54}(2-d)^{10} & \text{if }d<2. \end{cases}$$ ![enter image description here][11] As you can see, the result is very similar to my first thought: > The two balls in the back corners shoot away along rays parallel to the two sides of the triangle. Here is a picture showing the forces, with each force vector emanating from the point of contact. > ![enter image description here][12] This seems like good evidence that above 1st-thought behavior is indeed the limiting behavior in the case where the stiffness goes to infinity. As you might expect, most of the energy in this case is transferred very quickly at the beginning of the collision. Almost all of the energy has moves to the back corner balls in the first 0.02 milliseconds. Here is an animation of the forces: ![enter image description here][13] After that, the corner balls and the cue ball shoot out, and the remaining balls continue to collide gently for the next millisecond or so. While the simplicity of this behavior is appealing, I would guess that "real" billard balls do not have such a stiff force response. Of the models listed here, the intial Hertz-based model is probably the most accurate. Qualitatively, it certainly seems the closest to an "actual" break. <h2> Full Code </h2> &[Wolfram Notebook][14] ---------- I wrote this post originally for [Math Stack Exchange][15]. [1]: http://math.bard.edu/belk/code.htm [2]: http://i.stack.imgur.com/Y9ixR.gif [3]: https://en.wikipedia.org/wiki/Elasticity_%28physics%29 [4]: http://mathoverflow.net/questions/156263/perfectly-centered-break-of-a-perfectly-aligned-pool-ball-rack/156407?noredirect=1#comment400402_156407 [5]: http://i.stack.imgur.com/WY37i.gif [6]: http://i.stack.imgur.com/wHVJA.png [7]: https://en.wikipedia.org/wiki/Hooke%27s_law [8]: http://i.stack.imgur.com/a1l3b.gif [9]: http://i.stack.imgur.com/xM76n.gif [10]: https://en.wikipedia.org/wiki/Stiffness [11]: http://i.stack.imgur.com/nMJyT.gif [12]: http://i.stack.imgur.com/GKGT9.png [13]: http://i.stack.imgur.com/VuUWT.gif [14]: https://www.wolframcloud.com/obj/8c6b7e81-4a5c-4e3a-bb13-a3d47e728e64 [15]: http://math.stackexchange.com/a/659318/28293 Jim Belk 2015-01-08T18:02:10Z https://community.wolfram.com/groups/-/m/t/2411604 A new study group devoted to Differential Equations begins next Monday! A list of daily topics can be found on our [Daily Study Groups][1] page. This group will be led by one of our outstanding Wolfram certified instructors, Luke Titus, and will meet daily, Monday to Friday, over the next three weeks. Luke will share the excellent lesson videos created by him for the upcoming Wolfram U course "[Introduction to Differential Equations][2]". Study group sessions include time for exercises, discussion and Q&A. This study group will help you achieve the "Course Completion" certificate for the "Introduction to Differential Equations" course after you complete the course quizzes. Sign up: [Study group registration page][3] [1]: https://www.wolfram.com/wolfram-u/special-event/study-groups/ [2]: https://www.wolfram.com/wolfram-u/introduction-to-differential-equations/ [3]: https://www.bigmarker.com/series/daily-study-group-intro-to-differential-equations/series_details?utm_bmcr_source=community Devendra Kapadia 2021-11-22T16:35:30Z https://community.wolfram.com/groups/-/m/t/235291 [img]/c/portal/getImageAttachment?filename=fig0.gif&userId=93201[/img] Some time ago one of my friends asked me whether it is possible to design a cellular automaton which can generate realistic snowflakes. I recall my crystallography and thermodynamics knowledge and came up a very simple yet impressive model. [size=5][b]The Regular Triangular Lattice[/b][/size] First of all, we are trying to simulate snowflake, which is a kind of hexagonal crystal. So it should be best to construct our CA on a regular hexagonal grid, i.e. regular triangular lattice. We all know [b]CellularAutomaton[/b] inherently works on rectangle lattices ("4-lattice" for short), so how can we deduce a triangular lattice ("3-lattice" for short) on it? Well, the differences between rect-lattice and triangular one is just a geometric transformation. To demonstrate that, have a look at the following 4-lattice, with a blue square highlighting the range-1 [url=http://mathworld.wolfram.com/MooreNeighborhood.html]Moore neighborhood[/url]: [img=width: 388px; height: 396px;]/c/portal/getImageAttachment?filename=fig1.gif&userId=93201[/img] Clearly there is always a hexagon (the green area) in this kind of neighborhood. So forming a regular 3-lattice is as straightforward as doing a simple affine transformation (basically a shearing and a scaling): [img=width: 484px; height: 304px;]/c/portal/getImageAttachment?filename=fig2.gif&userId=93201[/img] So to take advantage of all the power of [b]CellularAutomaton[/b], all we have to do, is to use a following special 6-neighborhood stencil on rectangle lattices, meanwhile our model can be discussed and constructed on regular triangular lattice convieniently: [img=width: 118px; height: 57px;]/c/portal/getImageAttachment?filename=fig3.png&userId=93201[/img] And after the calculation, we can perform the affine transformation with following functions to get a nice hexagonal grid picture. [mcode]Clear[vertexFunc] vertexFunc = Compile[{{para, _Real, 1}}, Module[{center, ratio}, center = para[[1 ;; 2]]; ratio = para[[3]]; {Re[#], Im[#]} + {{1, -(1/2)}, {0, Sqrt[3]/2}}.Reverse[{-1, 1} center + {3, 0}] & /@ (ratio 1/ Sqrt[3] E^(I ?/6) E^(I Range[6] ?/3))], RuntimeAttributes -> {Listable}, Parallelization -> True, RuntimeOptions -> "Speed" (*,CompilationTarget?"C"*)]; Clear[displayfunc] displayfunc[array_, ratio_] := Graphics[{FaceForm[{ColorData["DeepSeaColors"][3]}], EdgeForm[{ColorData["DeepSeaColors"][4]}], Polygon[vertexFunc[Append[#, ratio]] & /@ Position[array, 1]]}, Background -> ColorData["DeepSeaColors"][0]][/mcode] [size=5][b]The Model[/b][/size] To construct the crystallization model, let's consider one of the 6-neighborhood stencil, where each cell represents a minimal crystal unit: [img=width: 261px; height: 236px;]/c/portal/getImageAttachment?filename=fig4.png&userId=93201[/img] A simple model will need only 2 states: [b]0[/b] for "[i]It's empty[/i]", [b]1[/b] for "[i]There is a crystal unit[/i]". So by considering all (except the [b]000000[/b] one, because we are generating ONE snowflake thus don't want a crystall randomly arises from void) [b]6-bit[/b] non-negative numbers, we can have a finite set of possible arrangements of the neighborhood: [mcode]stateSet = Tuples[{0, 1}, 6] // Rest[/mcode] However, from the viewpoint of physics, any two arrangements which can be transformed into each other with only rotation and reflection should be considered as the same arrangement in the sense of their physical effects on the central cell (i.e. cell[size=1]2,2[/size]) are the same: [img=width: 363px; height: 117px;]/c/portal/getImageAttachment?filename=fig5.png&userId=93201[/img] So we should gather [b]stateSet[/b] with above equivalence class: [mcode]gatherTestFunc = Function[lst, Union[Join[ RotateLeft[lst, # - 1] & /@ Flatten[Position[lst, 1]], RotateLeft[Reverse[lst], # - 1] & /@ Flatten[Position[Reverse[lst], 1]] ]]]; stateClsSet = Sort /@ Gather[stateSet, gatherTestFunc[#1] == gatherTestFunc[#2] &]; stateClsSetHomogeneous = ArrayPad[#, {{0, 12 - Length@#}, {0, 0}}] & /@ stateClsSet;[/mcode] Which turned out to be [b]12[/b] classes in total: [img=width: 710px; height: 127px;]/c/portal/getImageAttachment?filename=fig6.png&userId=93201[/img] Now from the viewpoint of cellular automaton, we need to establish a set of rules on how should any 6-neighborhood arrangement, i.e. those 12 kinds of equivalence classes, determine the state of the central cell. There are 4 kinds of possible transformations on cell[size=1]2,2[/size]: [b]0 --> 1[/b] is called [b]frozen[/b], [b]0 --> 0[/b] is [b]remaining empty[/b], [b]1 --> 1[/b] is [b]remaining frozen[/b], and [b]1 --> 0[/b] is called [b]melten[/b]. To make things more interesting and to explore more possibilities, we can introduce probability here, so certain arrangement will give certain probabilities corresponding to the 4 kinds of transformations. But notice that because of the unitarity of probability, we have Prob(frozen) + Prob(0->0) = 1 and Prob(melten) + Prob(1->1) = 1, so only 2 of the 4 probabilities are independent. In the following, we'll choose Prob(frozen) and Prob(melten), and denote them as [b]pFrozen[/b] and [b]pMelten[/b]. [img=width: 800px; height: 367px;]/c/portal/getImageAttachment?filename=fig7.png&userId=93201[/img] Back to physics / thermodynamics, those 24 probabilities, [b]pFrozen[/b] and [b]pMelten[/b], can of corse be determined by serious physical models, or they can be chosen randomly just for fun. For example, an intuitive (and naive) idea would be to believe an empty cell nearby a sharp pointed end or with abundant moisture source will have a high [b]pFrozen[/b]. (People who are interested in the serious physical models should not miss [url=http://psoup.math.wisc.edu/Snowfakes.htm]the Gravner-Griffeath Snowfakes model[/url].) Now we have the grid, the stencil, the neighborhood arrangement set and the transfer probabilities, we're offically ready to construct our cellular automaton rules. Following the above discussion, the construction is straightforward. There are only two points which need to pay attention to. One is to keep in mind that the rule function is applied on the 3x3 stencil, so even cell[size=1]1,1[/size] and cell[size=1]3,3[/size] has nothing to do with our model, don't forget handling them. The second is to use a [b]SeedRandom[/b] function to make sure same arrangement gives same result in same time step, otherwise the 6-fold rotational symmetry and 3 axes of reflection symmetry will both break! [mcode]Clear[ruleFunc] ruleFunc = With[{ stateClsSetHomogeneous = stateClsSetHomogeneous, seedStore = RandomInteger[{0, 1000}, 1000], pFreeze = {1, 0, 0.6, 0, 0.3, 0.15, 0, 0.2, 0, 0.2, 0, 0.8}, pMelt = {0, 0.7, 0.5, 0.7, 0.7, 0.5, 0.3, 0.5, 0.3, 0.2, 0.1, 0 } }, Compile[{{neighborarry, _Integer, 2}, {step, _Integer}}, Module[{cv, neighborlst, cls, rand}, cv = neighborarry[[2, 2]]; neighborlst = {#[[1, 2]], #[[1, 3]], #[[2, 3]], #[[3, 2]], #[[3, 1]], #[[2, 1]]} &[neighborarry]; If[Total[neighborlst] == 0, cv, cls = Position[stateClsSetHomogeneous, neighborlst][[1, 1]]; SeedRandom[seedStore[[step + 1]]]; rand = RandomReal[]; Boole@If[cv == 0, rand < pFreeze[[cls]], rand > pMelt[[cls]]] ]], (*CompilationTarget -> "C",*) RuntimeAttributes -> {Listable}, Parallelization -> True, RuntimeOptions -> "Speed" ] ];[/mcode] (Note: re-compile the rule function [b]ruleFunc[/b] will give a different set of [b]seedStore[/b] thus a different growth path.) Now everything is ready, let's grow a snowflake from the beginning! :D [mcode]dataSet = Module[{ rule, initM = {{ {0, 0, 0}, {0, 1, 0}, {0, 0, 0} }, 0}, rspec = {1, 1}, tmin = 0, tmax = 100, dt = 1}, rule = {ruleFunc, {}, rspec}; CellularAutomaton[rule, initM, {{tmin, tmax, dt}}] ]; // AbsoluteTiming Animate[ Rotate[displayfunc[dataSet[[k]], .8], 90 °], {k, 1, Length[dataSet], 1}, AnimationDirection -> ForwardBackward, AnimationRunning -> False, DisplayAllSteps -> True ][/mcode] [img]/c/portal/getImageAttachment?filename=fig0.gif&userId=93201[/img] [size=5][b]Possible Improvements[/b][/size] We used a [b]SeedRandom[/b] function in our CA rule function to force the 6-fold rotational symmetry and 3 axes of reflection symmetry, and performed the CA calculation on all cells. However, this so called [url=http://demonstrations.wolfram.com/DihedralGroupNOfOrder2n/][i]D[/i][size=1]6[/size] symmetry[/url] can (and should) be integrated into our model, which will saving [b]11/12[/b] of the calculation. Also, the randomness of the growth path comes from [b]seedStore[/b], so to generate a new growth path, we have to re-compile the rule function. But with a improved model as described above, this constraint will no longer exist. [img=width: 800px; height: 177px;]/c/portal/getImageAttachment?filename=fig8.png&userId=93201[/img] [b][size=4] [size=5]Open question [/size] [/size][/b] Can we construct a well-organized structure (like the crystals) from a cellular automaton defined on an [b]irregular[/b] grid? While I believe the answer is [i]yes[/i], the next question would be [i]how?[/i] Silvia Hao 2014-04-11T16:03:33Z https://community.wolfram.com/groups/-/m/t/787142 ## General information and download links ## If you're interested in crystal structures, you can now download the Crystallica application from the Wolfram Library Archive, and then you can do things like this: Needs["Crystallica`"]; CrystalPlot[ {{5.4,0,0},{0,5.4,0},{0,0,5.4}}, {{0,0,0},{0,0,.5},{0,.5,0},{.5,0,0},{.24,.24,.24},{.24,.76,.76},{.76,.24,.76},{.76,.76,.24}}, {1,2,2,2,3,3,3,3}, AtomCol->{"Firebrick","YellowGreen",White},AtomRad->.4, BondStyle->2,BondDist->3, CellLineStyle->False,AddQ->True,Lighting->{{"Directional",White,ImageScaled[{0,0,1}]}},Background->Black] ![enter image description here][1] Here are the download links for Crystallica and two other packages you may need: [Crystallica][2] - contains the functions `CrystalPlot` and `CrystalChange` [CifImport][3] - contains an import function for CIF files [VaspImport][4] - contains an import function for files related to [VASP][5] Once you've installed Crystallica (by saving the entire Crystallica folder - not the zip archive - to `$USerBaseDirectory/Applications` and re-starting the Kernel), you can enter Crystallica into the Documentation Center and you'll find lots of useful examples. Most of the examples in this post are taken from the Documentation. For the other two packages, just install them and evaluate this: ?CifImport ?VaspImport I'll first show you a few things the `CrystalPlot` function can do when you already have crystal structure data inside Mathematica, wherever it may have come from. Then we'll take a look at how to get the data into Mathematica in the first place, which is where `CifImport` and `VaspImport` will come into play - but we'll get data from other sources as well. I'll cover the different import solutions in separate replies to this thread, because I have a feeling that I'll be rambling on and on and on... ## Simple plot ## Traditional ball-and-stick plots are usually just fine, so the simplest thing you can do is this: CrystalPlot[ {{4.5,0,0},{0,4.5,0},{0,0,3}}, {{0,0,0},{.5,.5,.5},{.2,.8,.5},{.3,.3,0},{.7,.7,0},{.8,.2,.5}}, {1,1,2,2,2,2}] ![enter image description here][6] As you can see, `CrystalPlot` expects three arguments. The first one contains the lattice vectors, which are simply the three vectors that create the parallelepiped that constitutes the cell. The second argument contains the atomic coordinates, but they're given in the basis of the lattice vectors (which is quite useful in crystallography). The third argument is a list of integers that gives the atom types, with one entry for each atom. If you want to plot a molecule instead, you can call `CrystalPlot` with just two arguments: A list of atom coordinates in cartesian space, and a list of atom types. Everything else you see in the plot - the atoms, bonds, colours, arrows etc. - represents the default settings of various layout options. ## Advanced atoms and bonds ## Let's take a look at some more advanced options just for fun. For instance, atoms and bonds can look any way you need them to, because you can specify your own functions for them. You can also fine-tune where to put bonds and what to do with their thickness and colour in a physically (or chemically) meaningful way, but I won't show that here. So here are some customized atoms and bonds: Row[Table[ CrystalPlot[{{4,0,0},{0,4,0},{0,0,4}},{{0,0,0},{.4,.4,.4},{.8,.8,.8}},{1,2,3}, AtomRad->{.4,1.2,.7},AtomFunction->style,ImageSize->400], {style,{ (Ball[#1,#2]&), (Scale[Sphere[#1,#2],{1,1,.5}]&), ({EdgeForm[Thick],Opacity[.7],Cuboid[#1-.5*#2,#1+.5*#2]}&) }}]] ![enter image description here][7] Row[Table[ CrystalPlot[{{0,0,0},{5,0,0},{2.5,4,0}},{1,2,3},BondDist->6,BondStyle->style,ImageSize->400], {style,{ 1, Function[{bonds,partcol},Table[{If[ii<.5,partcol[#,1],partcol[#,2]],Sphere[bonds[[#,1]]+ii*(bonds[[#,2]]-bonds[[#,1]]),.15]},{ii,0,1,1/9}]&/@Range[Length[bonds]]], Function[{bonds,partcol},Module[{spiral,points,rad=.05}, spiral[atoms_]:=Module[{scale=.5,dist=atoms[[2]]-atoms[[1]],curls=60,normal,rot,scaled}, normal=Table[{scale*Cos[ii],scale*Sin[ii],.1*ii},{ii,0,curls,\[Pi]/10}]; scaled={#[[1]],#[[2]],10*Norm[dist]/curls*#[[3]]}&/@normal; rot=scaled.Quiet[RotationMatrix[{dist,{0,0,1}}]]; Join[{atoms[[1]]},#+atoms[[1]]&/@(rot[[25;;-25]]),{atoms[[2]]}]]; points=spiral/@bonds; {partcol[#,1],Tube[BSplineCurve[points[[#,;;Round[Length[points[[#]]]/2]]],rad]],partcol[#,2],Tube[BSplineCurve[points[[#,Round[Length[points[[#]]]/2];;]],rad]]}&/@Range[Length[bonds]] ]] }}]] ![enter image description here][8] ## Lattice planes ## Crystallica can also add lattice planes to the plot. You can specify them using [h,k,l] Miller indices and distance to the origin. CrystalPlot[{{3,0,0},{0,3,0},{0,0,3}},{{0,0,0}},{1}, AddQ->True,AtomRad->.3,AtomCol->"CadmiumYellow",Sysdim->2,CellLineStyle->2, LatticePlanes->Table[{{1,1,1},dist},{dist,1,5}],ContourStyle->{"TerreVerte",Opacity[.7]},BoundaryStyle->Thick] ![enter image description here][9] ## Coordination polyhedra ## You can automatically search for and plot coordination polyhedra. This is not limited to the commonly occurring tetrahedra and octahedra - you can actually look for polyhedra with arbitrary numbers of corners. There are also options to fine-tune both the searching and the rendering. plot[corners_,mixed_]:=CrystalPlot[{{0,0,0},{0,0,1.8},{-.9,-1.5,-.6},{-.9,1.5,-.6},{1.7,0,-.6},{.8,.8,.8}},{1,2,2,2,2,3}, BondStyle->False,ImageSize->250, PolyMode[corners]->{"Show"->All,"AllowMixed"->mixed},PolyStyle[corners]->Directive[Opacity[.5],EdgeForm[Thick]]]; Grid[{{ "", "Search for polyhedra with \n4 corners", "Search for polyhedra with \n5 corners" },{ "Allow \nmixed corners", plot[4,True], plot[5,True] },{ "Don't allow \nmixed corners", plot[4,False], plot[5,False] }},Dividers->All] ![enter image description here][10] CrystalPlot[{{2.5,-4.3,0},{2.5,4.3,0},{0,0,5.5}}, {{.5,0,0},{0,.5,.7},{.5,.5,.3},{.2,.4,.5},{.6,.8,.2},{.2,.8,.8},{.8,.6,.5},{.4,.2,.2},{.8,.2,.8}},{1,1,1,2,2,2,2,2,2}, PolyMode[4]->True,PolyStyle[4]->EdgeForm[None],AddQ->True, Sysdim->2,AtomRad->0,CellLineStyle->False,AtomCol->{"SlateGray","Firebrick"}, ViewAngle->.4,ViewPoint->{3.2,0,1.1},ViewVertical->{.5,0,1.2}] ![enter image description here][11] ## Other things ## Visualization aside, you can also build supercells, change cell shapes, or add, remove and sort atoms... but that's a bit boring to read, so I'll refer you to the Documentation page of the `CrystalChange` function instead. If you're interested, we can use this thread to talk about any questions you may have, or you can share your use of the package (if you decide to use it). I'm not offering full support here, but I'll be floating around, and I'd like to hear your feedback. We don't have any intentions to be involved in further development. But if you have a good idea and some time, then by all means, work on it for yourself, or host it on your favourite code collaboration site. Bianca Eifert and Christian Heiliger [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=teaser.png&userId=69107 [2]: http://library.wolfram.com/infocenter/MathSource/9372/ [3]: http://library.wolfram.com/infocenter/MathSource/9373/ [4]: http://library.wolfram.com/infocenter/MathSource/9375/ [5]: http://vasp.at/ [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=9692simple.png&userId=69107 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=atoms.png&userId=69107 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=bonds.png&userId=69107 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=planes.png&userId=69107 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=polys.png&userId=69107 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=polys2.png&userId=69107 [12]: http://rruff.geo.arizona.edu/AMS/CIF_text_files/13532_cif.txt [13]: http://cms.mpi.univie.ac.at/vasp/vasp/POSCAR_file.html [14]: http://wiki.jmol.org/index.php/File:Caffeine.mol Bianca Eifert 2016-02-05T18:43:18Z https://community.wolfram.com/groups/-/m/t/294122 ![enter image description here][5] When playing with Mathematica 10 I constructed this very simple example of an application of the NDSolve command, which I wanted to share. The objective is to model the growth of a special kind of brain tumour which affects mainly glial cells in a highly simplified way. I follow modelling ideas discussed in the excellent book ["Mathematical Biology" (Vol 2) by J.D. Murray][1]. It turns out that Gliomas, which are neoplasms of glial cells, i.e. neural calls capable of division, can be be modelled by a rather simple diffusion-growth model. $$\frac{d c}{dt}=\nabla\left(D(x) \nabla c \right)+ \rho c$$ where c is the concentration of cancer cells and $D(x)$ is the diffusion coefficient, which depends on the coordinates; $\rho$ models the growth rate of the cells. The following boundary condition has to be observe (even though will be ignored in the model I use later on): $${\bf n} \cdot D(x) \nabla c = 0 \qquad \text{for}\; x\; \text{on}\; \partial B.$$ In reality the diffusion coefficient will depend on the tissue type, i.e. gray matter vs white matter. I will use an image from a CT can to describe the different densities of the tissue instead. ![enter image description here][2] In the book by Murray great care is taken to estimate the diffusion coefficient but I just want to show the principle here. I use the attached file "brain-crop.jpg" and import it: img2=Import["~/Desktop/brain-crop.jpg"] Then I sharpen it and convert it to gray-scale. img3 = Sharpen[ColorConvert[img2, "Grayscale"]] Then I use that image to determine the diffusion coefficient, locally: diffcoeff = ListInterpolation[ImageData[img3], InterpolationOrder -> 3] I should now determine the boundaries using something like EdgeDetect. As the background is black and allows no diffusion at all, we can simplify this by just setting a larger (rectangular) boundary box like so: boundaries = {-y, y - 1, -x, x - 1}; \[CapitalOmega] = ImplicitRegion[And @@ (# <= 0 & /@ boundaries), {x, y}]; Next we can solve the ODE on the domain: sols = NDSolveValue[{{Div[1./500.*(diffcoeff[798.*x, 654*y])^4*Grad[u[t, x, y], {x, y}], {x, y}] - D[u[t, x, y], t] + 0.025*u[t, x, y] == NeumannValue[0., x >= 1. || x <= 0. || y <= 0. || y >= 1.]}, {u[0, x, y] == Exp[-1000. ((x - 0.6)^2 + (y - 0.6)^2)]}}, u, {x, y} \[Element] \[CapitalOmega], {t, 0, 20}, Method -> {"FiniteElement", "MeshOptions" -> {"BoundaryMeshGenerator" -> "Continuation", MaxCellMeasure -> 0.002}}] Note that we start with an initially Gaussian distributed tumour and describe its growth from there. Also I took the fourth power of the diffcoeff function, which changes the relation between grayscale and diffusion rate. You can change the coefficient to get different patterns for the growth. Interestingly, this integration gives a warning about intersecting boundaries in MMA10, which it did not say in the Prerelease version; if someone can fix that, that would be great. For any time we can now overlay the resulting distribution onto the CT image: ImageCompose[img3, {ContourPlot[ Max[sols[t, x, y], 0] /. t -> 2, {y, 0, 1}, {x, 0, 1}, PlotRange -> {{0, 1}, {0, 1}, {0.01, All}}, PlotPoints -> 100, Contours -> 200, ContourLines -> False, AspectRatio -> 798./654., ColorFunction -> "Temperature"], 0.6}] This should give something like this: ![enter image description here][3] Using frames = Table[ ImageCompose[ img3, {ContourPlot[ Max[sols[d, x, y], 0] /. d -> t, {y, 0, 1}, {x, 0, 1}, PlotRange -> {{0, 1}, {0, 1}, {0.01, All}}, PlotPoints -> 100, Contours -> 200, ContourLines -> False, AspectRatio -> 798./654., ColorFunction -> "Temperature"], 0.6}], {t, 0, 10, 0.5}]; we get a list of images, ![enter image description here][4] which can be animated ListAnimate[frames, DefaultDuration -> 20] to give ![enter image description here][5] This is only a very elementary demonstration, and certainly still far away from a "real" medical application, but it demonstrates the power of NDSolve and might, in a modified form, be useful as a case study for some introductory courses. Cheers, Marco [1]: http://www.springer.com/new+&+forthcoming+titles+%28default%29/book/978-0-387-95228-4 [2]: /c/portal/getImageAttachment?filename=brain-crop.jpg&userId=48754 [3]: /c/portal/getImageAttachment?filename=BrainTumor-still.jpg&userId=48754 [4]: /c/portal/getImageAttachment?filename=1473BrainTumor-frames.jpg&userId=48754 [5]: /c/portal/getImageAttachment?filename=BrainTumor.gif&userId=48754 Marco Thiel 2014-07-14T13:54:54Z https://community.wolfram.com/groups/-/m/t/1433064 ![fig7][331] I started the discussion [here][1] but I also want to repeat on this forum. There are many commercial and open code for solving the problems of unsteady flows. We are interested in the possibility of solving these problems using Mathematica FEM. Previously proposed solvers for stationary incompressible isothermal flows: Solving 2D Incompressible Flows using Finite Elements: http://community.wolfram.com/groups/-/m/t/610335 FEM Solver for Navier-Stokes equations in 2D: http://community.wolfram.com/groups/-/m/t/611304 Nonlinear FEM Solver for Navier-Stokes equations in 2D: https://mathematica.stackexchange.com/questions/94914/nonlinear-fem-solver-for-navier-stokes-equations-in-2d/96579#96579 We give several examples of the successful application of the finite element method for solving unsteady problem including nonisothermal and compressible flows. We will begin with two standard tests that were proposed to solve this class of problems by M. Schäfer and S. Turek, Benchmark computations of laminar ?ow around a cylinder (With support by F. Durst, E. Krause and R. Rannacher). In E. Hirschel, editor, Flow Simulation with High-Performance Computers II. DFG priority research program results 1993-1995, number 52 in Notes Numer. Fluid Mech., pp.547–566. Vieweg, Weisbaden, 1996. https://www.uio.no/studier/emner/matnat/math/MEK4300/v14/undervisningsmateriale/schaeferturek1996.pdf ![fig8][332] Let us consider the flow in a flat channel around a cylinder at Reynolds number = 100, when self-oscillations occur leading to the detachment of vortices in the aft part of cylinder. In this problem it is necessary to calculate drag coe?cient, lift coe?cient and pressure di?erence in the frontal and aft part of the cylinder as functions of time, maximum drag coe?cient, maximum lift coe?cient , Strouhal number and pressure di?erence $\Delta P(t)$ at $t = t0 +1/2f$. The frequency f is determined by the period of oscillations of lift coe?cient f=f(c_L). The data for this test, the code and the results are shown below. H = .41; L = 2.2; {x0, y0, r0} = {1/5, 1/5, 1/20}; ? = RegionDifference[Rectangle[{0, 0}, {L, H}], Disk[{x0, y0}, r0]]; RegionPlot[?, AspectRatio -> Automatic] K = 2000; Um = 1.5; ? = 10^-3; t0 = .004; U0[y_, t_] := 4*Um*y/H*(1 - y/H) UX[0][x_, y_] := 0; VY[0][x_, y_] := 0; P0[0][x_, y_] := 0; Do[ {UX[i], VY[i], P0[i]} = NDSolveValue[{{Inactive[ Div][({{-?, 0}, {0, -?}}.Inactive[Grad][ u[x, y], {x, y}]), {x, y}] + \!\(\*SuperscriptBox[\(p\), TagBox[ RowBox[{"(", RowBox[{"1", ",", "0"}], ")"}], Derivative], MultilineFunction->None]\)[x, y] + (u[x, y] - UX[i - 1][x, y])/t0 + UX[i - 1][x, y]*D[u[x, y], x] + VY[i - 1][x, y]*D[u[x, y], y], Inactive[ Div][({{-?, 0}, {0, -?}}.Inactive[Grad][ v[x, y], {x, y}]), {x, y}] + \!\(\*SuperscriptBox[\(p\), TagBox[ RowBox[{"(", RowBox[{"0", ",", "1"}], ")"}], Derivative], MultilineFunction->None]\)[x, y] + (v[x, y] - VY[i - 1][x, y])/t0 + UX[i - 1][x, y]*D[v[x, y], x] + VY[i - 1][x, y]*D[v[x, y], y], \!\(\*SuperscriptBox[\(u\), TagBox[ RowBox[{"(", RowBox[{"1", ",", "0"}], ")"}], Derivative], MultilineFunction->None]\)[x, y] + \!\(\*SuperscriptBox[\(v\), TagBox[ RowBox[{"(", RowBox[{"0", ",", "1"}], ")"}], Derivative], MultilineFunction->None]\)[x, y]} == {0, 0, 0} /. ? -> ?, { DirichletCondition[{u[x, y] == U0[y, i*t0], v[x, y] == 0}, x == 0.], DirichletCondition[{u[x, y] == 0., v[x, y] == 0.}, 0 <= x <= L && y == 0 || y == H], DirichletCondition[{u[x, y] == 0, v[x, y] == 0}, (x - x0)^2 + (y - y0)^2 == r0^2], DirichletCondition[p[x, y] == P0[i - 1][x, y], x == L]}}, {u, v, p}, {x, y} ? ?, Method -> {"FiniteElement", "InterpolationOrder" -> {u -> 2, v -> 2, p -> 1}, "MeshOptions" -> {"MaxCellMeasure" -> 0.001}}], {i, 1, K}]; {ContourPlot[UX[K/2][x, y], {x, y} ? ?, AspectRatio -> Automatic, ColorFunction -> "BlueGreenYellow", FrameLabel -> {x, y}, PlotLegends -> Automatic, Contours -> 20, PlotPoints -> 25, PlotLabel -> u, MaxRecursion -> 2], ContourPlot[VY[K/2][x, y], {x, y} ? ?, AspectRatio -> Automatic, ColorFunction -> "BlueGreenYellow", FrameLabel -> {x, y}, PlotLegends -> Automatic, Contours -> 20, PlotPoints -> 25, PlotLabel -> v, MaxRecursion -> 2, PlotRange -> All]} // Quiet {DensityPlot[UX[K][x, y], {x, y} ? ?, AspectRatio -> Automatic, ColorFunction -> "BlueGreenYellow", FrameLabel -> {x, y}, PlotLegends -> Automatic, PlotPoints -> 25, PlotLabel -> u, MaxRecursion -> 2], DensityPlot[VY[K][x, y], {x, y} ? ?, AspectRatio -> Automatic, ColorFunction -> "BlueGreenYellow", FrameLabel -> {x, y}, PlotLegends -> Automatic, PlotPoints -> 25, PlotLabel -> v, MaxRecursion -> 2, PlotRange -> All]} // Quiet dPl = Interpolation[ Table[{i*t0, (P0[i][.15, .2] - P0[i][.25, .2])}, {i, 0, K, 1}]]; cD = Table[{t0*i, NIntegrate[(-?*(-Sin[?] (Sin[?] \!\(\*SuperscriptBox[\(UX[i]\), TagBox[ RowBox[{"(", RowBox[{"0", ",", "1"}], ")"}], Derivative], MultilineFunction->None]\)[x0 + r Cos[?], y0 + r Sin[?]] + Cos[?] \!\(\*SuperscriptBox[\(UX[i]\), TagBox[ RowBox[{"(", RowBox[{"1", ",", "0"}], ")"}], Derivative], MultilineFunction->None]\)[x0 + r Cos[?], y0 + r Sin[?]]) + Cos[?] (Sin[?] \!\(\*SuperscriptBox[\(VY[i]\), TagBox[ RowBox[{"(", RowBox[{"0", ",", "1"}], ")"}], Derivative], MultilineFunction->None]\)[x0 + r Cos[?], y0 + r Sin[?]] + Cos[?] \!\(\*SuperscriptBox[\(VY[i]\), TagBox[ RowBox[{"(", RowBox[{"1", ",", "0"}], ")"}], Derivative], MultilineFunction->None]\)[x0 + r Cos[?], y0 + r Sin[?]]))*Sin[?] - P0[i][x0 + r Cos[?], y0 + r Sin[?]]* Cos[?]) /. {r -> r0}, {?, 0, 2*Pi}]}, {i, 1000, 2000}]; // Quiet cL = Table[{t0*i, -NIntegrate[(-?*(-Sin[?] (Sin[?] \!\(\*SuperscriptBox[\(UX[i]\), TagBox[ RowBox[{"(", RowBox[{"0", ",", "1"}], ")"}], Derivative], MultilineFunction->None]\)[x0 + r Cos[?], y0 + r Sin[?]] + Cos[?] \!\(\*SuperscriptBox[\(UX[i]\), TagBox[ RowBox[{"(", RowBox[{"1", ",", "0"}], ")"}], Derivative], MultilineFunction->None]\)[x0 + r Cos[?], y0 + r Sin[?]]) + Cos[?] (Sin[?] \!\(\*SuperscriptBox[\(VY[i]\), TagBox[ RowBox[{"(", RowBox[{"0", ",", "1"}], ")"}], Derivative], MultilineFunction->None]\)[x0 + r Cos[?], y0 + r Sin[?]] + Cos[?] \!\(\*SuperscriptBox[\(VY[i]\), TagBox[ RowBox[{"(", RowBox[{"1", ",", "0"}], ")"}], Derivative], MultilineFunction->None]\)[x0 + r Cos[?], y0 + r Sin[?]]))*Cos[?] + P0[i][x0 + r Cos[?], y0 + r Sin[?]]* Sin[?]) /. {r -> r0}, {?, 0, 2*Pi}]}, {i, 1000, 2000}]; // Quiet {ListLinePlot[cD, AxesLabel -> {"t", "\!\(\*SubscriptBox[\(c\), \(D\)]\)"}], ListLinePlot[cL, AxesLabel -> {"t", "\!\(\*SubscriptBox[\(c\), \(L\)]\)"}], Plot[dPl[x], {x, 0, 8}, AxesLabel -> {"t", "?P"}]} f002 = FindFit[cL, a*.5 + b*.8*Sin[k*16*t + c*1.], {a, b, k, c}, t] Plot[Evaluate[a*.5 + b*.8*Sin[k*16*t + c*1.] /. f002], {t, 4, 8}, Epilog -> Map[Point, cL]] k0=k/.f002; Struhalnumber = .1*16*k0/2/Pi cLm = MaximalBy[cL, Last] sol = {Max[cD[[All, 2]]], Max[cL[[All, 2]]], Struhalnumber, dPl[cLm[[1, 1]] + Pi/(16*k0)]} In Fig. 1 shows the components of the flow velocity and the required coefficients. Our solution of the problem and what is required in the test {3.17805, 1.03297, 0.266606, 2.60427} lowerbound= { 3.2200, 0.9900, 0.2950, 2.4600}; upperbound = {3.2400, 1.0100, 0.3050, 2.5000}; ![Fig1][2] Note that our results differ from allowable by several percent, but if you look at all the results of Table 4 from the cited article, then the agreement is quite acceptable.The worst prediction is for the Strouhal number. We note that we use the explicit Euler method, which gives an underestimate of the Strouhal number, as follows from the data in Table 4. The next test differs from the previous one in that the input speed varies according to the `U0[y_, t_] := 4*Um*y/H*(1 - y/H)*Sin[Pi*t/8]`. It is necessary to determine the time dependence of the drag and lift parameters for a half-period of oscillation, as well as the pressure drop at the last moment of time. In Fig. 2 shows the components of the flow velocity and the required coefficients. Our solution of the problem and what is required in the test sol = {3.0438934441256595`, 0.5073345082785012`, -0.11152933279750943`}; lowerbound = {2.9300, 0.4700, -0.1150}; upperbound = {2.9700, 0.4900, -0.1050}; ![Fig2][3] For this test, the agreement with the data in Table 5 is good. Consequently, the two tests are almost completely passed. I wrote and debugged this code using Mathematics 11.01. But when I ran this code using Mathematics 11.3, I got strange pictures, for example, the disk is represented as a hexagon, the size of the area is changed. ![Fig3][4] In addition, the numerical solution of the problem has changed, for example, test 2D2 {3.17805, 1.03297, 0.266606, 2.60427} v11.01 {3.15711, 1.11377, 0.266043, 2.54356} v11.03 The attached file contains the working code for test 2D3 describing the flow around the cylinder in a flat channel with a change in the flow velocity. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=test2D2.png&userId=1218692 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=test2D2.png&userId=1218692 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=test2D3.png&userId=1218692 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Math11.3.png&userId=1218692 [331]: http://community.wolfram.com//c/portal/getImageAttachment?filename=CylinderRe100test2D2.gif&userId=1218692 [332]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2D2test.png&userId=1218692 Alexander Trounev 2018-08-31T11:44:04Z https://community.wolfram.com/groups/-/m/t/3118205 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=heroimage.png&userId=1539902 [2]: https://www.wolframcloud.com/obj/5b3b5265-f1e2-406c-aef4-45a5f9ec363b Mohammad Bahrami 2024-02-07T19:21:52Z https://community.wolfram.com/groups/-/m/t/131302 I am reposting this here from the [url=http://mathematica.blogoverflow.com/]Stackexchange Mathematica blog[/url] so that more people might see it.  I'd be very happy to get some feedback on this plotting function.  If anyone can use the function, let me know how it works out for you, and if you'd recommend any changes.  If so, I can edit this post to have to most up-to-date version. As a chemist it is often useful to plot electronic orbitals. These are used to describe the wave function of electrons in atoms or molecules. Typically, these are output from electronic structure software in the form of a cube file, first developed by Gaussian. These files contain volumetric data for a given orbital on a three-dimensional grid. There exist many applications to visualize cube files, such as [url=http://www.ks.uiuc.edu/Research/vmd/plugins/molfile/cubeplugin.html]VMD [/url]or [url=http://www.gaussian.com/g_tech/gv5ref/results.htm]GaussView[/url], but I wanted to take advantage of Mathematica‘s capability to easily combine graphics, as well as the ability to automate the process in order to efficiently create frames for a [url=http://www.pnas.org/content/suppl/2013/09/05/1308604110.DCSupplemental/sm01.mp4]movie[/url]. First off, we need a function to extract the data from the cube file. In the process, we will create the text for an XYZ file, a format also developed by Gaussian. The function [b]OutForm[/b] is used here to mimic the printf function found in other programming languages. [mcode]OutForm[num_?NumericQ, width_Integer, ndig_Integer, OptionsPattern[]] := Module[{mant, exp, val}, {mant, exp} = MantissaExponent[num]; mant = ToString[NumberForm[mant, {ndig, ndig}]]; exp = If[Sign[exp] == -1, "-", "+"] <> IntegerString[exp, 10, 2]; val = mant <> "E" <> exp; StringJoin@PadLeft[Characters[val], width, " "] ]; ReadCube[cubeFileName_?StringQ] := Module[ {moltxt, nAtoms, lowerCorner, nx, ny, nz, xstep, ystep, zstep, atoms, desc1, desc2, xyzText, cubeDat, xgrid, ygrid, zgrid, dummy1, dummy2, atomicNumber, atomx, atomy, atomz, tmpString, headerTxt,bohr2angstrom}, bohr2angstrom = 0.529177249; moltxt = OpenRead[cubeFileName]; desc1 = Read[moltxt, String]; desc2 = Read[moltxt, String]; lowerCorner = {0, 0, 0}; {nAtoms, lowerCorner[[1]], lowerCorner[[2]], lowerCorner[[3]]} = Read[moltxt, String] // ImportString[#, "Table"][[1]] &; xyzText = ToString[nAtoms] <> "\n"; xyzText = xyzText <> desc1 <> desc2 <> "\n"; {nx, xstep, dummy1, dummy2} = Read[moltxt, String] // ImportString[#, "Table"][[1]] &; {ny, dummy1, ystep, dummy2} = Read[moltxt, String] // ImportString[#, "Table"][[1]] &; {nz, dummy1, dummy2, zstep} = Read[moltxt, String] // ImportString[#, "Table"][[1]] &; Do[ {atomicNumber, dummy1, atomx, atomy, atomz} = Read[moltxt, String] // ImportString[#, "Table"][[1]] &; xyzText = If[Sign[lowerCorner[[1]]] == 1, xyzText <> ElementData[atomicNumber, "Abbreviation"] <> OutForm[atomx, 17, 7] <> OutForm[atomy, 17, 7] <> OutForm[atomz, 17, 7] <> "\n", xyzText <> ElementData[atomicNumber, "Abbreviation"] <> OutForm[bohr2angstrom atomx, 17, 7] <> OutForm[bohr2angstrom atomy, 17, 7] <> OutForm[bohr2angstrom atomz, 17, 7] <> "\n"]; , {nAtoms}]; cubeDat = Partition[Partition[ReadList[moltxt, Number, nx ny nz], nz], ny]; Close[moltxt]; moltxt = OpenRead[cubeFileName]; headerTxt = Read[moltxt, Table[String, {2 + 4 + nAtoms}]]; Close[moltxt]; headerTxt = StringJoin@Riffle[headerTxt, "\n"]; xgrid = Range[lowerCorner[[1]], lowerCorner[[1]] + xstep (nx - 1), xstep]; ygrid = Range[lowerCorner[[2]], lowerCorner[[2]] + ystep (ny - 1), ystep]; zgrid = Range[lowerCorner[[3]], lowerCorner[[3]] + zstep (nz - 1), zstep]; {cubeDat, xgrid, ygrid, zgrid, xyzText, headerTxt} ];[/mcode] If you need to create a cube file, then the following function can be used: [mcode]WriteCube[cubeFileName_?StringQ, headerTxt_?StringQ, cubeData_] := Module[{stream}, stream = OpenWrite[cubeFileName, FormatType -> FortranForm]; WriteString[stream, headerTxt, "\n"]; Map[WriteString[stream, ##, "\n"] & @@ Riffle[ScientificForm[#, {3, 4}, NumberFormat -> (Row[{#1, "E", If[#3 == "", "+00", #3], "\t"}] &), NumberPadding -> {"", "0"}, NumberSigns -> {"-", " "}] & /@ #, "\n", {7, -1, 7}] &, cubeData, {2}]; Close[stream];][/mcode]Next we need the function to plot the orbital, [mcode]CubePlot[{cub_, xg_, yg_, zg_, xyz_}, plotopts : OptionsPattern[]] := Module[{xyzplot, bohr2picometer, datarange3D, pr}, bohr2picometer = 52.9177249; datarange3D = bohr2picometer {{xg[[1]], xg[[-1]]}, {yg[[1]], yg[[-1]]}, {zg[[1]], zg[[-1]]}}; xyzplot = ImportString[xyz, "XYZ"]; Show[xyzplot, ListContourPlot3D[Transpose[cub, {3, 2, 1}], Evaluate[FilterRules[{plotopts}, Options[ListContourPlot3D]]], Contours -> {-.02, .02}, ContourStyle -> {Blue, Red}, DataRange -> datarange3D, MeshStyle -> Gray, Lighting -> {{"Ambient", White}}], Evaluate[ FilterRules[{plotopts}, {ViewPoint, ViewVertical, ImageSize}]]] ]; [/mcode]Let’s look at an example. First we need to read in a cube file, download this cube file and place it in your base directory:  [url=https://dl.dropboxusercontent.com/s/rdsxcnqudn1s76n/cys-MO35.cube]cys-MO35cube[/url] [mcode]{cubedata,xg,yg,zg,xyz,header}= ReadCube["cys-MO35.cube"];[/mcode]Then plot it via[mcode]CubePlot[{cubedata, xg, yg, zg, xyz}][/mcode][img=width: 300px; height: 291px;]http://mathematica.blogoverflow.com/files/2013/09/pizCq-300x291.jpg[/img] When I want to create a movie file, I want all the images to have exactly the same [b]ViewAngle[/b], [b]ViewPoint[/b], and [b]ViewCenter[/b]. When you give these options to [b]CubePlot[/b], it feeds them directly to the [b]Show[/b] function [mcode]vp = {ViewCenter -> {0.5, 0.5, 0.5}, ViewPoint -> {1.072, 0.665, -3.13}, ViewVertical -> {0.443, 0.2477, 1.527}}; CubePlot[{cubedata, xg, yg, zg, xyz}, vp][/mcode][img=width: 280px; height: 300px;]http://mathematica.blogoverflow.com/files/2013/09/Q1mjs-280x300.jpg[/img] Finally, you can also give any options that normally go to [b]ListContourPlot3D[/b][mcode]CubePlot[{cubedata, xg, yg, zg, xyz}, vp, ContourStyle -> {Texture[ExampleData[{"ColorTexture", "Vavona"}]], Texture[ExampleData[{"ColorTexture", "Amboyna"}]]}, Contours -> {-.015, .015}][/mcode][img=width: 288px; height: 300px;]http://mathematica.blogoverflow.com/files/2013/09/fLyJ7-288x300.jpg[/img] Many thanks to Daniel Healion for the [b]ReadCube[/b] and [b]WriteCube[/b] functions. Jason Biggs 2013-09-27T18:35:45Z https://community.wolfram.com/groups/-/m/t/181641 Wanted to share with my kids the classical experiment on a rolling object down an incline plane using legos, arduino and Mathematica for the Raspberry Pi. Using a window valance and some lego technic pieces we proceeded to build the inclined plane platform. [img=width: 300px; height: 400px;]/c/portal/getImageAttachment?filename=inclinedplane1.JPG&userId=78214[/img] Using legos was great to allow to attach both leds and photorresistors to the inclined plane. It also allowed us to set up build a platform from where to attach a servo motor and a protractor to measure the angle of inclination. [img=width: 400px; height: 533px;]/c/portal/getImageAttachment?filename=inclinedplane2.JPG&userId=78214[/img] We'll detect when the ball reaches a certain point of the platform by the the disminution of the LED light received at the photoresistors. [img=width: 300px; height: 400px;]/c/portal/getImageAttachment?filename=8270photo(1).JPG&userId=78214[/img] The adafruit web site is a very good site to explain the details on how to connect the photoresistors and leds to the Arduino. [url=http://learn.adafruit.com/adafruit-arduino-lesson-2-leds/leds]http://learn.adafruit.com/adafruit-arduino-lesson-2-leds/leds[/url] [url=http://learn.adafruit.com/photocells/using-a-photocell]http://learn.adafruit.com/photocells/using-a-photocell[/url] As the readings of the photocells require of analog inputs, we decided to use a spare arduino we had at our disposal, and to have more fun, use XBEE modules to connect the arduino to the raspberry pi. [img=width: 300px; height: 225px;]/c/portal/getImageAttachment?filename=6471photo(2).JPG&userId=78214[/img] The following is the code at the Arduino.[code] #include <Servo.h> int servoPin = 9; int LightSensor[4]={A1,A2,A3,A4}; int current[4]={0,0,0,0}; double timers[4]={0,0,0,0}; int previous[4]={0,0,0,0}; Servo servo; int i=0; double factor=0.7; double timer = 0; int inByte =0; void setup() { Serial.begin(19200); servo.attach(servoPin); servo.write(0); delay(2000); for (i=0;i<4;i++){ previous[i]=analogRead(LightSensor[i]); } } void loop() { if(Serial.available()>0){ inByte=Serial.read(); if (inByte==65) { servo.write(90); timer=millis(); trackBall(); for (i=0;i<4;i++){ Serial.println(timers[i]); } servo.write(0); } } } void trackBall(){ int m =0; while (m<4){ current[m]=analogRead(LightSensor[m]); if (current[m]<factor*previous[m]){ timers[m]=millis()-timer; m++; } } }[/code] Mathematica code and results to follow [mcode]serial = DeviceOpen["Serial", {"/dev/ttyUSB0", "BaudRate" -> 19200}] lengths = {0., 0.175, 0.43, 0.69} ;(*Distance between light sensors in meters*) data = {};(*List to capture the time between sensors*) ping := Module[{}, DeviceWriteBuffer[serial, {"A"}]; Pause[3]; ToExpression[StringSplit[FromCharacterCode[DeviceReadBuffer[serial]]]]/1000] (*Function pings sends an "A" to the arduino to release the ball and \ collect timing*) Button["Collect Data", data = Append[data, ping]] Dynamic[tdata = Transpose@data; dataPoints = Flatten[Table[{tdata[[i, j]], lengths[[i]]}, {i, Length[lengths]}, {j, Length[data]}], 1]; lm = Fit[dataPoints, {1, x, x^2}, x]; Plot[lm, {x, -0.3, 1.2}, Epilog -> {Red, PointSize[Large], Point[dataPoints]}, AspectRatio -> 1, PlotLabel -> lm]][/mcode]Using a hollow ball, we can work out the gravity value [img=width: 440px; height: 500px;]/c/portal/getImageAttachment?filename=Untitled.png&userId=78214[/img] Using a golf ball [img=width: 500px; height: 482px;]/c/portal/getImageAttachment?filename=InclinedPlane.png&userId=78214[/img] A couple of videos of the experiment in action [url=https://www.youtube.com/watch?v=4eRZ48N3vM8]https://www.youtube.com/watch?v=4eRZ48N3vM8[/url] [url=https://www.youtube.com/watch?v=eLVPpEcyw_0]https://www.youtube.com/watch?v=eLVPpEcyw_0[/url] [url=https://www.youtube.com/watch?v=53WaEcRWY_0]https://www.youtube.com/watch?v=53WaEcRWY_0[/url] Diego Zviovich 2014-01-08T01:09:54Z https://community.wolfram.com/groups/-/m/t/203498 I have written a palette and a package to help input properly typeset units.  The palette and package allow for quick input of units in Mathematica, avoiding the clunky units-discovery approach involving Wolfram Alpha queries. As an example, the expression below can be inputted quickly using the palette or by using the input aliases that are loaded by the package.[center][img=width: 206px; height: 89px;]/c/portal/getImageAttachment?filename=InputExample.jpg&userId=23384[/img][/center]The link to a page for downloads is: [url=http://www.blinn.edu/brazos/natscience/phys/thonan/Mathematica/]http://www.blinn.edu/brazos/natscience/phys/thonan/Mathematica/[/url] . Terrence Honan 2014-02-20T02:03:07Z https://community.wolfram.com/groups/-/m/t/3178293 ![Quantum qubit states and probabilities using Mathematica's quantum framework][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=quantummathematica.png&userId=20103 [2]: https://www.wolframcloud.com/obj/88ca7f05-28c8-4f26-9e76-1efe24135e1a Mohammad Bahrami 2024-05-18T00:10:49Z https://community.wolfram.com/groups/-/m/t/863933 Many of you have seen the strandbeest (from Dutch, meaning beach-beast). These PVC tube animals created by Theo Jansen walk along the beach and are wind powered: ![enter image description here][1] Years ago (2009 to be more exact) I made a post on my blog about the movement of the legs, as evidenced by the still-nicely-working Mathematica notebook: ![enter image description here][2] At the time the proportions of the legs were not known publicly so I meticulously studied frames of (low quality) YouTube videos. I made the following diagram in Illustrator of what I thought I saw: ![enter image description here][3] ![enter image description here][4] On the left the length of the legs in red, and in blue the numbers of the joints. On the right the trajectory of the joints that I calculated at the time in Mathematica. It's funny that my blog does not exist any more (for years actually), but these images live on, as I found out when I looked for strandbeest on Google Images: ![enter image description here][5] My images! But not on my website! Nice to see people still use it. Now, in 2016, I saw these files on my laptop, and thought: is there finally more known about them? Well yes, there is! The exact proportions are now known and there is tons and tons of videos, lectures, 3D-printable strandbeest models, interviews with Theo Jansen and other stuff! So now we can find the exact dimensions readily on the internet: ![enter image description here][6] Notice that I (wrongly) assumed that the legs had 'feet'! oops! I was very happy to see that my lengths were not that wrong though! Let's recreate the strandbeest. We do so by first creating a function that quickly finds the intersection of two circles: Clear[FindPoint, FindLines] FindPoint[p1 : {x1_, y1_}, p2 : {x2_, y2_}, R_, r_, side_] := Module[{d, x, y, vc1, vc2, p, sol, sol1, sol2, s1, s2, sr}, d = N@Sqrt[(x2 - x1)^2 + (y2 - y1)^2]; x = (d^2 - r^2 + R^2)/(2 d); y = Sqrt[R^2 - x^2]; vc1 = Normalize[{x2 - x1, y2 - y1}]; vc2 = Cross[vc1]; p = {x1, y1} + x vc1; {sol1, sol2} = {p + y vc2, p - y vc2}; s1 = Sign[Last[Cross[Append[(p2 - p1), 0], Append[(sol1 - p1), 0]]]]; s2 = Sign[Last[Cross[Append[(p2 - p1), 0], Append[(sol2 - p1), 0]]]]; sr = If[side === Left, 1, -1]; Switch[sr, s1, sol1 , s2 , sol2 ] ] This finds on the side 'side' (Left/Right) the intersection point of two circles positioned at p1 and p2, with radii R and r, respectively. And now we can easily compute all the little vertices/joints of our beast: FindLines[\[Theta]_] := Module[{p1, p2, p3, p4, p5, p6, p7, p8, p10, p11, p12, p13, p14, p15}, {p1, p2, p3, p4, p5, p6, p7, p8, p10, p11, p12, p13, p14, p15} = FindPoints[\[Theta]]; {{p1, p2}, {p2, p3}, {p3, p4}, {p1, p4}, {p2, p6}, {p4, p6}, {p3, p5}, {p4, p5}, {p5, p8}, {p6, p8}, {p6, p7}, {p7, p8}, {p1, p11}, {p10, p11}, {p2, p10}, {p2, p13}, {p11, p13}, {p10, p12}, {p11, p12}, {p12, p14}, {p13, p14}, {p13, p15}, {p14, p15}} ] FindPoints[\[Theta]_] := Module[{p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15, p16}, p1 = {0, 0}; p4 = {38, -7.8}; p11 = {-38, -7.8}; p2 = 15 {Cos[\[Theta]], Sin[\[Theta]]}; p3 = FindPoint[p2, p4, 50, 41.5, Left]; p6 = FindPoint[p2, p4, 61.9, 39.3, Right]; p5 = FindPoint[p3, p4, 55.8, 41.5, Left]; p8 = FindPoint[p5, p6, 39.4, 36.7, Left]; p7 = FindPoint[p6, p8, 49, 65.7, Right]; p10 = FindPoint[p2, p11, 50, 41.5, Right]; p13 = FindPoint[p2, p11, 61.9, 39.3, Left]; p12 = FindPoint[p10, p11, 55.8, 41.5, Right]; p14 = FindPoint[p12, p13, 39.4, 36.7, Right]; p15 = FindPoint[p13, p14, 49, 65.7, Left]; {p1, p2, p3, p4, p5, p6, p7, p8, p10, p11, p12, p13, p14, p15} ] Now we can plot it easily: trajectoriesdata = (FindPoints /@ Subdivide[0, 2 Pi, 100])\[Transpose]; Manipulate[ Graphics[{Arrowheads[Large], Arrow /@ trajectoriesdata, Thick, Red, Line[FindLines[\[Theta]]]}, PlotRange -> {{-150, 150}, {-120, 70}}, ImageSize -> 800 ] , {\[Theta], 0, 2 \[Pi]} ] ![enter image description here][7] We can also make an entire bunch of legs at the same time and make a 3D beast! Manipulate[ mp = 60; n = 12; \[CurlyPhi] = Table[Mod[5 \[Iota], n, 1], {\[Iota], 1, n}]; Graphics3D[{Darker@Yellow, Table[ Line[ Map[Prepend[mp \[Iota]], FindLines[\[Theta] + \[CurlyPhi][[\[Iota]]] (2 Pi/n)], {2}]], {\[Iota], n} ] , Black, Line[{{mp 1, 0, 0}, {mp n, 0, 0}}] } , Lighting -> "Neutral", PlotRangePadding -> Scaled[.1], PlotRange -> {{-mp, (n + 1) mp}, {-150, 150}, {-150, 150}}, Boxed -> False, ImageSize -> 700 ] , {\[Theta], 0, 2 \[Pi]} ] ![enter image description here][8] From the side we can look at how the legs of 4-pair-legged and 6-pair-legged versions of the beasts work: ![enter image description here][9] ![enter image description here][10] Hope you enjoyed this! Perhaps someone else can make this thing actually walk over a (bumpy) surface? [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=LVDKumerus2.jpg&userId=73716 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-05-29at00.51.53.png&userId=73716 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=strandbeest_sketch.png&userId=73716 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=strandbeest_trajectories.png&userId=73716 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-05-29at00.16.23.png&userId=73716 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Strandbeest_Leg_Proportions-01.png&userId=73716 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=3493strandwalk.gif&userId=73716 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=3587strandwalk3D.gif&userId=73716 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=4legged.gif&userId=73716 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=6legged.gif&userId=73716 Sander Huisman 2016-05-28T23:02:16Z 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/118650 I'm working on the development of some massively on-line education material ([i]whether massively online open courseware is a good thing is a different question, but if it is going to happen, we might as well try to get in early and do it well[/i]).  I'm creating content for an entire materials science undergraduate curriculum. The most important part of the content involves computation, visualization, and problem-solving.  The students build up a solution by solving a set of sub-problems and then incorporate all of the solutions into something that is meaningful, and hopefully, satisfying to them.  Because the solutions to the subproblems are interdependent, I have to provide a mechanism for showing a solution and allow them to proceed to the end of the lesson.  If I just provide the solution carte blanche, the student doesn't get the benefit and satisfaction of solving it themselves.  Thus, there are two competing   factors: 1) force the students to struggle a bit and learn by doing so, 2) provide content that permits them to get to the end and hopefully recognize the beauty of completing a complicated problem. I've rolled out some of this content in the form of "master classes on materials science problem solving" and have had a chance to observe how students interact with the content. ([i]these are the observations that lead to the monstrosity of code that is posted above[/i]). Here is the crononlogy: (1) In my first iteration, I asked them to solve a subproblem and then provided the solution in a closed group.  Students now are used to being fed immediate content and as soon as the problems became challenging, they would just open the content and accept it as "the solution".  The opportunity to teach by doing was a lost. (2) In my second iteration, I attempted to create some small barrier to "just clicking and not thinking". I ask them to work out a subproblem, and  I put my solutions into a separate .m file. Each of the files was encoded---the students had to go find the encryption key to display the solution.  Initially, the solutions appeared in the content notebook, but I evolved to having each subproblem's solution appear in a separate notebook.  This would allow easy comparison between their solution and mine.  Here is what happened, with the entire solution dumped onto the screen and they weren't paying much attention to the content and solution development.  They were trying their own solutions, but they weren't getting the full benefit of learning my solutions. (3) Third iteration: In an attempt to have the students read and follow the logic of a developed solution, I had each substep of the solution appear in a dialog with a button.  Clicking the button dumped that substep into a developing notebook.  This worked better, but I found a fraction of students would just look for the button and not the solution.  I had to find a way to slow them down. (4) Thus, the fourth iteration is [b][url=http://community.wolfram.com/groups/-/m/t/54822]what you see here[/url][/b].  I'll adopt John's solution to put up signposts (think Burma shave).  I'll also need to adapt [b][url=http://community.wolfram.com/groups/-/m/t/48441]John's previous solution[/url][/b]  to this pause technique for material that contains evaluatable expressions.   W. Craig Carter 2013-09-05T07:30:05Z https://community.wolfram.com/groups/-/m/t/463721 ![Aftermath of the solar eclipse][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=4902Hero.gif&userId=20103 [2]: https://www.wolframcloud.com/obj/5838919a-e64d-49fe-9193-c6ce123184f2 Marco Thiel 2015-03-21T01:18:08Z https://community.wolfram.com/groups/-/m/t/2448552 ![enter image description here][1] ![enter image description here][2] A new study group devoted to [Quantum Computation Framework][3] begins Monday Jan 24th! A list of daily topics can be found on our Daily Study Groups page. This group will be led by me and few other developers from Wolfram Quantum Team. We will meet daily, Monday to Friday. Study group sessions include time for exercises, discussion and Q&A. This study group will help you acquire an intro knowledge of quantum computing and learn how to implement quantum algorithms in the [Wolfram Quantum Computation Framework][4]. Feel free to explore [our framework][5]. Sign up: [Study group registration page][6] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2022-01-17at3.53.39PM.png&userId=1539902 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=FrontImage.jpeg&userId=1539902 [3]: https://www.bigmarker.com/series/daily-study-group-quantum-computation-framework/series_details?utm_bmcr_source=wolfram-u [4]: https://www.wolframcloud.com/obj/wolframquantumframework/DeployedResources/Paclet/Wolfram/QuantumFramework/ [5]: https://www.wolframcloud.com/obj/wolframquantumframework/DeployedResources/Paclet/Wolfram/QuantumFramework/ [6]: https://www.bigmarker.com/series/daily-study-group-quantum-computation-framework/series_details?utm_bmcr_source=community Mohammad Bahrami 2022-01-17T18:20:25Z 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/515162 **See attached notebook for details**. A [shuttlecock][1] (previously called Shuttlecork) (also called a bird or birdie) is a high-drag projectile used in the sport of badminton. It has an open conical shape: the cone is formed from 16 or so overlapping feathers, usually goose or duck, embedded into a rounded cork base. The cork is covered with thin leather. The shuttlecock's shape makes it extremely aerodynamically stable. Regardless of initial orientation, it will turn to fly cork first, and remain in the cork-first orientation. ![enter image description here][2] *Image courtesy of IOP Science* The name shuttlecock is frequently shortened to shuttle. The "shuttle" part of the name was probably derived from its back-and-forth motion during the game, resembling the shuttle of a loom; the "cock" part of the name was probably derived from the resemblance of the feathers to those on a cockerel. ![enter image description here][3] **The code with NDSolveValue is attached**. Here is the resulting simulation of the flight of badminton shuttlecocks: ![enter image description here][4] ![enter image description here][5] &[Wolfram Notebook][6] > [References][7] [1]: https://en.wikipedia.org/?title=Shuttlecock [2]: /c/portal/getImageAttachment?filename=sdf54wyehfgsd54qt.png&userId=11733 [3]: /c/portal/getImageAttachment?filename=sz.png&userId=476423 [4]: /c/portal/getImageAttachment?filename=ssdf3544ytjkjghd.gif&userId=11733 [5]: /c/portal/getImageAttachment?filename=1523Anim.gif&userId=476423 [6]: https://www.wolframcloud.com/obj/ff04670b-b2e3-4281-86a5-0cbb60e61592 [7]: http://iopscience.iop.org/1367-2630/17/6/063001/article Mariusz Iwaniuk 2015-06-18T14:56:37Z