Community RSS Feed
https://community.wolfram.com
RSS Feed for Wolfram Community showing any discussions in tag Staff Picks sorted by active[WSS20] Local Dimension Measure and Rotation Groups in Wolfram Models
https://community.wolfram.com/groups/-/m/t/2027996
![enter image description here][1]
&[Wolfram Notebook][2]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=9678wormholefpost.png&userId=1919403
[2]: https://www.wolframcloud.com/obj/tobiascanavesi/Published/canavesipost.nbTobias Canavesi2020-07-14T14:16:12Z[WSS20] Deep Learning Applied to Gravitational Wave Detection
https://community.wolfram.com/groups/-/m/t/2027779
![enter image description here][1]
&[Wolfram Notebook][2]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=FrontCover.png&userId=2026413
[2]: https://www.wolframcloud.com/obj/a3f59ae7-f159-4ee0-8588-55da81973c64Bar Alluf2020-07-14T11:32:54Z[WSS20] Implementing Mutual Information
https://community.wolfram.com/groups/-/m/t/2030629
![Karman vortex street and an estimation of mutual information][1]
&[Wolfram Notebook][2]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=animationkarman.gif&userId=1894013
[2]: https://www.wolframcloud.com/obj/luigi.brancati93/Published/WSS20-Project-Notebook-final.nbLuigi Brancati2020-07-14T18:12:42Z[WSS20] Constructing protein surfaces
https://community.wolfram.com/groups/-/m/t/2029621
![enter image description here][2]
&[Wolfram Notebook][1]
[1]:
https://www.wolframcloud.com/obj/polyachenko.yua/Published/WSS2020%20Construction%20of%20protein%20surfaces.nb
[2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=mainpic.jpg&userId=2025530Yury POLYACHENKO2020-07-14T16:48:25Z[WSS20] Full Discretization of Local Gauge Invariance
https://community.wolfram.com/groups/-/m/t/2030337
![A U(1) Graph Bundle over an R^3 Lattice Space][1]
&[Wolfram Notebook][2]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=c6bundle.jpg&userId=2029929
[2]: https://www.wolframcloud.com/obj/a439a840-9244-444b-98d8-d6dffb146c87Graham Van Goffrier2020-07-14T17:35:37ZTop 20 COVID countries HeatMap by absolute death and death in ppm
https://community.wolfram.com/groups/-/m/t/2004800
*MODERATOR NOTE: coronavirus resources & updates:* https://wolfr.am/coronavirus *Click on image to zoom in. Click browser back button to return.*
----------
[![enter image description here][1]][1]
I would like to share with the community this HeatMap that I did using ArrayPlot, with the Top 20 countries in Absolute Covid Death number. Below is the notebook used to generate code.
&[Wolfram Notebook][2]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=5458heatMap.png&userId=25532
[2]: https://www.wolframcloud.com/obj/a37f339f-4172-4cd2-9233-09f5931a31edRodrigo Murta2020-06-15T19:56:27Z[WSC20] Computing Radioactive Decay Products as a Function of Time
https://community.wolfram.com/groups/-/m/t/2034014
![enter image description here][1]
&[Wolfram Notebook][2]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Cover_Image_3.png&userId=2033261
[2]: https://www.wolframcloud.com/obj/regosheldon2003/Published/RadioactiveDecayVisualization2.nbSheldon Rego2020-07-15T20:02:17ZCatch comet C/2020 F3 (NEOWISE) which is putting on quite a show
https://community.wolfram.com/groups/-/m/t/2024815
&[Wolfram Notebook][1]
[1]: https://www.wolframcloud.com/obj/cf70227c-9327-43a4-b99a-2682df626bb4Jeff Bryant2020-07-12T02:07:28ZOptical Illusions and Self-Anamorphism in a Conical Mirror
https://community.wolfram.com/groups/-/m/t/2027565
![enter image description here][1]
Looking at the above simulations and as demonstrated in [my past Wolfram community contribution][2], reflection and anamorphism in a conical mirror result in considerable deformation of an image. It seems therefore unlikely that an image could be equal to its reflection in a conical mirror. I was therefore surprised reading the article "[Self Anamorphic Images][3]" by Andrew Crompton illustrating the existence of "self-anamorphic" images. "Self anamorphic" meaning: the image and its reflection are identical except for scaling and rotation.
I wanted to investigate this further with Mathematica and constructed my own conical mirror to test this. A conical mirror is very sensitive to geometric precision and cannot be made accurately enough with reflecting foil as is the case for a [cylindrical mirror][4]. I needed to make a [CNC precision turned][5] cone, polished and subsequently [chrome plated][6].
![enter image description here][7]
**1. Geometry of reflection and anamorphism in a conical mirror**
![enter image description here][8]
We first need another look at the geometry of reflection in a conical mirror: we take a cone with apex T, base radius 1 and opening angle 2alpha. Look down from an infinite viewpoint along the z-axis and we see a point A in the xy-plane reflected as a point R on the cone's base. Due to the radial symmetry of the cone, polar coordinates are the ideal choice. The polar coordinates of R are (r,t) and of A are (R,t). We can say that R is the reflection of A and A is the anamorphic image of R. A and R can be considered as an [enantiomorphic][9] point pair.
According to the laws of reflection, in the triangles BRS and ARS, we can derive the relation: (1 - r) cot(alpha) == (R - r) cot(2 alpha). We solve this equation for r and R as follows (we standardize for a cone opening angle of alpha -> Pi/6):
eqn = (1 - r) Cot[alpha] == (R - r) Cot[2 alpha];
Solve[eqn, #] & /@ {R, r} // Flatten // Simplify
% /. alpha -> Pi/6 // Simplify
(*{R->1-(-1+r) Sec[2 alpha],r->1-(-1+R) Cos[2 alpha]}
{R->3-2 r,r->(3-R)/2}*)
We can now make the functions *reflect* and *anamorph* that convert the radial coordinates from R and A into one another. Since the points R and A are on the same line through the origin, their angular coordinate t remains unchanged.
reflect[r_] := (3 - r)/2
anamorph[r_] := 3 - 2 r
The functions reflect and anamorph are the inverse of one-another.
anamorph@reflect[2.75] == 2.75 (*True*)
**2. Reflection of (filled) polar curves in a conical mirror**
As curves can be interpreted as sets of points, we can also have enantiomorph curve-pairs. When expressed in polar coordinates, we apply the functions *reflect* or *anamorph* to the radial coordinates of each point in the curve. This is a simple curve and its reflection as seen looking down in a conical mirror:
butterfly[t_, a1_, a2_] := a1 - a2 Cos[t] Sin[3 t]
PolarPlot[{1, butterfly[t, 2, -1], reflect[butterfly[t, 2, -1]],
3}, {t, -\[Pi], \[Pi]},
PlotStyle -> {Gray, Directive[Black, AbsoluteThickness[4]],
Directive[Gray, AbsoluteThickness[4]], Directive[Gray, DotDashed]},
PlotLegends -> {"mirror rim", "anamorphic curve",
"reflection curve", Nothing}]
![enter image description here][10]
Regular polygons are interesting curves for reflection in a conical mirror. We see that reflect converts a square into a 4-petaled rose-like curve (left) and a 4-petaled rose-like curve into a square (right). The cone is represented by a gray disk in the center.
square[r_] := r Cos[Pi/4] Sec[2/4 ArcTan[Cot[2 t]]]
GraphicsRow[{Show[Graphics[{Point[{0, 0}], Opacity[.15], Disk[]}],
PolarPlot[{square[2.5], reflect[square[1.75]]}, {t, -Pi, Pi},
PlotStyle -> Blue]],
Show[Graphics[{Point[{0, 0}], Opacity[.15], Disk[]}],
PolarPlot[{square[.75], anamorph[square[.75]]}, {t, -Pi, Pi},
PlotStyle -> Red]]}]
![enter image description here][11]
In 3D now, we can see below: (left) a pentagon reflects as a 5-petaled rose-like curve and (right) a 5-petaled rose-like curve reflects as a pentagon in a conical mirror. Or inversely: (left) the anamorphic image of a rose curve is a pentagon and (right) the anamorphic image of a pentagon is a rose curve using a conical mirror.
pentagon[r_] := r Cos[\[Pi]/5] Sec[2/5 ArcTan[Cot[(5 t)/2]]]
GraphicsRow[
MapThread[
Module[{alpha = Pi/6, op = .5, pts, ptsA, ptsR},
pts = Table[{pentagon[#2], t}, {t, -3.141, 3.14, .01}];
ptsR = (Flatten[{FromPolarCoordinates[#1], 0}] &) /@ pts;
ptsA = Table[
Flatten[{FromPolarCoordinates[{#1[pentagon[#2]], t}],
0}], {t, -3.141, 3.14, .01}];
Graphics3D[{{FaceForm[Lighter[LightGray, 1]],
Cylinder[{{0, 0, 0}, {0, 0, -.01}}, 3]}, {Opacity[op],
Cone[{{0, 0, 0}, {0, 0, 1/Tan[alpha]}}, 1]}, {#3,
AbsoluteThickness[3], Line[ptsA]}, {#3, AbsoluteThickness[3],
Line[ptsR]}}]] &, {{reflect, anamorph}, {2.1, .7}, {Blue,
Red}}]]
![enter image description here][12]
Using filled curves reveals an "optical illusion" with the **apparent** inversion of black and white: the white pentagon **seems** to reflect as a black rose and the black pentagon as a white rose?
filledPolarPlot[r_, edgeCol_, faceCol_] :=
PolarPlot[r, {t, 0, 2 \[Pi]}, Axes -> False] /.
Line[x__] :> {EdgeForm[edgeCol], FaceForm[faceCol], Polygon[x]}
GraphicsRow[MapThread[Show[filledPolarPlot[3, Black, #1],
filledPolarPlot[pentagon[2.25], Black, #2],
filledPolarPlot[1, Lighter[Gray, .5], Lighter[Gray, .5]],
filledPolarPlot[reflect@pentagon[2.25], #3, #3]] &, {{Black,
White}, {White, Black}, {Black, White}}]]
![enter image description here][13]
![enter image description here][14]
**3. Condition for self anamorphism in a conical mirror**
According to [A. Crompton, Self Anamorphic Images][15], Journal of Mathematics and the ArtsPublication, June 2008: "A curve is called self-anamorphic if it has the same shape as its reflection in a curved mirror except for rotation and rescaling".
We are looking for a periodic curve in polar coordinates in the x-y plane and centered around and reflected in an upright conical mirror. The radial coordinate R(t) of the curve should have a period of 2 Pi and can be represented by its Fourier series approximation:
R[t] = Sum[
an Cos[n t] + bn Sin[n t], {n, 0,
7}] (*limit of 8 terms sufficient for the discussion here*)
As stated at the beginning, to be self - anamorphic, the reflected curve r(t) needs to be a scaled and rotated version of R(t) and a linear combination of R(t) a +b R(t+t0) . If the scaling factor is m and the rotation angle t0, we can write the equations:
eqns = TrigExpand //@ (a + b (Cos[n t] an + Sin[n t] bn) ==
m (Cos[n (t + t0)] an + Sin[n (t + t0)] bn))
(*a+an b Cos[n t]+b bn Sin[n t]== an m Cos[n t] Cos[n t0]+bn m Cos[n \
t0] Sin[n t]+bn m Cos[n t] Sin[n t0]-an m Sin[n t] Sin[n t0]*)
\
Solve[eqns, {an, bn}]
(*{an->(a+b Sin[n t] bn-m Sin[n (t+t0)] bi)/(b Cos[n t]+m Cos[n \
(t+t0)])}
{bn->(a-b Cos[n t] an-m Cos[n (t+t0)] an)/(b Sin[n t]+m Sin[n \
(t+t0)])}*)
We have now two equations with as coefficient matrix:
mat = {{b/m + Cos[n t0], Sin[n t0]}, {-Sin[n t0], b/m + Cos[n t0]}}
(*{{b/m+Cos[n t0],Sin[n t0]},{-Sin[n t0],b/m+Cos[n t0]}}*)
To have (an indefinite number of) solutions, we need the determinant of the coefficient matrix to be zero.
det = Det[mat] // FullSimplify // Apart
(*( b^2+m^2)/m^2+(2 b Cos[n t0])/m*)
FindInstance[
det == 0, {m, b, Cos[n t0]}]
(*{{m->1,b\[Rule]1,Cos[n t0]->-1}}*)
Flatten@
Solve[Cos[(nt0)] == -1, (nt0)]
(* nt0->ConditionalExpression[-Pi+2 Pi \
c1,Element[c1,Integers]],nt0->ConditionalExpression[Pi+2 Pi \
c1,Element[c1,Integers]] *)
For Cos(n t0) to be -1, possible combinations of t0 and (n t0) must be odd integer multiples of Pi . This gives a table of the possible combinations of frequency indices n and rotations t0 that will produce self-anamorphic curves. t0 is the rotation angle between the curve and its reflection and n is the frequency index of the coefficient of the Fourier expansion of the curve:
Grid[lst =
Prepend[Cases[
Table[Flatten[{t0,
Table[180 \[Degree]/t0 (2 p + 1), {p, 0, 6}]}], {t0,
10 \[Degree], 360 \[Degree], 1 \[Degree]}], {_?NumericQ, _?
IntegerQ, ___}],
Style[#, 15] & /@ {t0, n1, n2, n3, n4, n5, n6, n7}],
Background -> {{LightGray}, {LightGray}}]
![enter image description here][16]
We can conclude that we have an infinite amount of self-anamorphic curves by reflection in a conical mirror. Curves represented by Fourier series can have any values of the a and b coefficients provided that n*t0 is an odd multiple of Pi. The above table gives the values of n needed for each rotation t0 between the curve and its reflection.
**4. Examples of self anamorphism in a conical mirror.**
The curve that will reflect as a scaled copy of itself, rotated over 90 degree can be approximately represented by an expansion of the form a0+a1 cos(2t)+a2 cos(6t)+a3 cos(10t)+a4cos(14t)+a5 cos(18t)+... The ai can be any combination that keeps the curve within the limits of reflection by the cone. (this is for an opening angle of 30 degrees, the annulus((0,0),(1,3))). here is one example out of an infinite many:
With[{a1 = 0.189, a2 = -0.08, a3 = 0.048, a4 = 0},
Module[{polaR},
polaR = 1.5` + a1 Cos[2 t] + a2 Cos[6 t] + a3 Cos[10 t] +
a4 Cos[14 t];
Show[filledPolarPlot[polaR, Thick, White],
Graphics[{Circle[], LightGray, Disk[]}],
filledPolarPlot[reflect[polaR], Thick, White],
Graphics[Circle[{0, 0}, .01]], Background -> LightGray]]]
![enter image description here][17]
This animation shows the shape variations if we change only the coefficient a1. All these intermediate curves are self-anamorphic with their reflections in a conical mirror.
![enter image description here][18]
This is a set of 3 curves with t0=60 degree:
GraphicsRow@
MapThread[
Module[{polaR},
polaR = 1.95 + #1 Cos[3 t] + #2 Cos[9 t] + #3 Cos[15 t];
Show[filledPolarPlot[3, Thin, White],
filledPolarPlot[polaR, Thick, White],
filledPolarPlot[1, Black, LightGray],
filledPolarPlot[reflect[polaR], Thick,
White]]] &, {{.35, .3, .34}, {-.035, .164, .238}, {.4, .09, \
-.222}}]
![enter image description here][19]
... and 6 self anamorphic curves rotated over 45 degree:(here, we use filled curves and one can observe again the apparent black-white inversion between the white curves and their black reflections. As was demonstrated before, this inversion is merely an optical illusion.
Grid@Partition[
MapThread[
Module[{polaR},
polaR = 1.5 + #1 Cos[4 t] + #2 Cos[12 t] + #3 Cos[20 t] + #4 Cos[
28 t]; Show[filledPolarPlot[2.1, Black, Black],
filledPolarPlot[polaR, Black, White],
filledPolarPlot[1, Black, LightGray],
filledPolarPlot[
reflect[1.5 + #1 Cos[4 t] + #2 Cos[12 t] + #3 Cos[
20 t] + #4 Cos[28 t]], Black,
Black]]] &, {{-0.424`, -0.424`, -0.003`,
0.4`, -0.219`, -0.074`}, {0.008`, 0.128`, 0.127`, -0.037`, 0,
0.377`}, {0.002`, 0.002`, 0.053`, 0.`, 0, 0}, {0.001`, 0.001`,
0.001`, 0, 0.143`, 0.03`}}], 3]
![enter image description here][20]
This GIF shows a test to check if the curves are self-anamorphic i.e. the curves and their reflections are equal except for rotation and scaling. The video shows a 45 degree curve (bleu) of the form 1.5+a0.4 Cos[4t]-.137 Cos[12t]+a3Cos[20t] (n values per previous table) and its reflection (red). We first rotate the reflected curve up to 45 degrees and scale it up to coincide with the red original. Both are equal and, even if we change e.g the a3 coefficient at the end of the video, both shapes stay identical.
![enter image description here][21]
**4. The remarkable Heart Curve.**
An exceptional curve was found by Andrew Crompton in the above mentioned article: a certain combination of the 180 degree coefficients produces a heart-like curve which is quite remarkable. I am repeating his calculations here...
Module[{heart, a1 = -0.1061`, a2 = -.3806, a3 = 0.0843`,
a4 = -0.0552`, a5 = 0.028`, a6 = -0.0165`, a7 = 0.0068`},
heart[aa_] :=
1.5` + a1 Cos[t] - aa Cos[3 t] + a3 Cos[5 t] - a4 Cos[7 t] +
a5 Cos[9 t] - a6 Cos[11 t] + a7 Cos[13 t];
Rotate[Show[{Graphics[{Disk[{0, 0}, 3]}],
filledPolarPlot[heart[a2], Black, White],
Graphics[{Lighter[Gray, .5], Circle[], Disk[]}],
filledPolarPlot[reflect[heart[a2]], Black, Black],
Graphics[{EdgeForm[Black], FaceForm[White], Disk[{0, 0}, .025]}]},
Axes -> False, PlotRange -> 3], 3 Pi/2]]
![enter image description here][22]
... and show the result as reflected it in my conical mirror.
![enter image description here][23]
If we do the same in two colors, as in the following photo, we can easily see why the apparent black-white inversion above was an optical illusion:
![enter image description here][24]
The following illustration shows how it is not the green heart that reflects as the red heart but it is the green ring that becomes the green heart and the red ring that reflects as the red heart! This can easily be observed in two colors but it creates optical confusion when in black and white.
Module[{heart, a1 = -0.1061`, a2 = -.3806, a3 = 0.0843`,
a4 = -0.0552`, a5 = 0.028`, a6 = -0.0165`, a7 = 0.0068`,
green = RGBColor[12/256, 150/256, 100/256],
red = RGBColor[225/256, 45/256, 52/256]},
polaR = 1.5` + a1 Cos[t] - a2 Cos[3 t] + a3 Cos[5 t] - a4 Cos[7 t] +
a5 Cos[9 t] - a6 Cos[11 t] + a7 Cos[13 t];
Column[{Row[{Rotate[Show[filledPolarPlot[3., green, green],
filledPolarPlot[polaR, White, White]], 3 Pi/2],
Style[" \[DoubleRightArrow] ", 26],
Rotate[Show[filledPolarPlot[reflect@polaR, green, green],
ImageSize -> 50], 3 Pi/2]}],
Row[{Rotate[Show[
filledPolarPlot[polaR, red, red],
filledPolarPlot[1, White, White], ImageSize -> 200], 3 Pi/2],
Style[" \[DoubleRightArrow] ", 26],
Rotate[Show[filledPolarPlot[1, red, red],
filledPolarPlot[reflect@polaR, White, White]], 3 Pi/2]}]}]]
![enter image description here][25]
To conclude, here is a Manipulate that can be used to explore the infinite amount of self-anamorphic curves. Select the rotation angle between the curve and its reflection, then set the 7 coefficients of the curves Fourier expansion and see the resulting curve and it, self-anamorphic reflection. Maybe you can find another recognizable or exceptional curve among the millions? Good luck and have fun!
Manipulate[
Module[{lst, curves, polaR},
lst = Cases[
Table[Flatten[{t0,
Table[180 Degree/t0 (2 p + 1), {p, 0, 6}]}], {t0, 10 Degree,
360 Degree, 1 Degree}], {_?NumericQ, _?IntegerQ, ___}];
curves = MapThread[
1.5 + a1 Cos[#1 t] + a2 Cos[#2 t] + a3 Cos[#3 t] + a4 Cos[#4 t] +
a5 Cos[#5 t] + a6 Cos[#6 t] + a7 Cos[#7 t] &,
Transpose[Rest /@ lst]]; polaR = curves[[sc]];
Rotate[Show[{Graphics[{Disk[{0, 0}, 2.5]}],
filledPolarPlot[polaR, Black, White],
Graphics[{Lighter[Gray, .5], Circle[], LightGray, Disk[]}],
filledPolarPlot[reflect[polaR], Black, Black],
Graphics[{EdgeForm[Black], FaceForm[White],
Disk[{0, 0}, .025]}]}, Axes -> False, PlotRange -> 2.5],
3 Pi/2]],
{{sc, 11, "select curve"},
Rule @@@ Transpose@{Range[1, 11],
ToString /@ (First /@ lst)}}, Delimiter, "select coefficients",
{{a1, -0.1061}, -.5, .5, .0001, ImageSize -> Small,
Appearance -> "Labeled"},
{{a2, .3806}, -.5, .5, .0001, ImageSize -> Small,
Appearance -> "Labeled"}, {{a3, .0843}, -.5, .5, .0001,
ImageSize -> Small, Appearance -> "Labeled"},
{{a4, 0.0552}, -.5, .5, .0001, ImageSize -> Small,
Appearance -> "Labeled"},
{{a5, .028}, -.5, .5, .0001, ImageSize -> Small,
Appearance -> "Labeled"},
{{a6, .0165}, -.2, .2, .0001, ImageSize -> Small,
Appearance -> "Labeled"}, {{a7, .0068}, -.1, .1, .0001,
ImageSize -> Small, Appearance -> "Labeled"}]
![enter image description here][26]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=10920GEandAlpha.png&userId=68637
[2]: https://community.wolfram.com/groups/-/m/t/1865458
[3]: https://www.researchgate.net/publication/232844275_Self-anamorphic_images
[4]: https://community.wolfram.com/groups/-/m/t/1597207
[5]: https://en.wikipedia.org/wiki/Numerical_control
[6]: https://en.wikipedia.org/wiki/Chrome_plating
[7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=chromecone.jpg&userId=68637
[8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3146geometryinfinity.png&userId=68637
[9]: https://www.thefreedictionary.com/enantiomorphic
[10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=4176butterflygraph.png&userId=68637
[11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1440square-roseconvert.png&userId=68637
[12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=9935roseandpentagonconvert3D.png&userId=68637
[13]: https://community.wolfram.com//c/portal/getImageAttachment?filename=6129penta-roseblack-white.png&userId=68637
[14]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1954whitepentagonduo.png&userId=68637
[15]: https://www.researchgate.net/publication/232844275_Self-anamorphic_images
[16]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3123frequencytable.png&userId=68637
[17]: https://community.wolfram.com//c/portal/getImageAttachment?filename=337790degreevariation.png&userId=68637
[18]: https://community.wolfram.com//c/portal/getImageAttachment?filename=486990degreevariation.gif&userId=68637
[19]: https://community.wolfram.com//c/portal/getImageAttachment?filename=4912t060degreetrio.png&userId=68637
[20]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3781t045degreesextet.png&userId=68637
[21]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3079testingscaleandrotation.gif&userId=68637
[22]: https://community.wolfram.com//c/portal/getImageAttachment?filename=8188heartMathematica.png&userId=68637
[23]: https://community.wolfram.com//c/portal/getImageAttachment?filename=10513heartduo.png&userId=68637
[24]: https://community.wolfram.com//c/portal/getImageAttachment?filename=coloredheartduo.png&userId=68637
[25]: https://community.wolfram.com//c/portal/getImageAttachment?filename=9431colorheartdiscussion.png&userId=68637
[26]: https://community.wolfram.com//c/portal/getImageAttachment?filename=6314finalManupulate.png&userId=68637Erik Mahieu2020-07-14T09:46:16ZVisualizing Radioactive Decay using Object Oriented Programming
https://community.wolfram.com/groups/-/m/t/2036781
![enter image description here][1]
&[Wolfram Notebook][2]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Radon-222.png&userId=2033261
[2]: https://www.wolframcloud.com/obj/regosheldon2003/Published/RadioactiveDecayVisualizationOOP.nbSheldon Rego2020-07-16T18:44:05Z[Notebook] A Cute Geometry Problem from Italian MO 2001
https://community.wolfram.com/groups/-/m/t/2036994
&[Wolfram Notebook][1]
[1]: https://www.wolframcloud.com/obj/shenghuiy/Published/italianMO2001.nbShenghui Yang2020-07-16T20:42:18Z[Notebook] Step by Step Solution to Iran MO 2019 Geometric Problem
https://community.wolfram.com/groups/-/m/t/2013794
![enter image description here][1]
&[Wolfram Notebook][2]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=3254demo.gif&userId=23928
[2]: https://www.wolframcloud.com/obj/dc692df0-f49b-4c94-86d0-1376ad465b9aShenghui Yang2020-06-26T16:09:03ZExploring a marine annelid worm along the phases of the moon
https://community.wolfram.com/groups/-/m/t/2046184
&[Wolfram Notebook][1]
[1]: https://www.wolframcloud.com/obj/jofree/Published/Circalunar_rythm.nbJofre Espigule-Pons2020-07-27T12:59:36ZReflection and Anamorphism in a Hanging Conical Mirror
https://community.wolfram.com/groups/-/m/t/2053926
![enter image description here][1]
I took the chrome plated conical mirror used in my [previous Wolfram Community contribution][2], suspended it upside down, and asked myself the (anamorphism) question : what should a (deformed) image look like to be reflected in this mirror as the (undeformed) original? We can use Mathematica to solve this problem!
![enter image description here][3]
**1. Geometry of reflection in a hanging conical mirror**
![enter image description here][4]
An observer looking from a viewpoint at V in the direction of the cone, will see the point S reflected as the point I. Q is the intersection point of the view line VI with the cone. This function computes this intersection:
viewlineConeIntersection[{yi_, zi_}, {xv_, zv_}, h0_, h_] :=
Module[{t1, t2},
t1 = Sqrt[-h^2 xv^2 yi^2 + h0^2 (xv^2 + yi^2) + xv^2 zi^2 +
yi^2 zv^2 - 2 h0 (xv^2 zi + yi^2 zv)];
t2 = 1/(h^2 (xv^2 + yi^2) - (zi - zv)^2);
{t2 xv ((h0 - zi) (zi - zv) + h (h yi^2 + t1)),
t2 yi (h^2 xv^2 + (h0 - zv) (-zi + zv) - h t1),
t2 (-h0 (zi - zv)^2 + h^2 (xv^2 zi + yi^2 zv) + h (-zi + zv) t1)}]
With the help of viewlineConeIntersection, the following function computes the intersection of the reflection line IQ with the x-y plane. This intersection is the anamorphic map of I.
hangingConeAnamorphicMap[{yi_, zi_}, {xv_, zv_}, h0_, h_] :=
Quiet[Module[{mirror, ptI, ptV, imageTriangle, vwLine, xq, yq, zq,
ptQ, xn, yn, zn, ptVr},
mirror = Cone[{{0, 0, h0 + h}, {0, 0, h0}}, 1]; ptI = {0, yi, zi};
ptV = {xv, 0, zv};
imageTriangle =
Triangle[{{0, 0, h0}, {0, -1, h + h0 - .001}, {0, 1,
h + h0 - .001}}];
If[! RegionMember[imageTriangle, {0, yi, zi}], {yi, zi} =
Rest[RegionNearest[imageTriangle, {0, yi, zi}]], {yi, zi}];
vwLine = Line[{ptI, ptV}]; {xq, yq, zq} =
viewlineConeIntersection[{yi, zi}, {xv, zv}, h0, h];
ptQ = {xq, yq, zq}; {xn, yn} = Normalize[{xq, yq}];
zn = -Sin[ArcTan[1/h]];
ptVr = ReflectionTransform[{xn, yn, zn}, ptQ][ptV];
Solve[{{x, y, z} \[Element] HalfLine[{ptVr, ptQ}] && z == 0}, {x,
y, z}][[1, All, -1]]]]
This is the function in action as the pointS follows the anamorphic map of a reflected circle:
![enter image description here][5]
**2. Preparing the images**
It is clear that the points I all will have to belong to the triangular region Triangle[{{-1,51.98/30},{1,51.98/30},{0,0}}]. The following code computes the function range staring from its triangular domain.
Module[{xv = 5., zv = 3., r = 1, h = 51.98/30, h0 = .5, triangle,
circlePts, anaCirclePts, trianglePts, anaTrianglePts},
triangle = Triangle[{{-h0 - .02, 0}, {-h0 - h, 1}, {-h0 - h, -1}}];
trianglePts =
DeleteDuplicates[
RegionNearest[triangle,
CirclePoints[{0, (h0 + h)/2}, 4, 1000]] /. {x_?NumericQ,
y_} :> {y, -x}];
anaTrianglePts =
DeleteCases[
ParallelMap[Most[hangingConeAnamorphicMap[#1, {xv, zv}, h0, h]] &,
trianglePts], {}];
Grid[{Style[#, Bold, 14] & /@ {"Domain", "Range"}, {Rotate[
Graphics[{HatchFilling[], FaceForm[LightGray],
EdgeForm[AbsoluteThickness[1.5]], triangle},
PlotRange -> {{-4, 2}, {-2, 2}}, Axes -> True,
TicksStyle -> Small, ImageSize -> 400], -Pi/2],
Rotate[Graphics[{HatchFilling[], FaceForm[LightGray],
EdgeForm[AbsoluteThickness[1.5]], FaceForm[Lighter[Gray, .85]],
Polygon[anaTrianglePts]},
PlotRange -> {{-4, 2.5}, {-4.5, 4.5}}, Axes -> True,
TicksStyle -> Small, ImageSize -> 300], -Pi/2]}}]]
![enter image description here][6]
The reflection appearing in the inverted cone will maximum be triangular in shape or at least fit inside a triangle. In our case (we suspend the cone with its tip at .5 above the x-y plane), this is the triangle Triangle[{{-1,51.98/30},{1,51.98/30},{0,0}}]:
Graphics[{EdgeForm[Black], HatchFilling[], FaceForm[LightGray],
Triangle[{{-1, 51.98/30}, {1, 51.98/30}, {0, 0}}] /. {x_?NumericQ,
y_} :> {x, y + 0.5}}, Axes -> True, AxesOrigin -> {0, 0}]
![enter image description here][7]
In order to fit an image inside this triangle, we need a function that convert the image to a set of colored polygons that fit into the triangle (or other) region.
Module[{mandrill, irc},
mandrill = ImageResize[ExampleData[{"TestImage", "Mandrill"}], 100];
irc = imageRegionCrop[mandrill,
Region@Triangle[{{-.99, 1}, {.97, 1}, {-.01, -.97}}]];
Graphics[{irc /. {x_?NumericQ, y_} :> {x, y + 1.5}, FaceForm[],
EdgeForm[Black],
Triangle[{{-.99, 1}, {.97, 1}, {-.01, -.97}}] /. {x_?NumericQ,
y_} :> {x, y + 1.5}}, Axes -> True,
AxesOrigin -> {0, 0} Axes -> True, AxesOrigin -> {0, 0}]]
![enter image description here][8]
**3. 3D simulation in Mathematica**
Now, we convert the triangular set of colored polygons into its anamorphic map with our function hangingConeAnamorphicMap. With Graphics3D, we can see a simulation of how the anamorphic image will look reflected in the hanging cone:
Module[{r = 1., h = 51.98/30, h0 = .5, xv = 5, zv = 3.5, mirrorCone,
ptV, imageTriangle, img, splitLogo, pixelPolys, anaPolys},
mirrorCone = Cone[{{0, 0, h0 + h}, {0, 0, h0}}, r];
ptV = {xv, 0, zv};
imageTriangle =
Triangle[{{0, 0, h0}, {0, -r, h + h0}, {0, r, h + h0}}];
img = ImageResize[ExampleData[{"TestImage", "Mandrill"}], 200];
splitLogo =
imageRegionCrop[img,
Triangle[{{-1, 51.98/30/2.}, {1,
51.98/30/2.}, {0, -51.98/30/2.}}]];
pixelPolys = splitLogo /. {x_?NumericQ, y_} :> {x, y + 1.5};
anaPolys =
DeleteCases[
MapAt[hangingConeAnamorphicMap[#, {5, 1.367}, .5, 51.98/30] &,
pixelPolys, {All, -1, All, All}] /. {x_?NumericQ, y_, z_} :> {x,
y}, {z == 0}, \[Infinity]];
Graphics3D[{{LightGray,
InfinitePlane[{{0, 0, 0}, {1, 0, 0}, {0, 1, 0}}]},
{Opacity[.35], LightGray, Specularity[1, 2],
mirrorCone}, {AbsoluteThickness[2],
Line[{{0, 0, h + h0 + 2}, {0, 0, h + h0}}], AbsolutePointSize[3],
Point[{0, 0, h + h0 + 22}]},
{FaceForm[], EdgeForm[{Blue, AbsoluteThickness[.5]}],
imageTriangle},
pixelPolys /. {y_, z_} :> {0, y, z},
anaPolys /. {x_?NumericQ, y_} :> {x, y, 0.001}}]]
![enter image description here][9]
**5. Real world testing**
To test this in a real world setting, we need a printout of the anamorphic image...
Graphics[{{Thin, Circle[]}, anaPolys}]
![enter image description here][10]
...locate the printout under our hanging conical mirror....
![enter image description here][11]
...and see the result reflected as the original and undeformed image!
![enter image description here][12]
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=mandrillsetupintro.jpg&userId=68637
[2]: https://community.wolfram.com/groups/-/m/t/2050345?p_p_auth=DRO9ZQfD
[3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=chromecone.jpg&userId=68637
[4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=6150geometryhangingcone.png&userId=68637
[5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=hangingcone.gif&userId=68637
[6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=7783domainandrange.png&userId=68637
[7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=triangle.png&userId=68637
[8]: https://community.wolfram.com//c/portal/getImageAttachment?filename=9702mandriltriangle.png&userId=68637
[9]: https://community.wolfram.com//c/portal/getImageAttachment?filename=mandrill3D.png&userId=68637
[10]: https://community.wolfram.com//c/portal/getImageAttachment?filename=6839mandrill.jpg&userId=68637
[11]: https://community.wolfram.com//c/portal/getImageAttachment?filename=8974mandrillsetup.jpg&userId=68637
[12]: https://community.wolfram.com//c/portal/getImageAttachment?filename=mandrillresult-2.jpg&userId=68637Erik Mahieu2020-08-08T11:58:47ZEstimation of energy yield of 2020 Beirut port explosion
https://community.wolfram.com/groups/-/m/t/2051264
Probably most of you heard the sad news that there was a giant explosion in the port of Beirut today August 3rd 2020. Several videos were released on which we can do analysis. Note that the method I will use was also famously used by G.I. Taylor to find the energy of the Trinity nuclear bomb test, and he found the right amount to within 10%! We will not be so lucky as the video quality was relatively poor as compared to the high-speed imaging done back then.
I extracted several frames from one of the videos:
![enter image description here][1]
SetDirectory[NotebookDirectory[]];
v1 = Import["1.mp4"];
fra = VideoExtractFrames[v1, Interval[{11, 12}]]
fra = ImageRotate[#, Right] & /@ fra;
For each of the frames I identified the explosion by clicking 3 point on the circle:
data={
{7,{{157.15625,365.20703125000006`},{233.83984375,379.76562500000006`},{272.015625,312.91015625000006`}}},
{8,{{318.16796874999994`,322.81640625000006`},{228.7890625,462.8515625},{103.61328125,393.38281250000006`}}},
{9,{{341.03515625000006`,311.34765625},{308.27734375,478.125},{93.86328125,420.34375}}},
{10,{{359.08984375,315.546875},{351.48828125,478.63671875000006`},{86.55078125,454.5078125}}},
{11,{{375.62109375,325.64453125},{330.05859375,535.3984375},{62.0390625,434.51171875}}},
{12,{{376.0390625,326.765625},{337.94140625,539.9257812499999},{46.4140625,462.55859375}}}
};
The first is the index of the frames, the last elements are points of the circle:
circs = CircleThrough /@ data[[;; 6, 2]];
r = circs[[All, 2]];
Here is the visualization:
Table[HighlightImage[fra[[data[[i, 1]]]], circs[[i]], "Boundary"], {i, Length[data]}]
![enter image description here][2]
Notice that I tracked the orange 'glow', not the shockwave or the smoke that was there partially before the main explosion (so on the conservative side and underestimating the energy release).
From Google earth I estimated the size of the face of the building on the left (a grain elevator) and found that every pixel corresponds to 0.59 m roughly (~22 meters corresponding to ~37 pixels).
cali = 0.5888486673789164`;
realr = r cali
The timestamps can be found from the video framerate.
Information[Import["video.mp4"]].
And so the timestamps are created and the dataset is created:
t = (Range[0, Length[realr] - 1]) 1/29.97;
tr = Transpose[{t, realr}]
Since the explosion started between two frames we include that in the fit (the t0):
fit = FindFit[
tr, { a (x + t0)^0.4, 0 < t0 < 1/30}, {{a, 200}, {t0, 1/60}}, x]
realfit = a (x + t0)^0.4 /. fit
tzero = t0 /. fit
realfitshifted = a (x)^0.4 /. fit
prefactor = a /. fit
The fit can be found [here][3] and is based on dimensional analysis with the variable E (energy), r (radius of the explosion), t (time), and ρ (density). This also explains the exponent 0.4 used for fitting.
We plot the data and the fit:
Show[{ListPlot[Transpose[{t + tzero, realr}]],
Plot[realfitshifted, {x, 0, 0.2}]},
PlotRange -> {{0, 0.2}, {0, 120}}, Frame -> True,
FrameLabel -> {"t", "r [m]"}]
![enter image description here][4]
Which is a pretty good fit.
We can now calculate the energy back from the explosion:
ClearAll[r, e, t, \[Rho]]
r == (e t^2/\[Rho])^(1/5)
Refine[DivideSides[%, t^(2/5)], t > 0]
%[[2]] == Quantity[prefactor, "Meters"/"Seconds"^(2/5)]
% /. \[Rho] -> Quantity[1, "Kilograms"/"Meters"^3]
energy = e /. Solve[%, e][[1]]
Yielding:
Quantity[4.2808721214488837`*^11, "Joules"]
and we can convert it to kiloton of TNT:
UnitConvert[energy, "KilotonsOfTNT"]
yielding:
Quantity[0.102315, "KilotonsOfTNT"]
This number is comparable to the 2015 Tianjin explosion (0.3 kilo tonnes of TNT).
[1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2020-08-04at21.44.20.png&userId=73716
[2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2020-08-05at12.00.12.png&userId=73716
[3]: https://en.wikipedia.org/wiki/Nuclear_weapon_yield#Calculating_yields_and_controversy
[4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2020-08-04at21.53.18.png&userId=73716Sander Huisman2020-08-04T19:57:48Z