Community RSS Feed
http://community.wolfram.com
RSS Feed for Wolfram Community showing any discussions in tag Equation Solving sorted by activeCorrect a NDSolve approach when an argument contains an InverseFunction?
http://community.wolfram.com/groups/-/m/t/972466
We have a thin crystal of thickness d illuminated uniformly from the left at an intensity lgti[0, t] of unity. The crystal is composed of a photo reactive species *a* which absorbs light. Inside the crystal at location x and time t the photo chemical reaction leads to a local concentration of *a* given as a[x, t] in the code below.
Code to generate the concentration, a[x, t], and light intensity, lgti[x, t], within the crystal is straightforward and is shown.
The cause of the errors generated using the code is that in some cases a[x, t] does not return a number.These exceptional cases are near a known limit of the InverseFunction and a[x, t] in these cases could be given the values unity if found. My problem is that using NumberQ inside a Module definition of a[x, t] always gives false because ligti[x, t] is unevaluated.
The starting code is shown but see the attached notebook.
ClearAll[a, x, t, eqns, \[Sigma]N, lgti, soln, t0, d, tmax]
\[Sigma]N = 1.78*10^4; d = 0.001; tmax = 3000.0;
a[x_, t_] := InverseFunction[(1.8996253051848473`/lgti[x, t] *
(162.99559471365637` Log[1 + 8.98898678414097` (1 - #1)] -
172.98458149779734` Log[#1]) ) &
] [t]
eqns = {D[lgti[x, t], x ] == - \[Sigma]N a[x, t ] lgti[x, t],(* Beer's Law *)
lgti[0, t] == 1,
lgti[x, 0] == Exp[-\[Sigma]N x]
};
t0 = AbsoluteTime[];
soln = NDSolve[eqns, lgti, {x, 0, d}, {t, 0, tmax},
MaxStepFraction -> 0.01] [[1]];
Print[ToString[(AbsoluteTime[] - t0)/60] <> " minutes"]
Any advice on how to code a[x, t] so that lgti[x, t] appears as a number within the body of the code would be welcome.
An alternate approach would also be well received.Mervin Hanson2016-12-01T00:35:14Z[GIF] Elaborating on Arrival's Alien Language, Part I., II. & III.
http://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=234448Brad Klee2017-03-18T20:23:59ZSolve an equation with a Piecewise function?
http://community.wolfram.com/groups/-/m/t/1035180
Hello I'm new to Mathematica, though I know a few about it. I'm trying to find a group of 2 values for Piecewise function changing with x, but I constantly have a problem with Solve producing a lot of errors can you tell me where is my mistake in this ? Whole thing is in attached file, Basically its:
F(x)=Piecewise[...](x,wl,wp)
Solve[MaxValue[F,x]/MinValue[F,x]==1.15,{wl,wp}] Or
CylindricalDecomposition[1.1<=MaxValue[F,x]/MinValue[F,x]<=1.2,{wl,wp}]
So I'm trying to get wl and wp values for optimization, but certainly I'm doing something wrong, please help.Pio Tyldens2017-03-19T15:24:41ZCalculate (A*Nabla)B ?
http://community.wolfram.com/groups/-/m/t/1035972
Does anyone how to write (A*Nabla)B in Mathematica?
As far as I understood I can also write (A*Nabla)B=Nabla(A*Transposed[B])-B(Nabla*A), but I can't get this to work either as I don't know how to write A*Transposed(B).
Any ideas?mkssion2017-03-20T18:28:47ZSolve an Elliptic PDE for u[x,y] with the rhs given by numerical f[u]?
http://community.wolfram.com/groups/-/m/t/1035422
I have a somewhat unusual mathematical problem. I need to solve numerically a second order elliptic PDE for u[x,y] with the right hand side given by numerical function F[u], that is, some give function of u, not of [x,y].
In 1D things work well
(* make interpolation of a linear function: *)
FofA = Interpolation[Table[{x, x}, {x, 0, 1, 10^-2}]];
(*construct a numerical function from the interpolation: *)
FofA1[x_] := FofA[z] /. z -> x
(* Find solutions for uā = FofA1[u] *)
uofx = Flatten[
NDSolve[{Dt[u[x], x] == (FofA1[u[x]]), u[1] == 1},
u, {x, 0, 1}]].{1};
(* Plot it and compare with analytical *)
Show[{Plot[u[x] /. uofx, {x, 0, 1}, PlotRange -> All],
Plot[E^(-1 + x), {x, 0, 1}]}]
But in 2D it fails. One of the hints, I think is: if I try to solve Poisson equation in the form
D[u[x, y], {x, 2}] + D[u[x, y], {y, 2}] == u[x, y]
the NDSolveValue works OK, but it fails for
D[u[x, y], {x, 2}] + D[u[x, y], {y, 2}] == u[x, y]^{1.}
(when the rhs is numerically evaluated)
Thanks a lot for the insight.Maxim Lyutikov2017-03-19T22:24:02Z[ā] Locator constrained by polygon and NSolve
http://community.wolfram.com/groups/-/m/t/1035196
Dear Community,
I have a polygon with a constrained locator in it. I would like to draw a horizontal line from the locator towards the left boundary of the polygon, which is also given by a stewise function called qgHSZ. I try to achieve this with NSolve, but I get some strange warnings, like
"Part 2 of {0.5,10.} does not exist" Why??
"NSolve was unable to solve the system with inexact coeficients, etc." Not clear either. If I test NSolve below the plot, it works fine.
What do I do wrong? Notebook attached.
Tx for the kind help in advance,
regards, AndrasAndras Gilicz2017-03-19T21:32:01ZSolve definite integrals?
http://community.wolfram.com/groups/-/m/t/1034805
Hello,
Please, I am trying to solve definite integral and its work but the results not simplified.
F = Integrate[(x^4*Exp[x])/(Exp[x] - 1)^2, {x, 0, 44}]
This is the result
(1/(15 (-1 + E^44)))4 (-\[Pi]^4 +
E^44 (\[Pi]^4 +
30 (-1874048 + 42592 Log[-1 + E^44] - 2904 PolyLog[2, 1/E^44] -
132 PolyLog[3, 1/E^44] - 3 PolyLog[4, 1/E^44])) +
30 (-42592 Log[-1 + E^44] +
3 (468512 + 968 PolyLog[2, 1/E^44] + 44 PolyLog[3, 1/E^44] +
PolyLog[4, 1/E^44])))studygroups 20002017-03-19T00:29:08ZMinimize can only do this problem if the constraint is Reduced first
http://community.wolfram.com/groups/-/m/t/1034401
Consider the following code:
In[1]:= Minimize[{x^2 - y^2,
Cos[x - y] >= 1/2, -5 <= x <= 5, -5 <= y <= 5}, {x, y}]
Out[1]= Minimize[{x^2 - y^2,
Cos[x - y] >= 1/2, -5 <= x <= 5, -5 <= y <= 5}, {x, y}]
In[3]:= r =
Reduce[{Cos[x - y] >= 1/2, -5 <= x <= 5, -5 <= y <= 5}, {x, y}]
Out[3]= (-5 <= x < 1/3 (15 - 7 \[Pi]) &&
1/3 (5 \[Pi] + 3 x) <= y <=
1/3 (7 \[Pi] + 3 x)) || (1/3 (15 - 7 \[Pi]) <= x <
1/3 (15 - 5 \[Pi]) &&
1/3 (5 \[Pi] + 3 x) <= y <= 5) || (x == 1/3 (15 - 5 \[Pi]) &&
y == 5) || (-5 <= x <= 1/3 (-15 + \[Pi]) && -5 <= y <=
1/3 (\[Pi] + 3 x)) || (1/3 (-15 + \[Pi]) < x < (15 - \[Pi])/3 &&
1/3 (-\[Pi] + 3 x) <= y <= 1/3 (\[Pi] + 3 x)) || ((15 - \[Pi])/3 <=
x <= 5 &&
1/3 (-\[Pi] + 3 x) <= y <= 5) || (x == 1/3 (-15 + 5 \[Pi]) &&
y == -5) || (1/3 (-15 + 5 \[Pi]) < x <=
1/3 (-15 + 7 \[Pi]) && -5 <= y <=
1/3 (-5 \[Pi] + 3 x)) || (1/3 (-15 + 7 \[Pi]) < x <= 5 &&
1/3 (-7 \[Pi] + 3 x) <= y <= 1/3 (-5 \[Pi] + 3 x))
In[4]:= Minimize[{x^2 - y^2, r}, {x, y}]
Out[4]= {1/9 (-150 \[Pi] + 25 \[Pi]^2), {x -> 5 - (5 \[Pi])/3,
y -> 5}}Frank Kampas2017-03-18T15:00:35Z[ā] NSolve[2x== 0,x] return {{}} in Mathematica 11.0.1?
http://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.
GijsbertGijsbert Wiesenekker2016-10-02T19:01:41Z