https://community.wolfram.com RSS Feed for Wolfram Community showing any discussions tagged with Numerical Computation sorted by most likes. https://community.wolfram.com/groups/-/m/t/122095 The latest way I have found to use my expensive math software for frivolous entertainment is this. Here's is a way to describe it. [list] [*]1000 dancers assume random positions on the dance-floor. [*]Each randomly chooses one "friend" and one "enemy". [*]At each step every dancer [list] [*]moves 0.5% closer to the centre of the floor [*]then takes a large step towards their friend [*]and a small step away from their enemy. [/list] [*]At random intervals one dancer re-chooses their friend and enemy [/list] Randomness is deliberately injected. Here is the dance... [mcode]n = 1000; r := RandomInteger[{1, n}]; f := (#/(.01 + Sqrt[#.#])) & /@ (x[[#]] - x) &; s := With[{r1 = r}, p[[r1]] = r; q[[r1]] = r]; x = RandomReal[{-1, 1}, {n, 2}]; {p, q} = RandomInteger[{1, n}, {2, n}]; Graphics[{PointSize[0.007], Dynamic[If[r < 100, s]; Point[x = 0.995 x + 0.02 f[p] - 0.01 f[q]]]}, PlotRange -> 2][/mcode] [img]/c/portal/getImageAttachment?filename=OPTfnlfrnds.gif&userId=11733[/img] Thanks to Vitaliy for posting this on my behalf, complete with animations :-) Background: I had read somewhere that macro-scale behaviour of animal swarms (think of flocks of starlings or shoals of herring) is explained by each individual following very simple rules local to their vicinity, essentially 1) try to keep up and 2) try not to collide. I started trying to play with this idea in Mathematica, but it was rather slow to identify the nearest neighbours of each particle. So I wondered what would happen if each particle acted according to the locations of two other particles, regardless of their proximity. The rule was simply to move away from one and towards the other. The contraction (x = 0.995 x) was added to prevent the particle cloud from dispersing towards infinity or drifting away from the origin. I tweaked the "towards" and "away" step sizes to strike a balance between the tendency to clump together and to spread apart (if you make the step sizes equal you get something more like a swarm of flies). With each particle's attractor and repeller fixed, the system finds a sort of dynamic equilibrium, so to keep things changing I added a rule to periodically change the attractor and repeller for one of the particles. The final adjustment was to make the "force" drop towards zero for particles at very close range. This helps to stop the formation of very tight clumps, and also prevents a division-by-zero error when a particle chooses itself as its attractor or repeller. The description of the system as a dance was an attempt to explain the swirling pattern on the screen without using mathematical language. I'd love to see what other "dances" can be created with other simple rules. Simon Woods 2013-09-11T18:31:12Z https://community.wolfram.com/groups/-/m/t/1569707 ![a very prime pencil][1] I just got a set of these pencils, from [Mathsgear][2]. The number printed on it is prime, and will remain so as you sharpen the pencil from the left, all the way down to the last digit, 7. Here is a recursive construction of all such *truncatable primes*. TruncatablePrimes[p_Integer?PrimeQ] := With[{digits = IntegerDigits[p]}, {p, TruncatablePrimes /@ (FromDigits /@ (Prepend[digits, #] & /@ Range[9]))} ]; TruncatablePrimes[p_Integer] := {} The one on the pencil is the largest one, In[7]:= Take[Sort[Flatten[TruncatablePrimes /@ Range[9]]], -5] Out[7]= { 9918918997653319693967, 57686312646216567629137, 95918918997653319693967, 96686312646216567629137, 357686312646216567629137} [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=IMG_20181212_120939.jpg&userId=143131 [2]: https://mathsgear.co.uk/products/truncatable-prime-pencil Roman Maeder 2018-12-12T12:01:36Z https://community.wolfram.com/groups/-/m/t/2763509 *Crossposted: https://mathematica.stackexchange.com/q/278250/13 * ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=RealRational_560.jpg&userId=11733 [2]: https://www.wolframcloud.com/obj/4dd2dfe1-b258-4a55-a8c4-39f6b4f0cfe9 Vitaliy Kaurov 2023-01-06T18:30:28Z 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/2017849 #Introduction One of the most thrilling parts in Nolan's movie "Interstellar" is the black hole Gargantua and its accretion disk. Its weird shape has surely attracted lots of attention. But do black holes and their accretion disks actually look like that? Not exactly. ![BH and accretion disk in Interstellar][1] In the paper "Gravitational lensing by spinning black holes in astrophysics, and in the movie Interstellar", the authors say that in the movie, redshift and blueshift, as well as the intensity difference is ignored to prevent confusion to the audience. So, although the outline of the accretion disk in "Interstellar" is accurate, the color and the intensity are not. Furthermore, even in the paper, effects brought by the time delay in the propagation of light are ignored, and the influence of gravity lensing on light intensity is simplified. Though I cannot easily render a spinning black hole (Kerr black hole), what I can do is try to render an accretion disk around a Schwarzschild black hole, and as physically correct as possible. The result would be something like this (observer static at 6 times the Schwarzschild radius): ![my rendering result, static observer][2] I strongly recommend you to see the videos at [Bilibili](https://www.bilibili.com/video/BV1Fp4y1S7EF) or [Youtube](https://www.youtube.com/watch?v=Dux1NkTaqwo) (Both have English subtitles) first to have a first impression, and it would be the best if you can click the vote up button XD. After that, If you would like to know more about the Mathematica realization and physical principles behind the scene, please continue. **A disclaimer first:** I know nothing about accretion disk physics, so the property of accretion disks are set arbitrarily. Furthermore, actual accretion disks are actually blazingly bright, and you would be blind instantly if you are looking at it from a short distance, so I have to make some modifications. #Analytics ###Physics Perspective First, we need to analyze this problem from the physics perspective, get to know about the problems we should consider. **For observers**, the intensity of light is determined by how much photons reached their eye in a certain angle range, and the color is determined by the spectrum of the light. However, the orientation, spectrum, and intensity of light beams can be influenced by the observer's movement, so we have to consider that. Naturally, the next question should be, where the light comes? Well, all the light must have come from some **light-emitting materials**, so we have to consider the light-emitting materials' property and movement. But the **light should travel** for some time and distance before reaching the observer's eye. This process involves tracing the light from the emitter to the observer to determine the direction of light the observer perceived, as well as how much portion of light can reach the observer's eyes. Till now, we have already listed out all effects, from the emission to the perception, which could influence our view, so I believe this rendering is "physically accurate". ### Programming Perspective But view from the programming perspective, the zeroth problem should be how lights travel around a black hole: we need the light path to calculate all other effects. Then, based on the light path, we can directly compute the equivalent of "brighter when closer" rule, as well as the time delay between light emission and observation. If combined with the movement of the light-emitting materials and the observer, we can compute the redshift and the blueshift. #Details, Theory, Coding and Results Now let's assume that we are stationary observers viewing from 6 times the Schwarzchild radius. ##Ray Tracing The first problem to solve is tracing the light beam. Light bends around black holes following the geodesics, and the most apparent consequence of this would be that the accretion disk we see would not be on a plane, but rather curved and bent. Fortunately for us, because Schwartzchild black holes are spherically symmetric, we can reduce the problem to 2D. The parametric equation of geodesics around a Schwarzschild black hole can be derived as follows: $$ \left\{ \begin{aligned} t''(\lambda)&=\frac{R_s r' t'}{R_s r-r^2}\\ r''(\lambda)&=\frac{-R_s r^2 r'^2-2r^3\theta'^2(R_s-r)^2+R_s(R_s-r)^2t'^2}{2r^3(R_s-r)}\\ \theta''(\lambda)&=-\frac{2r'\theta'}{r} \end{aligned} \right. $$ Where $\lambda$ is the ray parameter. Now we construct a set of light which originates from the observer, and trace them backward: ![Possible light paths][3] ![Definition of variables][4] ![How interpolation works][5] On each ray, we take some sample points and record the corresponding angle $\theta_0$, $\theta_1$, and time $\Delta T$. By interpolating them, we know about how a random object will look like in our eyes. (*Initial definitions*) Rs = 1; R0 = 6 Rs; Rmax = 6 Rs + 1.*^-6; (*Tracking the light*) parfunc = ParametricNDSolveValue[{{tt''[\[Tau]], rr''[\[Tau]], \[Theta]\[Theta]''[\[Tau]]} == {( Derivative[1][rr][\[Tau]] Derivative[1][tt][\[Tau]])/( rr[\[Tau]] - rr[\[Tau]]^2), ( rr[\[Tau]]^2 Derivative[1][ rr][\[Tau]]^2 - (-1 + rr[\[Tau]])^2 Derivative[1][ tt][\[Tau]]^2)/( 2 (-1 + rr[\[Tau]]) rr[\[Tau]]^3) + (-1 + rr[\[Tau]]) Derivative[1][\[Theta]\[Theta]][\[Tau]]^2, -(( 2 Derivative[1][rr][\[Tau]] Derivative[ 1][\[Theta]\[Theta]][\[Tau]])/rr[\[Tau]])}, {tt'[0], rr'[0], \[Theta]\[Theta]'[ 0]} == {1/(1 - Rs/R0), -Cos[\[Theta]0], Sqrt[1/(1 - Rs/R0)]/R0 Sin[\[Theta]0]}, {tt[0], rr[0], \[Theta]\[Theta][0]} == {0, R0, 0}, WhenEvent[ 1.01 Rs >= rr[\[Tau]] || rr[\[Tau]] >= Rmax || \[Theta]\[Theta][\[Tau]] >= 3.1 Pi, "StopIntegration"]}, {tt[\[Tau]], rr[\[Tau]], \[Theta]\[Theta][\[Tau]]}, {\[Tau], 0, 1000}, {\[Theta]0}]; (*data used in interpolation*) datp = Catenate@ Table[With[{pf = parfunc[\[Theta]]}, With[{\[Tau]max = pf[[1, 0, 1, 1, 2]], df = D[Rest@pf, \[Tau]], f = Rest@pf}, Block[{\[Tau] = Range[RandomReal[{0, \[Tau]max/500}], \[Tau]max, \[Tau]max/ 500]}, Select[ Thread[(Thread@f -> Thread@{\[Theta], ArcTan[-df[[1]], df[[2]] f[[1]] Sqrt[1 - Rs/f[[1]]]], pf[[1]]})], 2.4 Rs < #[[1, 1]] < 5.6 Rs && -0.05 Pi < #[[1, 1]] < 3.08 Pi &]]]], {\[Theta], Range[-2.5 Degree, 80 Degree, 1 Degree]~Join~ Range[20.2 Degree, 28.2 Degree, 0.5 Degree]~Join~ Range[23.025 Degree, 24.05 Degree, 0.05 Degree]~Join~ Range[23.2825 Degree, 23.4 Degree, 0.005 Degree]~Join~ Range[23.28525 Degree, 23.30025 Degree, 0.001 Degree]}]; datp = First /@ GatherBy[datp, Floor[#[[1]]/{0.01 Rs, 1 Degree}] &]; (*Construct InterpolatingFunctions*) ReceiveAngleFunction = Interpolation[Thread[{datp[[;; , 1]], datp[[;; , 2, 1]]}], InterpolationOrder -> 1]; EmitAngleFunction = Interpolation[Thread[{datp[[;; , 1]], datp[[;; , 2, 2]]}], InterpolationOrder -> 1]; DelayFunction = Interpolation[Thread[{datp[[;; , 1]], datp[[;; , 2, 3]]}], InterpolationOrder -> 1]; (*Angle vs time of observation*) GenerateAngleFunctions[R1_, \[Theta]1_] := Block[{\[Phi]1}, With[{interpol = Interpolation@ Table[{DelayFunction[R1, #] + Sqrt[2 R1^3] \[Phi]1, \[Phi]1}, {\[Phi]1, 0., 2 Pi, 10. Degree}]}, With[{ts = interpol[[1, 1, 1]], tperiod = 2. Pi Sqrt[2 R1^3]}, Function[t, interpol[t - Floor[t - ts, tperiod]]]]] & /@ ({#, 2 Pi - #, 2 Pi + #} &@ArcCos[Sin[\[Phi]1] Sin[\[Theta]1]])] If we only consider this effect, then we will have something like this: ![Light bending included][6] The inner two rings correspond to the light that rotates around the black hole for more than half a round. And if we consider the propagation time of light, the right side will be a bit brighter. ![Time correction included][7] This is because on the right, objects are moving away from you. So from your point of view, these particles will stay for a longer time on the right. (The reason is explained in the figure) ![Illustration of how velocity influence timing][8] ##"Brighter when Closer" The next question is about the "brighter when closer" rule. We all know that the further a bulb is, the dimmer it would appear to be. This is because the light from the bulb is approximately evenly distributed across solid angles, but as we move further, the solid angle corresponding to our eyes will be smaller. Mathematically, this is saying $I\propto S_0 \frac{d\Omega}{dS}$ where $S_0$ is the surface area of our eyes, $S$ is area, and $\Omega$ is the solid angle. !["Brighter when closer" rule in flat space][9] The same rules apply here in curved spacetime, except the light beams are weirder. !["Brighter when closer" rule in curved space][10] We know that $\frac{d\Omega}{dS}=(\frac{dx}{d\theta_x}\frac{dy}{d\theta_y})^{-1}$. While $\frac{dy}{d\theta_y}=\frac{R_0 \sin \alpha}{\sin \theta_1}$ can be derived using basic solid geometry, $\frac{dx}{d\theta_x}$ must be calculated numerically by tracing the light from the object to the observer. Similarly, we use interpolating function to generalize the result from a set of sample points to the whole space. (*Reverse ray tracing*) parfuncrev = ParametricNDSolveValue[{{tt''[\[Tau]], rr''[\[Tau]], \[Theta]\[Theta]''[\[Tau]]} == {( Derivative[1][rr][\[Tau]] Derivative[1][tt][\[Tau]])/( rr[\[Tau]] - rr[\[Tau]]^2), ( rr[\[Tau]]^2 Derivative[1][ rr][\[Tau]]^2 - (-1 + rr[\[Tau]])^2 Derivative[1][ tt][\[Tau]]^2)/( 2 (-1 + rr[\[Tau]]) rr[\[Tau]]^3) + (-1 + rr[\[Tau]]) Derivative[1][\[Theta]\[Theta]][\[Tau]]^2, -(( 2 Derivative[1][rr][\[Tau]] Derivative[ 1][\[Theta]\[Theta]][\[Tau]])/rr[\[Tau]])}, {tt'[0], rr'[0], \[Theta]\[Theta]'[0]} == {1/(1 - Rs/R1), Cos[\[Theta]0], -Sqrt[1/(1 - Rs/R1)]/R1 Sin[\[Theta]0]}, {tt[0], rr[0], \[Theta]\[Theta][0]} == {0, R1, \[Theta]1}, WhenEvent[\[Theta]\[Theta][\[Tau]] == 0, "StopIntegration"]}, {tt[\[Tau]], rr[\[Tau]], \[Theta]\[Theta][\[Tau]]}, {\[Tau], 0, 100}, {\[Theta]0, R1, \[Theta]1}]; (*data used in interpolation*) \[CapitalDelta]\[Phi] = 1.*^-5; intensity = Catenate@Table[{{R, \[Theta]}, R0^2 With[{\[Theta] = Abs[\[Theta]]}, Abs[Sin[EmitAngleFunction[ R, \[Theta]]]/(R0 \ Sin[\[Theta]])]*(\[CapitalDelta]\[Phi]/(Sin[ ReceiveAngleFunction[R, \[Theta]]]* Subtract @@ (With[{f = parfuncrev[ EmitAngleFunction[ R, \[Theta]] + # \[CapitalDelta]\[Phi], R, \[Theta]][[2, 0]]}, f@f[[1, 1, -1]]] & /@ {-1, 1})))]}, {R, 2.45 Rs, 5.55 Rs, 0.02 Rs}, {\[Theta], -3 Degree, 543 Degree, 2 Degree}]; (*Construct InterpolatingFunction*) IntensityFunction1 = Interpolation[intensity]; ![With intensity correction 1][11] The figure will be much more realistic in the aspect of intensity after we added this effect. The inner two rings are much dimmer because light bent dramatically is rare after all. ##Doppler Effect and Headlight Effect Now its time for Doppler effect and headlight effect. These two effects are related to the movement of light-emitting objects and observers. Though the names of these effects can be forbidding, these effects are quite common in everyday life. Blueshift refers to the phenomenon that when a car is approaching you, the noise made by the car would be more acute and loud, and redshift means when the car is leaving you, the noise would quieter and be of lower frequency. ![Doppler effect][12] The equation for the relativistic Doppler effect is: $$ f'=f\frac{\sqrt{1-\beta^2}}{1-\beta \cos \theta} $$ where $\beta=\frac{v}{c}$ and $\theta$ is the angle between the velocity direction of the light-emitting object and the light emitted, as observed by an external observer. In this case, we should further add a coefficient of $$ f''=f'\sqrt{\frac{1 - R_s/R_1}{1 - R_s/R_0}} $$ due to general relativistic effects. Headlight effect means when you are driving a car on rainy days, no matter how the wind blows, the raindrops will always run towards the windshield. But if you stop your vehicle, you can see how the wind influences the dropping direction of rain. ![Headlight effect][13] The equation for angle transformation is: $$ \cos \theta'= \frac{\cos \theta +\beta}{1+\beta \cos \theta} $$ and such, the intensity difference introduced by this can be written as: $$ \frac{dP'}{d\Omega}= \frac{dP}{d\Omega}\frac{\sin \theta}{\sin \theta'}\frac{d \theta}{d \theta'}=\frac{dP}{d\Omega}\frac{1 - \beta^2}{(1 -\beta \cos \theta)^2} $$ Except for the difference in timing brought by the curved spacetime, these two effects are purely in the special relativity regime. The only thing involved in coding is tedious coordinate transformation. (*Calculate moving speed*) Calc\[Beta][{R1_, \[Theta]_, \[Phi]_}, {vr_, v\[Theta]_, v\[Phi]_}] := Sqrt[vr^2/(1 - Rs/R1) + (R1 v\[Theta])^2 + (R1 Sin[\[Theta]] v\[Phi])^2]/ Sqrt[1 - Rs/R1] (*Calculate inner product between moving direction and light direction*) CalcCosAngle[{R1_, \[Theta]_, \[Phi]_}, {vr_, v\[Theta]_, v\[Phi]_}] := With[{v = {vr/Sqrt[1 - Rs/R1], R1 v\[Theta], R1 Sin[\[Theta]] v\[Phi]}}, MapThread[With[{\[Theta]0 = EmitAngleFunction[R1, #1]}, With[{vnormed = MapThread[Normalize@*List, v]}, MapThread[ Dot, {vnormed, Thread@{Cos[\[Theta]0], #2 Sin[\[Theta]0], 0}}, 1]]] &, {{\[Theta], 2 Pi - \[Theta], 2 Pi + \[Theta]}, {-1, 1, -1}}]] (*Frequency shift, Doppler effect + GR timing effects*) FrequencyMult[R1_, \[Beta]_, cos_] := Sqrt[(1 - Rs/R1)/(1 - Rs/R0)]*Sqrt[1 - \[Beta]^2]/(1 - \[Beta] cos) (*Intensity shift due to headlight effect only*) IntensityMult2[\[Beta]_, cos_] := (Sqrt[1 - \[Beta]^2]/(1 - \[Beta] cos))^2 Then we can put all these effects together and see how things works out! << PhysicalColor` IntensityFunctionScaling::usage = "Scale Intensity."; Protect@IntensityFunctionScaling; Options[RenderFunc] = {ColorFunction -> TemperatureColor, ColorFunctionScaling -> (# &), IntensityFunctionScaling -> (# &), "StaticObserver" -> True}; RenderFunc[R1_, {\[Theta]1_, t1_, \[Gamma]1_}, {T0_, I0_}, OptionsPattern[]] := Function[t, Through[#[t]]] &@Module[{ (*Velocity of observer*) vobs = N@Sqrt[(1 - Rs/R0) Rs/(2 R0)], (*list of \[Phi]1 parameters*) \[Phi]1l = Range[0., 2 Pi, 1 Degree], (*Polar coordinates \[Theta] and \[Phi]*) \[Theta]l0, \[Phi]l0, (*velocity of object and its norm*) vrl, v\[Theta]l, v\[Phi]l, vnorml }, (*Polar coordinate \[Theta]*) \[Theta]l0 = ArcCos[Sin[\[Phi]1l] Sin[\[Theta]1]]; (*Original \[Phi]*) \[Phi]l0 = ArcTan[Cos[\[Phi]1l], Sin[\[Phi]1l] Cos[\[Theta]1]] + \[Gamma]1; (*velocity of object*) vrl = ConstantArray[0, Length@\[Phi]1l]; v\[Theta]l = -(Cos[\[Phi]1l] Sin[\[Theta]1])/ Sqrt[1 - Sin[\[Theta]1]^2 Sin[\[Phi]1l]^2]*Sqrt[Rs/(2 R1^3)]; v\[Phi]l = 1/(Cos[\[Phi]1l]^2/Cos[\[Theta]1] + Cos[\[Theta]1] Sin[\[Phi]1l]^2)*Sqrt[Rs/(2 R1^3)]; (*velocity norm*) vnorml = Calc\[Beta][{R1, \[Theta]l0, 0}, {vrl, v\[Theta]l, v\[Phi]l}]; MapThread[Module[{ (*Observed \[Phi]1 parameter - t*) \[Phi]1t = #3, (*actual \[Theta] of object*) \[Theta]l = #1, (*angle between velocy and ray*) cosl = #4, (*Observed values - \[Phi]1*) (*Geometry*) \[Theta]obsl, \[Phi]obsl = \[Phi]l0 + #2, (*Frequency and intensity shift*) freqobsl, intobsl, (*helper function*) helpf }, \[Theta]obsl = ReceiveAngleFunction[R1, \[Theta]l]; (*Frequency*) freqobsl = FrequencyMult[R1, vnorml, cosl]; (*Process with the non-static observer*) If[OptionValue["StaticObserver"] =!= True, Module[{\[Theta]transl, \[Phi]transl, \[Delta] = ArcSin[vobs]}, (*Geometrics, static frame*) \[Theta]transl = ArcCos[Sin[\[Theta]obsl] Cos[\[Phi]obsl]]; \[Phi]transl = ArcTan[Sin[\[Theta]obsl] Sin[\[Phi]obsl], Cos[\[Theta]obsl]]; (*Frequency shift due to movement of observer, intensity shift is calculated together later*) freqobsl *= (1 + vobs Cos[\[Theta]transl])/Sqrt[1 - vobs^2]; (*Angle shift due to movement of observer*) \[Theta]transl = ArcCos[(vobs + Cos[\[Theta]transl])/(1 + vobs Cos[\[Theta]transl])]; (*Transform back*) (*Here we change the center of viewing angle so that the \ black hole's center is at {0,0}*) \[Theta]obsl = ArcCos[Sin[\[Delta]] Cos[\[Theta]transl] + Cos[\[Delta]] Sin[\[Theta]transl] Sin[\[Phi]transl]]; \[Phi]obsl = ArcTan[Cos[\[Delta]] Cos[\[Theta]transl] - Sin[\[Delta]] Sin[\[Theta]transl] Sin[\[Phi]transl], Sin[\[Theta]transl] Cos[\[Phi]transl]] ] ]; \[Phi]obsl = Catenate[ MapIndexed[#1 + 2 Pi #2[[1]] &, Split[\[Phi]obsl, Less]]]; (*Intensity*) intobsl = freqobsl^2*IntensityFunction1[R1, \[Theta]l]* IntensityMult2[vnorml, cosl]* TemperatureIntensity[freqobsl T0]/TemperatureIntensity[T0]/ freqobsl^4; (*Helper function to construct interpolating functions*) helpf[l_] := Interpolation[Thread[{\[Phi]1l, l}]]; With[{ cf = OptionValue[ColorFunction], (*Interpolating functions*) t11 = t1, \[Phi]1f = #3, \[Theta]func = helpf[\[Theta]obsl], \[Phi]func = helpf[\[Phi]obsl], freqfunc = helpf[OptionValue[ColorFunctionScaling][T0 freqobsl]], intfunc = helpf[OptionValue[IntensityFunctionScaling][I0 intobsl]] }, (*Final function*) Function[t, With[{\[Phi]11 = \[Phi]1f[t + t11]}, {Append[cf[freqfunc[\[Phi]11]], intfunc[\[Phi]11]], With[{\[Theta] = \[Theta]func[\[Phi]11], \[Phi] = \ \[Phi]func[\[Phi]11]}, (*Point[{Sin[\[Theta]]Cos[\[Phi]],Sin[\[Theta]]Sin[\[Phi]], Cos[\[Theta]]}]*) Point[Tan[\[Theta]] {Cos[\[Phi]], Sin[\[Phi]]}]]} ]] ] ] &, {{\[Theta]l0, 2 Pi - \[Theta]l0, 2 Pi + \[Theta]l0}, {0, Pi, 0}, GenerateAngleFunctions[R1, \[Theta]1], CalcCosAngle[{R1, \[Theta]l0, 0}, {vrl, v\[Theta]l, v\[Phi]l}]}]] (*My version of rasterize, which increase color precision in dimmer areas*) HDRRasterize[gr_Graphics, convertfunc_, opts : OptionsPattern[Rasterize]] := Module[{rasterl = Join[ColorSeparate[ColorConvert[Rasterize[gr, opts], "HSB"]], ColorSeparate[ ColorConvert[ Rasterize[ gr /. RGBColor[r_, g_, b_, op_] :> RGBColor[r, g, b, 16 op], opts], "HSB"]]], mask, invmask}, mask = Binarize[rasterl[[3]], 1/16]; invmask = 1 - mask; ColorCombine[{ mask*rasterl[[1]] + invmask*rasterl[[4]], mask*rasterl[[2]] + invmask*rasterl[[5]], mask*convertfunc[rasterl[[3]]] + invmask*convertfunc[rasterl[[6]]/16.]}, "HSB"] ] (*Preliminary computation*) npts = 5000; rflist = MapThread[ Function[{R1, \[Theta]1, t1, \[Gamma]1, T0, I0}, RenderFunc[R1, {\[Theta]1, t1, \[Gamma]1}, {T0, I0}, "StaticObserver" -> False(*, IntensityFunctionScaling\[Rule](.7(#/.5)^0.5&)*)]], {RandomReal[{3, 4.5}, npts], RandomReal[-{83, 86} Degree, npts], RandomReal[{0, 10000}, npts], RandomReal[15 Degree + {-2, 2} Degree, npts], RandomReal[{4000, 10000}, npts], RandomReal[{.03, .1}, npts] } ]; (*rendering!!!*) g = Graphics[{(*AbsolutePointSize@.1,White,Point[{Sin[20Degree]Cos[#], Sin[20Degree]Sin[#],Cos[20Degree]}&/@Range[0.,360.Degree, 60.Degree]],*)AbsoluteThickness@2, Map[Line[#[[;; , 2, 1]], VertexColors -> MapThread[ Function[{col, len, mult}, MapAt[mult^2*#*0.006/len &, col, 4]], {#[[;; , 1]], Prepend[#, #[[1]]] &@ BlockMap[Norm[#[[2]] - #[[1]]] &, #[[;; , 2, 1]], 2, 1], Subdivide[Length[#] - 1]}]] &, Reverse@Transpose[ Through[rflist[#]] & /@ (Range[0, 3, .1]), {3, 2, 1}], {2}]}, Background -> Black, ImageSize -> {500, Automatic}, PlotRange -> {{-1.28, 1.28}, {-0.72, 0.72}}]; HDRRasterize[g, #^(1/2.2) &, ImageSize -> {1920, 1080}] ![With all effects, static observer][14] Well, because objects at left are moving towards you, they will appear much brighter and blue-ish, while objects at right are much dimmer and red-ish. We can also consider the movement of the observer, which will make the image something like this: ![With all effects, observer moving][15] Hooray! The notebook can be found in the attachment or at [my github repo](https://github.com/wjxway/Realistic_Blackhole_Accretion_Disk). [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=bh10.png&userId=1340903 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=T_001.png&userId=1340903 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Path_4.png&userId=1340903 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=illus2.png&userId=1340903 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=illus1.png&userId=1340903 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=LightBending.png&userId=1340903 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=WithTimeCorrection.png&userId=1340903 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=illus3.png&userId=1340903 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=IntensityIllus.png&userId=1340903 [10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=illus4.png&userId=1340903 [11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=WithIntensity1.png&userId=1340903 [12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Doppler.jpg&userId=1340903 [13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=FrontLight.jpg&userId=1340903 [14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=WithAllEffects.png&userId=1340903 [15]: https://community.wolfram.com//c/portal/getImageAttachment?filename=WithObserverMoving.png&userId=1340903 Jingxian Wang 2020-07-02T11:26:03Z https://community.wolfram.com/groups/-/m/t/3467978 ![Collatz conjecture visualizations][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Main227052025.png&userId=20103 [2]: https://www.wolframcloud.com/obj/85fd1874-61c4-4798-8e48-d8ba6d037984 Anton Antonov 2025-05-27T12:23:54Z https://community.wolfram.com/groups/-/m/t/1843550 *MODERATOR NOTE: a submission to computations art contest, see more:* https://wolfr.am/CompArt-22 ---------- Showing Abs and Arg fields of Mandelbrot set under 200 iterations ![Mandelbrot_wallpaper.png][1] --- Showing Abs field of Mandelbrot set under 9 iterations ![9_iteration_abs.png][2] --- Showing Re vs. Im complex mapping of Mandelbrot set under 200 iterations ![ReIm_Complex_map.png][3] --- Mandelbrot Set on Neural Network =========================================== [The MXNet-based neural network framework](http://reference.wolfram.com/language/guide/NeuralNetworks.html) has been introduced to Wolfram Language since version 11. It is mostly designed for deep learning. However if we think about it, neural network is merely another fancy way to implement a certain program. As more and more functions are supported, it is now possible for us to "compile" general numerical program to neural network, which essentially gives us an interface to GPGPU parallel ability without the hassle of low-level coding. Inspired by [Brian](https://community.wolfram.com/web/tl2854)'s [recent post on MathCompile](https://community.wolfram.com/groups/-/m/t/1830592), we demonstrate in this post how to implement a neural network to compute the Mandelbrot set. ## Utilities As usual here is the code dump of some helper functions. Readers can evaluate then safely skip this section. ### code dump of helper functions ``` ClearAll[pipe, branch] pipe = RightComposition; branch = Through@*{##} &; ``` ``` Needs["NeuralNetworks`"] ``` ``` Clear[netInputPortSort] netInputPortSort[inPortLst_List] := Function[origNet, netInputPortSort[origNet, inPortLst]] netInputPortSort[origNet_NetGraph, inPortLst_List] := Block[{NetGraph = Inactive[NetGraph], fullnet, net}, fullnet = origNet ; net = fullnet[[1]] ; net["Inputs"] = AssociationThread[Rule[inPortLst, inPortLst /. net["Inputs"]]] ; ReplacePart[fullnet, 1 -> net] ] // Activate ``` --- # Basic concept The center of the Mandelbrot set computation is a simple iteration: $$\left\{ \begin{align} z_n &= c+z_{n-1}^2 \\ z_0 &= 0 \end{align} \right.$$ Under simple iteration it leads to the Mandelbrot set. ``` Block[{region, c, faclets} , (* random-points as different c for iteration: *) region = Disk[{-.5, 0}, 2] // DiscretizeGraphics // DiscretizeRegion[#, MaxCellMeasure -> .0001] & ; faclets = MeshCells[region, 2][[;; , 1]] ; c = MeshCoordinates[region].{1, I} ;(* The iteration taking place simultaneously for all c, nested 21 steps: *) Nest[Function[z, z^2 + c], 0, 21] // (* Visualizing the result: *) pipe[ pipe[(* Regularizing the norm for a clear visualization: *) Abs, HistogramTransform, Rescale, (1 - #)^2 &] , Append[ReIm[c]\[Transpose], #]\[Transpose] & , Graphics3D[ GraphicsComplex[#, {EdgeForm[], Polygon@faclets}] , Boxed -> False, SphericalRegion -> True, RotationAction -> "Fit" , ViewPoint -> {1, -2.4, 2.4}, ViewVertical -> {0, 0, 1} ] & ] ] ``` ![3D mesh of Mandelbrot set][4] Using the built-in [`MandelbrotSetPlot`](http://reference.wolfram.com/language/ref/MandelbrotSetPlot.html) function, it's straightforward to plot the traditional Mandelbrot set visualization: ``` MandelbrotSetPlot[{-2.5 - 2 I, 1.5 + 2 I}] ``` ![MandelbrotSetPlot][5] With some test we can notice that, for fixed `MaxIterations`, the relationship between computing time of `MandelbrotSetPlot` and `ImageResolution` follows a power law. ``` builtInTimeTest = {#, AbsoluteTiming[MandelbrotSetPlot[{-2.5 - 2 I, 1.5 + 2 I}, MaxIterations -> 100, ImageResolution -> #];][[1]]} & /@ Range[101, 4001, 100] NonlinearModelFit[builtInTimeTest, a r^k, {a, k}, r][r] // LogLogPlot[#, {r, 400, 5000}, PlotStyle -> Directive[Red, AbsoluteThickness[2]], Frame -> True, FrameTicks -> All] & // Show[{# , ListLogLogPlot[builtInTimeTest, PlotMarkers -> "OpenMarkers", PlotRange -> All] }, FrameLabel -> {"ImageResolution", "AbsoluteTiming"}] & ``` ![time benchmark of MandelbrotSetPlot][6] This is a scenario where parallel computation might make a difference. --- # Mandelbrot set on neural network -- A naïve attempt ## The implementation ### Iteration core net Neural network (short for **_NN_**) doesn't support complex number (yet). Aside from that, the iteration formula is simple enough for [`ThreadingLayer`](http://reference.wolfram.com/language/ref/ThreadingLayer.html): ``` iterNet = Module[{c = cX + cY I, z = x + y I}, z^2 + c // pipe[ ReIm, ComplexExpand, Echo[#, "{Re[\!\(\*SuperscriptBox[\(z\), \(2\)]\)+c], Im[\!\(\*SuperscriptBox[\(z\), \(2\)]\)+c]}:"] & , Map@pipe[ Inactive[Function][{cX, cY, x, y}, #] & , Activate , ThreadingLayer ] , Inactive[NetGraph][# , { (NetPort /@ StringSplit["cX,cY,x,y", ","]) -> # & /@ {1, 2} , 1 -> NetPort["x"], 2 -> NetPort["y"] } ] & , Activate ] ] ``` ![iterNet][7] It's very easy to perform the iteration with the help of [`Nest`](http://reference.wolfram.com/language/ref/Nest.html) / [`NestList`](http://reference.wolfram.com/language/ref/NestList.html). ``` Block[{region, c, xyInit, result} , (* random-points as different c for iteration: *) region = Disk[{0, 0}, .5] // DiscretizeGraphics // DiscretizeRegion[#, MaxCellMeasure -> .01] & ; c = MeshCoordinates[region].{1, I} // ReIm ; c = AssociationThread[StringSplit["cX,cY", ","], c\[Transpose]] ; xyInit = AssociationThread[StringSplit["x,y", ","], 0*Values[c]] ; result = NestList[ pipe[ Map[Clip[#, {-2, 2}] &] , Join[c, #] & , iterNet ] , xyInit, 20 ] ; result // pipe[ Values, Rest, Map@Transpose , Transpose , MapThread[{#2, BSplineCurve@#1} &, {#, # // Length // Range // N // Rescale // Map[ColorData["Rainbow"]]}] & , Graphics[#, Frame -> True, FrameTicks -> All, PlotRange -> {GoldenRatio {-1, 1}, {-1, 1}}, PlotRangeClipping -> True] & ] ] ``` ![Nest on iterNet][8] ### Nest net Now we have the core net representing the iteration formula, we need to mimic the functionality of `Nest[f, expr, n]` fully on a neural network. The go-to function is of course [`NetNestOperator`](https://reference.wolfram.com/language/ref/NetNestOperator.html). However in our case, the same $c$ is used repeatedly for all iterations, so we'd like to pass it directly to each iteration. Thus, we do it with the following customized `NetNestPartialOperator` function: ``` ClearAll[NetNestPartialOperator] NetNestPartialOperator[net_, staticPorts_List, nestPort_, iterNum_Integer] := Module[{pIdx, netIdx, staticpath, nestpath}, netIdx = Range[iterNum] ; pIdx = AssociationThread[staticPorts, staticPorts // Length // Range // Map[ToString]] ; staticpath = Function[p, NetPort["static" <> pIdx[p]] -> (NetPort[#, p] & /@ netIdx)] /@ staticPorts ; nestpath = Thread[Flatten[{NetPort["nest"], netIdx // Most}] -> (NetPort[#, nestPort] & /@ netIdx)] ; Inactive[NetGraph][ConstantArray[net, iterNum], {staticpath, nestpath} // Flatten] // Activate // netInputPortSort[Flatten[{"nest", "static" <> # & /@ Values[pIdx]}]] ] ``` Basically our `NetNestPartialOperator` takes a [`net_NetGraph`](https://reference.wolfram.com/language/ref/NetGraph.html) as the 1st argument. One of `net`'s input ports, i.e. `nestPort`, is going to be nested across iterations; other input ports (i.e. `staticPorts`) will be feed in constant/non-nested values. Here is a simple example realizing a 5 steps nest iteration `Nest[Function[c,a+b+c],c0,5]`: ``` Module[{coreNet, nestNet} , coreNet = NetGraph[{ThreadingLayer[#1+#2+#3&]}, {{NetPort["a"],NetPort["b"],NetPort["c"]}->1},"a"->"Real","b"->"Real","c"->"Real"] ; nestNet = NetNestPartialOperator[coreNet, {"a", "b"}, "c", 5] ; { {"coreNet", "nestNet"} , Quiet[ NetInformation[#, "MXNetNodeGraph"] // Graph[#, VertexSize -> 0.2, VertexLabels -> "Name"] & ] & /@ {coreNet, nestNet} }\[Transpose] // Grid[#, Background -> {{GrayLevel[.9], None}, None}, Frame -> All, FrameStyle -> Black] & ] ``` ![NetNestPartialOperator example][9] ### The Mandelbrot net In order to construct a net suitable for `NetNestPartialOperator`, we merge the real and imaginary ports in `iterNet` into a single "complex" port. ``` zNet = NetGraph[{ReplicateLayer[1], ReplicateLayer[1], CatenateLayer[]}, {NetPort["1"] -> 1, NetPort["2"] -> 2, {1, 2} -> 3}]; nestcoreNet = NetGraph[ {PartLayer[1], PartLayer[2], iterNet, zNet} , { (NetPort[#] -> NetPort[3, #]) & /@ StringSplit["cX,cY", ","] , NetPort["z"] -> {1, 2} , {{1, 2}, StringSplit["x,y", ","]} // MapThread[(#1 -> NetPort[3, #2]) &] , {StringSplit["x,y", ","], StringSplit["1,2", ","]} // MapThread[(NetPort[3, #1] -> NetPort[4, #2]) &] } ] ``` ![nestcoreNet][10] Thus a full net computing the Mandelbrot set is constructed as follows: ``` ClearAll[mandelbrot] mandelbrot[iterNum_Integer?Positive] := NetGraph[{ zNet , ElementwiseLayer[0 # &] , NetNestPartialOperator[nestcoreNet, StringSplit["cX,cY", ","], "z", iterNum] }, { {NetPort["cX"], NetPort["cY"]} -> 1 -> 2 , {2, NetPort["cX"], NetPort["cY"]} -> 3 } ] ``` ## Results We showcase our `mandelbrot` net with 9 iteration steps over the complex region ${-2-1.2I,1+1.2I}$, with a image resolution $401 \times 501$. The network is executed on a GPU (NVIDIA GeForce GTX 1050 Ti) with [`"Real64"`](https://reference.wolfram.com/language/ref/NetGraph.html#1010560149) precision. ``` mandelbrotF = mandelbrot[9]; ``` ``` result = Module[{region = {-2 - 1.2 I, 1 + 1.2 I}, resol = 501, aspr}, region = region // ReIm // Transpose ; aspr = region.{-1, 1} // Reverse // Apply[Divide] ; resol = resol {1, aspr} // Round ; {resol, region} // pipe[ MapThread[Rescale[Range[#1] // N // Rescale, {0, 1}, #2] &] , Tuples , AssociationThread[{"cX", "cY"}, #\[Transpose]] & , AbsoluteTiming[mandelbrotF[#, WorkingPrecision -> "Real64", TargetDevice -> "GPU"]] & , pipe[ branch[pipe[First, Quantity[#, "Seconds"] &, Echo[#, "Computing time on NN:"] &], Last] , Last] , Developer`ToPackedArray , ArrayReshape[#, {2, Sequence @@ resol}] & , {1, I}.# & , Transpose, Reverse ] ]; (* Computing time on NN: 3.08505 s *) ``` ``` result // Dimensions (* {401, 501} *) ``` ``` result // pipe[ branch[ pipe[ Abs , pipe[ branch[Flatten /* HistogramTransform, Dimensions /* Last] , Apply@Partition ] , Rescale, (1 - #)^5 & ] , pipe[Arg, Sin, Rescale] ] , Map @ pipe[ Image[#, ImageSize -> Length[#]] & , Colorize[#, ColorFunction -> "DarkColorFractalGradient"] & ] ] ``` ![naive result][11] Note the highlighted [periodic bulbs and Mandelbrot dendritic islands](https://dhushara.com/DarkHeart/DarkHeart.htm) in the left image, and the pattern approximately following the [external rays](https://en.wikipedia.org/wiki/External_ray) of the set in the right image. As a comparison, here is the result from the same region, iteration steps and resolution using the built-in `MandelbrotSetPlot` function. ``` AbsoluteTiming[ MandelbrotSetPlot[{-2 - 1.2 I, 1 + 1.2 I}, MaxIterations -> 9, ImageResolution -> 501] ] // pipe[ branch[pipe[First, Quantity[#, "Seconds"] &, Echo[#, "Computing time:"] &], Last], Last , #[[1, 1]] &, Reverse, Image[#, ImageSize -> Dimensions[#][[1]]] & ] (* Computing time: 0.187943 s *) ``` ![MandelbrotSetPlotOver(-2-1.2I,1+1.2I)][12] Clearly at this resolution scale, `MandelbrotSetPlot` is much faster than our neural-net function. But at a much larger resolution our function will eventually win. ``` myMandelbrotSetPlotTiming[resolution_Integer] := Module[ {region = {-2 - 1.2 I, 1 + 1.2 I}, aspr, resol} , region = region // ReIm // Transpose ; aspr = region.{-1, 1} // Reverse // Apply[Divide] ; resol = resolution {1, aspr} // Round ; {resol, region} // pipe[ MapThread[Rescale[Range[#1] // N // Rescale, {0, 1}, #2] &] , Tuples , AssociationThread[{"cX", "cY"}, #\[Transpose]] & , AbsoluteTiming[mandelbrotF[#, WorkingPrecision -> "Real64", TargetDevice -> "GPU"];][[1]] & , {resolution, #} & ] ] myTimeTest = myMandelbrotSetPlotTiming /@ Range[101, 4001, 100]; NonlinearModelFit[myTimeTest, a r^k, {a, k}, r][r] // LogLogPlot[#, {r, 400, 5000}, PlotStyle -> Directive[Purple, AbsoluteThickness[2]], Frame -> True, FrameTicks -> All] & // Show[ { # , ListLogLogPlot[myTimeTest, PlotMarkers -> Graphics[{FaceForm[White], EdgeForm[{Orange, AbsoluteThickness[1]}], Polygon[CirclePoints[4]]}, ImageSize -> 7], PlotRange -> All] } , FrameLabel -> {"ImageResolution", "AbsoluteTiming"} ] & ``` ![time benchmark of NN based mandelbrot][13] Comparing with previous benchmark result of `MandelbrotSetPlot`, we can see our NN-based function has an advantage when the image resolution is large enough. ![time bench comparison][14] --- # Mandelbrot set on neural network -- Avoid overflow Careful readers will find that for larger iteration steps and/or a larger computing region, our naïvely implemented `mandelbrot` will lead to overflow. That is of course due to the $c$ values leading to divergency. One simple way to avoid this overflow is to constrain the nested $z$ to a bounded region at every iteration step. ## The implementation ### A constrained iteration core net The simplest way to constrain the nested $z$ is to clip it into a rectangle region. ``` iterNet = Module[{c = cX + cY I, z = x + y I}, z^2 + c // pipe[ ReIm, ComplexExpand, Echo[#, "{Re[\!\(\*SuperscriptBox[\(z\), \(2\)]\)+c], Im[\!\(\*SuperscriptBox[\(z\), \(2\)]\)+c]}:"] & , Map@pipe[ (* The constraint: -> *) Block[{escR = 3}, escR Clip[#/escR]] & , Inactive[Function][{cX, cY, x, y}, #] & , Activate , ThreadingLayer ] , Inactive[NetGraph][# , { (NetPort /@ StringSplit["cX,cY,x,y", ","]) -> # & /@ {1, 2} , 1 -> NetPort["x"], 2 -> NetPort["y"] } ] & , Activate ] ] ``` ### The Mandelbrot net Re-evaluating the rest of the code leads to our simply constrained `mandelbrotCons` function. ``` nestcoreNet = NetGraph[ {PartLayer[1], PartLayer[2], iterNet, zNet} , { (NetPort[#] -> NetPort[3, #]) & /@ StringSplit["cX,cY", ","] , NetPort["z"] -> {1, 2} , {{1, 2}, StringSplit["x,y", ","]} // MapThread[(#1 -> NetPort[3, #2]) &] , {StringSplit["x,y", ","], StringSplit["1,2", ","]} // MapThread[(NetPort[3, #1] -> NetPort[4, #2]) &] } ] ``` ``` ClearAll[mandelbrotCons] mandelbrotCons[iterNum_Integer?Positive] := NetGraph[{ zNet , ElementwiseLayer[0 # &] , NetNestPartialOperator[nestcoreNet, StringSplit["cX,cY", ","], "z", iterNum] }, { {NetPort["cX"], NetPort["cY"]} -> 1 -> 2 , {2, NetPort["cX"], NetPort["cY"]} -> 3 } ] ``` ## Results Now we can go for much larger iteration steps on a larger region. ``` mandelbrotConsF = mandelbrotCons[200]; ``` ``` result = Module[{region = {-3 - 2 I, 1 + 2 I}, resol = 1001, aspr}, region = region // ReIm // Transpose ; aspr = region.{-1, 1} // Reverse // Apply[Divide] ; resol = resol {1, aspr} // Round ; {resol, region} // pipe[ MapThread[Rescale[Range[#1] // N // Rescale, {0, 1}, #2] &] , Tuples , AssociationThread[{"cX", "cY"}, #\[Transpose]] & , AbsoluteTiming[mandelbrotConsF[#, WorkingPrecision -> "Real64", TargetDevice -> "GPU"]] & , pipe[ branch[pipe[First, Quantity[#, "Seconds"] &, Echo[#, "Computing time on NN:"] &], Last] , Last] , Developer`ToPackedArray , ArrayReshape[#, {2, Sequence @@ resol}] & , {1, I}.# & , Transpose, Reverse ] ]; (* Computing time on NN: 6.29684 s *) ``` ``` result // Dimensions (* {1001, 1001} *) ``` ``` result // pipe[ branch[ pipe[ Abs , pipe[ branch[Flatten /* HistogramTransform, Dimensions /* Last] , Apply@Partition ] , Rescale, (1 - #)^5 & ] , pipe[Arg, Sin, Rescale] ] , Map @ pipe[ Image[#, ImageSize -> Length[#]] & , Colorize[#, ColorFunction -> "DarkColorFractalGradient"] & ] ] ``` ![constrained result][15] Or thresholding at 2 to get the classical Mandelbrot set. ``` result // Abs // UnitStep[2 - #] & // Image ``` ![classical Mandelbrot 200][16] ### Zoom-in For zoomed-in regions, this clipped version gives interesting results. ``` result = Module[{region = {-0.65 + 0.47 I, -0.4 + 0.72 I}, resol = 1001, aspr}, region = region // ReIm // Transpose ; aspr = region.{-1, 1} // Reverse // Apply[Divide] ; resol = resol {1, aspr} // Round ; {resol, region} // pipe[ MapThread[Rescale[Range[#1] // N // Rescale, {0, 1}, #2] &] , Tuples , AssociationThread[{"cX", "cY"}, #\[Transpose]] & , AbsoluteTiming[mandelbrotConsF[#, WorkingPrecision -> "Real64", TargetDevice -> "GPU"]] & , pipe[ branch[pipe[First, Quantity[#, "Seconds"] &, Echo[#, "Computing time on NN:"] &], Last] , Last] , Developer`ToPackedArray , ArrayReshape[#, {2, Sequence @@ resol}] & , {1, I}.# & , Transpose, Reverse ] ]; (* Computing time on NN: 6.06289 s *) ``` ``` result // pipe[ branch[ pipe[ Abs , pipe[branch[Flatten /* HistogramTransform, Dimensions /* Last], Apply@Partition] , Rescale, (1 - #)^5 &, Sin[\[Pi]/2 #] &, Rescale ] , pipe[Arg, Sin[#/2] &, Rescale] ] , Map@pipe[ Image[#, ImageSize -> Round[Length[#]/2]] & , Colorize[#, ColorFunction -> "StarryNightColors"] & ] ] ``` ![zoom-inAt(-0.65+0.47I,-0.4+0.72I)][17] ### Complex map We can also stylize the result any way we want, say, showing the complex mapping like the [`ComplexPlot`](https://reference.wolfram.com/language/ref/ComplexPlot.html). Abs vs. Arg: ``` result // pipe[ branch[ pipe[ Arg , branch[ pipe[Sin[#/2] &, Rescale] , pipe[ Sin[50 #] &, ArcSin, Rescale, #^.5 & ] ] ] , pipe[ Abs , Rescale, Log[10^-3 + #] &, Rescale , branch[ pipe[Sin[200 #] &, ArcSin, Rescale, #^.5 &] , pipe[#^5 &, Rescale[#, {0, 1}, {1, .3}] &] ] ] ] , Apply@Function[{arg2, abs2}, {arg2[[1]], arg2[[2]] abs2[[1]], abs2[[2]]}] , Image[#, ColorSpace -> "HSB", Interleaving -> False] & ] ``` ![Complex map: Abs vs Arg][18] Or Re vs. Im: ``` result // pipe[ branch[ pipe[ ReIm, Transpose[#, {2, 3, 1}] & , Map@pipe[ Cos[100 2 \[Pi] #] &, Rescale, #^.2 & ] ] , pipe[ Abs , Rescale, Log[10^-3 + #] &, Rescale , branch[ pipe[Sin[\[Pi]/2 #] &, Rescale] , pipe[#^5 &, Rescale[#, {0, 1}, {1, .5}] &] ] ] ] , Apply@Function[{reim, abs2}, {abs2[[1]], Times @@ reim, abs2[[2]]}] , Image[#, ColorSpace -> "HSB", Interleaving -> False] & ] ``` ![Complex map: Re vs Im][19] ### A different region (The detailed code in this section is omitted in the post, but included in the attached notebook.) Computing over a different region (`-0.0452407411 + 0.9868162204352258 I + 2.7 10^-5 {-1 - I, 1 + I}`) and fiddling with color palettes from `ColorData["ThemeGradients"]` gives us this wallpaper-like result (the [`ColorFunction`](https://reference.wolfram.com/language/ref/Colorize.html#777264821) used here is `"M10DefaultDensityGradient"`). ![zoom-in 2][20] Also the corresponding complex map plots: ![complex maps: Abs vs Arg & Re vs Im][21] --- # References - [Exploding the Dark Heart of Chaos](https://dhushara.com/DarkHeart/DarkHeart.htm) - [Wikipedia: External ray](https://en.wikipedia.org/wiki/External_ray) - [MathWorld: Mandelbrot Set](http://mathworld.wolfram.com/MandelbrotSet.html) - [Wikipedia: Mandelbrot set](https://en.wikipedia.org/wiki/Mandelbrot_set) - [The Mandelbrot Set Browser](http://www.cuug.ab.ca/dewara/mandelbrot/Mandelbrowser.html) [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Mandelbrot_wallpaper.png&userId=93201 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=9_iteration_abs.png&userId=93201 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ReIm_Complex_map.png&userId=93201 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3D_mesh.png&userId=93201 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=MandelbrotSetPlot.png&userId=93201 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=time_bench_MandelbrotSetPlot.png&userId=93201 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=iterNet.png&userId=93201 [8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=iterNet_Nest.png&userId=93201 [9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=NetNestPartialOperator_example.png&userId=93201 [10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=nestcoreNet.png&userId=93201 [11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=naive_result.png&userId=93201 [12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=MandelbrotSetPlot2.png&userId=93201 [13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=time_bench_NN.png&userId=93201 [14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=time_bench_comparison.png&userId=93201 [15]: https://community.wolfram.com//c/portal/getImageAttachment?filename=constrained_result.png&userId=93201 [16]: https://community.wolfram.com//c/portal/getImageAttachment?filename=classical_Mandelbrot_200.png&userId=93201 [17]: https://community.wolfram.com//c/portal/getImageAttachment?filename=zoom_in_1.png&userId=93201 [18]: https://community.wolfram.com//c/portal/getImageAttachment?filename=AbsArg_Complex_map.png&userId=93201 [19]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ReIm_Complex_map.png&userId=93201 [20]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Mandelbrot_wallpaper.png&userId=93201 [21]: https://community.wolfram.com//c/portal/getImageAttachment?filename=complex_maps_2.png&userId=93201 Silvia Hao 2019-12-19T07:59:59Z https://community.wolfram.com/groups/-/m/t/3202678 ![System model+simulation w/ FEM: electric vehicle Tesla Model S energy, battery, drivetrain, thermal][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Slide1.PNG&userId=2403714 [2]: https://www.wolframcloud.com/obj/b779f2cd-4e78-496d-b09b-fceee440b0fc Vedat Senol 2024-07-01T16:27:50Z https://community.wolfram.com/groups/-/m/t/745870 While going through the Wolfram Demonstration Project site, I came across an simulation of a Trebuchet: [Optimizing the Counterweight Trebuchet][1] I was wondering if it is possible to animate the Trebuchet in such a way that the projectile of the trebuchet actually leaves the sling and makes impact against a wall at a certain distance say x='some constant'. [![enter image description here][2]][1] [1]: http://demonstrations.wolfram.com/OptimizingTheCounterweightTrebuchet [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=6648popup_3.jpg&userId=11733 Varun Kulkarni 2015-11-26T22:26:41Z 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/3111908 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3781Hero1.png&userId=20103 [2]: https://www.wolframcloud.com/obj/b6f6fbbb-0aa5-43ff-937a-cf9482eaf9e2 Michael Trott 2024-01-29T16:58:25Z https://community.wolfram.com/groups/-/m/t/2030201 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/e9934595-75e0-42eb-92bc-ae38528364a7 [Original]: https://www.wolframcloud.com/obj/ss8659/Published/WSS20-Level-Index-Arithmetic-5.nb Swastik Banerjee 2020-07-14T17:07:16Z https://community.wolfram.com/groups/-/m/t/2978606 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Bicycleproblems.gif&userId=20103 [2]: https://www.wolframcloud.com/obj/92111047-bf26-4059-8d44-326bf82736e9 Stan Wagon 2023-07-28T16:56:02Z https://community.wolfram.com/groups/-/m/t/2961701 [![enter image description here][1]][2] &[Wolfram Notebook][3] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=43t45h545qerfgvfdsfh.jpg&userId=11733 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=43t45h545qerfgvfdsfh.jpg&userId=11733 [3]: https://www.wolframcloud.com/obj/ec0d857e-09b2-4862-87b8-0d0c23869f69 Vitaliy Kaurov 2023-07-13T17:19:37Z https://community.wolfram.com/groups/-/m/t/2740397 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/2d627ca1-036a-4d6e-afaa-bd73bd641674 Jose Martin-Garcia 2022-12-21T15:37:36Z https://community.wolfram.com/groups/-/m/t/826688 **Wolfram Language Fingerprint Identification and Matching** ======================================================== ![enter image description here][1] Introduction ============ The objective of this study was to create a Mathematica program that would accurately and efficiently compare multiple fingerprints without external hardware. I began my work in August of 2014 as a member of the Wolfram Research Mentorship Program, after having attended the Wolfram Mathematica Camp earlier that summer. Fingerprint analysis by computational means has grown in significance in modern society; fingerprint matching has been relevant in the field of criminology for a long time, but its applications are growing to complement modern technology, such as the fingerprint recognition functionality of iPhones. Detecting fingerprints accurately, however, requires either sensitive and expensive specialized fingerprinting machines or specialized technology unavailable to the public. Thus far, there are extremely few applications that allow users to acquire and compare their fingerprints easily. In my research, I examined the ability of Mathematica and its image processing functionality to compare and analyze fingerprints extracted from live photographs. Methods/Experimentation ======================= Acquisition of Fingerprints for Testing --------------------------------------- Fingerprints for this research were acquired from several locations. These include: extracted Fingerprints from OnyxKit application, VeriFinger Fingerprint Database, FVC2 (Fingerprint Verification Contest) Sample Database, and CASIA-Fingerprint V5 Biometrics Ideal Test. All downloaded Fingerprint sets are free, but require registration. When live testing was done, fingerprints were taken from myself, close family, as well as friends. Pre-Printed Fingerprint Analysis -------------------------------- - **ImageKeyPoints (Testing on Pre-Printed Fingerprints)** After investigation into several other methods of fingerprint matching, the Mathematica commands ImageKeyPoints and ImageCorresponding Points were determined to be the best method of comparing fingerprints. ImageKeyPoints is a Mathematica command that uses the SURF (Speeded Up Robust Features) algorithm that uses a complex blob detector to identify points within the image that stood out in contrast to surrounding points, which are analyzed using the Haar wavelet sum. The command outputs coordinates of points which are determined to be sufficiently unique or distinct. The following code and image are an illustration of a set of key points on a Pre-Printed Fingerprint from the VeriFinger Fingerprint Database: HighlightImage[FP1, ImageKeypoints[FP1], "HighlightColor" -> Yellow] ![enter image description here][2] The number of key points for an image was quantified using the simple command: Length[ImageKeyPoints[FP1]] Over every Pre-Printed Database, the number of Key Points was quantified to ensure that there was no significant difference within a set of images from the same database, as this number is used in a later calculation. When comparing a set of fingerprints, I found that there was no statistically significant difference within sets with p < .05. - **ImageCorrespondingPoints (Testing on Pre-Printed Fingerprints)** ImageCorrespondingPoints (ICP) is a similar command to ImageKeyPoints; the purpose of ICP is to identify points in common between two images. These Corresponding Points are selected from the set of Key Points. A sample snippet of code as well as an image of ICP on a pair of images of a fingerprint extracted from OnyxKit application. *Corresponding Points highlighted from two different Fingerprints from the Same Individual* Images = {FP1, FP3}; matches = ImageCorrespondingPoints @@ images; MapThread[ Show[#1, Graphics[{Yellow, MapIndexed[Inset[#2[[1]], #1] &, #2]}]] &, {images, matches}] ![enter image description here][3] *Corresponding Points highlighted from two different Fingerprints from Different Individuals* ![enter image description here][4] The number of Corresponding points for a pair of images was quantified using the simple command: Length[ImageCorrespondingPoints[FP1, FP2]] - **Determining the Threshold** A percentage similarity between two fingerprints was calculated as follows: (2 NumberofCorrespondingPoints[FP1, FP2])/(NumberofImageKeyPoints[FP1] + NumberofImageKeyPoints[FP2]) This is essentially equal to the number of points in common between the two images divided by the average number of key points. This %Similarity was calculated among thousands of pairs of images from the same finger of the same individual, as well as fingerprints from different individuals. These fingerprints were captured using OnyxKit. The key of this project was to find the proper %Similarity (threshold) with which we can say that if the calculated %Similarity > Threshold, then the fingerprints are the same, and if %Similarity < Threshold, then the fingerprints are different. The Threshold determined for pre-printed fingerprints was determined to be the surprisingly and extremely small, 1.5%. Such a low threshold is a key indicator that our method for comparing fingerprints is very accurate in predicting if fingerprints are different, allowing us to set a low threshold to capture fingerprints from the same individual that may have a low number of Corresponding Points. - **KeyPointStrength** A key component of the analysis was determining the proper KeyPointStrength in the ImageCorrespondingPoints. KeyPointStrength is an option of ICP, which alters the requirements for a point to be considered a Key Point. An increase in KeyPointStrength corresponds to a decreased number of Key Points found. The values for KeyPointStrength Testing included KSP = .001, .0004, .0005, .00075. The code for KSP was: ImageCorrespondingPoints[FP1, FP2, KeypointStrength -> ____ ] The conclusion was that at a KeypointStrength of .0004, the results were optimal: for two of the same fingerprints, the certainty of a match = 85%. For two different Fingerprints, the certainty of no match is 86%. The value of KSP was eventually changed when testing on live finger images, when a similar analysis was repeated. Live Fingerprint Analysis ------------------------- - **Extraction of Finger from Image** All of the prior analysis set the precedent for the investigation into live fingerprints. The purpose of this project was to allow a user to upload multiple images of fingers taken simply by a camera or phone without necessity of specialized technology. Therefore, after pictures of fingers were uploaded to the program, a system had to be discovered to isolate only the finger from a complete image. This presents a significant Image Processing and Manipulation problem. I proposed three solutions this problem: **(1) Pure Image Manipulation (No Preparation Required)** In this method, a picture of a fingerprint is taken without regard to the background. The purpose of this code is to be able to extract a fingerprint from the uploaded image. This extracted fingerprint should be surrounded by a black background to which image key points can be applied properly on. FPExtract[k_] := ImageCrop[ ImageSubtract[k, ColorNegate[ DeleteSmallComponents[ MorphologicalBinarize[ ColorCombine[ColorSeparate[k], "LAB"], {.65}]]]]] **Extraction Results:** *Original Image:* ![enter image description here][5] *Extracted Image:* ![enter image description here][6] **(2) Uniform Background Method** In this method, the background is taken into account. Here, the image of the fingerprint must be taken with a purely uniform background. The results of this extraction are shown below: FPExtracted1 = ImageMultiply[ FP1 SelectComponents[FillingTransform@Binarize[FP1], "Area", -1]]; FPExtractedFinal = ImageSubtract[FP1, FPExtracted1] *Original Image:* ![enter image description here][7] *Extracted Image:* ![enter image description here][8] **(3) Flash Photography** A slightly unique method was discovered when I realized that simply turning flash on may be extremely effective. This was motivated by my desire to use a form of morphological binarize; this requires a contrast in the lighting of the finger vs the lighting of the background. Therefore, I reasoned, when the flash is aimed on the finger when a photograph is being taken, that should facilitate the use of a binarize command to extract the fingerprint. FPExtract[a_] := ImageCrop[ ImageSubtract[a, ColorNegate[DeleteSmallComponents[Binarize[a]]]]] *Original Image:* ![enter image description here][9] *Extracted Image:* ![enter image description here][10] **Conclusion** After large amounts of testing, it was determined that with regard to accuracy as well as practicality, the best method would be the method 3 using flash photography. The other methods are included here to reveal the potential for better solutions, especially method 1, which if improved, would be the ideal method. - **Threshold Determination** The threshold for this portion of the project was set using the exact same method as previously described. A large set of pairs of fingerprints using method 3 was analyzed to determine the ideal threshold. It was determined that the ideal threshold to maximize correct interpretations of pairs of fingerprints was approximately 1.2%. - **Reference Fingerprints and Probability Calculations** Most standard fingerprint matching software requires a number of reference fingerprints. This means, that give an input fingerprint FP1, and reference fingerprints FP2, FP3, ...., FPN, the input fingerprint is compared to each reference fingerprint to increase the accuracy of the final conclusion. These reference fingerprints can either be from a different individual from the input or from the same individual, and a decision is thus made. It is critical to determine the probability of making an accurate conclusion during this process. For example, as the number of reference fingerprints increases, the probability of making a correct conclusion increases. Probability calculations were done using conditional Bayesian probability. The general formula for this is: P(B|A) = (P(B)P(A|B)) / (P(B)P(A|B) + P(B^c)P(A|Bc) In this computation, certain information needs to be known prior to computation: this includes the general probability that a known correct match will be interpreted as a match. This was determined to be 90%. It also was needed to be known what the probability of a known invalid match being interpreted as a valid match. This was determined to be 11%. These numbers were acquired after analyzing thousands of pairs of fingerprints. There are two situations in which this is applied: **(1) Probability of Match** In this scenario, B= Probability of Correct Conclusion, and A = Number of Matches Found The following code computes the probability of a conclusion of a match, given that there are MatchCount number of determined matches that are greater than the threshold. ProbabilityofSame = ((.90)^MatchCount (1 - .90)^(Length[t] - MatchCount))/ (((.90)^MatchCount (1 - .90)^(Length[t] - MatchCount)) + ((.11)^MatchCount (1 - .11)^(Length[t] - MatchCount))) **(2) Probability of Invalid Match** In this scenario, B= Probability of Correct Conclusion, and A = Number of Matches Found The following code computes the probability of a conclusion of a match, given that there are MatchCount number of determined matches that are greater than the threshold. ProbabilityofSame = ((.90)^MatchCount (1 - .90)^(Length[t] - MatchCount))/ (((.90)^MatchCount (1 - .90)^(Length[t] - MatchCount)) + ((.11)^MatchCount (1 - .11)^(Length[t] - MatchCount))); - **Final Determination of Results** The final conclusion of whether the result is a match or an invalid match is determined using the probabilities computed above. If the probability of a valid match is greater than the probability of an invalid match, then the result is a match, and vice versa. The final conclusion is printed as well as calculated probability that the result is correct. ![enter image description here][11] **Conclusion:** Through this project, I have explored the use of Mathematica to identify and match fingerprints. A number of different methods were used throughout this project, but after significant data analysis, the method through Key Point analysis was determined to be the most effective. As a result, users should be able to input live photographed fingerprints and analyze them. Beyond its immediate results, this project also has several implications for future study. A significant amount of time of this study, although not included in this report, was devoted to the study of traditional Fingerprint matching techniques, such as ridge bifurcations, edges, etc. The code developed in this avenue was not further pursued, as the key points analysis was more practical, but there is room here for much further investigation. Improvements in the image processing would also be highly relevant, as improved fingerprint extraction would increase the significance of results tremendously. Finally, more data in even larger quantities would be helpful in confirming the current threshold, or establishing a new, final one. **Acknowledgements:** I would primarily like to thank Dr. Rowland for his mentorship and assistance throughout the entire course of the project. I would also like to thank Ms. Kimball for her involvement and assistance near the end of the project, as well as the Onyx and the various Fingerprinting Databases for allowing my use of their samples. Finally, I would like to thank my parents for their constant support. **Final Code** This is the code the deploys the program directly to the cloud CloudDeploy[FormFunction[{ {{"y", "Input Fingerprint"} -> "Image", {"x", "Number of Reference Fingerprints"} -> {"1", "2", "3", "4"}}, Function[ Table[{"a" <> ToString[i], "Reference Fingerprint " <> ToString[i]} -> "Image", {i, ToExpression[#x]}] ]}, Module[{RefFP, FPAnalysis, MatchCount, NumberofCorrespondingPoints, NumberofInputKeyPoints, NumberofReferenceKeyPoints, ProbabilityofSame, ProbabilityofDifferent, FPAnalysisModified, FPAnalysisFinalModified, w, u, q, n, t, b}, t = Table[ #["a" <> ToString[j]], {j, ToExpression[#x]}]; b = ImageRotate[#y, 3 Pi /2]; t = Table[ImageRotate[t[[i]], 3 Pi/2], {i, 1, Length[t]}]; NumberofInputKeyPoints = Length[ImageKeypoints[b]]; NumberofReferenceKeyPoints = Table[ Length[ ImageKeypoints[t[[u]]]], {u, 1, Length[t]}]; NumberofCorrespondingPoints = Table[ Length[ Flatten[ ImageCorrespondingPoints[b, t[[q]]], 1]], {q, 1, Length[t]}]; FPAnalysis = Table[{ MapThread[ Show[#1, Graphics[{Yellow, MapIndexed[Inset[#2[[1]], #1] &, #2]}]] &, {{b, t[[n]]}, ImageCorrespondingPoints @@ {b, t[[n]]}}], Row[{N[ 200 NumberofCorrespondingPoints[[n]] / (Plus[NumberofInputKeyPoints, NumberofReferenceKeyPoints[[n]] ])], "%"}], Which[ 200 NumberofCorrespondingPoints[[ n]]/ (Plus[NumberofInputKeyPoints, NumberofReferenceKeyPoints[[n]]]) > 1.2, "Match", 200 NumberofCorrespondingPoints[[ n]]/ (Plus[NumberofInputKeyPoints, NumberofReferenceKeyPoints[[n]]]) < 1.2, "Invalid Match"]}, {n, 1, Length[t]}]; MatchCount = (Length[t] - Total[StringCount[Flatten[FPAnalysis][[4 ;; ;; 4]], "Invalid Match"]]); ProbabilityofSame = ((.90)^ MatchCount (1 - .90)^(Length[t] - MatchCount) ) / (((.90)^ MatchCount (1 - .90)^(Length[t] - MatchCount) ) + ((.11)^ MatchCount (1 - .11)^(Length[t] - MatchCount) )); ProbabilityofDifferent = ((.11)^ MatchCount (1 - .11)^(Length[t] - MatchCount) )/ (((.90)^ MatchCount (1 - .90)^(Length[t] - MatchCount) ) + ((.11)^ MatchCount (1 - .11)^(Length[t] - MatchCount) )); FPAnalysisModified = FPAnalysis /. "Match" -> Item[Style["Match", FontWeight -> Bold, FontFamily -> Times, FontSize -> 16], Background -> Green]; FPAnalysisFinalModified = FPAnalysisModified /. "Invalid Match" -> Item[Style["Invalid Match", FontWeight -> Bold, FontFamily -> Times, FontSize -> 16], Background -> Red]; Grid[ { { Framed[ Grid[{{"Wolfram Mathematica Fingerprint Matching Research:", "Tushar Dwivedi"}, {"Final Result:", If[ProbabilityofSame > ProbabilityofDifferent, " MATCH ", " INVALID MATCH "]}, { "Number of Reference Fingerprints Input:", Length[t]}, {"Certainty of Result:", If[ProbabilityofSame > ProbabilityofDifferent, StringJoin[ToString[100 ProbabilityofSame], "%"], StringJoin[ToString[100 ProbabilityofDifferent], "%"]]}, { "Average Number of Critical Points:", N[Mean[Join[ NumberofReferenceKeyPoints, \ {NumberofInputKeyPoints}]]]}, { "Average Number of Corresponding Points:", N[ Mean[NumberofCorrespondingPoints]]}}, Background -> {{1 -> LightBlue, 2 -> LightYellow}, None}]]}, {Insert[ ReplacePart[ Grid[ Join[ {{Style["Corresponding Points Display", FontSize -> 16, FontFamily -> Times], SpanFromLeft, Style["Threshold: 1.2%", FontSize -> 16, FontFamily -> Times], Item[If[ProbabilityofSame > ProbabilityofDifferent Style["Result: MATCH", FontFamily -> Times, FontWeight -> Bold], Style["Result: INVALID MATCH", FontFamily -> Times, FontWeight -> Bold]], Background -> If[ProbabilityofSame > ProbabilityofDifferent, Green, Red]] }}, Flatten /@ FPAnalysisFinalModified] ], 1 -> Prepend[ First[ Grid[ Join[ {{Style["Corresponding Points Display", FontSize -> 16, FontFamily -> Times], SpanFromLeft, Style["Threshold: 1.2%", FontSize -> 16, FontFamily -> Times], Item[If[ProbabilityofSame > ProbabilityofDifferent, Style["Result: MATCH", FontFamily -> Times, FontWeight -> Bold], Style["Result: INVALID MATCH", FontFamily -> Times, FontWeight -> Bold]], Background -> If[ProbabilityofSame > ProbabilityofDifferent, Green, Red]] }}, Flatten /@ FPAnalysisFinalModified] ] ], {Style["Fingerprint Input", FontSize -> 16 , FontWeight -> Bold, FontFamily -> Times], Style["Reference Fingerprint", FontSize -> 16 , FontWeight -> Bold, FontFamily -> Times], Style["Match Strength", FontSize -> 16 , FontWeight -> Bold, FontFamily -> Times], Style["Result", FontSize -> 16 , FontWeight -> Bold, FontFamily -> Times]}]], {Dividers -> All, Spacings -> 1.5` {1, 1}}, 2]}, {Framed@Text [Style[ " The input fingerprint was paired with each of the input \ reference fingerprints, and Wolfram Mathematica was used to identify \ critical points in all input fingerprints. These critical points \ include bifurcations (where the fingerprint line branches), ridge \ endings (where the fingerprint line stops), and various other \ minuitae. The major premise of fingerprint testing is to compare the \ critical points in two fingerprints, and find how many of these \ minuitae are the same. Therefore, the number of critical points in \ the input that corresponded to critical points in the reference \ fingerprint was calculated for each pair. The Match Strength is \ calculated by finding the percent of the average number of critical \ points that correspond between the pair of fingerprints. After \ testing thousands of pairs of fingerprints, the threshold for a Match \ Strength to qualify as a match was set at 1.2%. Thus, if the match \ strength was greater than 1.2% for a pair, then that pair of the \ input and reference was determined to be a match. To get the overall \ determination of a match or invalid match, Bayesian probability was \ used to calculate the certainty of being a match based on the number \ of matches or invalid matches found between the input fingerprint and \ each of the reference fingerprints.", TextAlignment -> Left, FontSize -> 14, FontFamily -> Times, LineSpacing -> {1.67, 0}], Background -> LightGreen]}} ] ] &, "PNG", AppearanceRules -> <| "Title" -> "Wolfram Fingerprint Identification", "Description" -> "Match your fingerprints!"|>], Permissions -> "Public"] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=FinalOutputScreenshot.png&userId=522318 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Fingerprint1.png&userId=522318 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-03-20at2.31.23PM.png&userId=522318 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-03-20at2.31.32PM.png&userId=522318 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-03-20at2.31.40PM.png&userId=522318 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-03-20at2.31.46PM.png&userId=522318 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-03-20at2.31.53PM.png&userId=522318 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-03-20at2.31.57PM.png&userId=522318 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-03-20at2.32.04PM.png&userId=522318 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-03-20at2.32.09PM.png&userId=522318 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-03-20at2.32.22PM.png&userId=522318 Tushar Dwivedi 2016-03-20T21:14: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/1485074 Hello people of the community, I'm an enthusiast of **Mathematica** and **Wolfram|Alpha** who's been busy for the last few days with a project on possible numerical candidates to be used as random alternative bases for various applications. As I know there are amazing mathematical friends in the community, I decided to humbly expose my work and ask about opinions, etc. Only for the purpose of presenting some of my ideas and also to start an informal discussion on this kind of subject: number randomness. And maybe it can also be useful for someone here. To begin with, I understand that the randomness that I speak in this text is not truly random, but it serves as the basis for almost-random operations and distributions that need that specific degree of trust. In order to study the randomness of the transcendental numbers, candidates for transcendental and notable irrational numbers, I used a table base and developed a digit counting workbook. I only used numbers with 10000 decimal digits for the study (generated using **Mathematica** and the data later adapted to data workbook). Below is the example of the interface I used with the Pi number: ![enter image description here][1] Each workbook of data like this above is a point on a chart, that is, many similar to this will result in the characteristic curve of each number review. In this study I compared four different specific characteristics (Y-axis). Using the workbook I could detail these quantities as the digits increased to 10000 on the X-axis. I used the transcendental number Pi to start the study. In this study I made my own version of properties to study the numbers and are not necessarily the conventional way of doing it. Given: C = Deviation of the average arithmetic between all the decimal digits in the range. S = Deviation of the average count of different digits: how many nine, how many 8 etc... T = It measures the difference of how many numbers are between 0 and 4 in contrast to those between 5 and 9, such as a coin toss, result between rounding up or down situations. A = Total number of digits forming or part of doubles, triples, etc.: 11,222,5555, 333333333... (in the interval studied). I've tested several numbers and their combinations. As for example: **E^Pi, Pi^E, E^sqrt(2), 2^sqrt(2), Zeta (3), Gamma(1/3), Ln(2), Ln(Pi), E^(1/Pi), E+Pi, GoldenRatio, EulerGamma, E+Ln(2)+EulerGamma**, etc... around 30 different numbers, preferably transcendentals, irrational and other notorious candidates. There are two types of accuracy in this project, some I made with with 31 data points and some more detailed with 91 data points. Below is the detailed graph of **Pi** referring to the characteristics already stipulated: ![enter image description here][2] In this graph each vertical line is one point to the curve and has a separation of 110 digits, there are 91 points from 100 to 10000 digits on the X-axis. Below are a few more examples with other notable numbers: E Number ![enter image description here][3] Gamma(1/3) Number ![enter image description here][4] Ln(2) Number ![enter image description here][5] Each of these charts above have the space between the vertical lines of 330 digits (X-axis) and use 31 points between 100 and 10000. They represent the characteristic curve of each number (Y-axis). Note 1: Realize that the closer to the X-axis are the curves, in all graphics, the more well distributed and favored is the number for its use in random applications. Then the following: I calculated the **AREA** below the curve in the graphs to characterize each of its value. The method I used was to calculate the area through average trapezoids formed by the arithmetic mean, so consequently I considered its own degree of precision. Note 2: The important point in this study **IS NOT** the absolute values that I found (because I used a specific method), **BUT** the comparison of the values between the different numbers, since I used the same process in all objects of study, making it possible to compare. Below is the table for four important numbers using the accuracy of 31 points. ![enter image description here][6] The Pi number has the lowest frequency to form repetitions of ALL the numbers tested (..would that be the manifestation of it irrationality?). Well, after a sequence of tests and more tests, in this quest to find candidates equal or almost good as Pi in this characteristic, I found by chance a very good candidate number: the number **C (10)!** , or **ChampernowneNumber(10)!** (! = factorial): I used **Mathematica** to generate the test numbers (examples): ![enter image description here][7] In this example above are the first 500 digits of the numbers C(10) and C(10)!, but in the real study I used 10000 digits (also generated by **Mathematica**). Examples of digit count according to the amount of total digits. The left is the C (10)! And the right is Pi: ![enter image description here][8] Below is the result of the workbook I generated for the C (10)! using 31 points of precision: ![enter image description here][9] Full chart of Champernowne (10)! (now with 91 points, 110 in 110 digits, 100 to 10000): ![enter image description here][10] ![enter image description here][11] Comparing the data I got for Pi e C(10)! numbers (max accuracy, chart of 91 points): ![enter image description here][12] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Pigraph0.jpg&userId=1316061 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Pigraph1.jpg&userId=1316061 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=e.jpg&userId=1316061 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=gamma13.jpg&userId=1316061 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ln2.jpg&userId=1316061 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=tablei.jpg&userId=1316061 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=champernowneini.jpg&userId=1316061 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=tabledual.jpg&userId=1316061 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=tablei2.jpg&userId=1316061 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=champernowne!.jpg&userId=1316061 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=tablef.jpg&userId=1316061 [12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=conclusao.jpg&userId=1316061 I conclude that: of all the numbers tested (transcendental, irrational, etc.) the number that has the characteristic of not-repeating-numeral to those of Pi is the **ChampernowneNumber (10)**! : a possible candidate to replace it in applications that need randomness and it IS NOT possible or convenient to incorporate Pi (is that a best alternative candidate? ). Currently I take 2 minutes to do a fast previous checkup on any number with the workbook, 1 hour to create and analyze completely with the chart 31 points and 3 hours for the chart of 91 points. Please if you liked the work I did let me know giving a LIKE Claudio Chaib 2018-09-29T21:29:53Z 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