https://community.wolfram.com RSS Feed for Wolfram Community showing any discussions tagged with Equation Solving sorted by most likes. https://community.wolfram.com/groups/-/m/t/1557676 **[Open in Cloud][1] | Download to Desktop via Attachments Below** ![Forgot to add the end result][111] I recently got inspired by a sculpture sold on [Saatchi Art][2] featuring anamorphic deformation by reflection in a spherical mirror. Being curious and interested in anamorphic transformations, I wanted to build something similar and find the math behind it using Mathematica... ![Saatchi art][3] A plain, undecorated Christmas ball can serve as a perfect convex spherical mirror to test some of our physics and coding skills. I used a 7 cm XMas ball now dumped in stores for Euro1.75 a sixpack! In a nutshell: I wanted to see how a deformed text should look like in order to show up undeformed when reflected in a ball shaped mirror. ![Xmass ballls][4] The graphics below show a spherical mirror centered at C:(0,0,0), our eye at viewpoint V: (xv,0,zv) and a reflected point S on the base plane beneath the ball. One of the reflected light rays leaving S will meet the mirror at Q such that its reflection meets the eye at V. But the eye at V will now perceive the point S at I. ![complete view pane][5] I is a perceived image point inside the view disk perpendicular to VC. According to the law of reflection, the lines VQI and SRQ will form equal angles with the normal n to the sphere in Q. All image points will be restricted to a disk that is the base of the view cone with the line CV as axis and an opening angle of tan^-1(zv/xv). This image disk is at an offset 1/xv from C and has a radius of Sqrt[1-(1/xv)^2]. ![view cone][6] The point Q (q1, q2, q3) is the intersection of the view line VI and the mirror sphere. It can be computed by solving this equation: solQ = NSolve[ Element[{x, y, z}, HalfLine[{imagePointI, viewPointV}]] && Element[{x, y, z}, Sphere[]], {x, y, z}]; pointQ = First[{x, y, z} /. solQ]; {q1, q2, q3} = pointQ; The points C, Q, I, V and S are all in the same plane. We have R, the projection of V to the normal n. projectionPlane = InfinitePlane[pointQ, {pointQ, viewPointV}]; reflectionPt = 2 Projection[viewPointV, pointQ] - viewPointV; The point S is now the intersection of of the line QR with the base plane. It can be computed by solving this equation: solS = NSolve[{{x, y, z} \[Element] HalfLine[{{q1, q2, q3}, reflectionPt}] && {x, y, z} \[Element] InfinitePlane[{{0, 0, -1}, {0, 1, -1}, {0, -1, -1}}]}, {x, y, z}]; After simplification, we can write the following function that maps the perceived image point I to the reflected point R : xmasBallMap[iPt : {yi_, zi_}, vPt : {xv_, zv_}] := Module[{imagePtRotated, solQ, q1, q2, q3}, (*image point in real (rotated) pane*) imagePtRotated = {(1 - zi zv)/Norm@vPt, yi, (xv^2 zi + zv)/xv/Norm@vPt}; (*intersection viewline-sphere: Q*) solQ = NSolve[ Element[{x, y, z}, HalfLine[{imagePtRotated, {xv, 0, zv}}]] && Element[{x, y, z}, Sphere[]], {x, y, z}]; {q1, q2, q3} = First[{x, y, z} /. solQ]; Join[{-(1 + q3) (q2^2 + q3^2) xv + q1^2 (xv - q3 xv) + q1^3 (-1 + zv) + q1 q2^2 (-1 + zv) + q1 q3 (q3 (-1 + zv) + 2 zv), q2 (2 q1 xv + q1^2 (-1 + zv) + q2^2 (-1 + zv) + q3 (q3 (-1 + zv) + 2 zv))}/(-2 q1 q3 xv + q3^2 (q3 - zv) + q1^2 (q3 + zv) + q2^2 (q3 + zv)), {-1}]] All possible image points have to fit inside the lower half-disk. This is a grid of image points inside the view disk: pts = Table[ Table[{x, y}, {x, -Floor[Sqrt[1 - y^2], .1] + .1, Floor[Sqrt[1 - y^2], .1] - .1, .025}], {y, 0, -.9, -.025}]; viewDisk = Graphics[{Circle[{0, 0}, 1, {\[Pi], 2. \[Pi]}], {AbsolutePointSize[2], Point /@ pts}}, Axes -> True, AxesOrigin -> {-1, -1}, AxesStyle -> Directive[Thin, Red]] ![all points in view disk][7] This is the reflected spherical anamorphic map of these points: ![all anamorphic points][8] We can see that there is a large magnification between the perceived image inside the ball and it reflected image. Getting a point too close to the rim of the view disk will project its reflection far away. This GIF shows the function in action. The image point I follows a circle in the perceived image disk while its reflection S follows the closed curve of its map xmasBallmap(I, v) in the base plane. ![reflected image gif][9] We can now further test our function with some text e.g.: "\[MathematicaIcon]Mathematica\[MathematicaIcon]". ma = First[First[ ImportString[ ExportString[ Style["\[MathematicaIcon]Mathematica\[MathematicaIcon]", FontFamily -> "Times", FontSize -> 72], "PDF"], "TextMode" -> "Outlines"]]] /. FilledCurve :> JoinedCurve; The text image needs to be rescaled and centered to fit inside the ball. maCenteredScaled = ma /. {x_?NumericQ, y_?NumericQ} :> {x, y}*.005 /. {x_?NumericQ, y_?NumericQ} :> {x - .93, y - .45}; This shows the text as should be perceived in the lower half of the mirror sphere: ![Mathematica in view disk][10] This is the code for a 3D view of the complete setup: the spherical mirror, the perceived text in the disk inside the sphere and the deformed, anamorphic image on the base plane. Quiet@Module[{xv = 10., zv = 3., \[Phi], rotationTF, pointA, viewPt, mathPts, rotatedMathPts, reflectedPts}, (*view angle*)\[Phi] = ArcTan[xv, zv]; rotationTF = RotationTransform[-\[Phi], {0, 1, 0}, {0, 0, 0}]; (*view pane rotation anchor*) pointA = {(0 - .01) Cos[\[Phi]], 0, (0 - .01) Sin[\[Phi]]}; (*point coordinates in y-z plane*) mathPts = maCenteredScaled[[-1, 1, All, -1]]; rotatedMathPts = Map[rotationTF, mathPts /. {y_?NumericQ, z_?NumericQ} :> {0, y, z}, {3}]; reflectedPts = Map[xmasBallMap[#, {xv, zv}] &, mathPts, {3}]; Graphics3D[{ (*reflected image plane (floor)*){Opacity[.45], LightBlue, InfinitePlane[{{0, 0, -1}, {1, 0, -1}, {-1, .5, -1}}]}, (*mirror sphere*){Opacity[.35], Sphere[]}, (*center of sphere*){Black, Sphere[{0, 0, 0}, .03]}, (*percieved image pane*){Opacity[.35], Cylinder[{{0, 0, 0}, pointA}, 1]}, (*perceived image*){Red, Line /@ rotatedMathPts}, (*reflected image*){Red, AbsoluteThickness[3], Line /@ reflectedPts}}, Boxed -> False]] ![full 3D view][11] Time to try the real thing. This shows a 7cm diameter XMas ball mirror with the text reflected in it. ![Xmass ball real][12] Get yourself a nice reflecting Christmas ball and this is a pdf for you to printout and try it! (see attached pdf file for printing) ![enter image description here][13] [1]: https://www.wolframcloud.com/objects/wolfram-community/Anamorphic-Reflections-in-a-Christmas-Ball-by-Erik-Mathieu [2]: https://www.saatchiart.com/art/Sculpture-All-is-in-One-Anamorphosis-2018-604-1-20/779925/4007113/view [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=saatchismall.png&userId=68637 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=love-balls-resize.gif&userId=68637 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=defaultviewpane.png&userId=68637 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1450view-cone.png&userId=68637 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=allimagepts.png&userId=68637 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=allanamopts.png&userId=68637 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=reflected-circle.gif&userId=68637 [10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=mathematicainsphere.png&userId=68637 [11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=mathematica-code.png&userId=68637 [12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=mathematicaXmsBall.png&userId=68637 [13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=printout.png&userId=68637 [111]: https://community.wolfram.com//c/portal/getImageAttachment?filename=LoveYouXmsBall-1.jpg&userId=68637 Erik Mahieu 2018-11-22T15:55:11Z https://community.wolfram.com/groups/-/m/t/2399430 *SUPPLEMENTARY WOLFRAM MATERIALS for the ARTICLE:* > Sergio Manzetti, Alexander Trounev (2021). > A Navier-Stokes model for Rogue wave simulation. > ResearchGate, Technical Report. https://www.researchgate.net/publication/354527324 ------ ![enter image description here][1] ABSTRACT -------------------------------------- Rogue waves are anomalous phenomena occurring over large sea bodies, where they are said appear out of nowhere and disappear without a trace. Simulations of rogue waves have been carried over the last 40 years, with several models published. In this paper we investigate the formation of rogue waves by two models: I. the Navier-Stokes equation where we take into account density and viscosity gradient on the air-water interface due to diffusion and II. a Korteveg de Vries-type model for quantum jumps which we developed earlier. We derive also a stable fluids algorithm which we use to compute nonlinear waves interaction produced by the wind. The results are discussed and compared. This code solves problem of viscous incompressible flow with gravitational force in a rectangle with periodic boundary condition on the left and right side and with Dirichlet condition on the top and bottom side. In the initial condition fluid velocity is periodic wave, and density has unit step like distribution on the air/water interface. Some other application of this code has been discussed on https://mathematica.stackexchange.com/questions/246091/stable-fluids-code-for-electromagnetic-mixture-application This model has been discussed in our report [A Navier-Stokes model for Rogue wave simulation][2] Two phase model of air-water interface -------------------------------------- Let us consider the system of equations describing nonlinear waves on the air-water interface. As it well known the air and the water can be considered as viscous incompressible fluids with density $\rho_a, \rho_w$, and dynamical viscosity $\mu_a, \mu_w$ consequently. Taking into account the gravity force and diffusion on the air-water interface, we have $$\nabla.\bf{u}=0\\ \frac{\partial \mathbf{u}}{\partial t}+(\mathbf{u}.\nabla)\mathbf{u}+\frac{\nabla P}{\rho_i}=\nu_i\nabla ^2\mathbf{u}+\mathbf{f}\\\ \frac{\partial \phi}{\partial t} +(\mathbf{u}.\nabla)\phi=\frac{\nu_i}{Sc_i}\nabla ^2\phi\\ $$ Here it is indicated $\rho_i, i=a,w $ - air and water density, $\mathbf{u}=(u_x,u_y)$ - flow velocity, $P$ - pressure; $\bf{f}$ - force acting on the volume of the air-water mixture; $\phi$ - the interface function describing the averaged density of the air-water mixture; $Sc_i$ - analog of the Schmidt number characterized water diffusion in the air and air diffusion in the water. Note that we considered averaged effect of mass transfer on the air-water interface including drops and bubbles. Let us define the Cartesian coordinate system so that the $y$ axis is directed against the direction of the gravitational acceleration vector and the $x$ axis is parallel to horizon. Let suppose that the water surface relief is described by the equation $y=r(t,x,y)$ - Figure 1. ![Figure 1. Flow geometry on the air-water interface with waves of small (left) and large (right) amplitude][3] We set the boundary conditions for the flow parameters on the top and bottom part of the boundary layer and periodic boundary conditions by coordinate $x$ as follows: $$ y=0: \mathbf{u}=0,\phi=\rho_w\\ y=H: \mathbf{u}=(U_0,0), \phi=\rho_a\\ \mathbf{u}(t,0,y)=\mathbf{u}(t,L,y)\\ \phi(t,0,y)=\phi(t,L,y). $$ Here $H$ is the height of the boundary layer,$U_0$ is the wind velocity, $L$ is the period of the wave tray. We assume that at the initial time the flow velocity and interface function are given by $$ t=0, y<H/2:u_x = 0, u_y=V_0 \sin(2 \pi n x/L), \phi =\rho_w\\ t=0, y\ge H/2: u_x=U_0, u_y=V_0\sin (2 \pi n x/L), \phi =\rho_a\\ $$ This problem can be solved with using numerical methods and an appropriate turbulence model. We have used stable fluids algorithm (Stam1999, Stam 2000) to solve 2D Navier-Stokes equations and to simulate nonlinear waves interaction on the air-water interface with a given wind velocity on the top of the boundary layer. While in the standard gravity wave theory the air-water interface is considered mainly as a potential flow, in our approach we take into account velocity, viscosity and density gradients on the interface. Since air/water density ratio is about $10^{-3}$ we have some challenging numerical problem. To solve this problem we made some simplifications in the basic Navier-Stokes equations. First, we suppose that velocity is a continues field at $t>0$ so that flow in the water and flow in the air is an united flow continuously distributed from the bottom to the top and the periodic one in the $x$ direction. We neglect by the surface tension due to large scale of the waves. Therefore we don't need any boundary condition on the air-water interface. Second, at $t>0$ we introduce continues density as $\rho=\phi$ to compute velocity field on every step. Third, we use stable fluid algorithm in time in the very specific order described below. Stable fluids algorithm ----------------------- 1) Solve advection equation with using boundary conditions, initial data from the previous step, and an implicit algorithm $$ \frac{\partial \mathbf{u}_1}{\partial t}+(\mathbf{u}_1.\nabla) \bf{u}_1=0 $$ 2) Solve diffusion equation with $\nu_i=\nu_i(\phi)$, initial data $\mathbf{u}_1$, boundary conditions and with using, for example, Gauss-Seidel relaxation algorithm $$ \frac{\partial \mathbf {u}_2}{\partial t}-\nu_i \nabla^2 \mathbf{u}_2=0$$ here $$\nu_i(\phi)=\nu_w \phi ^k, k=-0.4029$$ for the air temperature of 20C. 3) Add force to the velocity field from the previous step as follows $$ \mathbf{u}_3=\mathbf{u}_2+\mathbf{f} dt\\ $$ To simulate force acting on the volume of air-water mixture we used approximation $$ f_y=-\frac{(\rho_w-\phi)(\phi-\rho_w/2)(\phi-\rho_a)}{\rho_w^2(\rho_w-\rho_a)Fr^2} $$ 4) Make projection step. Here we can use two models. First model is standard projection (Stam 1999) by solving Poison equation $$ t>0, \nabla^2 q=\nabla . \bf{u}_3\\ \bf{u}_4=\bf{u}_3-\nabla q $$ Note, that this step allows us to define divergent free velocity field. 5) Update velocity field $\bf{u}_4\longrightarrow \bf{u}_5$ with using boundary conditions. 6) Make diffusion step with interface function by solving diffusion equation with initial condition from the previous step, with boundary conditions, and with $\nu=\nu_i(\phi)/Sc$ as follows $$ \frac{\partial \phi_1}{\partial t}-\nu \nabla^2 \phi_1=0 $$ 7) Make advection step by solving advection equation with initial data from step 6 with boundary conditions using an implicit algorithm (from step 1, for example), $$ \frac{\partial \phi_2}{\partial t}+(\bf{u}_5.\nabla) \phi_2=0 $$ 8) Update interface function with boundary conditions. 9) Return to step 1 with updated velocity and interface function. This algorithm can be also used in some different order, for example, in the beginning we can compute step 3 (Stam1999). Also we can make steps 6-8 first, and then compute velocity field with steps 1-5. The question about stability of the stable fluids algorithm not really solved yet. From our experience, we can't do arbitrary time step, but $dt$ is limiting by the grid size as usual for more precise computation. In our computations we have used $dt=2/N$ for $N\times N$ grid. In general case the numerical solution depends on the Froude number $Fr=\frac{U_0}{\sqrt{g L}}$, Reynolds number $Re=\frac{U_0 L}{\nu_w}$, Schmidt number and number of waves in the initial data. In our computations we fixed the Froude number, so that we can put $H=L=1$. We also fixed the Reynolds number, therefore we can put $U_0=1.5, V_0=0.5$. The algorithm 1-9 has been implemented with FDM and compiled to C with using Mathematica 12.3. Code to simulate air/water interface with $Re=10^4, Fr=1$ ---- rhoWater20C = 1.027; nuW20C = 0.01007; rhoAir20C = 0.001204; nuA20C = 0.151;dif = 1/10000; pec = .1; U0 = 1.5; V0 = .5; dn0 = 0.997658; dn1 = 0.514102; kap = 1; n = 81; Fr = 1; F0 = 1; n1 = n + 1; sm = 600; r = 20; den = ConstantArray[dn1 (1 + dn0 Tanh[-kap Range[-n1/2, n1/2]]), n1];u0 = ConstantArray[0, {n1, n1}]; Do[ u0[[i, j]] = U0 (1 + Tanh[kap (j - n1/2)])/2;, {i, n1}, {j, n1}]; v0 = ConstantArray[0., {n1, n1}]; Do[ v0[[i, j]] = V0 Sin[10 Pi (i - 1)/n];, {i, n1}, {j, n1}];periodic[n_, up_, ud_, ub_] := Module[{bd = ub}, Do[bd[[1, i]] = .5 (bd[[n, i]] + bd[[2, i]]); bd[[n + 1, i]] = bd[[1, i]]; bd[[i, 1]] = ud; bd[[i, n + 1]] = up;, {i, 2, n}]; bd[[1, 1]] = .5 (bd[[2, 1]] + bd[[1, 2]]); bd[[n + 1, n + 1]] = .5 (bd[[n, n + 1]] + bd[[n + 1, n]]); bd[[n + 1, 1]] = .5 (bd[[n, 1]] + bd[[n + 1, 2]]); bd[[1, n + 1]] = .5 (bd[[1, n]] + bd[[2, n + 1]]); bd]; diffuse[n_, r_, a_, c_, c0_] := Module[{c1 = c}, Do[Do[Do[ c1[[i, j]] = (c0[[i, j]] + (a/den[[i, j]]^.4029) (c1[[i - 1, j]] + c1[[i + 1, j]] + c1[[i, j - 1]] + c1[[i, j + 1]]))/(1 + 4 a/den[[i, j]]^.4029);, {j, 2, n}];, {i, 2, n}]; Do[c1[[1, i]] = c1[[n, i]]; c1[[n + 1, i]] = c1[[2, i]]; c1[[i, 1]] = c0[[i, 1]]; c1[[i, n + 1]] = c0[[i, n + 1]];, {i, 2, n}]; c1[[1, 1]] = .5 (c1[[2, 1]] + c1[[1, 2]]); c1[[n + 1, n + 1]] = .5 (c1[[n, n + 1]] + c1[[n + 1, n]]); c1[[n + 1, 1]] = .5 (c1[[n, 1]] + c1[[n + 1, 2]]); c1[[1, n + 1]] = .5 (c1[[1, n]] + c1[[2, n + 1]]);, {k, 0, r}]; c1]; advect[n_, d0_, u_, v_, dt_] := Module[{x, y, d1, dt0, i0, i1, j0, j1, s0, s1, t0, t1}, d1 = ConstantArray[0, {n + 1, n + 1}]; dt0 = dt n; Do[Do[x = i - dt0 u[[i, j]]; y = j - dt0 v[[i, j]]; i0 = Which[x <= 1, 1, 1 < x < n, Floor[x], True, n]; i1 = i0 + 1; j0 = Which[y <= 1, 1, 1 < y < n, Floor[y], True, n]; j1 = j0 + 1; s1 = x - i0; s0 = 1 - s1; t1 = y - j0; t0 = 1 - t1; d1[[i, j]] = s0 (t0 d0[[i0, j0]] + t1 d0[[i0, j1]]) + s1 (t0 d0[[i1, j0]] + t1 d0[[i1, j1]]);, {j, 1, n + 1}];, {i, 1, n + 1}]; d1]; project[n_, r_, u0_, v0_, u_, v_] := Module[{ux = u, vy = v, div, p}, p = ConstantArray[0, {n + 1, n + 1}]; div = ConstantArray[0, {n + 1, n + 1}]; ux = ConstantArray[0, {n + 1, n + 1}]; vy = ConstantArray[0, {n + 1, n + 1}]; Do[div[[i, j]] = -.5/ n (u0[[i + 1, j]] - u0[[i - 1, j]] + v0[[i, 1 + j]] - v0[[i, j - 1]]);, {i, 2, n}, {j, 2, n}]; Do[Do[Do[ p[[i, j]] = (div[[i, j]] + (p[[i - 1, j]] + p[[i + 1, j]] + p[[i, j - 1]] + p[[i, j + 1]]))/4;, {j, 2, n}], {i, 2, n}];, {k, 0, r}]; Do[ux[[i, j]] = u0[[i, j]] - .5 n (p[[i + 1, j]] - p[[i - 1, j]]); vy[[i, j]] = v0[[i, j]] - .5 n (p[[i, j + 1]] - p[[i, j - 1]]);, {i, 2, n}, {j, 2, n}]; {ux, vy}]; Fx[t_, x_, y_] := 0; Fy[t_, x_, y_] := -1/Fr^2; onestep[n_, step_, r_, a_, uin_, vin_, dt_, c_] := Module[{u1, v1, f1, f2, u, v, u0, v0}, f1 = ConstantArray[0, {n + 1, n + 1}]; f2 = ConstantArray[0., {n + 1, n + 1}]; u0 = ConstantArray[0., {n + 1, n + 1}]; v0 = ConstantArray[0., {n + 1, n + 1}]; u = ConstantArray[0., {n + 1, n + 1}]; v = ConstantArray[0., {n + 1, n + 1}]; u1 = ConstantArray[0., {n + 1, n + 1}]; v1 = ConstantArray[0., {n + 1, n + 1}]; u0 = uin; v0 = vin; Do[ f2[[i, j]] = 1/Fr^2 (den[[i, j]] - rhoWater20C/2) (rhoWater20C - den[[i, j]]) (den[[i, j]] - rhoAir20C)/(rhoWater20C - rhoAir20C)/rhoWater20C^2;, {i, 2, n}, {j, 2, n}]; v0 += f2 dt; u0 = advect[n, u0, u0, v0, dt]; v0 = advect[n, v0, u0, v0, dt]; mnV = 0; u0 = periodic[n, U0, 0, u0]; v0 = periodic[n, mnV, mnV, v0]; u0 = diffuse[n, r, a, c, u0]; v0 = diffuse[n, r, a, c, v0]; u0 = periodic[n, U0, 0, u0]; v0 = periodic[n, mnV, mnV, v0]; {u1, v1} = project[n, r, u0, v0, u, v]; u0 = periodic[n, U0, 0, u1]; v0 = periodic[n, mnV, mnV, v1]; {u0, v0}] cf = With[{cg = Compile`GetElement, hp = HoldPattern, dv = DownValues}, Hold@Compile[{{u0argu, _Real, 2}, {v0argu, _Real, 2}, {denargu, _Real, 2}, {sm, _Integer}, {n, _Integer}, {r, _Integer}, dif, pec, F0}, Module[{u0 = u0argu, v0 = v0argu, uu, vv, dd, den = denargu, c = Table[0., {n + 1}, {n + 1}], dt = 40./n^2, a, dnup = den[[1, n + 1]], dnd = den[[1, 1]]}, a = dt dif n n; uu = vv = dd = Table[0., {sm + 1}, {n + 1}, {n + 1}]; Do[ den = advect[n, den, u0, v0, dt]; den = periodic[n, dnup, dnd, den]; den = diffuse[n, r, a/pec, c, den]; den = periodic[n, dnup, dnd, den]; dd[[step + 1]] = den; {u0, v0} = onestep[n, step, r, a, u0, v0, dt, c]; uu[[step + 1]] = u0; vv[[step + 1]] = v0;, {step, 0, sm}]; {uu, vv, dd}], CompilationTarget -> C, RuntimeOptions -> "Speed"] /. dv@onestep /. Flatten[dv /@ {Fx, Fy, advect, diffuse, periodic, project}] /. hp@ConstantArray[c_, {i_, j_}] :> Table[0., {i}, {j}] /. hp@Part[a__] :> cg[a] /. hp[cg[a__] = rhs_] :> (Part[a] = rhs) // ReleaseHold]; Visualization ------------- rst = cf[u0, v0, den, sm, n, r, dif, pec, F0];Do[lstu[k] = Flatten[Table[{{(i - 1)/n, (j - 1)/n}, rst[[1, k, i, j]]}, {i, n1}, {j, n1}], 1]; lstv[k] = Flatten[Table[{{(i - 1)/n, (j - 1)/n}, rst[[2, k, i, j]]}, {i, n1}, {j, n1}], 1];, {k, sm}]; Do[Uvel[i] = Interpolation[lstu[i], InterpolationOrder -> 3];, {i, 1, sm}]; Do[Vvel[i] = Interpolation[lstv[i], InterpolationOrder -> 3];, {i, 1, sm}]; Do[lst4[k] = Flatten[Table[{{(i - 1)/n, (j - 1)/n}, rst[[3, k, i, j]]}, {i, n1}, {j, n1}], 1];, {k, sm}]; Do[rh[k] = Interpolation[lst4[k], InterpolationOrder -> 3];, {k, sm}];{ContourPlot[Uvel[10][x, y], {x, 0, 1}, {y, 0, 1}, ColorFunction -> "BlueGreenYellow", Frame -> False, PlotRange -> All, ImageSize -> Small, MaxRecursion -> 2, Contours -> 15, ContourStyle -> Yellow, PlotLegends -> Automatic], ContourPlot[Vvel[10][x, y], {x, 0, 1}, {y, 0, 1}, ColorFunction -> "BlueGreenYellow", Frame -> False, PlotRange -> All, ImageSize -> Small, MaxRecursion -> 2, Contours -> 15, ContourStyle -> Yellow, PlotLegends -> Automatic], ContourPlot[1 - rh[10][x, y], {x, 0, 1}, {y, 0, 1}, ColorFunction -> "BlueGreenYellow", Frame -> False, PlotRange -> All, ImageSize -> Small, MaxRecursion -> 2, Contours -> 15, ContourStyle -> Yellow, PlotLegends -> Automatic], ContourPlot[Uvel[sm][x, y], {x, 0, 1}, {y, 0, 1}, ColorFunction -> "BlueGreenYellow", Frame -> False, PlotRange -> All, ImageSize -> Small, MaxRecursion -> 2, Contours -> 15, ContourStyle -> Yellow, PlotLegends -> Automatic], ContourPlot[Vvel[sm][x, y], {x, 0, 1}, {y, 0, 1}, ColorFunction -> "BlueGreenYellow", Frame -> False, PlotRange -> All, ImageSize -> Small, MaxRecursion -> 2, Contours -> 15, ContourStyle -> Yellow, PlotLegends -> Automatic], ContourPlot[1 - rh[sm][x, y], {x, 0, 1}, {y, 0, 1}, ColorFunction -> "BlueGreenYellow", Frame -> False, PlotRange -> All, ImageSize -> Small, MaxRecursion -> 2, Contours -> 8, ContourStyle -> Yellow, PlotLegends -> Automatic]} In this Figure are shown velocity components $u_x$ (left), $u_y$ (middle) and 1- density (right) on step 10 (upper line) and on final step $sm=600$ ![Figure 2][4] UPDATE ---------- Next step is to animate wave transformation using interface function. We can show velocity field over density as follows Show[ContourPlot[1 - rh[sm][x, y]/rhoWater20C, {x, 0, 1}, {y, 0, 1}, PlotRange -> All, ColorFunction -> "BlueGreenYellow", Contours -> 8, ContourStyle -> Yellow, Frame -> False, PlotLegends -> Automatic], StreamPlot[{Uvel[sm][x, y], Vvel[sm][x, y]}, {x, 0, 1}, {y, 0, 1}, PlotRange -> All, StreamColorFunction -> None, VectorPoints -> Fine, VectorColorFunction -> Hue, PlotLegends -> Automatic, StreamColorFunctionScaling -> True, StreamStyle -> LightGray]] ![Figure 3][5] We can also compute frames for animation with using interface function frames=Table[ContourPlot[1 - rh[i][x, y], {x, 0, 1}, {y, 0, 1}, ColorFunction -> "BlueGreenYellow", Frame -> False, PlotRange -> All, ImageSize -> Small, MaxRecursion -> 2, Contours -> 8, ContourStyle -> Yellow, PlotLabel -> i], {i, 20, sm, 20}]; Animate[frames] ![Figure 4][6] References ---------- Jos Stam. Stable fluids. In Computer Graphics Proceedings Annual Conference Series, Los Angeles, Aug. 3–8, 199. Jos Stam. Interacting with smoke and fire in real time. Communications of the ACM, 43(7):77–83, July 2000. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=RogueWave.gif&userId=11733 [2]: https://www.researchgate.net/publication/354527324_A_Navier-Stokes_model_for_Rogue_wave_simulation [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Figure1.jpg&userId=1218692 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Figure2.jpg&userId=1218692 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Figure3.jpg&userId=1218692 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Fr3v3.AW1300Q5.gif&userId=1218692 Alexander Trounev 2021-11-03T06:49:53Z https://community.wolfram.com/groups/-/m/t/1063480 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/373ccb1d-e97f-40ec-aa0a-0d3001c4728d Mariusz Iwaniuk 2017-04-16T22:38:51Z https://community.wolfram.com/groups/-/m/t/2975371 A Wolfram U Daily Study Group on "Solving ODEs and PDEs" begins on Monday, August 8, 2023. Join me and a cohort of fellow enthusiasts to learn about the techniques for solving ordinary differential equations (ODEs) and partial differential equations (PDEs) using Wolfram Language. Learn how to use the DSolve (for symbolic solutions) and the NDSolve (a general numerical differential equation solver) functions. Topics covered include the numerical method of lines, the finite element method (FEM), the use and construction of meshes, boundary value problems and eigenvalue problems. Participate in live Q&A and review your understanding through interactive in-session polls. Complete quizzes at the end of the study group to get your certificate of program completion. August 7-11, 2023, 11am-12pm CT (4-5pm GMT) > [**REGISTER HERE**][1] Please feel free to use this thread to collaborate and share ideas, materials and links to other resources with fellow learners. I look forward to seeing you online! ![enter image description here][2] [1]: https://www.bigmarker.com/series/daily-study-group-wsg41 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=WolframUBanner.jpeg&userId=20103 Luke Titus 2023-07-24T18:32:33Z https://community.wolfram.com/groups/-/m/t/2085563 ![enter image description here][1] In a previous Wolfram Demonstration [Pendulum with Varying Length or How to Improve Your Next Swing Ride][2], I modelled a swing and rider system as a pendulum with varying length. Inspired by the article "[Pumping a Playground Swing][3]" by Post et al. I looked at an alternative strategy to "optimize my swing ride". The swing-rider system can be modeled as a double pendulum. The regular, *unforced double pendulum* maintains a constant level of energy. Kinetic-and potential energy are merely converted into one another and their sum remains constant. In the case of a swing however, we have a *forced double pendulum* as the rider wants to go higher and "pump" his way up. This can only be achieved by increasing the total energy in the (swing and rider) system. "Energy insertion" can be done by someone pushing the rider or by a properly synchronized change in the position of the center of mass (CM) of the rider. In the mentioned demonstration, the CM change was limited to an up and down crouching of the rider. Here, I will analyse a more general, circular or elliptic position change of the rider's CM. **Geometry** Let us first look at the geometry of the swing-rider system: The swinging kid at P can introduce energy into the double pendulum by forcibly moving his center of gravity in an elliptic movement around a point Z on the rigid swing rods OS. \[Theta] is the angle of the swing movement and \[Phi] is the angle of the crouching movement (rotation). We need a "crouching function" linking the angles \[Phi] and \[Theta]: \[Phi] = \[Omega] \[Theta]+\[Phi]0. \[Omega] is the crouching frequency and \[Phi]0 is the crouching's initial angular offset. Animate[ With[{L = 10, r = 2., \[Omega] = 3., \[Phi]0 = 0, a = .62, b = 2}, Module[{pivot, \[Phi], trace, seatCenter, hipPivot, hip}, pivot = {0, 0}; \[Phi] = \[Omega] \[Theta] + \[Phi]0; seatCenter = {L Sin[\[Theta]], -L Cos[\[Theta]]}; hipPivot = (L - r) {Sin[\[Theta]], -Cos[\[Theta]]}; hip = {(L - r - a Cos[\[Phi]]) Sin[\[Theta]] + b Cos[\[Theta]] Sin[\[Phi]], Cos[\[Theta]] (-L + r + a Cos[\[Phi]]) + b Sin[\[Theta]] Sin[\[Phi]]}; trace = Rotate[Circle[hipPivot, {b, a}], \[Theta]]; Graphics[{Line[{pivot, seatCenter}], Blue, Line[{hipPivot, hip}], PointSize[.015], Point[{pivot, hip, hipPivot, seatCenter}], {Red, trace}, {Dashed, Line[{hip, pivot}]}, {Black, Text[Style["O", 12], pivot, {-1, -1}], Text[Style["Z", 12], hipPivot, {1, 1}], Text[Style["P", 12], hip, {-1, -1}], Text[Style["S", 12], seatCenter, {-1, 1}]}}]]], {\[Theta], 0, 2 Pi}] ![enter image description here][4] **Dynamic Model** We add the driver's mass mk at P and consider the crouching as a periodic driving force. We use Newton's laws to derive the equation of motion: (*hip (CM) coordinate*) xh[t_] := b Cos[\[Theta][t]] Sin[\[Phi]0 + t \[Omega]] + (L - r - a Cos[\[Phi]0 + t \[Omega]]) Sin[\[Theta][t]]; yh[t_] := (-L + r + a Cos[\[Phi]0 + t \[Omega]]) Cos[\[Theta][t]] + b Sin[\[Phi]0 + t \[Omega]] Sin[\[Theta][t]]; (*effective swing length*)l = Sqrt[xh[t]^2 + yh[t]^2]; (*equilibrium of forces*) deqns = {mk xh''[t] == s[t] xh[t]/l, mk yh''[t] == s[t] yh[t]/l - mk g}; deqn = Eliminate[deqns, s[t]] // FullSimplify ![enter image description here][5] This is an animation showing a solution of the differential equation. The evolution of the energy levels shows how the forced position changes in the rider's CM is increasing the total energy in the system. Trying to reach a large energy increase in a short time is the goal of every swing rider. Here, a maximum energy level with a high swing is reached after a mere 1.5 full swings. Animate[Module[{a = 1.75, b = 1.5, \[Omega] = 1.9, \[Phi]0 = 0, \[Theta]0 = \[Pi]/4, \[Theta]00 = 0, V, T, mk = 50, g = 9.81, L = 10, l, xh, yh, \[Theta]sol, seat, hip, hipPivot, trace, tMax = 16, r = .75}, pivot = {0, 0}; (*crouch function*)\[Phi][t_] := \[Omega] t + \[Phi]0; xh[t_] := b Cos[\[Theta][t]] Sin[\[Phi]0 + t \[Omega]] + (L - r - a Cos[\[Phi]0 + t \[Omega]]) Sin[\[Theta][t]]; yh[t_] := (-L + r + a Cos[\[Phi]0 + t \[Omega]]) Cos[\[Theta][t]] + b Sin[\[Phi]0 + t \[Omega]] Sin[\[Theta][t]]; sol = First@ NDSolve[{deqn, \[Theta][0] == \[Theta]0, \[Theta]'[ 0] == \[Theta]00}, \[Theta], {t, 0, tMax}]; hip = {xh[t], yh[t]} /. sol /. t -> time; seat = L {Sin[\[Theta][time]], -Cos[\[Theta][time]]} /. sol; hipPivot = (L - r) {Sin[\[Theta][time]], -Cos[\[Theta][time]]} /. sol; trace = Rotate[Circle[hipPivot, {b, a}], \[Theta][time]] /. sol; (*kinetic energy*) T[t_] := Evaluate[.5 mk (xh'[t]^2 + yh'[t]^2)] /. sol;(*potential energy*)V[t_] := mk g yh[t] /. sol; Column[{ Plot[Evaluate[{V[t], T[t] + V[t]}], {t, 0, tMax}, Filling -> {2 -> {1}, 1 -> Bottom}, PlotLabel -> "Energy", PlotLegends -> Placed[{"Potential", "Total"}, Bottom], AxesLabel -> {"t", ""}, Epilog -> {AbsoluteThickness[.75], Line[{{time, -10000}, {time, 10000}}]}], Graphics[{(*support*){FaceForm[Yellow], EdgeForm[Black], Triangle[{pivot, 10 {-.035, .045}, 10 {.035, .045}}], Red, Disk[pivot, .01]}, (*floor*), {Brown, AbsoluteThickness[4], Line[{{-10, -L - a}, {10, -L - a}}]}, Point[{pivot, seat, hipPivot}], Line[{pivot, hip}], {Directive[Blue, AbsoluteThickness[.5]], trace}, {DotDashed, Line[{pivot, seat}]}, {Blue, Line[{hipPivot, hip}]}, {Red, AbsolutePointSize[7], Point@hip, White, Disk[hip, .025]}, ParametricPlot[ Evaluate[{xh[t], yh[t]} /. sol], {t, 0, time + .001}, PlotStyle -> Directive[Red, AbsoluteThickness[.75]]][[1]]}, PlotRange -> 12, Axes -> True]}]], {time, 0, 15.5, .25}] ![enter image description here][6] **Adding a rider** I designed a simplified rider figure with the hip position at the center of gravity and fixed points where the foot is on the seat and the grip of the hand is on the front rod. This figure can then simply be fitted into the previous code to make a working and more realistic model. kidNSwing[hip : {hx_, hy_}] := With[{pivot = {0, 0}, L = 10, seat = .75, head = .45, grip = 2.5, leg = 1.55, thigh = 1.4, trunk = 1.5, arm1 = 1.25, arm2 = 1.2}, Module[{(*joints*)ptF, ptB, ptT, ptS, ptK, ptP, ptN, ptE, ptH, ptD}, ptT = {-.2, -L}; ptS = {0, -L + .085}; ptF = {-seat, -L}; ptB = {seat, -L}; ptK = findTop[ptS, hip, leg, thigh]; ptH = AngleVector[{(L - grip), -1.6458}]; ptN = First@ Nearest[{x, y} /. Solve[{x, y} \[Element] Line[{ptS, pivot}] && EuclideanDistance[{x, y}, hip] == trunk + .1, {x, y}], pivot]; ptE = findTop[ptN, ptH, arm2, arm2]; ptD = First@ Nearest[{x, y} /. Solve[{x, y} \[Element] Line[{ptN, pivot}] && EuclideanDistance[{x, y}, hip] == trunk + head + .175, {x, y}], pivot]; {(*seat*){AbsoluteThickness[6], Gray, Line[{ptF, ptB}]}, (*rods*){AbsoluteThickness[.9], Line[{ptF, {0, 0}, ptB}]}, {PointSize[.01], Point[hip]}, (*trunk & limbs*) {FaceForm[Lighter[Red, .8]], EdgeForm[AbsoluteThickness[1]], StadiumShape[#, .125] & /@ Partition[{ptT, ptS, ptK, hip, ptN, ptE, ptH}, 2, 1] }, (*joints*){Disk[#, .12] & /@ {ptT, ptS, ptK,(*hip,*)ptN, ptE, ptH}, White, Disk[#, .065] & /@ {hip, ptT, ptS, ptK,(*hip,*)ptN, ptE, ptH}}, (*head*){Darker[Gray, .35], Disk[ptD, head, {176 \[Degree], -154 \[Degree]}],(*eye*)White, Disk[ptD, .075]}}]] ![enter image description here][7] **Full model to Optimize your Swing ride** The equation of motion is then introduced in a Manipulate. This lets the user experiment with a simple model of the swing and rider system to explore the conditions for an optimized swing ride . The parameters of the hip (CM) displacement and the initial conditions (angular position and speed) can be adjusted. The energy level graph on top lets the user see where the maximum energy level occurs and try do move this as much as possible to the start of the ride. Manipulate[With[{mk = 50, g = 9.81, pivot = {0, 0}, L = 10}, Module[{deqn, crouch, xh, yh, sol, \[Phi], V, T, hipPivot, hip, trace}, time = Min[tMax, time]; \[Phi][t_] := \[Omega] t + \[Phi]0; crouch[t_] := {b Sin[\[Phi][t]], -L + r + a Cos[\[Phi][t]]}; xh[t_] := b Cos[\[Theta][t]] Sin[\[Phi]0 + t \[Omega]] + (L - r - a Cos[\[Phi]0 + t \[Omega]]) Sin[\[Theta][t]]; yh[t_] := (-L + r + a Cos[\[Phi]0 + t \[Omega]]) Cos[\[Theta][t]] + b Sin[\[Phi]0 + t \[Omega]] Sin[\[Theta][t]]; deqn = 2 b ((-L + r) \[Omega]^2 + g Cos[\[Theta][t]]) Sin[\[Phi]0 + t \[Omega]] + 4 \[Omega] (a (L - r) + (-a^2 + b^2) Cos[\[Phi]0 + t \[Omega]]) Sin[\[Phi]0 + t \[Omega]] Derivative[ 1][\[Theta]][ t] + (a^2 + b^2 + 2 (L - r)^2 + 4 a (-L + r) Cos[\[Phi]0 + t \[Omega]] + (a - b) (a + b) Cos[ 2 (\[Phi]0 + t \[Omega])]) (\[Theta]^\[Prime]\[Prime])[ t] == 2 g (-L + r + a Cos[\[Phi]0 + t \[Omega]]) Sin[\[Theta][ t]]; sol = First@ NDSolve[{deqn, \[Theta][0] == \[Theta]0, \[Theta]'[ 0] == \[Theta]00}, \[Theta], {t, 0, tMax}]; hip[t_] := {xh[t], yh[t]} /. sol; hipPivot = (L - r) {Sin[\[Theta][time]], -Cos[\[Theta][time]]} /. sol; trace[t_] := Rotate[Circle[hipPivot, {b, a}], \[Theta][t]]; T[t_] := Evaluate[.5 mk (xh'[t]^2 + yh'[t]^2)] /. sol; V[t_] := mk g yh[t] /. sol; Column[{ Plot[Evaluate[{V[t], T[t] + V[t]}], {t, 0, tMax}, Filling -> {2 -> {1}, 1 -> Bottom}, PlotLabel -> "Energy", PlotLegends -> Placed[{"Potential", "Total"}, Bottom], AxesLabel -> {"t", ""}, AxesStyle -> 7, Epilog -> {AbsoluteThickness[.75], Line[{{time, -1*^6}, {time, 1*^6}}]}, ImageSize -> 400, AspectRatio -> .3], Graphics[{ {FaceForm[Yellow], EdgeForm[Black], Triangle[{pivot, {-.35, .45}, {.35, .45}}], Red, Disk[pivot, .15]}, (*floor*), {Brown, AbsoluteThickness[4], Line[{{-20, -L - 1}, {20, -L - 1}}]}, ParametricPlot[ hip[t] /. sol, {t, 0, If[sdt, tMax, time + .01]}, PerformanceGoal -> "Quality", PlotStyle -> Directive[AbsoluteThickness[.45], Red], PlotPoints -> 10][[1]], Rotate[kidNSwing[crouch[time]], \[Theta][time], pivot] /. sol, If[ sht, {Directive[Dashed, Blue, AbsoluteThickness[1.5]], trace[time] /. sol}, Nothing]}, Background -> Lighter[Gray, 0.8], Axes -> True, Frame -> True, FrameTicks -> None, PlotRange -> 1.1 {{-L, L}, {-L - .1, L}}, ImageSize -> 400]}]]], Style["animation", Bold, 10], {{time, 0.}, 0., tMax, .001, ImageSize -> Tiny, Appearance -> "Labeled"}, Delimiter, Style["swinging", Bold, 10], "initial angular position kid", {{\[Theta]0, 1.31}, -1.57, 1.57, .001, ImageSize -> Tiny, Appearance -> "Labeled"}, "initial angular speed", {{\[Theta]00, 0}, -6, 6, .0001, ImageSize -> Tiny, Appearance -> "Labeled"}, Delimiter, Style["crouching", Bold, 10], "major axis a (in line with swing rods)", {{a, .75}, 0., 2, .001, ImageSize -> Tiny, Appearance -> "Labeled"}, "minor axis b (perpendicular to swing rods)", {{b, .274}, 0., 2, .001, ImageSize -> Tiny, Appearance -> "Labeled"}, "frequency", {{\[Omega], 1.904}, -5, 5, .001, ImageSize -> Tiny, Appearance -> "Labeled"}, "angular offset", {{\[Phi]0, 0}, -1.57, 1.57, .0001, ImageSize -> Tiny, Appearance -> "Labeled"}, Delimiter, "hip vertical offset", {{r, 1.6722}, 0, 2.5, .0001, ImageSize -> Tiny, Appearance -> "Labeled"}, Delimiter, Row[{"show full dynamic trace", Control[{{sdt, False, ""}, {True, False}}]}], Row[{"show static trace", Control[{{sht, False, ""}, {True, False}}]}], {{tMax, 30, "total time"}, None}, TrackedSymbols :> True, ControlPlacement -> Left] ![enter image description here][8] After some experimenting, one can easily derive some conclusions: 1. the most important effect is to synchronize the crouching (\[Phi]) with the swinging (\[Theta]). Best results are achieved if the crouching frequency (\[Omega]) is double the swing frequency. 2. up and down crouching (a is the crouching path's semimajor axis in line with swing rods) has more effect than forward- backward leaning (b is the crouching path's semi-minor axis perpendicular to swing rods) **Some Favorite Rides** 1. A start from absolute standstill and zero position. Only the hip movement is in action here and is enough to add energy to the system. "zero start-1" :> {a = 0.75, b = 0.75, r = 1.6722, \[Theta]00 = 0, \[Theta]0 = 0, \[Phi]0 = 0.253, \[Omega] = 1} ![enter image description here][9] 2. This example also has zero initial speed and position but the crouching is synchronized in a nearly optimal way (\[Omega]= approximately 2), resulting in a spectacular swing over the top (we have rigid rods, no ropes or chains!). "zero start-2" :> {a = 1.2, b = 0, r = 1.6722, \[Theta]00 = 0, \[Theta]0 = 0.785, \[Phi]0 = 0.4664, \[Omega] = 1.994} ![enter image description here][10] 3. Other relations of crouching to swinging can result in some nice periodic rides. "oval track" :> {a = 0.75, b = 0, r = 0.8, \[Theta]00 = 0.0714, \[Theta]0 = 1.265, \[Phi]0 = -0.2527, \[Omega] = 3.74} ![enter image description here][11] Experiment freely with the previous Manipulate and get as much fun as I did with this simple model of something we are all familiar with. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=zerostart-6.gif&userId=68637 [2]: https://demonstrations.wolfram.com/PendulumWithVaryingLengthOrHowToImproveYourNextSwingRide/ [3]: https://pdfs.semanticscholar.org/9b19/8d284aee700cc35c2faae5683ff5e6fba66d.pdf [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=5490dynamicgeometry.gif&userId=68637 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1981eqnofmotion.png&userId=68637 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=2550modelwokid.gif&userId=68637 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=8117kidNswingcombi.gif&userId=68637 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ezgif.com-resize.png&userId=68637 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=8451zerostart-1.gif&userId=68637 [10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=zerostart-4.gif&userId=68637 [11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=zerostart-5.gif&userId=68637 Erik Mahieu 2020-09-29T12:38:26Z https://community.wolfram.com/groups/-/m/t/1610701 On February 11, Nasser M. Abbasi compiled a [huge report][1] about PDE solving with [Mathematica 11.3 and a recent (2018 version) of another major CAS system][2] , listing some of the PDE textbooks consulted (strangely no one among Evans, Farlow, Strauss, Sauvigny, Taylor is included). According to the [results][3] and to the [table of results][4] , Mathematica is dramaticaly behind its competitor and the knowledge of PDE by both the system seem very limited, compared to results one can find in a textbook. To be noticed, if you look at his [page][5] , Abbasi seems to use more Mathematica than the competitor. Let's hope that researchers at Wolfram will implement a **better knowledge of PDE into Mathematica**, rather than spreading their efforts on all those (some of them kind of bizarre) fields : not just to fill the gap with its competitor, but **because PDE is a very crucial MATHEMATICAL topic**. [1]: https://www.12000.org/my_notes/pde_in_CAS/pde_in_cas_legal.pdf [2]: https://www.12000.org/my_notes/pde_in_CAS/pdse1.htm [3]: https://www.12000.org/my_notes/pde_in_CAS/pdse2.htm [4]: https://www.12000.org/my_notes/pde_in_CAS/pdse3.htm [5]: https://www.12000.org/index.htm Camila Garcia 2019-02-11T19:48:19Z 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 https://community.wolfram.com/groups/-/m/t/1330785 *WOLFRAM MATERIALS for the ARTICLE:* > William Gilpin. *Cryptographic hashing using chaotic hydrodynamics*. > Proceedings of the National Academy of Sciences, 115 (19) (2018), pp. 4869-4874. > https://doi.org/10.1073/pnas.1721852115 > [Full article in PDF][1] ![enter image description here][2] ##Introduction## Last week, William Gilpin published a fascinating paper suggesting a physics-based hashing mechanism in the Proceedings of the National Society: Cryptographic hashing using chaotic hydrodynamics: https://doi.org/10.1073/pnas.1721852115 The paper discusses a hashing algorithm based on fluid mechanics: Particles are distributed in a 2D disk. The inside of the disk is filled with an idealized fluid and the fluid is now stirred with a single stirrer. The stirring process is modelled with two possible stirrer positions. A message (say made from 0s and 1s) can now be encoded through which of the two stirrer positions is active. If the bit from the message is 1, use stirrer position 1, if the bit of the message is 0, use stirrer position 2. After some bites are processed, and the fluid is stirred, this process mixes the particles. Dropping some of the information content of the actual particle positions, e.g. by taking only the x-positions of the particle positions allows to build a hash by using the particle indices after sorting the particles along the x-axis. The Methods section of the paper mentions that all calculations were carried out using Mathematica 11.0. Unfortunately no notebook supplement was given. So, playing around with ideas of the paper, I re-implemented some of the computations of the paper. The paper is behind a paywall, but fortunately the author's website has a downloadable copy of the paper [here][3]. The potential importance of physics-based models for hashing, and so for cryptocurrencies was pointed out at various sites (e.g. [Stanford News][4], [btcmanager][5]). It is fun to play around with the model. ##The chaotic advection model model## This classic model goes back to Hassan Aref (whom I was fortunate to know personally) from his 1984 paper [Stirring by chaotic advection][6]. The Hamiltonian for the movement of a particle with coordinates {ξ,η} in a circle of radius a under the influence of agitating vortex at {x,y} (possibly time-dependent) of strength Γ and its mirror vortex. H[{ξ_, η_}, {x_, y_}] = Γ/(2 π) Log[ComplexExpand[ Abs[((ξ + I η) - (x + I y))/((ξ + I η) - a^2/( x - I y))]] ] ![enter image description here][7] The resulting equations of motion: odes = {ξ'[t] == -D[H[{ξ[t], η[t]}, {x[t], y[t]}], η[t]], η'[ t] == +D[H[{ξ[t], η[t]}, {x[t], y[t]}], ξ[t]]} // Simplify ![enter image description here][8] Solve the equations of motion for randomly selected parameters and plot the particle trajectory. For a position-independent and time-independent vortex, the particle moves in a circle. nds = NDSolveValue[{ Block[{a = 1, Γ = 1, x = 0.5 &, y = 0 &}, odes], ξ[0] == 0.3, η[0] == -0.4}, {ξ[t], η[t]}, {t, 0, 10}] ![enter image description here][9] ParametricPlot[Evaluate[nds], {t, 0, 10}] ![enter image description here][10] Here the vortex moves around in a periodic manner. The resulting particle trajectory has a high degree of symmetry. nds2 = NDSolveValue[{ Block[{a = 1, Γ = 1, x = 0.8 Cos[2 Pi #/200] &, y = 0.8 Sin[2 Pi #/200] &}, odes], ξ[0] == 0.3, η[0] == -0.4}, {ξ[t], η[t]}, {t, 0, 400}] ![enter image description here][11] ParametricPlot[Evaluate[nds2], {t, 0, 400}, PlotPoints -> 400] ![enter image description here][12] Letting the vortex move along a random curve results in a chaotic movement of the particle. We color the particle's trajectory with time. (* vortex movement curve *) randomCurve = BSplineFunction[RandomPoint[Disk[], {100}]]; X[t_Real] := randomCurve[t/100][[1]] Y[t_Real] := randomCurve[t/100][[2]] nds2 = NDSolveValue[{ Block[{a = 1, Γ = 10, x = X, y = Y}, odes], ξ[0] == 0.3, η[0] == -0.4}, {ξ[t], η[t]}, {t, 0, 100}] ![enter image description here][13] ParametricPlot[Evaluate[nds2], {t, 0, 100}, PlotPoints -> 1000, ColorFunction -> Function[{x, y, u}, ColorData["DarkRainbow"][u]]] ![enter image description here][14] Having two possible positions of the vortex and switching periodically between them results in a particle trajectory that is made of piecewise circle arcs. nds2 = NDSolveValue[{ Block[{a = 1, Γ = 10, x = Sign[Sin[Pi #]]/2 &, y = 0 &}, odes], ξ[0] == 2/3, η[0] == 0}, {ξ[t], η[t]}, {t, 0, 100}]; ParametricPlot[Evaluate[nds2], {t, 0, 100}, PlotPoints -> 1000, ColorFunction -> Function[{x, y, u}, ColorData["DarkRainbow"][u]]] ![enter image description here][15] Using initially 4320 points on a circle shows how the initial circle gets stretched and ripped apart and the points distribute chaotically over the disk. nds2 = NDSolveValue[{ Block[{a = 1, Γ = 10, x = Sign[Sin[Pi #]]/2 &, y = 0 &}, odes], ξ[0] == Table[2/3 Cos[φ], {φ, 0, 2 Pi, 2 Pi/(12 360)}], η[0] == Table[2/3 Sin[φ], {φ, 0, 2 Pi, 2 Pi/(12 360)}]}, {ξ[t], η[t]}, {t, 0, 2}]; GraphicsGrid[ Partition[Graphics[{LightGray, Disk[], Black, PointSize[0.005], Point[Transpose[nds2 /. t -> #]]}, ImageSize -> 120] & /@Range[0, 2, 2/19] , 5]] ![enter image description here][16] With time running upwards, here is a 3D image of this stirring process. The transition from using the right stirrer to using the left stirrer at time 1 is clearly visible. trajectories3D = Transpose[Table[ Append[#, N[τ]] & /@ Transpose[nds2 /. t -> τ], {τ, 0, 2, 2/100}]]; Graphics3D[{Thickness[0.001], Opacity[0.2], BSplineCurve /@ RandomSample[trajectories3D, 1600]}, PlotRange -> All, Axes -> True, BoxRatios -> {1, 1, 2}] ![enter image description here][17] Here is the corresponding interactive demonstration. Manipulate[ Graphics[{LightGray, Disk[], Black, PointSize[0.005], Point[Transpose[nds2 /. t -> τ]]}], {τ, 0, 2, Appearance -> "Labeled"}] ![enter image description here][18] The x-position of the particles will be used later. Here is a plot of the x-positions of 540 points initially on a circle over time.One observes many crossing of these x-trajectories. nds2B = NDSolveValue[{ Block[{a = 1, Γ = 4, x = Sign[Sin[Pi #]]/2 &, y = 0 &}, odes], ξ[0] == Table[2/3 Cos[φ], {φ, 0, 2 Pi, 2 Pi/540}], η[0] == Table[2/3 Sin[φ], {φ, 0, 2 Pi, 2 Pi/540}]}, {ξ[t], η[t]}, {t, 0, 12}]; ListLinePlot[Transpose[Table[{t, #} & /@ nds2B[[1]], {t, 0., 4, 4/200}] ], PlotStyle -> Table[Directive[Opacity[0.4], Thickness[0.001], ColorData["DarkRainbow"][j/541]], {j, 541}], Frame -> True, Axes -> False, FrameLabel -> {t, x}] ![enter image description here][19] Using a Dynamic[particleGraphics] we can easily model many more particles in real time without having to store large interpolating functions. We solve the the equations of motion over small time increments and the graphic updates dynamically. rPoints = Select[Flatten[Table[N[{x, y}], {x, -1, 1, 2/101}, {y, -1, 1, 2/101}], 1], Norm[#] < 1 &]; Dynamic[Graphics[{LightGray, Disk[], Black, PointSize[0.001], Point[rPoints]}]] ![enter image description here][20] rhsξ[X_, ξ_List, η_List] := With[{ Γ = 5}, -(((1 - X^2) Γ η (1 + X^2 - 2 X ξ))/(2 π (X^2 + η^2 - 2 X ξ + ξ^2) (1 - 2 X ξ + X^2 (η^2 + ξ^2))))] rhsη[X_, ξ_List, η_List] := With[{ Γ = 5}, -(((1 - X^2) Γ (-ξ - X^2 ξ + X (1 - η^2 + ξ^2)))/(2 π (X^2 + η^2 - 2 X ξ + ξ^2) (1 - 2 X ξ + X^2 (η^2 + ξ^2))))] With[{Δt = 10^-2, T = 0.2}, Monitor[ Do[ nds = NDSolveValue[ Block[{ X = Evaluate[1/2 Sign[Sin[Pi (k + 1/2) Δt/T]]] &}, {ξ'[t] == rhsξ[t, ξ[t], η[t]], η'[t] == rhsη[t, ξ[t], η[t]], ξ[k Δt] == Transpose[rPoints][[1]], η[k Δt] == Transpose[rPoints][[2]]}], {ξ[t], η[t]}, {t, (k + 1) Δt, (k + 1) Δt}] /. t -> (k + 1) Δt; rPoints = Transpose[nds], {k, 0, 200}], k]] Switching irregularly between the two stirrer positions gives qualitatively similar-looking trajectories. We use a sum of three trig functions see here for a detailed account on this type of function). (* left or right stirrer is on *) Plot[Sign[Sin[Pi t] + Sin[Pi Sqrt[2] t] + Sin[Pi Sqrt[3] t]], {t, 0, 100}, Exclusions -> None] ![enter image description here][21] nds3 = NDSolveValue[{ Block[{a = 1, Γ = 10, x = Sign[Sin[Pi #] + Sin[Pi Sqrt[2] #] + Sin[Pi Sqrt[3] #]]/2 &, y = 0 &}, odes], ξ[0] == 2/3, η[0] == 0}, {ξ[t], η[t]}, {t, 0, 100}]; ParametricPlot[Evaluate[nds3], {t, 0, 100}, PlotPoints -> 1000, ColorFunction -> Function[{x, y, u}, ColorData["DarkRainbow"][u]]] ![enter image description here][22] We can also change the stirring direction. nds3B = NDSolveValue[{ Block[{a = 1, Γ = 10 Sign[Sin[Pi t] + Sin[Pi Sqrt[2] t] + Sin[Pi Sqrt[3] t]], x = Sign[Sin[Pi #] + Sin[Pi Sqrt[2] #] + Sin[Pi Sqrt[3] #]]/2 &, y = 0 &}, odes], ξ[0] == 2/3, η[0] == 0}, {ξ[t], η[ t]}, {t, 0, 100}]; ParametricPlot[Evaluate[nds3B], {t, 0, 100}, PlotPoints -> 1000, ColorFunction -> Function[{x, y, u}, ColorData["DarkRainbow"][u]]] ![enter image description here][23] Here are three stirrer positions at the vertices of an equilateral triangle. st3[t_] = Piecewise[ With[{r = RandomInteger[{0, 2}]}, {1/2. {Cos[2 Pi r/3], Sin[2 Pi r/3]}, #[[1]] <= t <= #[[2]] }] & /@ Partition[FoldList[Plus, 0, RandomReal[{0, 1}, 300]], 2, 1]]; x3[t_Real] := st3[t][[1]] y3[t_Real] := st3[t][[2]] nds3 = NDSolveValue[{ Block[{a = 1, Γ = 5, x = x3, y = y3}, odes], ξ[0] == 1/3, η[0] == 0}, {ξ[t], η[t]}, {t, 0, 100}] ![enter image description here][24] ParametricPlot[Evaluate[nds3], {t, 0, 100}, PlotPoints -> 1000, ColorFunction -> Function[{x, y, u}, ColorData["DarkRainbow"][u]]] ![enter image description here][25] ##Side note: the linked twist map## Mathematically, alternating left and right use of the stirrer, is isomorphic to a so-called linked twist map. The following implements a simple realization of a linked twist map from Cairns /Kolganova. https://doi.org/10.1088/0951-7715/9/4/011 Clear[g, h, f]; g[{x_, y_}] := {x, Mod[Piecewise[{{y + 4 x, Abs[x] <= 1/4}}, y], 1, -1/2]} h[{x_, y_}] := {Mod[Piecewise[{{x + 4 y, Abs[y] <= 1/4}}, x], 1, -1/2], y} f[{x_, y_}] := g[h[{x, y}]] f[{x, y}] ![enter image description here][26] In explicit piecewise form, the map is more complicated. (To fit it, we use a reduce size.) (f2 = PiecewiseExpand[# , -1/2 < x < 1/2 && -1/2 < y < 1/2] & /@ f[{x, y}]) ![enter image description here][27] Here are the first and second component visualized. {ContourPlot[Evaluate[f2[[1]]], {x, -1/2, 1/2} , {y, -1/2, 1/2}, Exclusions -> {}, PlotPoints -> 60], ContourPlot[Evaluate[f2[[2]]], {x, -1/2, 1/2} , {y, -1/2, 1/2}, Exclusions -> {}, PlotPoints -> 60]} ![enter image description here][28] Applying the linked twist map to a set of points inside a square hints at the ergodic nature of the map. ptsRG = With[{pp = 80}, Table[{RGBColor[x + 1/2, y + 1/2, 0.5], Point[{x, y}]}, {y, -1/2, 1/2, 1/pp}, {x, -1/2, 1/2, 1/pp}]]; Graphics /@ NestList[Function[p, p /. Point[xy_] :> Point[f@xy]], ptsRG, 3] ![enter image description here][29] ##Closed form mapping## As mentioned, for a fixed stirrer position, a particle moves along a circle. This means that to move the particle to its final position, we don't have to solve nonlinear differential equations, but rather can calculate the final position through algebraic computations which are unfortunately not fully explicit. Doing the calculations (see Aref's paper for details) shows that we will have to solve of transcendental equation. In the following we will use a unit disk of radius 1 and a unit strength vortex. The particle is initially at {r,θ} (in polar coordinates) and the stirrer is at {±b,0}. a = 1; Γ = 1; The circle the particle is moving on. circle[{r_, θ_}, b_] := Module[{λ, ξc, ρ}, λ = Sqrt[(b^2 + r^2 - 2 b r Cos[θ])/(a^4/b^2 + r^2 - 2 a^2 r Cos[θ]/b)]; ξc = (b - λ^2 a^2/b)/(1 - λ^2); ρ = Abs[λ/(1 - λ^2) (a^2/b - b)]; Circle[{ξc, 0}, ρ]] The period for one revolution on the circle. period[{r_, θ_}, b_, T_] := Module[{λ, ρ, Tλ}, λ = Sqrt[(b^2 + r^2 - 2 b r Cos[θ])/(a^4/b^2 + r^2 - 2 a^2 r Cos[θ]/b)]; ρ = Abs[λ/(1 - λ^2) (a^2/b - b)]; Tλ = (2 Pi)^2 ρ^2/Γ (1 + λ^2)/(1 - λ^2) ] The final position after rotating for time T. rotate[{r_, θ_}, b_, T_, opts___] := Module[{(*λ,ξc,ρ,θp,Tλ,eq,fr*)}, λ = Sqrt[(b^2 + r^2 - 2 b r Cos[θ])/(a^4/b^2 + r^2 - 2 a^2 r Cos[θ]/b)]; ξc = (b - λ^2 a^2/b)/(1 - λ^2); ρ = Abs[λ/(1 - λ^2) (a^2/b - b)]; θp = ArcTan[r Cos[θ] - ξc, r Sin[θ]]; Tλ = (2 Pi)^2 ρ^2/Γ (1 + λ^2)/(1 - λ^2); (* the implicit equation to be solved numerically for θt *) eq = θt - 2 λ/(1 + λ^2) Sin[θt] == θp - 2 λ/(1 + λ^2) Sin[θp] + 2 Pi T/Tλ; fr = FindRoot[eq, {θt, θp}, opts] // Quiet; (* could use Solve[eq, θt, Reals] *) {Sqrt[ρ^2 + ξc^2 + 2 ρ ξc Cos[θt]], ArcTan[ρ Cos[θt] + ξc, ρ Sin[θt]]} /. fr] A high-precision version for later use. rotateHP[{r_, θ_}, b_, T_ ] := With[{prec = Precision[{r, θ}]}, rotate[{r, θ}, b, T, WorkingPrecision -> Min[prec, 200] - 1, PrecisionGoal -> prec - 10]] rotateHP[{2/5, 1}, 1/2, 10^-10] {0.3999999999735895736749310453217879335729586969724148186668989989685300449569453838180010833652353802304511654926113687832716502416432363896855780225351918314742068365263060199921670958293439964299441, 1.000000000034865509829422032384759003150106866109371061507406908121303212377635808764825759934117372434662086592066738925787825280696681907390281734196810440241159138906978471624124765879791828431390} Also for later use, rotate many points at once. rotate[l : {_List ..}, b_, T_ ] := rotate[#, b, T] & /@ l rotateHP[l : {_List ..}, b_, T_ ] := rotateHP[#, b, T] & /@ l The locator is the initial particle position; the stirrer position is the purple point. We show the circle and the final particle position (gray point). Manipulate[ Graphics[{LightGray, Disk[], Purple, PointSize[0.02], Point[{b, 0}] , Gray, circle[ToPolarCoordinates[p], b] , PointSize[0.01], Point[p], Blue , Point[ FromPolarCoordinates[ rotate @@ SetPrecision[ {ToPolarCoordinates[p], b, T}, 200] ]]}], {{T, 0.2}, 0.001, 10}, {{b, 0.5}, -0.999, 0.999}, {{p, {0.3, 0.4}}, Locator}] ![enter image description here][30] Here is a plot of the period for one revolution as a function of the initial position of the particle. The period can get quite large when points are near the boundary of the disk ParametricPlot3D[{r Cos[θ], r Sin[θ], period[{r, θ}, 1/2, 1]}, {r, 0, 1}, {θ, -Pi, Pi}, BoxRatios -> {1, 1, 0.3}, PlotPoints -> 40, MeshFunctions -> {#3 &}] ![enter image description here][31] For the stirrer located at {0.5,0}, here are the possible circles that the particle will move on. Graphics[Table[circle[{r, θ}, 1/2.] , {r, 1/10, 9/10, 1/10}, {θ, -Pi, Pi, 2 Pi/20}]] ![enter image description here][32] We use the closed form of the stirring map to visualize the flow. Here are about 20k points in stripes in the unit disk. stripePoints = Select[RandomPoint[Disk[], 40000], Function[xy, Mod[xy[[1]], 0.2] < 0.1]]; Graphics[{PointSize[0.002], Point[stripePoints]}] ![enter image description here][33] We repeatedly stir with the left and then the right stirrer on for time 1. swirled[1] = rotate[ToPolarCoordinates[stripePoints], 0.5, 1]; Graphics[{PointSize[0.002], Point[FromPolarCoordinates[swirled[1]]]}] ![enter image description here][34] swirled[2] = rotate[swirled[1], -0.5, 1]; Graphics[{PointSize[0.002], Point[FromPolarCoordinates[swirled[2]]]}] ![enter image description here][35] swirled[3] = rotate[swirled[2], 0.5, 1]; Graphics[{PointSize[0.002], Point[FromPolarCoordinates[swirled[3]]]}] ![enter image description here][36] swirled[4] = rotate[swirled[3], -0.5, 1]; Graphics[{PointSize[0.002], Point[FromPolarCoordinates[swirled[4]]]}] ![enter image description here][37] ##Now stir and make hashes## We now use two different initial positions of the points: a sunflower-like one and a random one. randominitialPositions[n_, prec_] := SortBy[Table[ReIm[RandomReal[{0, 1}, WorkingPrecision -> prec] * Exp[ I RandomReal[{-Pi, Pi}, WorkingPrecision -> prec]]], {n}], First] SeedRandom[1234]; initialPositionsR = randominitialPositions[100, 250]; Graphics[{LightGray, Disk[], MapIndexed[Function[{p, pos}, {Red, PointSize[0.002], Point[p], Black, Text[pos[[1]], p]}], N[initialPositionsR]]}] ![enter image description here][38] sunflower[n_, R_, prec_] := Table[FromPolarCoordinates[ N[{Sqrt[j/n] R, Mod[2 Pi (1 - 1/GoldenRatio) j, 2 Pi, -Pi]}, prec]], {j, n}] Graphics[{LightGray, Disk[], Black, Point[sunflower[1000, 0.9, 20]]}] ![enter image description here][39] The message to encode we will tell in the form of a sequence of 0s and 1s. A zero means use the left stirrer position and a 1 means use the right stirrer position. So, we define a stirring process with a given message σ and fixed b and T as follows: stirringProcess[initialPositions_, bAbs_, T_, σ_List] := FromPolarCoordinates /@ FoldList[rotateHP[#1, #2 bAbs, T] &, ToPolarCoordinates /@ initialPositions, 2 σ - 1] Here is a simple message: message1 = RandomInteger[{0, 1}, 50] {1, 1, 0, 0, 0, 0, 0, 1, 1, 1, 0, 1, 1, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1,1, 0, 1, 0} Now we carry out the corresponding stirring process. (We arbitrarily use b=1/2 and T=1/10.) sP1 = stirringProcess[initialPositionsR, 1/2, 1/10, message1]; To get a feeling for the stirring process, we connect successive positions of each particle with a randomly colored spline interpolation. (Note that the spline interpolation does not exactly represent the particle's trajectory.) Graphics[{LightGray, Disk[], Thickness[0.001], Map[Function[c, {RandomColor[], BSplineCurve[c, SplineDegree -> 5]}], Transpose[N[Table[sP1[[j]], {j, 50}]]]]}] ![enter image description here][40] Now, can we trust these results? We can check by running the stirring process (numerically) backwards. sP1Rev = stirringProcess[sP1[[-1]], 1/2, -1/10, Reverse[message1]]; The so-recovered initial positions agree to at least 80 digits with the original point positions. sP1Rev[[-1]] - initialPositionsR // Abs // Max // Accuracy 86.9777 As mentioned earlier, we define the hashes as the positions of the particles when ordered according to their x-values. So, for a given particle configurations, this is the hash-making function. makeHash[l_] := Sort[ MapIndexed[{#1, #2[[1]]} &, l]][[All, 2]] Because the hashes are permutations of the particle numberings, the number of hashes grows factorially with the particle number and 58 particles could model a 256 bit hash and 99 particles a 512 bit hash. {2^256, {57!, 58!}} // N {1.15792*10^77, {4.05269*10^76, 2.35056*10^78}} {2^512, {98!, 99!}} // N {1.34078*10^154, {9.42689*10^153, 9.33262*10^155}} hashes1 = makeHash /@ sP1; Here is a visualization how the hashes evolve with each stir. The coloring is from blue (1) to 100 (red) of the initial particle numbering. ArrayPlot[hashes1, ColorFunction -> ColorData["DarkRainbow"], PlotRange -> {1, 100}] ![enter image description here][41] This is how the edit distance of the hashes increases with successive stirrings. ListPlot[Table[{j, EditDistance[hashes1[[1]], hashes1[[j]]]}, {j, 1, 50}], Filling -> Axis] ![enter image description here][42] Gilpin defines the rearrangement index of a hash as the sum of the absolute difference between neighboring particle indices. rearrangementIndex[indexList_] := Total[Abs[Differences[indexList]]] Here is the growth rate of the rearrangement index for our just-calculated hashes. ListPlot[Table[{j, rearrangementIndex[hashes1[[j]]]}, {j, 1, 50}], Filling -> Axis] ![enter image description here][43] Let's make a second message that has one bit flipped, say at position 10. message2 = MapAt[1 - # &, message1, 10] {1, 1, 0, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1, 0, 1, 1, 0, 0, 1, 1, 0, 1, 0, 0, 1, 1, 0, 0, 0, 1, 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 0, 1, 0} message1 - message2 {0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0} The resulting particle movements look quite different. sP2 = stirringProcess[initialPositionsR, 1/2, 1/10, message2]; Graphics[{LightGray, Disk[], Thickness[0.001], Map[Function[c, {RandomColor[], BSplineCurve[c, SplineDegree -> 5]}], Transpose[N[Table[sP2[[j]], {j, 50}]]]]}] ![enter image description here][44] The edit distances between the two hash sequences increase quickly after the different bit is encountered. hashes2 = makeHash /@ sP2; ListPlot[Table[{j, EditDistance[hashes1[[j]], hashes2[[j]]]}, {j, 0, 50}], Filling -> Axis] ![enter image description here][45] Gilpin carried out many numerical experiments investigating how the hashes behave as a function of the hash length (number of particles), stirring time T, and message length. The next two examples change only the stirring time, and keep all other parameters: message, stirrer distance, initial particle distance. sP1B = stirringProcess[initialPositionsR, 1/2, 1/9, message1]; hashes1B = makeHash /@ sP1B; ListPlot[Table[{j, EditDistance[hashes1[[j]], hashes1B[[j]]]}, {j, 0, 50}], Filling -> Axis] ![enter image description here][46] With increasing stirring time, the edit distance between the hashes quickly increases. sP1C = stirringProcess[initialPositionsR, 1/2, 1/2, message1]; hashes1C = makeHash /@ sP1C; ListPlot[Table[{j, EditDistance[hashes1[[j]], hashes1C[[j]]]}, {j, 0, 50}], Filling -> Axis] ![enter image description here][47] Next, we use the phyllotaxis-like initial position from above with 200 particles. We also use a longer stirring time (T=1). message3 = RandomInteger[{0, 1}, 50] {0, 1, 0, 0, 1, 0, 0, 0, 0, 1, 0, 1, 0, 1, 0, 0, 0, 1, 1, 1, 0, 1, 1, 1, 1, 0, 0, 0, 1, 0, 1, 1, 0, 0, 1, 1, 0, 0, 1, 1, 1, 1, 1, 0, 0, 0,1, 0, 1, 0} sP3 = stirringProcess[sunflower[200, 9/10, 250], 1/2, 1, message3]; A plot of the 200 particle trajectories suggests a good mixing. Graphics[{LightGray, Disk[], Thickness[0.001], Map[Function[c, {RandomColor[], BSplineCurve[c, SplineDegree -> 5]}], Transpose[N[Table[sP3[[j]], {j, 50}]]]]}] ![enter image description here][48] Already after the first stir, the edit distance between the original hash and the one resulting after stirring is quite large. hashes3 = makeHash /@ sP3; ListPlot[Table[{j, EditDistance[hashes3[[1]], hashes3[[j]]]}, {j, 0, 50}], Filling -> Axis] ![enter image description here][49] We will end here. The interested reader can continue to model, stir a million times, count trajectory exchanges, and statistically analyze other aspects of the proposed hashing scheme from Gilpin's paper. PS: And one can compare with theoretical hashing probabilities for ideal hashes. Such as: draw \[ScriptCapitalN]s hashes from M! possible hashes. How many different hashes Subscript[\[ScriptCapitalN], U] does one draw in average? uniqueHashes[M_, \[ScriptCapitalN]s_] := M! (1 - (1 - 1/M!)^\[ScriptCapitalN]s) Plot3D[uniqueHashes[M, \[ScriptCapitalN]s], {M, 1, 60}, {\[ScriptCapitalN]s, 1, 1000}, MeshFunctions -> {#3 &}, PlotPoints -> 100, ScalingFunctions -> "Log", PlotRange -> All, WorkingPrecision -> 50, AxesLabel -> {Style["M", Italic], Style["\[ScriptCapitalN]s", Italic], Style["\!\(\*SubscriptBox[\(\[ScriptCapitalN]\), \(U\)]\)", Italic]}] ![enter image description here][50] For Ns≪M!, this becomes: Series[Mfac (1 - (1 - 1/Mfac)^\[ScriptCapitalN]s), {Mfac, ∞, 2}] /. Mfac -> M! // Simplify ![enter image description here][51] uniqueHashesApprox[M_, \[ScriptCapitalN]s_] := \[ScriptCapitalN]s - (\[ScriptCapitalN]s*(\[ScriptCapitalN]s - 1))/(2*M!) + (\[ScriptCapitalN]s*(\[ScriptCapitalN]s - 1)*(\[ScriptCapitalN]s - 2))/(6*M!^2) Here is a quick numerical modeling with a sample size of 100 from 6!=720 possible hashes. With[{M = 6, \[ScriptCapitalN]s = 100}, {Table[Length[ Tally[RandomChoice[Range[M!], \[ScriptCapitalN]s]]], {10000}] // Mean, uniqueHashes[M, \[ScriptCapitalN]s], uniqueHashesApprox[M, \[ScriptCapitalN]s]}] // N {93.407, 93.4267, 93.4369} I definitely suggest reading the whole paper, including the Supplementary Information. The notebook with all the code and visualizations is attached. [1]: https://www.pnas.org/doi/epdf/10.1073/pnas.1721852115 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-05-02at11.55.34AM.png&userId=20103 [3]: http://www.wgilpin.com/papers/gilpin_pnas_2018.pdf [4]: https://news.stanford.edu/2018/04/23/swirling-liquids-shed-light-bitcoin-works/ [5]: https://btcmanager.com/stanford-university-physicists-uncover-correlation-between-bitcoin-transactions-and-laws-of-nature/ [6]: https://www.cambridge.org/core/journals/journal-of-fluid-mechanics/article/stirring-by-chaotic-advection/7B32CACE61D5AD79077846D7ACF4A31E [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=61661.png&userId=20103 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=82192.png&userId=20103 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=40363.png&userId=20103 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=79744.png&userId=20103 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=59285.png&userId=20103 [12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=10756.png&userId=20103 [13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=34567.png&userId=20103 [14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=92028.png&userId=20103 [15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=19639.png&userId=20103 [16]: http://community.wolfram.com//c/portal/getImageAttachment?filename=385110.png&userId=20103 [17]: http://community.wolfram.com//c/portal/getImageAttachment?filename=341511.png&userId=20103 [18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=891612.png&userId=20103 [19]: http://community.wolfram.com//c/portal/getImageAttachment?filename=903513.png&userId=20103 [20]: http://community.wolfram.com//c/portal/getImageAttachment?filename=200714.png&userId=20103 [21]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1069415.png&userId=20103 [22]: http://community.wolfram.com//c/portal/getImageAttachment?filename=577216.png&userId=20103 [23]: http://community.wolfram.com//c/portal/getImageAttachment?filename=224217.png&userId=20103 [24]: http://community.wolfram.com//c/portal/getImageAttachment?filename=435818.png&userId=20103 [25]: http://community.wolfram.com//c/portal/getImageAttachment?filename=121819.png&userId=20103 [26]: http://community.wolfram.com//c/portal/getImageAttachment?filename=370620.png&userId=20103 [27]: http://community.wolfram.com//c/portal/getImageAttachment?filename=949421.png&userId=20103 [28]: http://community.wolfram.com//c/portal/getImageAttachment?filename=426622.png&userId=20103 [29]: http://community.wolfram.com//c/portal/getImageAttachment?filename=281923.png&userId=20103 [30]: http://community.wolfram.com//c/portal/getImageAttachment?filename=365024.png&userId=20103 [31]: http://community.wolfram.com//c/portal/getImageAttachment?filename=389825.png&userId=20103 [32]: http://community.wolfram.com//c/portal/getImageAttachment?filename=256626.png&userId=20103 [33]: http://community.wolfram.com//c/portal/getImageAttachment?filename=218327.png&userId=20103 [34]: http://community.wolfram.com//c/portal/getImageAttachment?filename=319828.png&userId=20103 [35]: http://community.wolfram.com//c/portal/getImageAttachment?filename=889929.png&userId=20103 [36]: http://community.wolfram.com//c/portal/getImageAttachment?filename=995130.png&userId=20103 [37]: http://community.wolfram.com//c/portal/getImageAttachment?filename=30s.png&userId=20103 [38]: http://community.wolfram.com//c/portal/getImageAttachment?filename=639031.png&userId=20103 [39]: http://community.wolfram.com//c/portal/getImageAttachment?filename=469232.png&userId=20103 [40]: http://community.wolfram.com//c/portal/getImageAttachment?filename=123233.png&userId=20103 [41]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1074134.png&userId=20103 [42]: http://community.wolfram.com//c/portal/getImageAttachment?filename=497035.png&userId=20103 [43]: http://community.wolfram.com//c/portal/getImageAttachment?filename=993836.png&userId=20103 [44]: http://community.wolfram.com//c/portal/getImageAttachment?filename=852637.png&userId=20103 [45]: http://community.wolfram.com//c/portal/getImageAttachment?filename=597938.png&userId=20103 [46]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1011739.png&userId=20103 [47]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1005540.png&userId=20103 [48]: http://community.wolfram.com//c/portal/getImageAttachment?filename=132941.png&userId=20103 [49]: http://community.wolfram.com//c/portal/getImageAttachment?filename=625642.png&userId=20103 [50]: http://community.wolfram.com//c/portal/getImageAttachment?filename=879343.png&userId=20103 [51]: http://community.wolfram.com//c/portal/getImageAttachment?filename=1026844.png&userId=20103 Michael Trott 2018-05-02T11:44:45Z https://community.wolfram.com/groups/-/m/t/127970 I am trying to find the equations and the solution to an equation that seems to have several names: Hodgkin-Huxley Cable Equation, Propogation Equation, Wave Equation.  I am looking for the equation and solution to the action potential as it goes down an axon in Mathematica code. I am stuck with being in a wheel chair and tied to oxygen thus I cannot get to a library.  I no longer work as a professor so I have no one to ask.  So I am stuck.  I would appreciate any help Thank you Jake Jake Trexel 2013-09-22T22:06:08Z https://community.wolfram.com/groups/-/m/t/2922562 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/aa9ac0c4-abff-46be-b3a4-0ada00a34d86 Sangdon Lee 2023-05-20T17:14:58Z 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/1313605 ##Motivation## Some time ago, my coworker Eila Stiegler was working on her [blog][1] about the cool [Marathon visualization website][2]. While doing so, she asked me if it is possible to make artistic word clouds, such as the one from the 2017 Champaign-Urbana marathon poster (that hangs on her office door) using the Wolfram Language . With only a few weeks until [this year's marathon][3] left, I will give this a try. ![enter image description here][4] That is an interesting problem—how to make such-type deformed dense letter arrangements in the Wolfram Language. This hand-made poster has many nice elements, e.g.: - the words are all contained in the outline of the [Alma Mater][5] - the characters fill out most of the space with smooth outlines, but the character is still recognizable (like in a CAPTCHA) - the characters of a given word are not all the same size, but the size varies smoothly along a word - the [Illini coloring][6] is correlated to the flow of the robe To keep this post at reasonable length, let's try to reproduce the first two features: a dense packing of characters that fills a given outer shape. Our overall approach will be the following: - make an initial word cloud (using WordCloud) within a given shape (the Alma Mater) - solve the diffusion equation (using NDSolve) to let the characters of the words diffuse/flow into the space between the words/characters and between the characters and the boundary of the outer shape - follow the boundaries of the letters under this diffusion process (again using NDSolve) The use of the diffusion equation to spread out areas was pioneered by [Gastner and Newman][7] in building cartograms in their cartogram algorithm. (Because we don't want to preserve the character weights/areas, we will use different boundary conditions.) If one imagines a liquid with time-and position-dependent concentrations n(t,x,y) of say ink, the ink will spread to a uniform distribution in the long time limit. In our case, the initial letters have a lot of ink and the space between the letters is ink-free. To follow a single ink molecule, one first solves the classical diffusion equation (with Subscript[c, D] being the diffusion coefficient) ![enter image description here][8] then defines the flow ![enter image description here][9] and then follows that path {x(x),y(t)} of a given inc molecule (in our case character boundary point) with initial position {$x_0,y_0$} through the nonlinear system of ordinary coupled differential equations. ![enter image description here][10] As hinted above, in our example, we will start with a high concentration of ink at the characters and follow the ink molecules that are at the edges of the characters over time. The individual characters will over time diffuse into the voids between them but they will not start overlapping. And the movement into the voids depends on the available space. So, we expect smooth curves as the boundaries of the spread-out letters. If we would say, use the wave equation instead, we would get interference effects from overlapping waves from the individual characters and the propagation would be uniform in each direction. The result will be the following: (click to play) [![enter image description here][11] ][12] ##The Alma Mater Outline## First we need an outline of the outer, word-confining shape. Using a photograph of the Alma Mater, we can quickly trace out the boundary. Show[ ImageTake[ Import["https://tinyurl.com/yd6dn242"], {220, -500}, {320, -320}], ImageSize -> 300] ![enter image description here][13] almaMater = {{761.7, 1432.}, {790.8, 1425.}, {832.7, 1417.}, {862.3, 1405.}, {900.7, 1388.}, {928.2, 1386.}, {946.5, 1364.}, {978.9, 1355.}, {989.5, 1340.}, {1031., 1324.}, {1068., 1333.}, {1094., 1333.}, {1075., 1325.}, {1068., 1321.}, {1108., 1296.}, {1102., 1290.}, {1088., 1297.}, {1099., 1285.}, {1093., 1269.}, {1076., 1268.}, {1071., 1262.}, {1034., 1286.}, {995.5, 1289.}, {1001., 1231.}, {990.4, 1183.}, {987.3, 1149.}, {970.6, 1133.}, {950.2, 1133.}, {929.3, 1126.}, {909., 1123.}, {882.1, 1127.}, {867.6, 1135.}, {854.8, 1148.}, {865.5, 1072.}, {874.2, 980.6}, {887.6, 848.7}, {897.3, 709.4}, {900.9, 629.1}, {906.5, 537.5}, {866.6, 528.8}, {857.9, 533.3}, {833.4, 528.7}, {814.1, 530.2}, {776.2, 535.9}, {747.6, 537.4}, {710.3, 532.3}, {675.2, 533.8}, {632.2, 530.7}, {607.7, 532.3}, {590.4, 528.7}, {558.3, 533.3}, {554.7, 619.4}, {563.4, 710.6}, {564.1, 825.9}, {568.2, 931.9}, {575.9, 1021.}, {574.4, 1114.}, {571.3, 1129.}, {542.1, 1120.}, {513., 1109.}, {495.2, 1113.}, {473.8, 1132.}, {457.9, 1176.}, {445.6, 1250.}, {444.1, 1280.}, {415.6, 1281.}, {385., 1262.}, {376.4, 1269.}, {361.7, 1269.}, {353.5, 1282.}, {350.4, 1292.}, {375.5, 1309.}, {358.6, 1320.}, {361.9, 1328.}, {390.9, 1314.}, {432.9, 1332.}, {458., 1345.}, {488.7, 1362.}, {486.7, 1371.}, {528.1, 1386.}, {555.8, 1396.}, {593.7, 1407.}, {639.6, 1421.}, {660., 1430.}, {678.8, 1431.}, {676.4, 1454.}, {676.3, 1463.}, {665.7, 1485.}, {657.6, 1487.}, {643.4, 1502.}, {643.5, 1532.}, {654.2, 1554.}, {670.4, 1580.}, {693.5, 1594.}, {726.7, 1588.}, {749.9, 1568.}, {766.9, 1542.}, {765.8, 1521.}, {761.2, 1504.}, {752.6, 1484.}, {748.2, 1473.}, {748.2, 1450.}, {747.5, 1440.}, {761.7, 1432.}}; Graphics[FilledCurve[BSplineCurve[almaMater]]] ![enter image description here][14] For the use in WordCloud, we make mask that is exactly this shape. Show[almaMaterPolygon = Rasterize[Graphics[Polygon[ Table[ Evaluate[BSplineFunction[almaMater, SplineDegree -> 2][t]] - {750, 1000}, {t, 0, 1, 1/200}]]], "Image", ImageSize -> 800], ImageSize -> 300] ![enter image description here][15] ##Making the Word Cloud of Marathon Words## Next, we collect a set of words that describe the Illinois Marathon. Making a web search for pages that mention the marathon event or the twin city might give us some suggestions for words to include. sites = Function[searchTerm, WebSearch[searchTerm, MaxItems -> 25]] /@ {"Illinois marathon", "Champaign marathon", "Urbana marathon", "Champaign-Urbana"}; urls = Union[Flatten[Normal[#[All, "Hyperlink"]] & /@ sites]]; Monitor[pageData = Table[Import[urls[[j, 1]]], {j, 1 Length[urls]}]; // Quiet, j] words = KeySelect[ Select[WordCounts[ DeleteStopwords[ StringJoin[Riffle[ToLowerCase[Cases[pageData, _String]], " "]]]], # >= 50 &], StringLength[#] > 2 &]; WordCloud[words, PlotTheme -> "Monochrome"] ![enter image description here][16] We include the word 'cold', as it was a fresh morning at last year's race. ![enter image description here][17] So, in the following we will use this list of words. words = {"Marathon", "26.2\[ThinSpace]miles", "42.195\[ThinSpace]km", "Champaign", "Urbana", "4\[ThinSpace]hours", "5\[ThinSpace]k", "10\[ThinSpace]k", "46112\[ThinSpace]y", "138336\[ThinSpace]ft", "Walk", "2017", "26\[ThinSpace]mi 385\[ThinSpace]y", "Battle of Marathon", "Half", "7\[ThinSpace]am", "\[TildeTilde]2,600\[ThinSpace]Cal", "9th Race", "Memorial Stadium", "Dick Beardsley", "Sunny", "Rainy", "Windy", "Cold", "Warm", "Fun", "9\[ThinSpace]min/mile", "490\[ThinSpace]BC", "Race", "Running", "Pheidippides", "April\[ThinSpace]21,22", "Pacers", "Christie", "Illinois", "Start", "Expo", "Alma Mater", "02:22:18", "Stadium", "Relay", "Olympic 1896", "Abe's Log", "BIB", "Race Street", "Green Street", "Boston Qualifier", "Winner"}; We use selected seed values to obtain a word cloud that has some words in the head and so that all characters are strictly contained in the Alma Mater. Different seeds will result in different-looking word clouds. SeedRandom[111] WordCloud[(RandomReal[{1, 2}] -> #) & /@ words, ColorNegate@almaMaterPolygon, WordOrientation -> {-Pi/3, Pi/3}, MaxItems -> \[Infinity], ColorFunction -> (Black &), FontSize -> {5, 15}, RandomSeeding -> 111] ![enter image description here][18] To avoid any dependence of the following calculations and visualisations, here is the word cloud that we want to use in the following (obtained with the seeds 35, 35). ![enter image description here][19] ![enter image description here][20] Here are the words from the word cloud within the Alma Mater. With[{d = ImageSize -> ImageDimensions[almaMaterPolygon]}, Overlay[{Show[almaMaterPolygon, d], Show[SetAlphaChannel[Show[wc1, d], Darker@ColorNegate[almaMaterPolygon]], d]}] // Rasterize[#, "Image", ImageSize -> 400] &] ![enter image description here][21] ##Build a Region-object for the Words in the Alma Mater## As we want to solve the diffusion equation, we build a region-object to use in the numerical differential equation solver. We want the characters to have a high initial value and have the characters flow out. To get a good numerical solution, we want a fine grid near the boundaries of the characters that form the words. We load the FEM package to have such useful functions such as ToElementMesh at our disposal. Needs["NDSolve`FEM`"] The characters from the word cloud taken out. Using a larger image size will give later smoother-looking characters. But it will also increase the computation time. Show[im = ImageMesh[ras = Rasterize[wc1, "Image", ImageSize -> 800]], Frame -> True] ![enter image description here][22] The Alma Mater region mask: Show[im2 = ImageMesh[ImageResize[almaMaterPolygon, ImageDimensions[ras]]], Frame -> True] ![enter image description here][23] And here are the characters taken out of the Alma Mater region. im3 = RegionDifference[im, im2] ![enter image description here][24] Next, we build the triangulated version for use in the PDE solving. We see the fine triangulation near the character boundaries that we want for an accurate solution of the PDE. holes = im3["RegionHoles"]; (em = ToElementMesh[RegionBoundary[im3], "RegionMarker" -> ({#, 0, 1} & /@ holes), "MaxCellMeasure" -> 100])[ "Wireframe"] /. {e_EdgeForm :> EdgeForm[{Black, Thickness[0.0001]}]} ![enter image description here][25] The corresponding mesh region. mr = MeshRegion[em] ![enter image description here][26] And these are the meshed versions of the individual characters. outer = Rectangle @@ Transpose[RegionBounds[im]]; Show[allChars = RegionDifference[outer, im] // DiscretizeRegion[#, MaxCellMeasure -> 5] &, Frame -> True] ![enter image description here][27] Length[chars = ConnectedMeshComponents[allChars]] > 371 Right now, about 21 % of the area of the Alma Mater are occupied by the characters. Quantity[100 Total[Area /@ chars]/Area[mr], "Percent"] // NumberForm[#, 4] & > 21.22% ##Colors the Words of the Word Cloud## We want to color each word individually. By overlaying the region characters with the original word cloud, we identify which characters belong to the same word. We use standard [Illini colors][28]. uOfIColors = {RGBColor[19/255, 31/255, 51/255], RGBColor[250/255, 99/255, 0/255]}; SeedRandom[25]; Show[rasC = Rasterize[wc1 /. GrayLevel[0] :> Blend[uOfIColors, RandomReal[]], "Image", ImageSize -> 800], ImageSize -> 300] ![enter image description here][29] imC = Reverse@ImageData[rasC]; getColor[cm_] := Module[{xMin, xMax, yMin, yMax, reg, points, ccs}, {{xMin, xMax}, {yMin, yMax}} = RegionBounds[cm] ; reg = RegionMember[cm]; points = Cases[Table[ If[reg[{x, y}], {x, y}, Null], {x, Floor[xMin], Ceiling[xMax]}, {y, Floor[yMin], Ceiling[yMax]}], {_, _}, {-2}]; (* majority color *) ccs = DeleteCases[Reverse[SortBy[Tally[ imC[[Sequence @@ Reverse[#]]] & /@ points], Last]], {{1.`, 1.`, 1.`}, _}]; ccs[[1]]] Monitor[charColors = Table[getColor[chars[[j]]], {j, Length[chars]}];, j] Here are the characters, as regions, colored. Show[Table[ Region[chars[[j]], BaseStyle -> {RGBColor @@ charColors[[j, 1]]}], {j, Length[chars]}]] ![enter image description here][30] ##Make Triangles and Region Functions## We extract the triangles from the mesh for the construction of the initial conditions that will be needed in the next section. triangles = (MeshPrimitives[mr, 2] /. Region`Mesh`Quadratic[Polygon[{p1_, p2_, p3_, ___}]] :> Polygon[{p1, p2, p3}]); We have about 240k triangles in our FEM mesh. Length[triangles] > 243642 We calculate the areas and centroids of these triangles. {centroids, areas} = Transpose[{RegionCentroid[#], Area[#]} & /@ Take[triangles, All]]; Here is a distribution of the sizes of the triangles from the mesh. Histogram[areas, 5000] ![enter image description here][31] rb = RegionBoundary[mr]; rd = RegionDistance[allChars]; srd = SignedRegionDistance[mr]; ##Reconstructing Deformed Characters from Their Boundary Points## As a small intermezzo, and because we will need it later anyway, we implement a function that given a 2D mesh region and a function that maps these points to new (evolved) points, builds filled curves. We do need this function because we want smoothed boundaries and filling of our character outlines. Most of the code deals with detecting interior holes and the order of the points. If we have characters with 'holes' (e.g. A, B), we will actually draw multiple filled curves. First we will draw the outermost one, and then the inner holes with the color of the outer environment on top. makeClosedCurve[mr_MeshRegion, f_] := Module[{coords, newCoords, lines, gr, orderPoints, fun}, coords = MeshCoordinates[mr]; newCoords = f /@ coords; lines = MeshCells[mr, 1] /. Region`Mesh`Quadratic[Line[{p1_, p2_, _}]] :> Line[{p1, p2}]; (* order points *) gr = Graph[UndirectedEdge @@@ lines[[All, 1]]]; orderPoints = FindHamiltonianPath[gr]; fun = BSplineFunction[Append[#, First[#]] &@newCoords[[orderPoints]], SplineDegree -> 3 (* could use SplineClosed \[Rule] True *)]; Line[Table[fun[s], {s, 0, 1, 1/360}]] ] makeFilledCurve[mr_MeshRegion, f_, {col1_, col2_}] := Module[{cmcs, cmcs3}, cmcs = ConnectedMeshComponents[RegionBoundary[mr]]; Which[Length[cmcs] === 1, {col1, FilledCurve[{makeClosedCurve[cmcs[[1]], f]}]}, Length[cmcs] > 1, cmcs3 = Reverse[SortBy[cmcs, ArcLength]]; {col1, FilledCurve[ makeClosedCurve[cmcs3[[1]], f]], col2, FilledCurve[makeClosedCurve[#, f]] & /@ Rest[cmcs3]} ]] Two examples. With and without holes. {Graphics[makeFilledCurve[chars[[5]], Identity, {Red, Blue}]], Graphics[makeFilledCurve[chars[[5]], -CubeRoot[#] &, {Red, Blue}]]} ![enter image description here][32] {Graphics[makeFilledCurve[chars[[1]], Identity, {Red, Blue}]], Graphics[makeFilledCurve[chars[[1]], -CubeRoot[#] &, {Red, Blue}]]} ![enter image description here][33] ##Construct the Initial Conditions for the Diffusion Equation## To get some kind of randomness, we construct a random wavy function that determines the initial height of the characters. The height represents the initial 'ink concentration'. This means by using different concrete realizations of the function wavy will result in different final diffused word clouds. Here is a plot of the initial concentration within the bounding rectangle as well as in the Alma Mater. SeedRandom[40]; wavy[{x_, y_}] = With[{S = 1000, M = 12}, Sum[RandomReal[{-1, 1}] Cos[x/S RandomReal[{-M, M}] + 2 Pi RandomReal[]] Cos[ y/S RandomReal[{-M, M}] + 2 Pi RandomReal[]], {6}]^2]; {Plot3D[wavy[{x, y}], {x, 300, 1100}, {y, 530, 1600}, MeshFunctions -> {#3 &}, PlotPoints -> 40, PlotRange -> All, BoxRatios -> {758, 1065, 300}, ImageSize -> 360], Plot3D[wavy[{x, y}], {x, y} \[Element] Polygon[almaMater], MeshFunctions -> {#3 &}, PlotPoints -> 40, PlotRange -> All, BoxRatios -> {758, 1065, 300}, ImageSize -> 360]} ![enter image description here][34] triangleIntegrate[f_] := (f /@ centroids).areas maxDist = 190; We will construct such initial conditions, that the total concentration of the characters equals the (negative) concentration in all the space between the characters. This will allow for a nice filling flow, without flowing out of the outer region. We avoid sharp corners in the initial conditions and smooth the concentration at the boundaries of the characters. (* area of the characters and their smoothed boundaries *) H1[{x_Real, y_Real}] := With[{d = rd[{x, y}], ? = 3}, wavy[{x, y}] Which[d == 0, 1, d > ?, 0, True, Cos[d/? Pi/2]^2]] ?m = triangleIntegrate[H1] > 124522. (* area between the characters *) H2[{x_Real, y_Real}] := With[{d = rd[{x, y}], ? = 3, d2 = -srd[{x, y}]}, Which[d == 0, 0, d <= ?, 0 Cos[d/? Pi/2]^2, d >= ?, Sin[d2/maxDist Pi/2]^.5]] ?2m = triangleIntegrate[H2] > 108853. factorB = B /. Solve[?m == B ?2m, B][[1]] > 1.14395 We compensate the positive concentration of the characters with a negative one between the characters. We do shape the negative concentration in a bathtub-shaped like manner with the value zero at the boundary. H3[{x_Real, y_Real}] := With[{d = rd[{x, y}], ? = 3, d2 = -srd[{x, y}]}, Which[d == 0, wavy[{x, y}], d <= ?, wavy[{x, y}] Cos[d/? Pi/2]^2, True, -factorB Abs[Sin[d2/maxDist Pi/2]]^.5]] The integrals of the positive and negative concentrations even out to a high degree. triangleIntegrate[H3] > -1.45519*10^-11 Here is a plot of the initial concentration for the diffusion equation within the Alma Mater. Plot3D[Evaluate[H3[{x, y}]], {x, y} ? em, PlotRange -> All, MeshFunctions -> {#3 &}, PlotPoints -> 80, ImageSize -> 500] ![enter image description here][35] ##Deciding on the Boundary Conditions ## To solve the diffusion equation, we also need boundary conditions of the domain (at the boundary of the Alma Mater). To decide between Dirichlet and Neumann conditions, we solve a simple 1D model. The two gray lines show the path of the two points at the edge of the initial concentration bump. Manipulate[ Module[{nds, U, V}, nds = NDSolveValue[{If[method == "Neumann", D[U[t, x], t] - D[U[t, x], {x, 2}] == NeumannValue[v, True], Sequence @@ {D[U[t, x], t] - D[U[t, x], {x, 2}] == 0, DirichletCondition[U[t, x] == v, True]}], U[0, x] == If[Abs[x] < Pi/2, H Cos[x]^2, 1]}, U , {x, -Pi, Pi}, {t, 0, 5}, Method -> {"PDEDiscretization" -> {"MethodOfLines", "SpatialDiscretization" -> { "FiniteElement", "MeshOptions" -> {"MaxCellMeasure" -> 0.01}}}}]; V = Function[{t, x}, Evaluate[D[nds[t, x], x]/nds[t, x]]]; With[{nds1 = nds, V1 = V}, Manipulate[ Module[{nds2R, nds2L}, Column[{Plot[nds1[?, ?], {?, -Pi, Pi}, AxesLabel -> {Style["x", Italic], Style["u", Italic]}, PlotLabel -> Row[{Style["t", Italic], "=", ?}]], Plot3D[nds1[s, ?], {?, -Pi, Pi}, {s, 0, ?}, MeshFunctions -> {#3 &}, AxesLabel -> {Style["x", Italic], Style["t", Italic], Style["u", Italic]} ], nds2R = NDSolveValue[{X'[s] == V1[s, X[s]], X[0] == +Pi/2}, X, {s, 0, ?}]; nds2L = NDSolveValue[{X'[s] == V1[s, X[s]], X[0] == -Pi/2}, X, {s, 0, ?}]; ParametricPlot[ Evaluate[{{nds2L[s], s}, {nds2R[s], s}}], {s, 0, ?}, AxesLabel -> {Style["x", Italic], Style["t", Italic]}, PlotStyle -> Gray, AspectRatio -> 1/GoldenRatio, PlotRange -> {{-Pi, Pi}, All}] }]], {{?, 1}, 0, 5, Appearance -> "Labeled"}, TrackedSymbols :> {?}]]], {{method, "Neumann"}, {"Neumann", "Dirichlet"}}, {{v, 1, "boundary condition value"} , -3, 3, Appearance -> "Labeled"}, {{H, 2, "initial bump height"}, -3, 3, Appearance -> "Labeled"}, TrackedSymbols :> {method, v, H}, SaveDefinitions -> True] ![enter image description here][36] After some playing around one sees that Neumann boundary conditions with positive values seem to be a good choice to spread out the concentration out up to the outer boundary. ##Solve the Diffusion Equation with Neumann Boundary Conditions## Now we solve the diffusion equation numerically. An appropriate value for the diffusion coefficient Subscript[c, D] and corresponding total integration time t can be found after some experimentation or some crude estimation based on the classic formula $?|{x,y}|^2??4c_Dt.$ cD = 50; uSolN = NDSolveValue[{D[n[t, x, y], t] - cD Laplacian[n[t, x, y], {x, y}] == NeumannValue[1, True], n[0, x, y] == 1 + H3[{x, y}]}, n, {x, y} ? em, {t, 0, 100}, PrecisionGoal -> 5] // Quiet ![enter image description here][37] Here are a few plots of the concentration at various times (we show the concentration for t=0.01, t=0.5, t=5, and t=50). With increasing time the concentration differences even out. And the character shapes slowly disappear. concentrationPlot[t_] := Plot3D[Evaluate[uSolN[t, x, y]], {x, y} \[Element] em, PlotRange -> All, MeshFunctions -> {#3 &}, PlotPoints -> 80, ImageSize -> 500] concentrationPlot[0.01] ![enter image description here][38] concentrationPlot[0.5] ![enter image description here][39] concentrationPlot[5] ![enter image description here][40] concentrationPlot[50] ![enter image description here][41] ##Calculate the Flow Field## But we are not interested in the concentration itself, but rather in the integrals of the flow of the concentration. The flow vector field can be easily obtained by differentiating the interpolating function that represents the diffusion equation solution with respect to the coordinates. vX[t_, x_Real, y_Real] = -D[uSolN[t, x, y], x]/uSolN[t, x, y] ![enter image description here][42] vY[t_, x_Real, y_Real] = -D[uSolN[t, x, y], y]/uSolN[t, x, y] ![enter image description here][43] Here is a plot of the direction of the flow at t=0.1 and at the much later time t=10. Each color represent a flow direction. colF = If[# == 10, White, ColorData["VisibleSpectrum"][380 + 370 (#1 + Pi)/(2 Pi)]] &; vectorGrid[T_] := With[{t = T, pp = 800}, Monitor[ Table[If[srd[{x, y}] >= 0, 10, ArcTan[vX[t, 1. x, 1. y], vY[t, 1. x, 1. y]]], {y, 0, 1100, 1100/pp}, {x, 0, 800, 800/pp}], N[y]]] /. Indeterminate -> 0. ReliefPlot[vectorGrid[0.1], ColorFunction -> colF, ColorFunctionScaling -> False, AspectRatio -> Automatic, Frame -> False] ![enter image description here][44] ReliefPlot[vectorGrid[10], ColorFunction -> colF, ColorFunctionScaling -> False, AspectRatio -> Automatic, Frame -> False] ![enter image description here][45] Here is a line integral convolution plot that shows the flow at some early time. vectors = With[{t = 0.1, pp = 600}, Monitor[ Table[If[ srd[{x, y}] > 0, {0, 0}, {vX[t, 1. x, 1. y], vY[t, 1. x, 1. y]}], {y, 0, 1100, 1100/pp}, {x, 0, 800, 800/pp}], N[y]]]; ListLineIntegralConvolutionPlot[Map[Normalize, Transpose@vectors, {2}], PerformanceGoal -> "Quality", RasterSize -> 600, LineIntegralConvolutionScale -> 20, AspectRatio -> 11/8, Frame -> False] ![enter image description here][46] ##Diffuse the Characters of the Words## For a few characters (M=20), we calculate their time evolution under the diffusion. To be time-efficient, we only diffuse/propagate the boundary points, rather than all interior points. The above-defined function makeFilledCurve will then reconstruct the full character. We use the "StiffnessSwitching" option for calculating along the flow lines to avoid getting stuck at potential abrupt function value changes. M = 20; Monitor[ ptsA = Table[pts = MeshPrimitives[RegionBoundary[chars[[m]]], {0}]; ? = Length[pts]; Table[NDSolveValue[{x'[t] == cD vX[t, x[t], y[t]], y'[t] == cD vY[t, x[t], y[t]], x[0] == pts[[j, 1, 1]], y[0] == pts[[j, 1, 2]]}, {x[t], y[t]}, {t, 0, 80}, PrecisionGoal -> 3, StartingStepSize -> 10^-4, MaxSteps -> 10000, Method -> "StiffnessSwitching"] , {j, ?}], {m, M}], {m, {j, ?}}]; Some examples of the propagated/diffused boundaries of the characters. The points of the boundaries are connected by line segments. To obtain smoother-looking curves, we will use splines in the final graphics. Early times are blue and later times are more red-like. The expansion of the characters is clearly visible. Table[Show[Table[MeshRegion[ptsA[[k]] /. t -> 10^?, Style[MeshCells[RegionBoundary[chars[[k]]], 1], ColorData["ThermometerColors"][(? + 3)/5]]], {?, -3, 1, 0.1}], ImageSize -> 140], {k, 9}] ![enter image description here][47] The following Manipulate allows to change the time, and so the character shape, interactively. Manipulate[ Show[Table[ MeshRegion[ptsA[[m]] /. t -> ?, MeshCells[RegionBoundary[chars[[m]]], 1]], {m, M}], PlotRange -> {{100, 800}, {100, 1000}}, ImageSize -> 400] // Quiet, {?, 0, 50}] ##Make the Dense Word Cloud(s)## Now we have all ingredients together to make a dense word cloud. We define a function that diffuses/propagates a point forward in time. diffusionMove[{x0_, y0_}, T_] := #[T] & /@ NDSolveValue[{x'[t] == cD vX[t, x[t], y[t]], y'[t] == cD vY[t, x[t], y[t]], x[0] == x0, y[0] == y0}, {x, y}, {t, T, T}, MaxStepSize -> 0.1, PrecisionGoal -> 3, StartingStepSize -> 10^-4, MaxSteps -> 500000, Method -> "StiffnessSwitching"] outline = makeClosedCurve[RegionBoundary[mr], Identity]; rnA = RegionNearest[RegionBoundary@mr]; fix[{x_, y_}] := If[srd[{x, y}] <= 0, {x, y}, rnA[{x, y}]] fix[Line[l_]] := Line[fix /@ l] The function makeFlowImage generates a word cloud of the diffused-out characters at time t. makeFlowImage[T_] := Module[{mfc}, Monitor[ allCharsD = Table[Check[mfc = makeFilledCurve[chars[[k]], diffusionMove[#, T] &, {RGBColor @@ charColors[[k, 1]], LightBlue}], mfc /. l_Line :> fix[l]], {k, Length[chars]}];, Text@Row[{"Calculating diffusion shape for character ", k, " from ", Length[chars], " characters."}]]; Graphics[{LightBlue, FilledCurve[outline], Black, outline, allCharsD}, ImageSize -> 600]]; Looping over all boundary points of all characters shows how the characters spread out over time and fill the void to the Alma Mater boundary and between the characters and words. Here are the outlines of the characters at various times. makeFlowImage[0.5] ![enter image description here][48] makeFlowImage[1] ![enter image description here][49] makeFlowImage[5] ![enter image description here][50] makeFlowImage[10] ![enter image description here][51] makeFlowImage[20] ![enter image description here][52] makeFlowImage[50] ![enter image description here][53] makeFlowImage[100] ![enter image description here][54] [1]: http://blog.wolfram.com/2018/01/18/running-the-numbers-with-the-illinois-marathon-viewer/ [2]: https://www.wolframcloud.com/objects/marathon/IL/Champaign/2017/MarathonViewer [3]: http://illinoismarathon.com/ [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=43611.png&userId=20103 [5]: https://en.wikipedia.org/wiki/Alma_Mater_%28Illinois_sculpture%29 [6]: http://fightingillini.com/sports/2015/11/10/traditions_orangeandblue.aspx [7]: http://www.pnas.org/content/101/20/7499.full [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=61732.png&userId=20103 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=90303.png&userId=20103 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=70474.png&userId=20103 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=9013ScreenShot2018-04-02at13.00.56.png&userId=20103 [12]: https://www.youtube.com/watch?v=7ioYnpeHBJE&feature=youtu.be [13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=43165.png&userId=20103 [14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=74246.png&userId=20103 [15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=63597.png&userId=20103 [16]: http://community.wolfram.com//c/portal/getImageAttachment?filename=42148.png&userId=20103 [17]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-04-02at10.13.07.png&userId=20103 [18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=96899.png&userId=20103 [19]: http://community.wolfram.com//c/portal/getImageAttachment?filename=x1.png&userId=20103 [20]: http://community.wolfram.com//c/portal/getImageAttachment?filename=824510.png&userId=20103 [21]: http://community.wolfram.com//c/portal/getImageAttachment?filename=678711.png&userId=20103 [22]: http://community.wolfram.com//c/portal/getImageAttachment?filename=612512.png&userId=20103 [23]: http://community.wolfram.com//c/portal/getImageAttachment?filename=606313.png&userId=20103 [24]: http://community.wolfram.com//c/portal/getImageAttachment?filename=666514.png&userId=20103 [25]: http://community.wolfram.com//c/portal/getImageAttachment?filename=808015.png&userId=20103 [26]: http://community.wolfram.com//c/portal/getImageAttachment?filename=669516.png&userId=20103 [27]: http://community.wolfram.com//c/portal/getImageAttachment?filename=610517.png&userId=20103 [28]: http://identitystandards.illinois.edu/graphicstandardsmanual/generalguidelines/colors.html [29]: http://community.wolfram.com//c/portal/getImageAttachment?filename=648518.png&userId=20103 [30]: http://community.wolfram.com//c/portal/getImageAttachment?filename=952619.png&userId=20103 [31]: http://community.wolfram.com//c/portal/getImageAttachment?filename=232920.png&userId=20103 [32]: http://community.wolfram.com//c/portal/getImageAttachment?filename=972621.png&userId=20103 [33]: http://community.wolfram.com//c/portal/getImageAttachment?filename=741422.png&userId=20103 [34]: http://community.wolfram.com//c/portal/getImageAttachment?filename=320623.png&userId=20103 [35]: http://community.wolfram.com//c/portal/getImageAttachment?filename=278824.png&userId=20103 [36]: http://community.wolfram.com//c/portal/getImageAttachment?filename=865425.png&userId=20103 [37]: http://community.wolfram.com//c/portal/getImageAttachment?filename=243726.png&userId=20103 [38]: http://community.wolfram.com//c/portal/getImageAttachment?filename=179227.png&userId=20103 [39]: http://community.wolfram.com//c/portal/getImageAttachment?filename=766428.png&userId=20103 [40]: http://community.wolfram.com//c/portal/getImageAttachment?filename=468129.png&userId=20103 [41]: http://community.wolfram.com//c/portal/getImageAttachment?filename=166030.png&userId=20103 [42]: http://community.wolfram.com//c/portal/getImageAttachment?filename=388031.png&userId=20103 [43]: http://community.wolfram.com//c/portal/getImageAttachment?filename=285132.png&userId=20103 [44]: http://community.wolfram.com//c/portal/getImageAttachment?filename=637133.png&userId=20103 [45]: http://community.wolfram.com//c/portal/getImageAttachment?filename=181734.png&userId=20103 [46]: http://community.wolfram.com//c/portal/getImageAttachment?filename=115535.png&userId=20103 [47]: http://community.wolfram.com//c/portal/getImageAttachment?filename=445136.png&userId=20103 [48]: http://community.wolfram.com//c/portal/getImageAttachment?filename=981937.png&userId=20103 [49]: http://community.wolfram.com//c/portal/getImageAttachment?filename=793338.png&userId=20103 [50]: http://community.wolfram.com//c/portal/getImageAttachment?filename=985739.png&userId=20103 [51]: http://community.wolfram.com//c/portal/getImageAttachment?filename=365640.png&userId=20103 [52]: http://community.wolfram.com//c/portal/getImageAttachment?filename=729441.png&userId=20103 [53]: http://community.wolfram.com//c/portal/getImageAttachment?filename=496942.png&userId=20103 [54]: http://community.wolfram.com//c/portal/getImageAttachment?filename=471943.png&userId=20103 Michael Trott 2018-04-02T16:52:14Z https://community.wolfram.com/groups/-/m/t/355110 Imagine you have an irregular image like this: ![enter image description here][1] How would you solve a differential equation or compute an integral over a region of this shape? First, let's get the boundary: i = Import["http://wolfr.am/ZS7ERg"]; edge = EdgeDetect[ColorNegate[i]] ![enter image description here][2] It is now easy to extract points with `Position` but how to order them inside `Polygon` correctly along the boundary? Using `FindShortestTour`! - a trick I learned from this excellent post: [Find polygons corresponding to image borders][3] reg = MeshRegion[#, Polygon[Last[FindShortestTour[#]]]] &@ Position[ImageData[edge], 1] ![enter image description here][4] Now we are ready to have fun: Plot3D[Cos[.0002 ((x - 215)^2 + (y - 215)^2)]^2, {x, y} \[Element] reg, Mesh -> None, Filling -> -3, FillingStyle -> Red, PlotRange -> All, BoxRatios -> {1, 1, 1/3}] ![enter image description here][5] uif = NDSolveValue[{\!\(\*SubsuperscriptBox[\(\[Del]\), \({x, y}\), \(2\)]\(u[x, y]\)\) == 0, DirichletCondition[u[x, y] == 1/2 + Sin[.0001 x y] , True]}, u, {x, y} \[Element] reg]; ContourPlot[uif[x, y], {x, y} \[Element] reg, PlotPoints -> 50, ContourStyle -> Opacity[.2], Contours -> 50, ColorFunction -> "Rainbow"] ![enter image description here][6] [1]: /c/portal/getImageAttachment?filename=sdfgewr456.png&userId=11733 [2]: /c/portal/getImageAttachment?filename=sdfgghr678596454.png&userId=11733 [3]: http://community.wolfram.com/groups/-/m/t/235551 [4]: /c/portal/getImageAttachment?filename=sdfs4563gndfgert.png&userId=11733 [5]: /c/portal/getImageAttachment?filename=asdas2343254678656fdgsdas.png&userId=11733 [6]: /c/portal/getImageAttachment?filename=345dfg54tgdfg456tdsf.png&userId=11733 Vitaliy Kaurov 2014-09-25T18:50:52Z https://community.wolfram.com/groups/-/m/t/3137899 I have a real-valued function of four variables, namely $L[\phi, m0, m1, m2]$. I am interested in taking the partial derivative $\partial_{\phi}L$ thereof and setting the partial derivative to zero, that is $\partial_{\phi}L = 0$. Then solving for $\phi \in [0,2\pi]$ in terms of $m0, m1, m2 \in \mathbb{N}_{0}$. I have reached the point in the attached code where I have generated the partial derivative $\partial_{\phi}L$, but I am having difficulty setting the partial derivative to zero and getting an analytic expression for $\phi$ in terms of the other variables $m0,~m1$ and $m2$. Please advise if there is a clear way of doing this analytically and numerically. &[Wolfram Notebook][1] Just a note that the function $L[\phi, m0, m1, m2]$ is defined in terms of probabilities $P1, P2$ and $P3$, hence it has a real-valued output for any $\phi \in \mathbb{R}$. Link to [related Mathematica SE post][2]. [1]: https://www.wolframcloud.com/obj/8a8e8c5b-b040-4954-bc13-f6fd943d5026 [2]: https://mathematica.stackexchange.com/questions/300241/solving-multivariable-equation-after-setting-partial-derivative-to-zero?noredirect=1#comment739470_300241 Byron Alexander 2024-03-09T14:21:21Z https://community.wolfram.com/groups/-/m/t/932742 I just upgraded to Mathematica 11.0.1 and ran into a problem with NSolve. The following simplified example illustrates it: NSolve[ 2 x == 0, x] This returns {{}} Anyone else having this problem? I am running Mathematica on Ubuntu 16.04 64 bit. Gijsbert Gijsbert Wiesenekker 2016-10-02T19:01:41Z https://community.wolfram.com/groups/-/m/t/3499774 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/3ee8e0d5-9a50-4ab1-9f50-db5a5f804d17 David Keith 2025-07-10T18:06:30Z https://community.wolfram.com/groups/-/m/t/2466894 *MODERATOR NOTE: a submission to computations art contest, see more:* https://wolfr.am/CompArt-22 *check the particle's point of view version here:* https://community.wolfram.com/groups/-/m/t/2543566 ![enter image description here][1] > YouTube video: https://youtu.be/DI504zatHCI > Twitter post: https://twitter.com/bencbartlett/status/1440039445261029377 > Math animations collection: https://muon.people.stanford.edu/math-animations &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ezgif-3-3cf45e6291.gif&userId=20103 [2]: https://www.wolframcloud.com/obj/38e945bc-a797-4c7f-844a-1ebceb6b150a Ben Bartlett 2022-02-08T18:42:06Z https://community.wolfram.com/groups/-/m/t/2153362 *Wolfram notebook is attached at the end of the post.* ---------- ![enter image description here][1] This post is about FEM simulation of violin vibration modes in 3D. As well known there are Helmholtz resonances of air inside the violin body with frequencies dependent on geometry of f-holes. This is the main reason why violin has so pronounced sound. To simulate these modes with Mathematica FEM we first define the body geometry (this is my design with given volume and area of f-holes, but it taken from the real violin): xy = {{3.805405405405406`,3.34954954954955`},{3.8252252252252257`,6.6990990990991`},{3.9441441441441443`,7.9081081081081095`}, {4.47927927927928`,8.601801801801802`},{5.014414414414414`,8.264864864864865`},{4.816216216216216`,7.8882882882882885`}, {4.895495495495496`,7.630630630630631`},{5.232432432432433`,7.432432432432433`},{5.47027027027027`,7.491891891891892`}, {5.648648648648649`,7.8882882882882885`},{5.668468468468468`,8.046846846846847`},{5.56936936936937`,8.403603603603605`}, {5.252252252252252`,8.681081081081082`},{4.855855855855856`,8.780180180180182`},{4.518918918918919`,8.8`}, {3.9639639639639643`,8.522522522522523`},{3.567567567567568`,7.967567567567568`},{3.3693693693693696`,7.372972972972973`}, {3.2306306306306305`,6.67927927927928`},{3.1513513513513516`,3.3693693693693696`},{3.1513513513513516`,2.655855855855856`}, {2.9729729729729732`,1.783783783783784`},{2.8738738738738743`,1.4666666666666668`},{2.100900900900901`,0.7927927927927928`}, {1.7243243243243245`,1.3081081081081083`},{2.021621621621622`,1.7639639639639642`},{2.0414414414414415`,2.0414414414414415`}, {1.9621621621621623`,2.23963963963964`},{1.6648648648648652`,2.4378378378378383`},{1.4666666666666668`,2.5171171171171176`}, {1.10990990990991`,2.338738738738739`},{0.891891891891892`,1.9423423423423425`},{0.9315315315315316`,1.4072072072072073`}, {1.5657657657657658`,0.7927927927927928`},{2.081081081081081`,0.6342342342342343`},{2.5963963963963965`,0.7927927927927928`}, {3.0918918918918923`,1.2090090090090093`},{3.5081081081081082`,1.902702702702703`},{3.706306306306306`,2.6954954954954955`}}; reg1 = RegionUnion[Disk[{0, 19.5/2}, 19.5/2], Disk[{0, 36 - 15.5/2}, 15.5/2], Rectangle[{-10, 15}, {10, 25}]]; reg2 = RegionDifference[reg1, RegionUnion[Disk[{-10, 20}, 9.5/2], Disk[{10, 20}, 9.5/2]]]; c0 = {0, 36 - 15.5/2}; c1 = {7.03562, 25}; f[x_] := c0[[2]] + x (c1[[2]] - c0[[2]])/(c1[[1]] - c0[[1]]); r1 = Norm[c1 - {10, f[10]}]; reg3 = RegionDifference[reg2, Disk[{10, f[10]}, r1]]; f1[x_] := c0[[2]] - x (c1[[2]] - c0[[2]])/(c1[[1]] - c0[[1]]); reg4 = RegionDifference[reg3, Disk[{-10, f1[-10]}, r1]]; c10 = {0, 19.5/2}; c11 = {8.215838362577491`, 15}; f11[x_] := c10[[2]] + x (c11[[2]] - c10[[2]])/(c11[[1]] - c10[[1]]); r2 = Norm[c11 - {10, f11[10]}]; reg5 = RegionDifference[reg4, Disk[{10, f11[10]}, r2]]; f12[x_] := c10[[2]] - x (c11[[2]] - c10[[2]])/(c11[[1]] - c10[[1]]); reg6 = RegionDifference[reg5, Disk[{-10, f12[-10]}, r2]]; p6 = RegionPlot[reg6, AspectRatio -> Automatic]; fh[xf_, yf_] := RegionUnion[ Polygon[Table[{xy[[i, 1]] - xf, xy[[i, 2]] + yf}, {i, Length[xy]}]], Polygon[Table[{-xy[[i, 1]] + xf, xy[[i, 2]] + yf}, {i, Length[xy]}]]]; General view of the violin body from the front and back side Show[p6, Graphics[fh[7, 12], AspectRatio -> Automatic]] dz = 3.79; reg8 = ImplicitRegion[Element[{x, y}, reg6] && 0 <= z <= dz, {x, y, z}]; mesh3d1 = DiscretizeRegion[reg8, {{-10, 10}, {0, 36}, {0, dz}}] ![Figure 1][2] Next step is the computation of air modes in the violin body with using ` NDEigensystem[]` as follows ca = 34321(*T=20C*); L = -Laplacian[u[x, y, z], {x, y, z}]; {vals, funs} = NDEigensystem[{L, DirichletCondition[u[x, y, z] == 0, Element[{x, y}, fh[7, 11.49]] && z == dz]}, u, Element[{x, y, z}, mesh3d1], 15]; Finally we visualize first 5 modes and the main mode in 3D {Table[DensityPlot[funs[[i]][x, y, dz/2], {x, -10, 10}, {y, 0, 36}, PlotRange -> All, PlotLabel -> ca Sqrt[vals[[i]]]/(2 Pi), ColorFunction -> "Rainbow", AspectRatio -> Automatic], {i, 1, 5}], DensityPlot3D[ funs[[1]][x, y, z], {x, -10, 10}, {y, 0, 36}, {z, 0, dz}, PlotRange -> All, PlotLabel -> ca Sqrt[vals[[1]]]/(2 Pi), ColorFunction -> "Rainbow", AspectRatio -> Automatic, PlotLegends -> Automatic, PlotPoints -> 100, BoxRatios -> Automatic, OpacityFunction -> None, Boxed -> False]} ![Figure 2][3] Therefore the first mode of 440.033 Hz is close to "A4" (440 Hz) tone. But we expecting "C4" (261.626 Hz), or "C#4" (277.183 Hz). The main reason of this discrepancies could be the wood plate vibration from the back side. Thus we define mesh, parameters of the wood plate and modes as follows dreg = DiscretizeRegion[reg6, {{-10, 10}, {0, 36}}, MaxCellMeasure -> .05] Y = 10.8*10^9; nu = 31/100; rho = 500; h = .003; d = 10^4 Sqrt[Y h^2/(12 rho (1 - nu^2))];Ld2 = {Laplacian[-d u[x, y], {x, y}] + v[x, y], -d Laplacian[v[x, y], {x, y}]}; {vals, funs} = NDEigensystem[{Ld2, DirichletCondition[u[x, y] == 0, True]}, {u, v}, Element[{x, y}, dreg], 5]; Table[DensityPlot[Re[funs[[i, 1]][x, y]], {x, y} \[Element] dreg, PlotRange -> All, PlotLabel -> vals[[i]]/(2 Pi), ColorFunction -> "Rainbow", AspectRatio -> Automatic], {i, 2, Length[vals]}] ![Figure 3][4] Hence for wood plate we have mode of 259.394 Hz and it is close to C4 tone. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2021-01-04at1.47.31PM.jpg&userId=20103 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=bd9Wx.png&userId=1218692 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=w7dPm.png&userId=1218692 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=qb3HU.png&userId=1218692 Alexander Trounev 2021-01-03T23:13:58Z https://community.wolfram.com/groups/-/m/t/815125 I'm very new to Mathematica and to programming. Complete computer novice. I might be coming at my problem from too mathematical a viewpoint Basically what I'm trying to do is find the transmission of a generic wave through a series of potential barriers with spin orbit interaction and a magnetic field. Now, I can do all the maths, but at a certain point you have to compute these hideous 4x4 matrices so I hoped mathematica could do that part for me and give me graphs. I want to keep the functions as general as possible until right at the end so I can input parameters right at the graphing stage. But the evaluation gets so big that graphs take hours to plot even over small ranges. Also, the calculation is complicated enough that even if I define 5 out of 6 variables and only keep the variable I want to us as x axis, the evaluation uses up all of my memory and quits before it even finishes. I don't understand parallelization - and the little bit of experimenting I've done returns <<cannot be parallelized>> messages. The crucial line is Anz[n_, a_, d_, kx_, l_, g_] = Inverse[L[((n - 1)/2) (a + d), kx]].Smz[a, d, kx, l, g].(MatrixPower[Sz[a, d, kx, l, g], (n - 3)/2]).L[a, kx] Where L, Smz and Sz are all 4x4 matrices with huge elements. Like so huge I cannot post even one here. Please help, My computation as is isn't even as complicated as it need to be and it takes hours to plot a single graph! Eleanor Holmes 2016-03-02T17:07:09Z https://community.wolfram.com/groups/-/m/t/3604903 For reducing such input from a range (-infinity; +infinity) to the target interval (-π; +π] on which trigonometric functions shall operate, the original input must be taken modulo 2π. Performance of such a modulo reduction on limited hardware systems depends on the number of digits you provide for 2π. Said number may be in the order of some hundred to some thousand. How can I specify this number for WolframAlpha? WolframAlpha understands my request to give me, e.g., 700 digits of 2π and returns them properly. But if and when I try to compute a given real number modulo (700 digits of 2π) it fails to decode my wish and, alas, doesn't advise me what to do instead. Any hint in this matter is appreciated. Thanks in advance. Walter Bonin 2026-01-11T23:23:02Z