Community RSS Feed
https://community.wolfram.com
RSS Feed for Wolfram Community showing any discussions in tag Mathematics sorted by active[✓] Solve the following equation?
https://community.wolfram.com/groups/-/m/t/1665736
Consider the following code:
TC = L + (1 - q) + SC + Ca +
Cr + (Exp[1 - RealAbs[1 - \[Mu]/Subscript[y, 0]]])*
MC + ((Exp[(Subscript[\[Sigma], 1] - \[Sigma])/(
Subscript[\[Sigma], 1] - Subscript[\[Sigma], 2])]) - 1)*DC
n = D[TC, {{\[Sigma], \[Mu]}}]
Solve[n == 0 // Rationalize, {\[Sigma], \[Mu]}]
I need to solve the equation, but running so long.maghfira devi2019-04-22T06:51:44ZSpecify meshes and boundaries in NDSolveValue?
https://community.wolfram.com/groups/-/m/t/1665050
I am trying to solve Laplace's equations in two-dimensions in order obtain the voltage field with specified regions and boundaries. One of the regions in the problem is a half-disk. I wish to specify a voltage on the boundary of that half-disk. I do not think that I know what my problem is, but I suspect that the boundary I am generating for that half-disk is wrong.
Ultimately NDSolveValue appears to work, but does not give a plausible answer. This problem does not require much code. It would be very helpful if someone could examine it and let me know what I am doing wrong.Robert Curl2019-04-20T21:53:54Zcomputable famous theorems of geometry
https://community.wolfram.com/groups/-/m/t/1664846
[GeometricScene][1] and [FindGeometricConjectures][2] are two of my favorite new functions in Wolfram Language V12. V12 provides innovative automated capabilities to draw and reason about abstractly described scenes in the plane.
I also remember that I'd proved famous theorems of geometry over many days when I was a junior high school student. I will show nine theorems, including those in the Documentation Center and [WOLFRAM blog][3].
## Thaless Theorem ##
If A, B, and C are distinct points on a circle where the line AC is a diameter, then the angle \[Angle]ABC is a right angle.
gs = GeometricScene[{"A", "B", "C", "O"},
{Triangle[{"A", "B", "C"}],
CircleThrough[{"A", "B", "C"}, "O"],
"O" == Midpoint[{"A", "C"}],
Style[Line[{"A", "B"}], Orange],
Style[Line[{"B", "C"}], Orange]
}
];
RandomInstance[gs]
FindGeometricConjectures[gs]["Conclusions"]
![enter image description here][4]
![enter image description here][5]
## Napoleons Theorem ##
If regular triangles are constructed on the sides of any triangle, either all outward or all inward, the lines connecting the centres of those regular triangles themselves form an regular triangle.
gs = GeometricScene[{"C", "B", "A", "C'", "B'", "A'", "Oc", "Ob",
"Oa"},
{Triangle[{"C", "B", "A"}],
TC == Triangle[{"A", "B", "C'"}],
TB == Triangle[{"C", "A", "B'"}],
TA == Triangle[{"B", "C", "A'"}],
GeometricAssertion[{TC, TB, TA}, "Regular"],
"Oc" == TriangleCenter[TC, "Centroid"],
"Ob" == TriangleCenter[TB, "Centroid"],
"Oa" == TriangleCenter[TA, "Centroid"],
Style[Triangle[{"Oc", "Ob", "Oa"}], Orange]}
];
RandomInstance[gs]
FindGeometricConjectures[gs]["Conclusions"]
![enter image description here][6]
![enter image description here][7]
## Finsler-Hadwiger Theorem ##
ABCD and A BB CC DD are two squares with common vertex A. Let Q and S be the midpoints of BB D and DD B respectively, and let R and T be the centers of the two squares. Then the quadrilateral QRST is a square as well.
gs = GeometricScene[{"A", "B", "C", "D", "BB", "CC", "DD", "Q", "R", "S", "T"},
{GeometricAssertion[{Polygon[{"A", "B", "C", "D"}],
Polygon[{"A", "BB", "CC", "DD"}]}, "Regular", "Counterclockwise"],
"Q" == Midpoint[{"BB", "D"}],
"R" == Midpoint[{"A", "C"}],
"S" == Midpoint[{"B", "DD"}],
"T" == Midpoint[{"A", "CC"}],
Style[Polygon[{"Q", "R", "S", "T"}], Orange]}];
RandomInstance[gs]
FindGeometricConjectures[gs]["Conclusions"]
![enter image description here][8]
![enter image description here][9]
## Echols Theorem ##
The midpoints of AD, BE, and CF in two equilateral triangles ABC and DEF form a regular triangle.
gs = GeometricScene[{"A", "B", "C", "D", "E", "F", "L", "M", "N"},
{T1 == Triangle[{"A", "B", "C"}],
T2 == Triangle[{"D", "E", "F"}],
GeometricAssertion[{T1, T2}, "Regular"],
"L" == Midpoint[{"A", "D"}],
"M" == Midpoint[{"B", "E"}],
"N" == Midpoint[{"C", "F"}],
Style[Triangle[{"L", "M", "N"}], Orange]
}
];
RandomInstance[gs]
FindGeometricConjectures[gs]["Conclusions"]
![enter image description here][10]
![enter image description here][11]
## Simson Theorem & Steiner Theorem ##
Simson's Theorem states that ABC and a point P on its circumcircle, the three closest points to P on lines AB, AC, and BC are collinear. Steiner's Theorem states that if the vertical center of triangle ABC is H, the Simson line passes through the midpoint of PH.
gs = GeometricScene[{"A", "B", "C", "P", "L", "M", "N", "H", "S"},
{CircleThrough[{"P", "A", "B", "C"}],
"L" \[Element] InfiniteLine[{"B", "C"}],
"M" \[Element] InfiniteLine[{"C", "A"}],
"N" \[Element] InfiniteLine[{"A", "B"}],
PlanarAngle[{"P", "L", "B"}] == 90 \[Degree],
PlanarAngle[{"P", "M", "C"}] == 90 \[Degree],
PlanarAngle[{"P", "N", "A"}] == 90 \[Degree],
Style[InfiniteLine[{"L", "M"}], Orange],
GeometricAssertion[{InfiniteLine[{"A", "H"}], Line[{"B", "C"}]},
"Perpendicular"],
GeometricAssertion[{InfiniteLine[{"B", "H"}], Line[{"A", "C"}]},
"Perpendicular"],
Style[Line[{"P", "H"}], Orange],
Line[{"P", "S", "H"}], Line[{"L", "S", "M"}]
}
];
RandomInstance[gs]
FindGeometricConjectures[gs]["Conclusions"]
![enter image description here][12]
![enter image description here][13]
## Aubel Theorem ##
Starting with a given quadrilateral (a polygon having four sides), construct a square on each side.The two line segments between the centers of opposite squares are of equal lengths and are at right angles to one another.
gs = GeometricScene[{"A", "B", "C", "D", "A'", "A''", "B'",
"B''", "C'", "C''", "D'", "D''", "Oa", "Ob", "Oc", "Od"},
{GeometricAssertion[Polygon[{"A", "B", "C", "D"}], "Convex"],
GeometricAssertion[{pa = Polygon[{"A", "B", "A'", "A''"}],
pb = Polygon[{"B", "C", "B'", "B''"}],
pc = Polygon[{"C", "D", "C'", "C''"}],
pd = Polygon[{"D", "A", "D'", "D''"}]}, "Regular",
"Counterclockwise"],
"Oa" == Midpoint[{"A", "A'"}],
"Ob" == Midpoint[{"B", "B'"}],
"Oc" == Midpoint[{"C", "C'"}],
"Od" == Midpoint[{"D", "D'"}],
Style[Line[{"Oa", "Oc"}], Orange],
Style[Line[{"Ob", "Od"}], Orange]}
];
RandomInstance[gs]
FindGeometricConjectures[gs]["Conclusions"]
![enter image description here][14]
![enter image description here][15]
## Brahmagupta Theorem ##
If a cyclic quadrilateral has perpendicular diagonals, then the perpendicular to a side from the point of intersection of the diagonals always bisects the opposite side.
gs = GeometricScene[{"A", "B", "C", "D", "E", "M"},
{Polygon[{"A", "B", "C", "D"}],
CircleThrough[{"A", "B", "C", "D"}],
GeometricAssertion[{Line[{"A", "C"}], Line[{"B", "D"}]},
"Perpendicular"],
Line[{"A", "E", "C"}], Line[{"B", "E", "D"}],
"M" == Midpoint[{"A", "B"}],
Style[InfiniteLine[{"M", "E"}], Orange],
Style[Line[{"C", "D"}], Orange]
}
];
RandomInstance[gs]
FindGeometricConjectures[gs]["Conclusions"]
![enter image description here][16]
![enter image description here][17]
## Morley Theorem ##
In any triangle, the three points of intersection of the adjacent angle trisectors form a regular triangle.
gs = GeometricScene[{"A", "B", "C", "D", "E", "F"},
{Triangle[{"A", "B", "C"}],
PlanarAngle[{"A", "B", "F"}] == PlanarAngle[{"A", "B", "C"}]/3,
PlanarAngle[{"F", "A", "B"}] == PlanarAngle[{"C", "A", "B"}]/3,
PlanarAngle[{"C", "B", "D"}] == PlanarAngle[{"C", "B", "A"}]/3,
PlanarAngle[{"B", "C", "D"}] == PlanarAngle[{"B", "C", "A"}]/3,
PlanarAngle[{"A", "C", "E"}] == PlanarAngle[{"A", "C", "B"}]/3,
PlanarAngle[{"C", "A", "E"}] == PlanarAngle[{"C", "A", "B"}]/3,
"D" \[Element] Triangle[{"A", "B", "C"}],
"E" \[Element] Triangle[{"A", "B", "C"}],
"F" \[Element] Triangle[{"A", "B", "C"}],
Style[Triangle[{"D", "E", "F"}], Orange]
}
];
RandomInstance[gs]
FindGeometricConjectures[gs]["Conclusions"]
![enter image description here][18]
![enter image description here][19]
[1]: https://reference.wolfram.com/language/ref/GeometricScene.html
[2]: https://reference.wolfram.com/language/ref/FindGeometricConjectures.html
[3]: https://blog.wolfram.com/2019/04/16/version-12-launches-today-big-jump-for-wolfram-language-and-mathematica/
[4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=122401.jpg&userId=1013863
[5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=801502.jpg&userId=1013863
[6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=508803.jpg&userId=1013863
[7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=222204.jpg&userId=1013863
[8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=289105.jpg&userId=1013863
[9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=932006.jpg&userId=1013863
[10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=876507.jpg&userId=1013863
[11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=184108.jpg&userId=1013863
[12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=350909.jpg&userId=1013863
[13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=500710.jpg&userId=1013863
[14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=318711.jpg&userId=1013863
[15]: https://community.wolfram.com//c/portal/getImageAttachment?filename=254812.jpg&userId=1013863
[16]: https://community.wolfram.com//c/portal/getImageAttachment?filename=308813.jpg&userId=1013863
[17]: https://community.wolfram.com//c/portal/getImageAttachment?filename=934714.jpg&userId=1013863
[18]: https://community.wolfram.com//c/portal/getImageAttachment?filename=367015.jpg&userId=1013863
[19]: https://community.wolfram.com//c/portal/getImageAttachment?filename=16.jpg&userId=1013863Kotaro Okazaki2019-04-20T14:42:58Z[✓] Evaluate complex function Cos[Sqrt[s]]
https://community.wolfram.com/groups/-/m/t/1665868
Dear Sir/Madam,
I have evaluated a complex function Cos[Sqrt[s]] (s is complex variable) in Mathematica version 10. The results are presented in the attached file. However, Mathematica can not evaluate the function along the negative direction of the x-axis. Such a problem was not in Matlab. How can I resolve such problem in Mathematica?
Best regardsM Abadi2019-04-22T06:45:17ZGet detailed step by step operations of a Factoring?
https://community.wolfram.com/groups/-/m/t/1666130
In the below example:
In[41]:= Factor[((1/x - 1) (1/x + 1))/((x - 1) (1/x + 1))]
Out[41]= -(1/x)
I need Mathematica to provide a trace of each operation taken to get to the result (possibly with the associated rule but not mandatory).
In another software it is possible to do that with the command:
explain(factorExpr(((1/x - 1) (1/x + 1))/((x - 1) (1/x + 1))))
How can I do the same thing with Mathematica?LV Vß2019-04-22T08:37:25ZTest the significance of the result from NonlinearModelFit?
https://community.wolfram.com/groups/-/m/t/1665378
I have some data, and I have done a NonlinearModelFit on it, actually fitting it to a sine curve. I can get the "RSquared" and "AdjustedRSquared", e.g. with nlm["AdjustedRSquared"] where nlm is the output of the NonlinearModelFit. I now want to test the significance of the result. I would like to end up with a single number p, so that I could say, "the probability of getting such a fit by chance is p".
NonlinearModelFit has properties like "ParameterPValues" and "ParameterTStatistics". However, I have looked in the StatisticalModelAnalysis tutorial, and there is no real explanation of how they might be used or generally how to do significance testing.
Does NonlinearModelFit have built in ways to get significance (probability of fit being due to chance)? Or is there a good tutorial on using the output of Mathematica's NonlinearModelFit to do significance testing?Marc Widdowson2019-04-21T13:46:43ZInteger area search, SEPP triangles
https://community.wolfram.com/groups/-/m/t/1665973
#Description:
This work is the search for scalene SEPP (Square Even-Prime-Prime) triangles with integer area. They're semi-rare to be found. There are no square odd-prime-prime triangles with integer area, as there are no triangles with the three odd sides and integer area. Its first representative is the triangle with sides 3-4-5. Below is the representative image of a SEPP:
![enter image description here][1]
I've elaborated this simple code below to find the triangles with these properties. I opted to use parallel computing (8 kernels) and measured the computing time of each evaluate. The sides have the measurement until just below the quantity required in "n" (< n). The answer is in the form: "Quantity used" {"side a", "side b", "side c"} {“area”} “graphics”, with absolute time just below.
# Objective and Coding:
The main objective here is to find how many of these exist for sides varying up to 10,100, 1000… in amounts of powers of 10 (10^x). Following just one example with the sides up to 50 to test the code; only 1 triangle found, the 3-4-5:
Parallelize[n = 50;
p = PrimePi[n];
Do[a = (2*i)^2; b = Prime[j]; c = Prime[k];
If[c < a + b \[And] a < b + c \[And] b < a + c \[And]
Area[SSSTriangle[a, b, c]] \[Element] Integers,
Print[n, {a, b, c}, {Area[SSSTriangle[a, b, c]]},
Graphics[SSSTriangle[a, b, c]]]], {i, 1,
IntegerPart[Sqrt[n - 1]/2]}, {j, 2, p - 1}, {k, j + 1,
p}]] // AbsoluteTiming
![enter image description here][2]
Now a code modification to find multiple results of the processing time in just one evaluation. The example below is programmed to calculate from 10 to 100 with steps of 10 {m,10,100,10}:
Do[Print[Parallelize[n = m;
p = PrimePi[n];
Do[a = (2*i)^2; b = Prime[j]; c = Prime[k];
If[c < a + b \[And] a < b + c \[And] b < a + c \[And]
Area[SSSTriangle[a, b, c]] \[Element] Integers, Null], {i, 1,
IntegerPart[Sqrt[n - 1]/2]}, {j, 2, p - 1}, {k, j + 1, p}]] //
AbsoluteTiming], {m, 10, 100, 10}]
![enter image description here][3]
Above you can change in the code the part {m,10,100,10} by {m,{100,140,210}} to find, for example, the result for specific quantities of 100, 140, 210 etc. You can also change the Null part in the code by Print[n,{a,b,c},{Area[SSSTriangle[a,b,c]]},Graphics[SSSTriangle[a,b,c]]] to have multiple responses seeking the triangles.
#Calculation and Results:
To carry out the evaluation in this work I used the following machine (only to have an idea of the processing used):
Intel(R) Core(TM) i7-9700K CPU @ 3.60GHz, 3600 Mhz, 8 Core(s), 8 Logic Processor(s) (run with 8 Kernels), RAM 16.0 GB, BaseBoard B360M AORUS Gaming 3, X64, NVIDIA GeForce GTX 1060 6GB.
The following table was assembled with the data of the quantities (maximum values for the side) in "n" and the absolute times (seconds) spent on parallel computing:
![enter image description here][4]
Now the results found using values with powers of 10:
- From values up to 10 (<10) and up to 100 (<100):
![enter image description here][5]
- The result for sides up to 1000 (<1000):
![enter image description here][6]
- And finally the result for sides up to 10000 (<10000):
![enter image description here][7]
#Time Prediction (Fitting Model):
I also made an attempt to predict the time required to calculate and find triangles with sides larger than 10000, so I used FindFit as follows (I did using "a.x^b" and "a.x^b.c^x"). I chose reduce the x-axis in a factor of 10 to make the fit (do not know how this affected the accuracy or if has affected..?), below is the example of the first fit (result with the fit of the data from 1000 to 10000 with steps of 1000 and with the prediction for 10^5):
y = a*x^b // StandardForm
data = {{10, 0.171556}, {20, 0.529822}, {30, 1.05338}, {40,
1.86622}, {50, 3.123}, {60, 6.25655}, {70, 9.20718}, {80,
12.59}, {90, 15.356}, {100, 18.9604}, {110, 23.6784}, {120,
21.1587}, {130, 25.256}, {140, 28.0271}, {150, 34.3804}, {160,
38.2134}, {170, 45.9896}, {180, 51.1624}, {190, 56.4499}, {200,
64.8474}, {210, 71.6892}, {220, 115.029}, {230, 124.75}, {240,
139.067}, {250, 146.954}, {260, 117.413}, {300, 167.935}, {340,
236.836}, {380, 305.191}, {400, 345.106}, {440, 431.134}, {460,
475.442}, {500, 566.853}, {520, 623.334}, {550, 695.491}, {560,
716.899}, {580, 794.285}, {590, 833.365}, {600, 852.083}, {630,
982.572}, {640, 1021.09}, {660, 1148.21}, {690, 1265.83}, {700,
1322.47}, {710, 1324.94}, {750, 1428.75}, {780, 1560.02}, {800,
1676.75}, {820, 1819.18}, {860, 2024.3}, {900, 2290.71}, {950,
2629}, {1000, 2972.96}};
FindFit[%, a*x^b, {a, b}, x]
Table[a*x^b /. %, {x, 100, 1000, 100}] \[And]
Table[a*x^b /. %, {x, {10000}}]
![enter image description here][8]
This chart was created using the real absolute time data as well as the two curves generated by FindFit that I tested:
![enter image description here][9]
#Conclusion:
There are only 13 scalene SEPP triangles with integer area and sides varying up to 10000 (10^4).
The curves used in FindFit gave very divergent values to predict the time required to evaluate with the sides up to 100000 (10^5), and the curve fit "a.x^b" (fit 1) was more optimistic and estimated that it would take 8 days of computation in parallel, while the curve fit "a.x^b.c^x" (fit 2) estimated it would take 171.5 days! ... Anyway are very long computing time to calculate all the possibilities of sides up to 10^5.
To choose the best fit curve to be able to predict with longer times, I evaluated with the sides up to 15000 to have a real point of time and get to know which curve approaches better. The real time for sides up to 15000 was 7428.57 seconds. The “fit 1” curve came closest to the value with a prediction of 7679.62 seconds, while the “fit 2” curve estimated a time of 8452.19 seconds. The "fit 1" curve had a difference of 4 minutes and 11 seconds or approximately 3.4% of the real value.
#A Few Questions (that I have):
- Is there any way to make these codes faster or more efficient? Any other way to find that kind of triangle using codes?
- Is there a better way to use FindFit in this case to have a more accurate prediction? Maybe another function or more/less data? How to know the correct function model?
- How many of these triangles will there be if we search for sides up to 10^5 or even 10^6? Would anyone have any idea to help me find it?
Thank you very much to everyone in the community.
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=i1.png&userId=1316061
[2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=i2.png&userId=1316061
[3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=i3.png&userId=1316061
[4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=i4.png&userId=1316061
[5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=i5.png&userId=1316061
[6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=i6.png&userId=1316061
[7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=i7.png&userId=1316061
[8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=i8.png&userId=1316061
[9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=i9.png&userId=1316061Claudio Chaib2019-04-22T03:51:46ZPlot two lines for max/min error on a plot?
https://community.wolfram.com/groups/-/m/t/1665533
Dear all,
How do I plot two parallel lines for maximum and minimum values of relative error percentage as below:
In[124]:= m = {2.2027036725996783`,
5.280362701954329`, -1.0124449729925813`, 1.698979465419002`,
3.141591718306451`, -2.745060440009399`, -1.6113207086717107`,
0.16638391106163822`, -2.258695482994957`, -0.3482598627250328`,
4.925577851518227`, 2.6750207005122877`, -4.02288009868453`,
2.714952029120464`, 3.034760679525427`,
3.729591243576016`, -3.3014545762020924`, -0.22188437300968553`, \
-5.337065768483884`, -4.1220754806842725`,
0.5332742419880744`, -2.8743222182737225`, -2.693012697508946`,
0.32865798833744514`,
4.027192028466991`, -2.8987838601887117`, -0.16628212916201005`,
3.484024392679025`, -3.2865991892298494`, -1.4074929511476675`, \
-0.1376591620771673`, -1.340169784223353`, -0.18874557070863454`, \
-0.7158258869527857`, -1.6221568977272842`, 2.220428106758959`,
0.18756079584372606`, 2.877020526594872`, 1.6279535082847358`,
0.615660929310434`,
0.8731989288504256`, -2.4430509995815504`, -3.8101555754900276`, \
-0.41354676208662355`, -3.1882480501258503`,
2.797772540468918`, -4.423074431837073`, -0.15315482194415617`, \
-0.9330704276794881`, -2.6279243117503595`, 2.4286072216474692`,
3.303587280307156`,
3.8085267078688805`, -1.9518727734300068`, -4.213412770426206`, \
-2.357017551327045`,
3.4733691167400265`, -0.11673331538713343`, -0.40688016301067764`,
1.6698198640343067`, 0.14831028096303508`, 0.24317430279547272`,
3.011211821071481`, -0.48218554546387205`, 0.09689880402434317`,
1.191374402522961`, -2.7963094788933693`, -1.7336554568628828`,
0.7339703452354714`, -0.8739780822047689`, -3.63379798637767`,
1.0591084727706641`, 5.324198415974884`,
0.0845454122567755`, -3.991208337015724`, -3.793925049867107`,
1.8074800549551044`, 1.1480036635543738`, -2.7476419011691475`,
1.00023361017206`, 0.028334302480905814`, -0.008048998604257977`}
In[129]:= {Max[m], Min[m]}
Out[129]= {5.3242, -5.33707}
In[130]:= ListLinePlot[m, LabelStyle -> {14, GrayLevel[0], Bold},
ImageSize -> 500, PlotStyle -> Blue,
AxesLabel -> {"Sample", "Relative Error (%)"}, Filling -> Axis,
PlotRange -> All]
![enter image description here][1]
Many thank!
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=4924Untitled.png&userId=943918M.A. Ghorbani2019-04-21T14:29:26Z[✓] Replace "I" with "0"?
https://community.wolfram.com/groups/-/m/t/1665703
So I wanted to replace i with 0 in my equation (pls don't ask why). I tried several options but none of them gave the result I wanted. What should I do?![showcase of the problem][1]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=wolfWTF.png&userId=1308552Daniel Voloshin2019-04-21T19:59:34ZInvert a 2x2 matrix with 2x2 matrix elements?
https://community.wolfram.com/groups/-/m/t/1651695
If this is my matrix a as follows:
a00 a01
a10 a11
Element a00 would be comprised of a matrix b as follows:
b00 b01
b10 b11
And so on ...
I want to solve my A matrix using Mathematica algorithm.
Thanks for your help.
Stanstan gianzero2019-04-07T16:35:03ZVisualizing simultaneous iteration methods for polynomial roots
https://community.wolfram.com/groups/-/m/t/1646447
One of my longstanding research interests in numerical analysis has been the family of "simultaneous iteration" methods for finding polynomial roots. (See e.g. [McNamee's book][1] for a comprehensive survey.) Briefly put, these are modified Newton-Raphson methods that allow one to find the roots of a polynomial all at once, as opposed to finding them one at a time and "deflating".
I had the idea to visualize how these algorithms gradually proceed from initial approximations to the roots, up to convergence. After a number of experiments, I settled on using [domain coloring][2] for visualization. I have found that the logarithmic derivatives of polynomials gave particularly striking plots.
For this post, I have used the scaled [exponential sum][3] of degree 20:
$$\frac{20!}{20^{20}}\sum_{k=0}^{20}\frac{(20z)^k}{k!}$$
as the example polynomial whose roots we want to see. It [is][4] [known][5] that the zeroes of this polynomial asymptotically approach the so-called Szegő curve as the polynomial degree goes to infinity.
![Szegő curve][6]
expPoly[x_] = With[{n = 20}, Sum[(n! (n x)^k)/(k! n^n), {k, 0, n}]]
---
I will now look at two of the most popular simultaneous iteration methods. The first one is the [(Weierstrass-)Durand-Kerner method][7],
$$x_i^{(k+1)}=x_i^{(k)}-\frac{p(x_i^{(k)})}{\prod\limits_{j\neq i} (x_i^{(k)}-x_j^{(k)})},\qquad i=1\dots n;\; k=0,1,\dots$$
which is (typically) quadratically convergent. (Note that in simultaneous iteration methods, the polynomials are always assumed to be monic (i.e., unit leading coefficient).)
Implementing the iteration is easy using `FixedPointList[]`. As is customary with these methods, we use as a starting approximation points equispaced around the unit circle, and slightly rotated:
ptsdk = FixedPointList[# - expPoly[#]/Table[Apply[Times, #[[k]] - Delete[#, k]],
{k, Length[#]}] &,
N[Exp[2 π I Range[0, 19]/20 - I π/40]], 40,
SameTest -> (EuclideanDistance[##] < 1.*^-6 &)];
I use a loose convergence criterion that is good enough for visualization purposes.
For the domain coloring plot, I will use a slightly modified version of the [DLMF color scheme][8], based on an idea of [Quilez][9].
DLMFPhaseColor[u_, s_:1, b_:1] := Module[{rgb},
rgb = Clip[{1, -1, -1} Abs[{8, 4, 8} Mod[u/(2 π), 1] -
{9, 3, 11}/2] + {-3, 3, 5}/2, {0, 1}];
rgb = (3 - 2 rgb) rgb^2;
Apply[RGBColor, b (1 + s (rgb - 1))]]
I then use a simplified version of [code originally written by user Heike][10] on Mathematica Stack Exchange:
dcdk = RegionPlot[True, {x, -9/8, 9/8}, {y, -9/8, 9/8},
ColorFunction ->
Function[{x, y}, DLMFPhaseColor[Arg[Total[1/(x + I y - #)]]]],
ColorFunctionScaling -> False, Frame -> False,
PlotPoints -> 405] & /@ ptsdk;
(This takes some time, due to the high `PlotPoints` setting.)
We can now see an animation:
ListAnimate[dcdk]
![Durand-Kerner][11]
The other method I will be looking at in this post is the (typically) cubically convergent [Ehrlich-Aberth(-Maehly) method][12],
$$x_i^{(k+1)}=x_i^{(k)}-\frac{\tfrac{p(x_i^{(k)})}{p^\prime(x_i^{(k)})}}{1-\tfrac{p(x_i^{(k)})}{p^\prime(x_i^{(k)})}\sum\limits_{j\neq i} \tfrac1{x_i^{(k)}-x_j^{(k)}}},\qquad i=1\dots n;\; k=0,1,\dots$$
which is also one of the methods available in *Mathematica*'s `NSolve[]`/`NRoots[]`.
Unfortunately, I have no way to get the iterates generated by `NSolve[]`, so I had to reimplement the method myself. We can use essentially the same code as was used for Durand-Kerner, with a few changes:
ptsea = FixedPointList[With[{ld = expPoly[#]/expPoly'[#]},
# - ld/(1 - ld Table[Tr[1/(#[[k]] - Delete[#, k])],
{k, Length[#]}])] &,
N[Exp[2 π I Range[0, 19]/20 - I π/40]], 40,
SameTest -> (EuclideanDistance[##] < 1.*^-6 &)];
dcea = RegionPlot[True, {x, -9/8, 9/8}, {y, -9/8, 9/8},
ColorFunction ->
Function[{x, y}, DLMFPhaseColor[Arg[Total[1/(x + I y - #)]]]],
ColorFunctionScaling -> False, Frame -> False,
PlotPoints -> 405] & /@ ptsea;
ListAnimate[dcea]
![Ehrlich-Aberth][13]
It would be interesting to use this visualization technique on other polynomials with interesting root structure, as well as other simultaneous iteration methods.
[1]: https://books.google.com/books?hl=en&id=4PMqxwG-eqQC&pg=PA67
[2]: https://en.wikipedia.org/wiki/Domain_coloring
[3]: http://mathworld.wolfram.com/ExponentialSumFunction.html
[4]: https://doi.org/10.1216/rmjm/1181072998
[5]: https://doi.org/10.1007/BFb0087909
[6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=vpliw.gif&userId=520181
[7]: https://en.wikipedia.org/wiki/Durand%E2%80%93Kerner_method
[8]: https://dlmf.nist.gov/help/vrml/aboutcolor#S2
[9]: https://www.shadertoy.com/view/MsS3Wc
[10]: https://mathematica.stackexchange.com/a/7293/
[11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=dcdk.gif&userId=520181
[12]: https://en.wikipedia.org/wiki/Aberth_method
[13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=dcea.gif&userId=520181J. M.2019-04-04T04:38:26Z96_6 Configuration
https://community.wolfram.com/groups/-/m/t/1664705
Every node has six lines.
Every line has six nodes.
If you like these designs
You can try out my codes.
![96_6 configuration][1]
base={{0,-1},{0,Root[1+2 #1+2 #1^3+#1^4&,2]},{1/2,Root[-11-8 #1+24 #1^2-32 #1^3+16 #1^4&,1]},{1/2,Root[-11+8 #1+24 #1^2+32 #1^3+16 #1^4&,2]},{1/2 (2-Sqrt[3]),-(1/2)},{Root[-1+4 #1-8 #1^3+8 #1^4&,2],Root[3-24 #1+48 #1^2-24 #1^3+8 #1^4&,1]},{Root[-1+4 #1-8 #1^3+8 #1^4&,2],Root[3+24 #1+48 #1^2+24 #1^3+8 #1^4&,2]},{Root[1+4 #1+16 #1^3+16 #1^4&,2],Root[1-20 #1+48 #1^2+16 #1^3+16 #1^4&,1]}};
nodes = Flatten[Table[RootReduce[#.RotationMatrix[n Pi/6 ]], {n, 0, 11}] & /@ base,1];
lines={{1,9,60,59,26,38},{1,8,49,57,83,64},{1,6,54,50,76,69},{1,5,52,51,30,42},{1,24,37,41,84,73},{1,14,27,31,67,68},{12,8,59,58,25,37},{12,7,60,56,82,63},{12,5,49,53,75,68},{12,4,51,50,29,41},{12,13,26,30,66,67},{12,23,48,40,83,84},{11,7,58,57,36,48},{11,6,59,55,81,62},{11,4,60,52,74,67},{11,3,49,50,28,40},{11,24,25,29,66,65},{11,22,47,39,82,83},{10,6,57,56,35,47},{10,5,58,54,80,61},{10,3,59,51,73,66},{10,2,49,60,27,39},{10,23,36,28,64,65},{10,21,46,38,81,82},{9,5,56,55,34,46},{9,4,57,53,79,72},{9,2,58,50,84,65},{9,22,35,27,63,64},{9,20,45,37,80,81},{8,4,55,54,33,45},{8,3,56,52,78,71},{8,21,34,26,62,63},{8,19,44,48,80,79},{7,3,54,53,32,44},{7,2,55,51,77,70},{7,20,33,25,61,62},{7,18,43,47,78,79},{6,2,53,52,31,43},{6,19,32,36,72,61},{6,17,42,46,77,78},{5,18,35,31,71,72},{5,16,45,41,76,77},{4,17,34,30,70,71},{4,15,44,40,75,76},{3,16,33,29,69,70},{3,14,43,39,74,75},{2,13,42,38,73,74},{2,15,32,28,68,69},{49,92,48,41,82,74},{49,94,26,31,69,65},{60,93,25,30,68,64},{60,91,47,40,81,73},{59,92,36,29,67,63},{59,90,46,39,80,84},{58,91,35,28,66,62},{58,89,45,38,83,79},{57,90,34,27,61,65},{57,88,44,37,82,78},{56,89,33,26,72,64},{56,87,43,48,81,77},{55,88,32,25,71,63},{55,86,42,47,80,76},{54,87,36,31,70,62},{54,85,46,41,75,79},{53,86,35,30,69,61},{53,96,45,40,74,78},{52,85,34,29,68,72},{52,95,44,39,73,77},{51,96,33,28,67,71},{51,94,43,38,84,76},{50,93,42,37,83,75},{50,95,32,27,66,70},{13,21,92,91,27,37},{13,20,93,89,82,65},{13,18,86,94,75,70},{13,17,96,95,31,41},{24,20,91,90,26,48},{24,19,92,88,81,64},{24,17,93,85,74,69},{24,16,95,94,30,40},{23,19,90,89,25,47},{23,18,91,87,80,63},{23,16,92,96,73,68},{23,15,93,94,29,39},{22,18,89,88,36,46},{22,17,90,86,79,62},{22,15,91,95,84,67},{22,14,93,92,28,38},{21,17,88,87,35,45},{21,16,89,85,78,61},{21,14,90,94,83,66},{20,16,87,86,34,44},{20,15,88,96,77,72},{19,15,86,85,33,43},{19,14,87,95,76,71},{18,14,85,96,32,42}};
From L. W. Berman, "Geometric Constructions for Symmetric 6-Configurations," Rigidity and Symmetry, Springer, 2014, p. 83.
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=96_6Config.jpg&userId=21530Ed Pegg2019-04-19T14:49:09ZSolve a wave equation with boundary conditions using NDSolve?
https://community.wolfram.com/groups/-/m/t/1664540
I want to study the time evolution of a small perturbation around the static solution of the following Wave Equation
$ -\partial_t^2 v(t,r) + \partial_r^2v(t,r) + \frac{2}{r}\partial_r v(t,r) = \frac{\partial V(v)}{\partial v}(t,r) $
for some expression of the potential $V(v)$ that is written in the code below. The coordinates $t,r$ run over $[0,+\infty]$.
By definition, the static solution $\hat{v}(r)$ is time-independent and I require the following initial/boundary conditions
$ \partial_r \hat{v}(r)|_{r=0} =0\,,\qquad \hat{v}(r \rightarrow +\infty) = 0. $
Obviously, to perform numerical computations the limit $r\rightarrow+\infty$ is replaced by $r=M$ where $M\gg \ell$ where $\ell$ is the characteristic length of the problem; it turns out to be $\ell \sim 2$ for the static solution.
I want to perturb this solution at $t=0$ and see how it evolves with time. So, now I am interested in the time-dependent solution which satisfies
$ v(t=0,r) = \hat{v}(r)\,\qquad \partial_t v(r,t)|_{t=0}=\delta \cdot 10^{-2}\,,\\
\partial_r v(t,r)|_{r=0}=0\,, \qquad v(r=M) = 0. $
where $\delta\ll 1$.
- While the numerical static solution satisfies $\hat{v}'(r=0)=0$, the time-dependent solution I got does not. I don't understand why. For a specific example with $\delta = 0.001$, I get $\partial_r v(t,r) \sim -0.000701892$ irrespectively of the value of the time variable `t`. In particular, it looks the initial condition $v(t=0,r) = \hat{v}(r)$ is not satisfied. Is this normal?
- Moreover, I get the error [![enter image description here][1]][1], why? Are my boundary conditions really inconsistent?
This is my code.
V[v_] = (-1 + (1/8 (-9 + Sqrt[145]) - v)^2)^2 + 3 (1/8 (-9 + Sqrt[145]) - v)^3;
sol[rmax_, \[Delta]_] := Last@Last@ Last@NDSolve[{+D[v[r], {r, 2}] + 2/r D[v[r], {r, 1}] - (D[V[v], v] /. v -> v[r]) == 0, (D[v[r], r] /. r -> SetPrecision[10^-10, 100]) == 0, v[SetPrecision[10^-10, 100]] == SetPrecision[\[Delta], 100]}, v, {r, 10^-10, rmax}, WorkingPrecision -> 50, Method -> "Extrapolation"]
iTf = sol[30, 1.506400187591933106770472351];
Plot[{iTf[r]}, {r, 0, 30}, PlotRange -> All, Frame -> True]
iTfTime = v /. ParametricNDSolve[{-D[v[t, r], {t, 2}] + D[v[t, r], {r, 2}] + 2/r D[v[t, r], {r, 1}] - (D[V[v], v] /. v -> v[t, r]) == 0, v[0, r] == iTf[r], ((D[v[t, r], t]) /. t -> 0) == +\[Delta] 10^-2, (D[v[t, r], r] /. r -> 10^-10) == 0}, v, {t, 0, 40}, {r, 10^-10, 30}, {\[Delta]}, WorkingPrecision -> MachinePrecision, Method -> {"MethodOfLines", "TemporalVariable" -> t, "SpatialDiscretization" -> {"TensorProductGrid", "MinPoints" -> 200}}, PrecisionGoal -> 15]
iTfTimeToPlot0 = iTfTime[0.001];
(*Checking boundary conditions in generic points*)
((D[iTfTimeToPlot0[t, r], t] /. t -> 0) /. r -> RandomReal[]) == +0.001 10^-2
(*Output: True*)
((D[iTfTimeToPlot0[t, r], r] /. r -> 10^-10) /. t -> RandomReal[]) == 0
(*Output: False*)
[1]: https://i.stack.imgur.com/SPDnN.pngmathPhys User2019-04-19T11:01:29ZRubiks Cubes and OOP in Mathematica
https://community.wolfram.com/groups/-/m/t/1659434
I recently got [nerd sniped](https://xkcd.com/356/) on a [question on Stack Exchange](https://mathematica.stackexchange.com/a/195065/38205)
Originally I just wanted to show off my immutable OOP framework that uses a bunch of Mathematica's built in features to make something with a nice interface like `CloudExpression` but then that devolved into redoing the entirety of [Roman Maeder's Rubiks Cube Demo](http://demonstrations.wolfram.com/RubiksCube/) as an object.
To make this work you need my `InterfaceObjects` package, which implements Mathematica OOP. You can single-line install that [here](https://paclets.github.io/PacletServer/interfaceobjects.html).
Then load the Rubik's cube package off GitHub [here](https://github.com/b3m2a1/mathematica-tools/blob/master/RubiksCube.wl) (you can also go there to see how this OOP package works):
Get["https://github.com/b3m2a1/mathematica-tools/raw/master/RubiksCube.wl"]
Now we can make an object:
new = RubiksCube[]
Visualize it:
new@"Show"[]
[![enter image description here][4]][4]
Make a new one of a different size and change its colors:
r1 = RubiksCube["Size" -> 4];
r1@"Colors" = ColorData["Atoms"] /@ {6, 7, 8, 9, 11, 13, 18};
r1@"Show"[Method -> {"ShrinkWrap" -> True}]
[![enter image description here][1]][1]
Or make two and plot them side by side with some twists:
r2 = RubiksCube["Origin" -> {10, 0, 0}, "Size" -> 10];
Show[
r1@"Twist"[.5, {"Y", 2}]@"Twist"[.5, {"Y", 4}]@"Show"[],
r2@"Show"[],
PlotRange -> All
]
You can also `Manipulate` the twisting, if you want:
Manipulate[
Fold[
#@"Twist"[#2[[1]], #2[[2]]] &,
new,
Thread[
{
{b, f, l, r, d, u},
{"Back", "Front", "Left", "Right", "Down", "Up"}
}
]
]@"Show"[],
{b, 0, 2 π, .01},
{f, 0, 2 π, .01},
{l, 0, 2 π, .01},
{r, 0, 2 π, .01},
{d, 0, 2 π, .01},
{u, 0, 2 π, .01},
DisplayAllSteps -> True
]
[![enter image description here][5]][5]
The OOP interface itself is actually very nice, as it allows us to only have to provide and document a single symbol and then some `"Methods"`, which actually are discoverable by name as well, along with the `"Properties"`:
r1@"Methods"
{"Show", "Twist"}
r1@"Properties"
{"Size", "Origin", "Colors", "Cuboids", "Version", "Properties", "Methods"}
[1]: https://i.stack.imgur.com/tPUcO.png
[2]: https://i.stack.imgur.com/CqJvT.png
[3]: https://i.stack.imgur.com/KKhN6.png
[4]: https://i.stack.imgur.com/pYwi3.png
[5]: https://i.stack.imgur.com/23f6J.png
[6]: https://i.stack.imgur.com/fbJR4.png
[7]: https://i.stack.imgur.com/bFcJo.png
[8]: https://i.stack.imgur.com/3PRrr.png
[9]: https://i.stack.imgur.com/QilkK.png
[10]: https://i.stack.imgur.com/b8lDe.pngb3m2a1 2019-04-13T00:38:14Z[GIF] Five Easy Pieces (Rotating truncation of the tetrahedron)
https://community.wolfram.com/groups/-/m/t/1660413
![Rotating truncation of the tetrahedron][1]
**Five Easy Pieces**
Practically the same idea (and code) as [_Give Me Some Space_][2], just truncating the tetrahedron rather than rectifying it.
The code for the `Manipulate` is below; when exporting to a GIF I used `"DisplayDurations" -> Prepend[Table[1/50, {199}], 1/2]` inside `Export` to get the animation to pause on the original tetrahedron for half a second.
DynamicModule[{viewpoint = {Cos[2π/3], Sin[2π/3], 1/Sqrt[2]},
g = .6, d = .2, n = 4,
v = PolyhedronData["Tetrahedron", "VertexCoordinates"],
e = {{2, 3, 4}, {1, 4, 3}, {4, 1, 2}, {3, 2, 1}},
tt = PolyhedronData["TruncatedTetrahedron", "VertexCoordinates"],
te = PolyhedronData["TruncatedTetrahedron", "Faces"][[2]],
cols = RGBColor /@ {"#e43a19", "#f2f4f7", "#111f4d"},
s, r},
Manipulate[
s = Haversine[π t];
r = Haversine[2 π t];
Graphics3D[{Thickness[.004], EdgeForm[None],
Table[
{GraphicsComplex[
(1/2 + r/2) v[[i]] + RotationTransform[2 π/3 s, v[[i]]][#] & /@ (v/4),
{cols[[1]], Polygon[e[[i]]], cols[[2]], Polygon[e[[Drop[Range[4], {i}]]]]}]},
{i, 1, Length[v]}],
GraphicsComplex[
RotationTransform[0, {0, 0, 1}][RotationTransform[π s, {-Sqrt[3], -3, Sqrt[6]}][1/4 tt]],
{cols[[1]], Polygon[te[[1, ;; 4]]], cols[[2]], Polygon[te[[1, 5 ;;]]]}]},
Boxed -> False, ImageSize -> {540, 540}, PlotRange -> 2.5,
Background -> cols[[-1]], ViewPoint -> 10 viewpoint,
ViewAngle -> π/125, ViewVertical -> {0, 0, 1},
SphericalRegion -> True,
Lighting -> {{"Ambient", GrayLevel[d]},
{"Directional", GrayLevel[g], ImageScaled[{2, 0, 2}]},
{"Directional", GrayLevel[g], ImageScaled[{-2, 2, 2}]},
{"Directional", GrayLevel[g], ImageScaled[{0, -2, 2}]}}],
{t, 0, 1}]
]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=tt8r.gif&userId=610054
[2]: https://community.wolfram.com/groups/-/m/t/962240Clayton Shonkwiler2019-04-14T21:23:52ZAnamorphosis and reflection between a Conical Mirror and a Cylinder
https://community.wolfram.com/groups/-/m/t/1660442
![intro][1]
Catoptric or mirror anamorphoses are deformed images that can only be seen undeformed with the help of a mirror.
Here, we experiment with a conical mirror surrounded by a vertical cylindrical surface.
We want to compute points of a deformed (anamorphic) image on the cylinder's inner surface such that it is perceived by the viewer as an undeformed image when looking down in the cone shaped mirror.
![enter image description here][2]
The above drawing shows the anamorphic setup: a conical mirror (radius r=1, height=h), surrounded by a cylindrical surface (radius R>r).
The viewpoint V is along the vertical axis of the cylinder (at infinity relative to the size of the cone).
A point S (xa,ya,za) on the cylinder's inner surface is reflected by the mirror at Q to the viewer's eye at V. The viewer perceives the point at I (xi,yi,0). The lines VQ and SQ form equal angles with the normal to the sphere at Q.
![enter image description here][3]
The above animation demonstrates the relation between the point I traveling along a straight line while its anamorphic map follows a curve on the inner surface of the cylinder.
We now write a function that expresses this geometric relationship:
cone2Cylinder[imagePoint : {xi_, yi_}, coneHeight : h_,
cylinderRadius : R_] :=
{(R xi)/Sqrt[xi^2 + yi^2], (R yi)/Sqrt[
xi^2 + yi^2],
h - h Sqrt[
xi^2 + yi^2] + (-R + Sqrt[xi^2 + yi^2]) Cot[2 ArcTan[1/h]]}
This function maps an image point to an anamorphic point.
To test our function, we use [again][4] one of the logos generated by the Wolfram Demonstration "[Character Rotation Patterns][5]" by Chris Carlson.
Which, after converting to a GraphicsComplex looks like this:
ig = ImageGraphics[sun, 2, Method -> "Exact"];
lines = Normal[ig][[1, -1]] /. FilledCurve -> Identity;
scaledLines = Map[#/948 - .5 &, lines, {6}]
Graphics[{Thick, scaledLines}]
![enter image description here][6]
We now compute the point coordinates of the lines in the GraphicsComplex to their anamorphic map {xa,ya,za} using the function cone2Cylinder.
anaLines = Map[anaCone2Cylinder[#, 1.57, 1.15] &, scaledLines, {5}];
Graphics3D[{{Opacity[.2], White,
Cylinder[{{0, 0, .3}, {0, 0, 1.2}}, 1.25]},
AbsoluteThickness[3], %}, Boxed -> False]
![enter image description here][7]
We then convert the anamorphic 3D drawing to the 2 dimensional developed interior face of the cylinder as {ArcTan[xa,ya} , za}. This GIF illustrates the unfolding of the cylindrical image:
![enter image description here][8]
developLineCoordinates =
Flatten[Map[{ArcTan @@ Most[#], Last[#]} &, anaLines, {5}][[-1]],
1][[All, 1]];
lstPP = Partition[#, 2, 1] & /@ developLineCoordinates;
DeleteCases[#, _?(EuclideanDistance @@ # > 1 &)] & /@ lstPP;
Graphics[{AbsoluteThickness[2], Line /@ %}, FrameTicks -> None,
Frame -> True, ImageSize -> 600]
develop = Image[%];
![enter image description here][9]
After printing the cylinder development to the right size (52 cm by 14 cm), it is glued around a cardboard cylinder (radius 8 cm). A home made conical mirror (base radius 7 cm, height 12 cm) is put inside the cylinder at the center. The anamorphic image on the cylinder wall is reflected as the undeformed original by the conical mirror. Here is the result: (the center is hidden by a coin resting at the top of the cone since anamorphic maps of points close to the cone center are off at infinite height on the cylinder wall)
![enter image description here][10]
**Another application** of the function is to use one of the many popular curves (".....-like curve" ) that can be extracted using Interpreter
Interpreter["PopularCurve"]["bunny-like curve"];
bugsbunnyPrimitives =
First@Cases[
First[ParametricPlot[
Entity["PopularCurve", "BunnyCurve"]["ParametricEquations"][
t], {t, 0, 30 \[Pi]}]] /. {x_?NumericQ,
y_?NumericQ} :> {x - 85, y - 50}/800, _Line, \[Infinity]];
![enter image description here][11]
The anamorphic map is created by applying anaCone2Cylinder to the point coordinates:
anaBunny =
Map[anaCone2Cylinder[#, 1.755, 1.25] &, bugsbunnyPrimitives, {2}];
Animate[Graphics3D[
Rotate[{{Opacity[.2], White,
Cylinder[{{0, 0, .25}, {0, 0, 1}}, 1.25]}, AbsoluteThickness[3],
Red, anaBunny}, \[Phi], {0, 0, 1}], Boxed -> False], {\[Phi], 0,
2 \[Pi]}]
![enter image description here][12]
This is the developed cylinder:
developRules = {x_?NumericQ, y_?NumericQ,
z_?NumericQ} :> {ArcTan[x, y], z};
developed = anaBunny /. developRules;
DeleteCases[
Partition[developed[[1]], 2, 1], _?(EuclideanDistance @@ # > 1 &)];
Graphics[{Red, AbsoluteThickness[3], Line /@ %}, FrameTicks -> None,
Frame -> True]
![enter image description here][13]
And the result, printed, glued inside a cylinder and using the same setup as in the previous example:
![enter image description here][14]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=logojointpics.png&userId=68637
[2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3379geometrycone.png&userId=68637
[3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=animationskipeedframes.gif&userId=68637
[4]: https://community.wolfram.com/groups/-/m/t/1646795?p_p_auth=1iKz6YW8
[5]: http://demonstrations.wolfram.com/CharacterRotationPatterns/
[6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=S-logooutlinecopy.png&userId=68637
[7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=9897logocylinder.png&userId=68637
[8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=unfolding.gif&userId=68637
[9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=4680logodeveloped.png&userId=68637
[10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=logofinalcombi.png&userId=68637
[11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=9385bunnyoriginal.png&userId=68637
[12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=cylinderanimation.gif&userId=68637
[13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=8734bunnydeveloped.png&userId=68637
[14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=6598bunnyfinal.jpg&userId=68637Erik Mahieu2019-04-15T07:18:15ZInclude special (reserved) symbols in variable names?
https://community.wolfram.com/groups/-/m/t/1663842
I'm trying to translate some gnarly physics equations over to Mathematica for easier exploration / manipulation / etc, and I'm running into a problem when it comes to variable names like ![enter image description here][1] .
In particular, these sorts of variable names are enormously convenient when writing equations and doing derivations by hand, but Mathematica seems to insist on treating the <parallel> symbol as an infix operator, causing it to produce errors.
Is there any way to override that behavior and tell Mathematica to treat the whole thing as a single, atomic symbol, or am I stuck with the undesirable and much less readable ![enter image description here][2] ?
The latter becomes especially cumbersome when I've got complicated equations with many expressions involving subscripts like "parallel", "perpendicular", etc. Doubly so when I've already got those expressions, using those symbols, in offline form in pen-and-paper notes.
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=v_parallel.gif&userId=1663808
[2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=v_parallel2.gif&userId=1663808Michael W.2019-04-18T19:19:37ZSolver for unsteady flow with the use of Mathematica FEM
https://community.wolfram.com/groups/-/m/t/1433064
![fig7][331]
I started the discussion [here][1] but I also want to repeat on this forum.
There are many commercial and open code for solving the problems of unsteady flows.
We are interested in the possibility of solving these problems using Mathematica FEM. Previously proposed solvers for stationary incompressible isothermal flows:
Solving 2D Incompressible Flows using Finite Elements:
http://community.wolfram.com/groups/-/m/t/610335
FEM Solver for Navier-Stokes equations in 2D:
http://community.wolfram.com/groups/-/m/t/611304
Nonlinear FEM Solver for Navier-Stokes equations in 2D:
https://mathematica.stackexchange.com/questions/94914/nonlinear-fem-solver-for-navier-stokes-equations-in-2d/96579#96579
We give several examples of the successful application of the finite element method for solving unsteady problem including nonisothermal and compressible flows. We will begin with two standard tests that were proposed to solve this class of problems by
M. Schäfer and S. Turek, Benchmark computations of laminar ﬂow around a cylinder (With support by F. Durst, E. Krause and R. Rannacher). In E. Hirschel, editor, Flow Simulation with High-Performance Computers II. DFG priority research program results 1993-1995, number 52 in Notes Numer. Fluid Mech., pp.547–566. Vieweg, Weisbaden, 1996. https://www.uio.no/studier/emner/matnat/math/MEK4300/v14/undervisningsmateriale/schaeferturek1996.pdf
![fig8][332]
Let us consider the flow in a flat channel around a cylinder at Reynolds number = 100, when self-oscillations occur leading to the detachment of vortices in the aft part of cylinder. In this problem it is necessary to calculate drag coeﬃcient, lift coeﬃcient and pressure diﬀerence in the frontal and aft part of the cylinder as functions of time, maximum drag coeﬃcient, maximum lift coeﬃcient , Strouhal number and pressure diﬀerence $\Delta P(t)$ at $t = t0 +1/2f$. The frequency f is determined by the period of oscillations of lift coeﬃcient f=f(c_L). The data for this test, the code and the results are shown below.
H = .41; L = 2.2; {x0, y0, r0} = {1/5, 1/5, 1/20};
Ω = RegionDifference[Rectangle[{0, 0}, {L, H}], Disk[{x0, y0}, r0]];
RegionPlot[Ω, AspectRatio -> Automatic]
K = 2000; Um = 1.5; ν = 10^-3; t0 = .004;
U0[y_, t_] := 4*Um*y/H*(1 - y/H)
UX[0][x_, y_] := 0;
VY[0][x_, y_] := 0;
P0[0][x_, y_] := 0;
Do[
{UX[i], VY[i], P0[i]} =
NDSolveValue[{{Inactive[
Div][({{-μ, 0}, {0, -μ}}.Inactive[Grad][
u[x, y], {x, y}]), {x, y}] +
\!\(\*SuperscriptBox[\(p\),
TagBox[
RowBox[{"(",
RowBox[{"1", ",", "0"}], ")"}],
Derivative],
MultilineFunction->None]\)[x, y] + (u[x, y] - UX[i - 1][x, y])/t0 +
UX[i - 1][x, y]*D[u[x, y], x] +
VY[i - 1][x, y]*D[u[x, y], y],
Inactive[
Div][({{-μ, 0}, {0, -μ}}.Inactive[Grad][
v[x, y], {x, y}]), {x, y}] +
\!\(\*SuperscriptBox[\(p\),
TagBox[
RowBox[{"(",
RowBox[{"0", ",", "1"}], ")"}],
Derivative],
MultilineFunction->None]\)[x, y] + (v[x, y] - VY[i - 1][x, y])/t0 +
UX[i - 1][x, y]*D[v[x, y], x] +
VY[i - 1][x, y]*D[v[x, y], y],
\!\(\*SuperscriptBox[\(u\),
TagBox[
RowBox[{"(",
RowBox[{"1", ",", "0"}], ")"}],
Derivative],
MultilineFunction->None]\)[x, y] +
\!\(\*SuperscriptBox[\(v\),
TagBox[
RowBox[{"(",
RowBox[{"0", ",", "1"}], ")"}],
Derivative],
MultilineFunction->None]\)[x, y]} == {0, 0, 0} /. μ -> ν, {
DirichletCondition[{u[x, y] == U0[y, i*t0], v[x, y] == 0},
x == 0.],
DirichletCondition[{u[x, y] == 0., v[x, y] == 0.},
0 <= x <= L && y == 0 || y == H],
DirichletCondition[{u[x, y] == 0,
v[x, y] == 0}, (x - x0)^2 + (y - y0)^2 == r0^2],
DirichletCondition[p[x, y] == P0[i - 1][x, y], x == L]}}, {u, v,
p}, {x, y} ∈ Ω,
Method -> {"FiniteElement",
"InterpolationOrder" -> {u -> 2, v -> 2, p -> 1},
"MeshOptions" -> {"MaxCellMeasure" -> 0.001}}], {i, 1, K}];
{ContourPlot[UX[K/2][x, y], {x, y} ∈ Ω,
AspectRatio -> Automatic, ColorFunction -> "BlueGreenYellow",
FrameLabel -> {x, y}, PlotLegends -> Automatic, Contours -> 20,
PlotPoints -> 25, PlotLabel -> u, MaxRecursion -> 2],
ContourPlot[VY[K/2][x, y], {x, y} ∈ Ω,
AspectRatio -> Automatic, ColorFunction -> "BlueGreenYellow",
FrameLabel -> {x, y}, PlotLegends -> Automatic, Contours -> 20,
PlotPoints -> 25, PlotLabel -> v, MaxRecursion -> 2,
PlotRange -> All]} // Quiet
{DensityPlot[UX[K][x, y], {x, y} ∈ Ω,
AspectRatio -> Automatic, ColorFunction -> "BlueGreenYellow",
FrameLabel -> {x, y}, PlotLegends -> Automatic, PlotPoints -> 25,
PlotLabel -> u, MaxRecursion -> 2],
DensityPlot[VY[K][x, y], {x, y} ∈ Ω,
AspectRatio -> Automatic, ColorFunction -> "BlueGreenYellow",
FrameLabel -> {x, y}, PlotLegends -> Automatic, PlotPoints -> 25,
PlotLabel -> v, MaxRecursion -> 2, PlotRange -> All]} // Quiet
dPl = Interpolation[
Table[{i*t0, (P0[i][.15, .2] - P0[i][.25, .2])}, {i, 0, K, 1}]];
cD = Table[{t0*i, NIntegrate[(-ν*(-Sin[θ] (Sin[θ]
\!\(\*SuperscriptBox[\(UX[i]\),
TagBox[
RowBox[{"(",
RowBox[{"0", ",", "1"}], ")"}],
Derivative],
MultilineFunction->None]\)[x0 + r Cos[θ],
y0 + r Sin[θ]] + Cos[θ]
\!\(\*SuperscriptBox[\(UX[i]\),
TagBox[
RowBox[{"(",
RowBox[{"1", ",", "0"}], ")"}],
Derivative],
MultilineFunction->None]\)[x0 + r Cos[θ],
y0 + r Sin[θ]]) + Cos[θ] (Sin[θ]
\!\(\*SuperscriptBox[\(VY[i]\),
TagBox[
RowBox[{"(",
RowBox[{"0", ",", "1"}], ")"}],
Derivative],
MultilineFunction->None]\)[x0 + r Cos[θ],
y0 + r Sin[θ]] + Cos[θ]
\!\(\*SuperscriptBox[\(VY[i]\),
TagBox[
RowBox[{"(",
RowBox[{"1", ",", "0"}], ")"}],
Derivative],
MultilineFunction->None]\)[x0 + r Cos[θ],
y0 + r Sin[θ]]))*Sin[θ] -
P0[i][x0 + r Cos[θ], y0 + r Sin[θ]]*
Cos[θ]) /. {r -> r0}, {θ, 0, 2*Pi}]}, {i,
1000, 2000}]; // Quiet
cL = Table[{t0*i, -NIntegrate[(-ν*(-Sin[θ] (Sin[θ]
\!\(\*SuperscriptBox[\(UX[i]\),
TagBox[
RowBox[{"(",
RowBox[{"0", ",", "1"}], ")"}],
Derivative],
MultilineFunction->None]\)[x0 + r Cos[θ],
y0 + r Sin[θ]] + Cos[θ]
\!\(\*SuperscriptBox[\(UX[i]\),
TagBox[
RowBox[{"(",
RowBox[{"1", ",", "0"}], ")"}],
Derivative],
MultilineFunction->None]\)[x0 + r Cos[θ],
y0 + r Sin[θ]]) +
Cos[θ] (Sin[θ]
\!\(\*SuperscriptBox[\(VY[i]\),
TagBox[
RowBox[{"(",
RowBox[{"0", ",", "1"}], ")"}],
Derivative],
MultilineFunction->None]\)[x0 + r Cos[θ],
y0 + r Sin[θ]] + Cos[θ]
\!\(\*SuperscriptBox[\(VY[i]\),
TagBox[
RowBox[{"(",
RowBox[{"1", ",", "0"}], ")"}],
Derivative],
MultilineFunction->None]\)[x0 + r Cos[θ],
y0 + r Sin[θ]]))*Cos[θ] +
P0[i][x0 + r Cos[θ], y0 + r Sin[θ]]*
Sin[θ]) /. {r -> r0}, {θ, 0, 2*Pi}]}, {i,
1000, 2000}]; // Quiet
{ListLinePlot[cD,
AxesLabel -> {"t", "\!\(\*SubscriptBox[\(c\), \(D\)]\)"}],
ListLinePlot[cL,
AxesLabel -> {"t", "\!\(\*SubscriptBox[\(c\), \(L\)]\)"}],
Plot[dPl[x], {x, 0, 8}, AxesLabel -> {"t", "ΔP"}]}
f002 = FindFit[cL, a*.5 + b*.8*Sin[k*16*t + c*1.], {a, b, k, c}, t]
Plot[Evaluate[a*.5 + b*.8*Sin[k*16*t + c*1.] /. f002], {t, 4, 8},
Epilog -> Map[Point, cL]]
k0=k/.f002;
Struhalnumber = .1*16*k0/2/Pi
cLm = MaximalBy[cL, Last]
sol = {Max[cD[[All, 2]]], Max[cL[[All, 2]]], Struhalnumber,
dPl[cLm[[1, 1]] + Pi/(16*k0)]}
In Fig. 1 shows the components of the flow velocity and the required coefficients. Our solution of the problem and what is required in the test
{3.17805, 1.03297, 0.266606, 2.60427}
lowerbound= { 3.2200, 0.9900, 0.2950, 2.4600};
upperbound = {3.2400, 1.0100, 0.3050, 2.5000};
![Fig1][2]
Note that our results differ from allowable by several percent, but if you look at all the results of Table 4 from the cited article, then the agreement is quite acceptable.The worst prediction is for the Strouhal number. We note that we use the explicit Euler method, which gives an underestimate of the Strouhal number, as follows from the data in Table 4.
The next test differs from the previous one in that the input speed varies according to the `U0[y_, t_] := 4*Um*y/H*(1 - y/H)*Sin[Pi*t/8]`. It is necessary to determine the time dependence of the drag and lift parameters for a half-period of oscillation, as well as the pressure drop at the last moment of time. In Fig. 2 shows the components of the flow velocity and the required coefficients. Our solution of the problem and what is required in the test
sol = {3.0438934441256595`,
0.5073345082785012`, -0.11152933279750943`};
lowerbound = {2.9300, 0.4700, -0.1150};
upperbound = {2.9700, 0.4900, -0.1050};
![Fig2][3]
For this test, the agreement with the data in Table 5 is good. Consequently, the two tests are almost completely passed.
I wrote and debugged this code using Mathematics 11.01. But when I ran this code using Mathematics 11.3, I got strange pictures, for example, the disk is represented as a hexagon, the size of the area is changed.
![Fig3][4]
In addition, the numerical solution of the problem has changed, for example, test 2D2
{3.17805, 1.03297, 0.266606, 2.60427} v11.01
{3.15711, 1.11377, 0.266043, 2.54356} v11.03
The attached file contains the working code for test 2D3 describing the flow around the cylinder in a flat channel with a change in the flow velocity.
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=test2D2.png&userId=1218692
[2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=test2D2.png&userId=1218692
[3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=test2D3.png&userId=1218692
[4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Math11.3.png&userId=1218692
[331]: http://community.wolfram.com//c/portal/getImageAttachment?filename=CylinderRe100test2D2.gif&userId=1218692
[332]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2D2test.png&userId=1218692Alexander Trounev2018-08-31T11:44:04ZPacking arbitrary shapes with WordCloud
https://community.wolfram.com/groups/-/m/t/1659824
![enter image description here][1]
We can extract information from `WordCloud` in order to translate a collection of regions so they pack nicely. First I'll create some `BoundaryMeshRegions` similar to how the glyphs were created by OP:
$letters = Table[BoundaryDiscretizeGraphics[
Text[Style[c, Italic, FontFamily -> "Times"]], _Text], {c, Alphabet[]}];
n = 30;
BlockRandom[
glyphs = RandomChoice[$letters, n];
scales = RandomReal[5, n],
RandomSeeding -> 1234
];
Plot the word cloud using random orientations:
wc = WordCloud[AssociationThread[glyphs, scales], WordSpacings -> 0,
WordOrientation -> "Random", RandomSeeding -> 1234]
<img src="https://i.stack.imgur.com/cquRW.png" width="360"/>
Notice that the objects aren't quite touching. Luckily when we convert this scene back to a collection of regions, they will seem to be touching. I think this has to do with padding within `Inset`. Using regions in the beginning rather then just graphics makes it easier to convert the insets into explicit coordinates and avoid padding.
insets = Cases[wc2, _Inset, ∞];
insetToReg[mr_, c_, p_, s_] :=
BoundaryMeshRegion[TransformedRegion[#,
TranslationTransform[c - RegionCentroid[BoundingRegion[#]]]],
MeshCellStyle -> {1 -> Black, 2 -> RandomColor[Hue[_]]}]& @ RegionResize[mr[[1]], s]
BlockRandom[Show[insetToReg @@@ insets], RandomSeeding -> 1234]
<img src="https://i.stack.imgur.com/1k8w7.png" width="360"/>
Or if you prefer a region instead of just a visualization:
RegionUnion[insetToReg @@@ insets]
<img src="https://i.stack.imgur.com/JByJo.png" width="360"/>
We can do this for polygons too:
BlockRandom[
polys =
Table[BoundaryMeshRegion[#[[FindShortestTour[#][[2]]]],
Line[Mod[Range[16], 15, 1]]] &[RandomReal[{0, 1}, {15, 2}]], n];
scales = RandomReal[{0, 1}, n],
RandomSeeding -> 1234
];
wc = WordCloud[AssociationThread[polys, scales], WordSpacings -> 0,
WordOrientation -> "Random", RandomSeeding -> 1234];
BlockRandom[Show[insetToReg @@@ Cases[wc, _Inset, ∞]],
RandomSeeding -> 1234]
<img src="https://i.stack.imgur.com/HMvfF.png" width="360"/>
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2019-04-15at11.14.52AM.png&userId=11733Chip Hurst2019-04-14T08:47:18ZCalculate the magnetic dipole due to a current circular loop?
https://community.wolfram.com/groups/-/m/t/1663559
Hey guys, I'm very new to mathematica, and am not a programmer. The last programming class I took was in 2005 for C++! But I'm taking a physics course to get into grad school and this is a project that we're workin on.
I can't seem to get actual values for my integrals. I understand that along the x-axis, I should see an output of 0. But, I get some message that doesn't mean anything to me. The code is posted below, and I've attached both the .nb file as well as our rubric so that you can see what we're trying to do.
The rubric says:
(a) Use the Biot-Savart law to calculate the magnetic field at any point in the yz-plane (i.e., at (0, y, z)) of the current loop shown in the figure below. The source point is (R cos φ, R sin φ, 0), and φ runs from 0 to 2π. Set up the integrals from which you could calculate Bx, By, and Bz.
(b) Evaluate the integral for Bx(y,z) and show that it is equal to zero.
(c) Use the Mathematica functions NIntegrate[] and StreamPlot[] to display the magnetic field lines By(y, z) and Bz(y, z) due to a current circular loop in the yz-plane. Take the current on the loop of radius 15 cm to be 1.5 A.
My code:
Clear["Global'*"]
u0 = 1.257*10^(-6); (*Permiability of free space*)
Ic = 1.5; (*Current in amps*)
R = .15; (*Radius in meters*)
ymax = 2.5*R;
zmax = 2.5*R;
\[Mu] = 4*\[Pi]*10^(-7);
B = \[Mu]*Ic/(2*R);
Bz[0, 0];
Bx[y_,z_]:=\[Mu]*Ic/(4*\[Pi]) *NIntegrate[((z*R*Cos[\[Phi]])/(R^2+y^2-2*y*R*Sin[\[Phi]]+z^2)^(3/2)),{\[Phi],0,2\[Pi]}] (*Integral for Biot-Savart Law along the x-axis. This will equal 0. Prove it*)
By[y_, z_] := \[Mu]*Ic/(4*\[Pi]) *NIntegrate[((z*R*Sin[\[Phi]])/(R^2 + y^2 - 2*y*R*Sin[\[Phi]] + z^2)^(3/2)), {\[Phi], 0, 2 \[Pi]}] (*Integral for Biot-Savart Law along the y-axis*)
Bz[y_, z_] := \[Mu]*Ic/(4*\[Pi]) *NIntegrate[((R^2 - y*R*Sin[\[Phi]])/(R^2 + y^2 - 2*y*R*Sin[\[Phi]] + z^2)^(3/2)), {\[Phi], 0, 2 \[Pi]}] (*Integral for Biot-Savart Law along the z-axis*)
p1 = StreamPlot[{By[y, z], Bz[y, z]}, {y, -ymax, ymax}, {z, -zmax, zmax}]Ryan Schmidt2019-04-18T14:21:49Z[✓] Find area of polygons in a geometric scene?
https://community.wolfram.com/groups/-/m/t/1663665
Is it possible to find a polygon area in geometric scenes?
For example, I want to find the area of a triangle kln:
scene = GeometricScene[{k, l, n, m}, {EuclideanDistance[k, n] == 3,
PlanarAngle[{l, m, n}] == 120 \[Degree],
Triangle[{k, l, n}],
GeometricAssertion[{CircleThrough[{k, l, n}], Line[{m, n}]},
"PairwiseTangent"],
GeometricAssertion[{CircleThrough[{k, l, n}], Line[{l, m}]},
"PairwiseTangent"], Polygon[{k, l, m, n}],
GeometricAssertion[{Line[{k, n}], Line[{l, m}]}, "Parallel"]}];
RandomInstance[scene, RandomSeeding -> 1]Nikita Tokarev2019-04-18T18:08:02ZCreate a 2 dimensional random walk with a do loop?
https://community.wolfram.com/groups/-/m/t/1663702
I am trying to create a 2 dimensional random walk that has an equal chance to do up, down, right, or left with a do loop and which statement, but I am not sure I have the correct coding.
M = Table[0, {1000}, {2}];
Do[x = RandomReal[];
Which[0 <= x <= 0.25, y = 1,
0.25 <= x <= 0.50, y = -1,
0.50 <= x <= 0.75, y = 1,
0.75 <= x <= 1.0, y = -1];
M[[i + 1, j]] = y + M[[i, j]],
{i, -999, 999}, {j, -1, 2}];
Grid[M]Jennifer Shaw2019-04-18T14:42:59ZPlot the change of variable for a Gaussian distribution?
https://community.wolfram.com/groups/-/m/t/1663517
I am going through the [Pattern Matching and Machine Learning][1] book by Bishop and have gotten stuck on a few things in Mathematica. In the [solution][2] for exercise 1.4 (page 7/101) there is a graph showing a probability distribution transformed by a function.
Here are the questions that I have regarding this:
* How do I plot the green and the magenta curves on the y axis?
* Why are the green and the magenta curves near each other in size in the book, but not in my own plots?
* Why can't I integrate the transformed curves so as to get the CDF?
* How do I get the mode of the transformed curves?
Here is the code for what I've done so far. I am been trying out various things to no avail.
```
dist = PDF[NormalDistribution[6, 1]]
g[y_] := Log[y] - Log[1.0 - y] + 5.0
Plot[{dist[x], dist[g[x]]*Abs[g'[x]], dist[g[x]]}, {x, 0, 10},
PlotRange -> Full, PlotLegends -> "Expressions"]
```
[1]: https://www.microsoft.com/en-us/research/people/cmbishop/#!prml-book
[2]: https://www.microsoft.com/en-us/research/wp-content/uploads/2016/05/prml-web-sol-2009-09-08.pdfMarko Grdinić2019-04-18T12:55:38ZExtract data from table & use it to perform arithmetic operation?
https://community.wolfram.com/groups/-/m/t/1663074
I am not sure about how I can explain this problem clearly. Nevertheless, let me try it. And it's bit lengthy:
I need to solve a sixth order equation given by the expression:
$$1 + {\frac{2\kappa-1}{2\kappa-3}\frac{Nezero}{k^2}} + {\frac{2\kappa-1}{2\kappa-3}}{\frac{Nbzero}{k^2 Tbe}} - \frac{(2\kappa-1)(2\kappa+1)}{(2\kappa-3)^2}\Bigg[{\frac{w^2 Nezero}{k^4 mpe}}+{\frac{(w-kU_b)^2Nbzero}{k^4Tbe^2mpe}}\Bigg]\\-{\frac{Npzero}{w^2}\bigg(1+\frac{3k^2Tpe}{w^2}\bigg)} - {\frac{z^2Nizero\times mpi}{w^2}\bigg(1+\frac{3k^2Tpe}{w^2}\bigg)}$$
Here there are some constant values, I vary ‘k’ and find the values of ‘w’. For single value of k, I will get 6 w’s. Some of it are complex. I separate it out into real and imaginary and write it on ‘**solnofequation**’. For simplicity, one can think **solnofequation** as a matrix or table, which in the present case has a dimension of 10 X 13 (10 rows and 13 columns; **rows will change as one change ‘kinterval’**). First column gives values of k, second column gives **real values** of **first root** for each k, third column gives **imaginary part** of **first root** etc.
Now I have to take the each real part in a row, subtract ‘k’ times ub divide by k times mpe. And then whole of this should get multiplied by kappa2 given in the programme.
E.g. `solnofequation[[2]]` gives `{0.2, 0.161643, 0, 1.06185, 0, -0.144433, -0.109161, -0.144433, 0.109161, 0.0116811, -0.117174, 0.0116811, 0.117174}`.
Here, first element if k, second element is real par of first root, third element is imaginary part of first root, fourth element is real par of second root and so on. Here, what I have to do is $\frac{(0.161643-0.2*ub)}{mpe}*kappa2$, then $\frac{(1.06185-0.2*ub)}{mpe}*kappa2$ so on.
Further, `solnofequation[[8]]` gives `{0.8, 0.609319, 0, 4.42253, 0, -0.636614, -0.409612, -0.636614,0.409612, 0.0366778, -0.453399, 0.0366778, 0.453399}`
Here, effectively what I have to do is $\frac{(0.609319-0.8*ub)}{mpe}*kappa2$, then $\frac{(4.42253-0.8*ub)}{mpe}*kappa2$ and so on.
This has to be done on each row. Then I need to export into a dat file, where **first column** gives values of k, **second column** gives real values of **first root** for each k, **third column** gives **imaginary** part of **first root** for each k, **fourth column** gives the **value of the real part of first root after above calculation for each k, fifth column** gives real values of second root for each k, **sixth column** gives **imaginary** part of **second root** for each k, **seventh column** gives **the value of the real part of second root after above calculation for each k** and so on.
All I could muster was:
1. solve the equation
2. write it on to a table with real and imaginary part separated
3. to export the file without what the calculation that I require.
Ideally, what I am expecting is something like this:
![expected][1]
The code that I have written is attached with this question.
Any help will be deeply appreciated. I know that this question is very lengthy, I could not help it. Thanks at least for those who took time to read this lengthy question.
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=XMNkC.png&userId=895827Sreeraj T2019-04-18T06:57:48ZReplicate Dave Giles' permutation test using WL?
https://community.wolfram.com/groups/-/m/t/1661603
Dear community members,
I'm trying to replicate Dave Giles' permutation test [examples][1] using Mathematica but I'm having difficulties randomly selecting 50,000 samples from all the possible permutations of a list of 20 prices.
Mathematica runs out of memory in my laptop (8 GB RAM).
prices = {5.0, 4.8, 4.7, 4.0, 5.3, 4.1, 5.5, 4.7, 3.3, 4.0, 4.0, 4.6,
5.3, 3.0, 3.5, 3.9, 4.7, 5.0, 5.2, 4.6};
In[4]:= RandomSample[Permutations[prices], 50000]
During evaluation of In[4]:= General::nomem: The current computation was aborted because there was insufficient memory available to complete the computation.
During evaluation of In[4]:= Throw::sysexc: Uncaught SystemException returned to top level. Can be caught with Catch[\[Ellipsis], _SystemException].
Out[4]= SystemException["MemoryAllocationFailure"]
Is there an alternative way that I could use to generate those samples?
[1]: https://davegiles.blogspot.com/2019/04/what-is-permutation-test.htmlRuben Garcia Berasategui2019-04-16T02:25:05Z