Community RSS Feed
http://community.wolfram.com
RSS Feed for Wolfram Community showing any discussions in tag Physics sorted by active[GIF] Square and Triangle Curve Shortening Flows
http://community.wolfram.com/groups/-/m/t/1246571
A few months ago, the thread [Circle Morphing into a triangle][1] came up. This thread falls short of discussing curvature flows, including the famous curve shortening flow. This is an important topic, leading to the more general Ricci flow, [as discussed by Jim Isenberg on Numberfile.][2] The purpose of this thread is to elaborate upon the earlier calculations by deforming square and triangle elliptic curves into circles, while preserving the interior area. As discussed elsewhere, the circle solves [Dido's problem][3], to enclose maximum area by the least amount of cow's hide. Thus an area-preserving flow ending with a circle, by reverse logic, will usually be a *curve lengthening flow*. This can be proven rigorously for the two examples here by integrating the perimeter as a Fourier series expansion. Building upon the earlier humorous [Arrival thread][4], future posts may explore seemingly obvious connections between elliptic curves and Zen drawings, especially Sengai's drawing, sometimes called "Circle, Triangle, Square", as seen on the cover of ["The Zen Art Book"][5] . Additional information about these calculations will eventually be made available in the form of a more serious article.
## Curve Parameterizations and Areas ##
Quartic\[Phi]0 = ArcSin[Sqrt[4 \[Alpha] \[CapitalPhi]]]/2;
QuarticF[1] = 1/Sqrt[\[CapitalPhi]] Cos[Quartic\[Phi]0 - Pi/2];
QuarticF[2] = 1/Sqrt[\[CapitalPhi]] Cos[Quartic\[Phi]0];
Cubic\[Phi]0 = (2/3) ArcSin[3 Sqrt[3] x/2];
CubicF[n_] :=
Sqrt[\[Alpha]] Divide[1 + 2 Cos[Cubic\[Phi]0 - n 2 Pi/3], 3 x] /. {
x -> Sqrt[\[Alpha] ] \[CapitalPhi]}
A3 = \[Alpha] Hypergeometric2F1[1/3, 2/3, 2, 27 \[Alpha]/4];
A4 = \[Alpha] Hypergeometric2F1[1/2, 1/2, 2, \[Alpha]];
## Triangle Animation: "△ Grow And Flow △" ##
TriangleGrow = PolarPlot[{
1, Evaluate[
Sqrt[1/A3] CubicF[1] /. \[CapitalPhi] ->
Cos[3 \[Phi]] /. {\[Alpha] -> 4/27}], Evaluate[
Sqrt[1/A3 /. {\[Alpha] -> 4/27}] CubicF[1] /. \[CapitalPhi] ->
Cos[3 \[Phi]] /. {\[Alpha] -> #/1000 (4/27)}]}, {\[Phi], 0,
2 Pi}, PlotRange -> {{-2, 2}, {-2, 2}},
PlotStyle -> {Gray, Gray, Directive[Thick, Black]},
Axes -> False] & /@ (10 Range[0, 100]);
TriangleFlow = PolarPlot[{
1, Evaluate[
Sqrt[1/A3] CubicF[1] /. \[CapitalPhi] ->
Cos[3 \[Phi]] /. {\[Alpha] -> 4/27}], Evaluate[
Sqrt[1/A3] CubicF[1] /. \[CapitalPhi] ->
Cos[3 \[Phi]] /. {\[Alpha] -> #/1000 (1/27)}]}, {\[Phi], 0,
2 Pi},
PlotRange -> {{-2, 2}, {-2, 2}},
PlotStyle -> {Gray, Gray, Directive[Thick, Black]},
Axes -> False] & /@ Reverse[10 Range[400]];
TriangleFinal = PolarPlot[{
Evaluate[
Sqrt[1/A3] CubicF[1] /. \[CapitalPhi] ->
Cos[3 \[Phi]] /. {\[Alpha] -> 4/27}], 1}, {\[Phi], 0, 2 Pi},
PlotRange -> {{-2, 2}, {-2, 2}},
PlotStyle -> {Gray, Directive[Thick, Black]}, Axes -> False];
TriangleGrowFlow = Join[TriangleGrow, Table[TriangleGrow[[-1]], {100}],
TriangleFlow, Table[TriangleFinal, {100}]];
ListAnimate[TriangleGrowFlow];
![TriangleGrowFlow][6]
[Youtube Video][7]
## Square Animation: "□ Grow and Flow □" ##
SquareGrow = PolarPlot[{
1,
Evaluate[
Sqrt[1/A4] QuarticF[
1] /. \[CapitalPhi] -> (Cos[\[Phi]] Sin[\[Phi]])^2 /. {\
\[Alpha] -> 1}], Evaluate[
Sqrt[1/A4 /. {\[Alpha] -> 1}] QuarticF[
1] /. \[CapitalPhi] -> (Cos[\[Phi]] Sin[\[Phi]])^2 /. {\
\[Alpha] -> #/1000}]}, {\[Phi], 0, 2 Pi},
PlotRange -> {{-2, 2}, {-2, 2}},
PlotStyle -> {Gray, Gray, Directive[Thick, Black]},
Axes -> False] & /@ (10 Range[0, 100]) // Quiet;
SquareFlow = PolarPlot[{
1,
Evaluate[
Sqrt[1/A4] QuarticF[
1] /. \[CapitalPhi] -> (Cos[\[Phi]] Sin[\[Phi]])^2 /. {\
\[Alpha] -> 1}], Evaluate[
Sqrt[1/A4] QuarticF[
1] /. \[CapitalPhi] -> (Cos[\[Phi]] Sin[\[Phi]])^2 /. {\
\[Alpha] -> #/1000}]}, {\[Phi], 0, 2 Pi},
PlotRange -> {{-2, 2}, {-2, 2}},
PlotStyle -> {Gray, Gray, Directive[Thick, Black]},
Axes -> False] & /@ Reverse[10 Range[100]] // Quiet;
SquareFinal = PolarPlot[{
Evaluate[
Sqrt[1/A4] QuarticF[
1] /. \[CapitalPhi] -> (Cos[\[Phi]] Sin[\[Phi]])^2 /. {\
\[Alpha] -> 1}], 1}, {\[Phi], 0, 2 Pi},
PlotRange -> {{-2, 2}, {-2, 2}},
PlotStyle -> {Gray, Directive[Thick, Black]}, Axes -> False] //
Quiet;
SquareGrowFlow = Join[SquareGrow, Table[SquareGrow[[-1]], {100}],
SquareFlow, Table[SquareFinal, {100}]];
ListAnimate[SquareGrowFlow]
![Square Grow Flow][8]
[Youtube Video][9]
[1]: http://community.wolfram.com/groups/-/m/t/1215747
[2]: https://www.youtube.com/watch?v=hwOCqA9Xw6A
[3]: http://mathworld.wolfram.com/DidosProblem.html
[4]: http://community.wolfram.com/groups/-/m/t/1034626
[5]: https://books.google.com/books?id=5CbJhbj0nNYC&printsec=frontcover&dq=the%20art%20of%20zen&hl=en&sa=X&ved=0ahUKEwj_5oPc3IzYAhXq5oMKHVMhDQwQ6AEIQDAE#v=onepage&q=the%20art%20of%20zen&f=false
[6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=TriangleGrowFlow.gif&userId=234448
[7]: https://www.youtube.com/watch?v=7a5Sw4nAoiA
[8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=SquareGrowFlow.gif&userId=234448
[9]: https://www.youtube.com/watch?v=yEQ9j6Ub_RcBrad Klee2017-12-15T19:53:57ZGet solutions to the gauged GL vortices in (1+1) dimensions?
http://community.wolfram.com/groups/-/m/t/1240500
I am trying to numerically solve the following differential equations for the profiles of the Gauged GL Vortices:
eqn1 = y''[x] + y'[x]/x - ((k - z[x])^2* y[x])/x^2 + ((1 - y[x]^2)*y[x])/2 == 0;
eqn2 = z''[x] - z'[x]/x + (k - z[x])*y[x]^2 == 0;
with the boundary conditions:
inf = 1000;
bc = {y[0] == 0, y[inf] == 1, z[0] == 0, z[inf] == 1};
I have tried a finite difference method but this seems to give large errors even for k = 1 so I am wondering if there is a better numerical method to yield a more accurate solution?
Below is my current function which I employ to solve these coupled differential equations:
Clear[fdd, pdetoode, tooderule, sollst]
fdd[{}, grid_, value_, order_] := value;
fdd[a__] := NDSolve`FiniteDifferenceDerivative@a;
pdetoode[funcvalue_List, rest__] :=
pdetoode[(Alternatives @@ Head /@ funcvalue) @@ funcvalue[[1]],
rest];
pdetoode[{func__}[var__], rest__] :=
pdetoode[Alternatives[func][var], rest];
pdetoode[rest__, grid_?VectorQ, o_Integer] :=
pdetoode[rest, {grid}, o];
pdetoode[func_[var__], time_, {grid : {__} ..}, o_Integer] :=
With[{pos = Position[{var}, time][[1, 1]]},
With[{bound = #[[{1, -1}]] & /@ {grid},
pat = Repeated[_, {pos - 1}],
spacevar = Alternatives @@ Delete[{var}, pos]},
With[{coordtoindex =
Function[coord,
MapThread[
Piecewise[{{1, # === #2[[1]]}, {-1, # === #2[[-1]]}},
All] &, {coord, bound}]]},
tooderule@
Flatten@{((u : func) |
Derivative[dx1 : pat, dt_, dx2___][(u : func)])[x1 : pat,
t_, x2___] :> (Sow@coordtoindex@{x1, x2};
fdd[{dx1, dx2}, {grid},
Outer[Derivative[dt][u@##]@t &, grid],
"DifferenceOrder" -> o]),
inde : spacevar :>
With[{i = Position[spacevar, inde][[1, 1]]},
Outer[Slot@i &, grid]]}]]];
tooderule[rule_][pde_List] := tooderule[rule] /@ pde;
tooderule[rule_]@Equal[a_, b_] :=
Equal[tooderule[rule][a - b], 0] //.
eqn : HoldPattern@Equal[_, _] :> Thread@eqn;
tooderule[rule_][expr_] := #[[Sequence @@ #2[[1, 1]]]] & @@
Reap[expr /. rule]
Clear@pdetoae;
pdetoae[funcvalue_List, rest__] :=
pdetoae[(Alternatives @@ Head /@ funcvalue) @@ funcvalue[[1]], rest];
pdetoae[{func__}[var__], rest__] :=
pdetoae[Alternatives[func][var], rest];
pdetoae[func_[var__], rest__] :=
Module[{t},
Function[pde, #[
pde /. {Derivative[d__][u : func][inde__] :>
Derivative[d, 0][u][inde, t], (u : func)[inde__] :>
u[inde, t]}] /. (u : func)[i__][t] :> u[i]] &@
pdetoode[func[var, t], t, rest]]Benjamin Leather2017-12-06T11:13:47ZProblem: Light transport through biological tissue
http://community.wolfram.com/groups/-/m/t/1241248
I'm new to Mathematica and while it seems like there should be a way to do this (it is effectively simultaneous equations) I don't know how to input it to Mathematica. I've tried using solve and setting it in a table first but it seems I'm not realizing something or missing something in the documentation about how to play with a few.
The problem represents light passing through tissue. There are two variables in the equation that I need to know, a and b. (if there is a method to input equations/code here can someone point it out to me?)
![enter image description here][1]
I(lam), I0(lam) are measured values. I will know these, they are the intensity of the light coming out and going into the volume at wavelength lambda. M(lam) is the absorption of tissue at the wavelength lamda, this I will also know at all lambdas.
d thickness of the tissue, this is a set value.
a and b are what I would like to know. That term represents the light scattering function for the tissue.
What I would like mathematica to do is tell me how many lambda's, or colors of light, do I have to measure at to find what a and b are, and the equation that gives me a and b.
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=KsqisKw.png&userId=20103Alan Riordan2017-12-07T12:03:56Z