https://community.wolfram.com RSS Feed for Wolfram Community showing any discussions tagged with Computer-Based Maths sorted by most likes. https://community.wolfram.com/groups/-/m/t/1569707 ![a very prime pencil][1] I just got a set of these pencils, from [Mathsgear][2]. The number printed on it is prime, and will remain so as you sharpen the pencil from the left, all the way down to the last digit, 7. Here is a recursive construction of all such *truncatable primes*. TruncatablePrimes[p_Integer?PrimeQ] := With[{digits = IntegerDigits[p]}, {p, TruncatablePrimes /@ (FromDigits /@ (Prepend[digits, #] & /@ Range[9]))} ]; TruncatablePrimes[p_Integer] := {} The one on the pencil is the largest one, In[7]:= Take[Sort[Flatten[TruncatablePrimes /@ Range[9]]], -5] Out[7]= { 9918918997653319693967, 57686312646216567629137, 95918918997653319693967, 96686312646216567629137, 357686312646216567629137} [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=IMG_20181212_120939.jpg&userId=143131 [2]: https://mathsgear.co.uk/products/truncatable-prime-pencil Roman Maeder 2018-12-12T12:01:36Z https://community.wolfram.com/groups/-/m/t/863933 Many of you have seen the strandbeest (from Dutch, meaning beach-beast). These PVC tube animals created by Theo Jansen walk along the beach and are wind powered: ![enter image description here][1] Years ago (2009 to be more exact) I made a post on my blog about the movement of the legs, as evidenced by the still-nicely-working Mathematica notebook: ![enter image description here][2] At the time the proportions of the legs were not known publicly so I meticulously studied frames of (low quality) YouTube videos. I made the following diagram in Illustrator of what I thought I saw: ![enter image description here][3] ![enter image description here][4] On the left the length of the legs in red, and in blue the numbers of the joints. On the right the trajectory of the joints that I calculated at the time in Mathematica. It's funny that my blog does not exist any more (for years actually), but these images live on, as I found out when I looked for strandbeest on Google Images: ![enter image description here][5] My images! But not on my website! Nice to see people still use it. Now, in 2016, I saw these files on my laptop, and thought: is there finally more known about them? Well yes, there is! The exact proportions are now known and there is tons and tons of videos, lectures, 3D-printable strandbeest models, interviews with Theo Jansen and other stuff! So now we can find the exact dimensions readily on the internet: ![enter image description here][6] Notice that I (wrongly) assumed that the legs had 'feet'! oops! I was very happy to see that my lengths were not that wrong though! Let's recreate the strandbeest. We do so by first creating a function that quickly finds the intersection of two circles: Clear[FindPoint, FindLines] FindPoint[p1 : {x1_, y1_}, p2 : {x2_, y2_}, R_, r_, side_] := Module[{d, x, y, vc1, vc2, p, sol, sol1, sol2, s1, s2, sr}, d = N@Sqrt[(x2 - x1)^2 + (y2 - y1)^2]; x = (d^2 - r^2 + R^2)/(2 d); y = Sqrt[R^2 - x^2]; vc1 = Normalize[{x2 - x1, y2 - y1}]; vc2 = Cross[vc1]; p = {x1, y1} + x vc1; {sol1, sol2} = {p + y vc2, p - y vc2}; s1 = Sign[Last[Cross[Append[(p2 - p1), 0], Append[(sol1 - p1), 0]]]]; s2 = Sign[Last[Cross[Append[(p2 - p1), 0], Append[(sol2 - p1), 0]]]]; sr = If[side === Left, 1, -1]; Switch[sr, s1, sol1 , s2 , sol2 ] ] This finds on the side 'side' (Left/Right) the intersection point of two circles positioned at p1 and p2, with radii R and r, respectively. And now we can easily compute all the little vertices/joints of our beast: FindLines[\[Theta]_] := Module[{p1, p2, p3, p4, p5, p6, p7, p8, p10, p11, p12, p13, p14, p15}, {p1, p2, p3, p4, p5, p6, p7, p8, p10, p11, p12, p13, p14, p15} = FindPoints[\[Theta]]; {{p1, p2}, {p2, p3}, {p3, p4}, {p1, p4}, {p2, p6}, {p4, p6}, {p3, p5}, {p4, p5}, {p5, p8}, {p6, p8}, {p6, p7}, {p7, p8}, {p1, p11}, {p10, p11}, {p2, p10}, {p2, p13}, {p11, p13}, {p10, p12}, {p11, p12}, {p12, p14}, {p13, p14}, {p13, p15}, {p14, p15}} ] FindPoints[\[Theta]_] := Module[{p1, p2, p3, p4, p5, p6, p7, p8, p9, p10, p11, p12, p13, p14, p15, p16}, p1 = {0, 0}; p4 = {38, -7.8}; p11 = {-38, -7.8}; p2 = 15 {Cos[\[Theta]], Sin[\[Theta]]}; p3 = FindPoint[p2, p4, 50, 41.5, Left]; p6 = FindPoint[p2, p4, 61.9, 39.3, Right]; p5 = FindPoint[p3, p4, 55.8, 41.5, Left]; p8 = FindPoint[p5, p6, 39.4, 36.7, Left]; p7 = FindPoint[p6, p8, 49, 65.7, Right]; p10 = FindPoint[p2, p11, 50, 41.5, Right]; p13 = FindPoint[p2, p11, 61.9, 39.3, Left]; p12 = FindPoint[p10, p11, 55.8, 41.5, Right]; p14 = FindPoint[p12, p13, 39.4, 36.7, Right]; p15 = FindPoint[p13, p14, 49, 65.7, Left]; {p1, p2, p3, p4, p5, p6, p7, p8, p10, p11, p12, p13, p14, p15} ] Now we can plot it easily: trajectoriesdata = (FindPoints /@ Subdivide[0, 2 Pi, 100])\[Transpose]; Manipulate[ Graphics[{Arrowheads[Large], Arrow /@ trajectoriesdata, Thick, Red, Line[FindLines[\[Theta]]]}, PlotRange -> {{-150, 150}, {-120, 70}}, ImageSize -> 800 ] , {\[Theta], 0, 2 \[Pi]} ] ![enter image description here][7] We can also make an entire bunch of legs at the same time and make a 3D beast! Manipulate[ mp = 60; n = 12; \[CurlyPhi] = Table[Mod[5 \[Iota], n, 1], {\[Iota], 1, n}]; Graphics3D[{Darker@Yellow, Table[ Line[ Map[Prepend[mp \[Iota]], FindLines[\[Theta] + \[CurlyPhi][[\[Iota]]] (2 Pi/n)], {2}]], {\[Iota], n} ] , Black, Line[{{mp 1, 0, 0}, {mp n, 0, 0}}] } , Lighting -> "Neutral", PlotRangePadding -> Scaled[.1], PlotRange -> {{-mp, (n + 1) mp}, {-150, 150}, {-150, 150}}, Boxed -> False, ImageSize -> 700 ] , {\[Theta], 0, 2 \[Pi]} ] ![enter image description here][8] From the side we can look at how the legs of 4-pair-legged and 6-pair-legged versions of the beasts work: ![enter image description here][9] ![enter image description here][10] Hope you enjoyed this! Perhaps someone else can make this thing actually walk over a (bumpy) surface? [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=LVDKumerus2.jpg&userId=73716 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-05-29at00.51.53.png&userId=73716 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=strandbeest_sketch.png&userId=73716 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=strandbeest_trajectories.png&userId=73716 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-05-29at00.16.23.png&userId=73716 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Strandbeest_Leg_Proportions-01.png&userId=73716 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=3493strandwalk.gif&userId=73716 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=3587strandwalk3D.gif&userId=73716 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=4legged.gif&userId=73716 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=6legged.gif&userId=73716 Sander Huisman 2016-05-28T23:02:16Z https://community.wolfram.com/groups/-/m/t/2098696 deleted David Ameneyro 2020-10-21T05:05:58Z https://community.wolfram.com/groups/-/m/t/2749012 > ## What is your one-liner for getting 2023? Comment below! ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=1672159412326.jpg&userId=11733 [2]: https://www.wolframcloud.com/obj/b1d18763-9553-40df-8636-84f31237e4ff Ed Pegg 2022-12-27T14:25:56Z https://community.wolfram.com/groups/-/m/t/114911 How small can a description of a large prime number be? There are the Fermat primes 2^n-1 for certain n, and in base 2 these are a sequence of ones.  In base 10, if you have just zeros and two ones, then the only primes of that form are 11 and 101.  If there are three ones then it is divisible by three.  But what about four ones?  It seems wrong to me that there might be an unbounded number of such primes. That's what some brief experiments suggest though. [mcode]1+10^4+10^18+10^201 == 1000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000001000000000000010001[/mcode]is the largest one I found.  Also I don't notice any patterns, e.g. here in the first 200 such primes [img=width: 68px; height: 432px;]/c/portal/getImageAttachment?filename=primes-1111.jpg&userId=23275[/img] and here are the first 254 primes with nonzero digits {1,2,1} [img=width: 347px; height: 432px;]/c/portal/getImageAttachment?filename=primes-121.jpg&userId=23275[/img] the largest found is [mcode]1+2*10^14+10^201 == 1000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000200000000000001[/mcode]Does anyone else have any primes which don't seem like they should be prime?  The more extreme the better. Todd Rowland 2013-09-03T04:50:53Z https://community.wolfram.com/groups/-/m/t/819760 I have been [developing videos][1] to teach Wolfram Language to people who have never used it before. These videos are based on the chapters of Stephen Wolfram's new book, An Elementary Introduction to the Wolfram Language. I made these videos to appeal to the people who prefer watching videos to reading books. The first time I used Mathematica was in school and my teacher, Mr. Hoek, gave me a love of the language that I couldn't have found elsewhere. He taught Mathematica using a cool style. He would type and speak as the class so as to better teach the concepts. He would also give interesting problems that truly challenged the class to think and use what he had just taught. The most important part is that he made learning Mathematica fun!!! I have based the videos style on his teaching style; typing and speaking while trying my hardest to make them fun and exciting. The process of making these videos has been interesting. Despite the fact that they are only 5 minutes long, they are not that simple to make. First I write the script for the video. Then, I record the typing for the video very slowly so mistakes don't appear in the video. I then fast forward it anywhere from 2 to 8 times depending on the section. I then add in my voice over it and fit the timing and the sections to match my voice. I have called the videos **Learning Coding with Kogan**. Here is the link to the [youtube channel][2]: [Lesson 1: Elementary Arithmetic][3] [Lesson 2: Introducing Functions][4] [Lesson 3: First Look At Lists][5] Any feedback would be great. Also please subscribe to the videos and share them with your friends. Thanks, Jonathan [1]: https://www.youtube.com/channel/UCV64YhbeP_UGrvAarOi41Qg [2]: https://www.youtube.com/channel/UCV64YhbeP_UGrvAarOi41Qg [3]: https://youtu.be/OpA5JZDfPaA [4]: https://youtu.be/Npr4rPOSbt0 [5]: https://youtu.be/wY9uYvR6V74 Jonathan Kogan 2016-03-09T01:37:46Z https://community.wolfram.com/groups/-/m/t/418720 ## This is it. The perfectly centered billiards break. Behold: ![enter image description here][2] <h2>Setup</h2> This break was computed in *Mathematica* using a numerical differential equations model. Here are a few details of the model: * All balls are assumed to be perfectly [elastic][3] and almost perfectly rigid. * Each ball has a mass of 1 unit and a radius of 1 unit. * The cue ball has a initial speed of 10 units/sec. * The force between two balls is given by the formula $$F \;=\; \begin{cases}0 & \text{if }d \geq 2, \\ 10^{11}(2-d)^{3/2} & \text{if }d < 2, \end{cases}$$ where $d$ is the distance between the centers of the balls. Note that the balls overlap if and only if $d < 2$. The power of $3/2$ was [suggested by Yoav Kallus][4] on Math Overflow, because it follows [Hertz's theory of non-adhesive elastic contact](https://en.wikipedia.org/wiki/Contact_mechanics#Hertzian_theory_of_non-adhesive_elastic_contact). The initial speed of the cue ball is immaterial -- slowing down the cue ball is the same as slowing down time. The force constant $10^{11}$ has no real effect as long as it's large enough, although it does change the speed at which the initial collision takes place. <h2>The Collision</h2> For this model, the entire collision takes place in the first 0.2 milliseconds, and none of the balls overlap by more than 0.025% of their radius during the collision. (These figures are model dependent -- real billiard balls may collide faster or slower than this.) The following animation shows the forces between the balls during the collision, with the force proportional to the area of each yellow circle. Note that the balls themselves hardly move at all *during* the collision, although they do accelerate quite a bit. ![enter image description here][5] <h2>The Trajectories</h2> The following picture shows the trajectories of the billiard balls after the collision. ![enter image description here][6] After the collision, some of the balls are travelling considerably faster than others. The following table shows the magnitude and direction of the velocity of each ball, where $0^\circ$ indicates straight up. $\begin{array}{|c|c|c|c|c|c|c|c|c|c|c|} \hline \text{ball} & \text{cue} & 1 & 2,3 & 4,6 & 5 & 7,10 & 8,9 & 11,15 & 12,14 & 13 \\ \hline \text{angle} & 0^\circ & 0^\circ & 40.1^\circ & 43.9^\circ & 0^\circ & 82.1^\circ & 161.8^\circ & 150^\circ & 178.2^\circ & 180^\circ \\ \hline \text{speed} & 1.79 & 1.20 & 1.57 & 1.42 & 0.12 & 1.31 & 0.25 & 5.60 & 2.57 & 2.63 \\ \hline \end{array} $ For comparison, remember that the initial speed of the cue ball was 10 units/sec. Thus, balls 11 and 15 (the back corner balls) shoot out at more than half the speed of the original cue ball, whereas ball 5 slowly rolls upwards at less than 2% of the speed of the original cue ball. By the way, if you add up the sum of the squares of the speeds of the balls, you get 100, since kinetic energy is conserved. <h2>Linear and Quadratic Responses</h2> The results of this model are dependent on the power of $3/2$ in the force law -- other force laws give other breaks. For example, we could try making the force a linear function of the overlap distance (in analogy with springs and [Hooke's law][7]), or we could try making the force proportional to the *square* of the overlap distance. The results are noticeably different ![enter image description here][8] ![enter image description here][9] <h2>Stiff Response</h2> Glenn the Udderboat points out that "stiff" balls might be best approximated by a force response involving a higher power of the distance (although this isn't the [usual definition][10] of "stiffness"). Unfortunately, the calculation time in *Mathematica* becomes longer when the power is increased, presumably because it needs to use a smaller time step to be sufficiently accurate. Here is a simulation involving a reasonably "stiff" force law $$F \;=\; \begin{cases}0 & \text{if }d \geq 2, \\ 10^{54}(2-d)^{10} & \text{if }d<2. \end{cases}$$ ![enter image description here][11] As you can see, the result is very similar to my first thought: > The two balls in the back corners shoot away along rays parallel to the two sides of the triangle. Here is a picture showing the forces, with each force vector emanating from the point of contact. > ![enter image description here][12] This seems like good evidence that above 1st-thought behavior is indeed the limiting behavior in the case where the stiffness goes to infinity. As you might expect, most of the energy in this case is transferred very quickly at the beginning of the collision. Almost all of the energy has moves to the back corner balls in the first 0.02 milliseconds. Here is an animation of the forces: ![enter image description here][13] After that, the corner balls and the cue ball shoot out, and the remaining balls continue to collide gently for the next millisecond or so. While the simplicity of this behavior is appealing, I would guess that "real" billard balls do not have such a stiff force response. Of the models listed here, the intial Hertz-based model is probably the most accurate. Qualitatively, it certainly seems the closest to an "actual" break. <h2> Full Code </h2> &[Wolfram Notebook][14] ---------- I wrote this post originally for [Math Stack Exchange][15]. [1]: http://math.bard.edu/belk/code.htm [2]: http://i.stack.imgur.com/Y9ixR.gif [3]: https://en.wikipedia.org/wiki/Elasticity_%28physics%29 [4]: http://mathoverflow.net/questions/156263/perfectly-centered-break-of-a-perfectly-aligned-pool-ball-rack/156407?noredirect=1#comment400402_156407 [5]: http://i.stack.imgur.com/WY37i.gif [6]: http://i.stack.imgur.com/wHVJA.png [7]: https://en.wikipedia.org/wiki/Hooke%27s_law [8]: http://i.stack.imgur.com/a1l3b.gif [9]: http://i.stack.imgur.com/xM76n.gif [10]: https://en.wikipedia.org/wiki/Stiffness [11]: http://i.stack.imgur.com/nMJyT.gif [12]: http://i.stack.imgur.com/GKGT9.png [13]: http://i.stack.imgur.com/VuUWT.gif [14]: https://www.wolframcloud.com/obj/8c6b7e81-4a5c-4e3a-bb13-a3d47e728e64 [15]: http://math.stackexchange.com/a/659318/28293 Jim Belk 2015-01-08T18:02:10Z https://community.wolfram.com/groups/-/m/t/1330220 I just came across a puzzle on [phys.org][1], which apparently went viral on Twitter. [Ed Southall posted a question][2] regarding a problem about the area of a triangle. We are asked what fraction of the area the pink triangle occupies: [![enter image description here][3]][4] It is quite easy to find the answer. What is more interesting is to find as many ways as possible for that. [On MentalFloss they describe some approaches to solve the puzzle][5]. The main idea of the "classical solutions" presented on that website are based on the similarity of triangles. I was wondering what computational thinking and the Wolfram Language could do for us... Setting the problem up ---------- It is necessary to "interpret the sketch". For example, we need to recognise that we can choose the base to be of length one, and that the other two sides have slope 2 and -1. With that we can define the region like so: reg = ImplicitRegion[2 x >= y && y <= 1 - x && 0 <= x <= 1 && 0 <= y <= 1, {x, y}]; I generated the plot above with this function: RegionPlot[reg, PlotRange -> {{0, 1}, {0, 1}}, PlotStyle -> RGBColor[1, .1, 1], FrameTicks -> False] ![enter image description here][6] Stephen Wolfram often says that the Wolfram Language is very useful also to state problems (read his blog posts on AI and on communicating with aliens). This becomes quite clear here. The definition of the `ImplicitRegion` makes the problem very clear; in fact much more precise than the image alone! Solution 1 ---------- The easiest solution is now to ask Mathematica directly for the answer: Area[reg] which gives 1/3 as expected. Solution 2 ---------- We can also use a Monte Carlo approach and generate points in the unit square and see how many of them are in the "pink region": M = 1000000; N[Length[Select[RandomPoint[Rectangle[{0, 0}, {1, 1}], M], 2 #[[1]] >= #[[2]] && #[[2]] <= 1 - #[[1]] &]]/M] which obviously gives slightly different results every time you run it. I got 0.333633 which is quite close to 1/3. Solution 3 ---------- The problem with the previous solution is that it is numerical and only gives an approximate value. The Wolfram Language also allows us to use the distributions to effectively run a Monte Carlo simulation on an "infinite number of points". dist = UniformDistribution[{{0, 1}, {0, 1}}]; Probability[2 x >= y \[And] y <= 1 - x, {x, y} \[Distributed] dist] which results in 1/3, so the precise result. Solution 4 ---------- If we recognise that in the definition of the implicit region defines the region by using the equations of two straight lines y==2 x && y == 1 - x We can then calculate where they intersect, i.e. the tip of the triangle: sols = Solve[y == 2 x && y == 1 - x, {x, y}] This gives {{x -> 1/3, y -> 2/3}} Where y is the height of the triangle. So then the area of the pink triangle is area=1/2 (x*y) + 1/2 ((1 - x)*y) /. sols[[1]] This come uses the hight line to calculate the areas of the resulting "left and right triangle". It is easier of course because we know that the length of the base of the triangle is 1 and the height is y so that we can write: area = y/2 (Just simplify the previous equation to get to this result!) As y is 2/3 we obtain 1/3 for the area of the pink triangle again. Solution 5 ---------- This one is going to be nice. We first import the image from the phys.org website: img = Import["https://3c1703fe8d.site.internapcdn.net/newman/gfx/news/2018/5ae713bf2d29a.jpg"]; You will notice that around the black square there is a slim white border, which can be removed using ImageCrop. There are three colours in the remaining plot: white, pink and black. We can ignore the black points (as they are only lines, i.e. one dimensional). The two dominating colours will be white and pink. So lets take all pixels and find three clusters of the values, corresponding to white, pink and black: clusters = FindClusters[Flatten[ImageData[ImageCrop[img]], 1], 3]; We now need to count how many points/pixels we have in any cluster. Then we will sort the sizes, and ignore the smallest one (i.e. black). Then we compute the ratio of pink points to all points: N[#[[2]]/Total[#[[{2, 3}]]]] &@Sort[Length /@ clusters] which gives 0.333709, so a very good approximate value. Conclusion ---------- You will notice that some of the solutions are distinctly different from the analytical and geometrical approaches presented on the mental floss website. I would classify the approaches I describe here as rather "computational" approaches. I challenge you to find further computational approaches and see what we can contribute to the discussion on twitter. [1]: https://phys.org/news/2018-04-math-puzzle-viral.html [2]: https://twitter.com/solvemymaths/status/988500302340022272?tfw_site=mental_floss&ref_src=twsrc%5Etfw&ref_url=http://mentalfloss.com/article/542049/can-you-solve-pink-triangle-math-problem-thats-stumping-internet [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-05-02at4.52.21PM.png&userId=20103 [4]: https://twitter.com/solvemymaths/status/988500302340022272?tfw_site=mental_floss&ref_src=twsrc%5Etfw&ref_url=http://mentalfloss.com/article/542049/can-you-solve-pink-triangle-math-problem-thats-stumping-internet [5]: http://mentalfloss.com/article/542049/can-you-solve-pink-triangle-math-problem-thats-stumping-internet [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2018-05-0101.03.40.png&userId=20103 Marco Thiel 2018-05-01T00:35:37Z https://community.wolfram.com/groups/-/m/t/896637 There are many ways to sum positive elements of a list such as, e.g., In[1]:= list = RandomReal[{-10, 10}, 1000000]; In[2]:= tList = { Plus @@ Map[If[# < 0, 0, #] &, list] // AbsoluteTiming, Total@Map[If[# < 0, 0, #] &, list] // AbsoluteTiming, Total[list /. x_ /; x < 0 -> 0] // AbsoluteTiming } Out[2]= {{2.51129, 2.49923*10^6}, {1.93032, 2.49923*10^6}, {1.6144, 2.49923*10^6}} In[3]:= BarChart@tList[[All, 1]] ![enter image description here][1] Can you recommend a code better than above ones? [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=a.png&userId=159033 Valeriu Ungureanu 2016-07-31T11:59:52Z https://community.wolfram.com/groups/-/m/t/1058615 ![enter image description here][1] Just a couple of days ago I posted about the Numberphile video about Frog Jumping ([see here][2]) where one of the forum members suggested I should check out the video about [sandpiles][3]. ![enter image description here][4] If you haven't seen it already, [you should][5]. I must admit it is a fairly long video that starts off boring, but it is pure gold at the end. Anyhow, how can we do such calculations in the Wolfram Language [I van Veen][6] was wondering. So here we go. We represent our sandpile as a simple matrix (following the example around 8:37 in the video): a = sp[{{3, 3, 3}, {3, 3, 3}, {3, 3, 3}}] b = sp[{{0, 0, 0}, {0, 1, 0}, {0, 0, 0}}] c = a + b If we execute this now, nothing really happens, that's because we have not yet told the computer how to add up sp objects. So let's add a definition: ClearAll[sp] sp[s_List] + sp[t_List] ^:= Module[{dim, r, tmp, neighbours}, dim = Dimensions[s]; r = s + t; While[Max[r] > 3, r = ArrayPad[r, 1, 0]; tmp = Quotient[r, 4]; r -= 4 tmp; r += RotateLeft[tmp, {0, 1}] + RotateLeft[tmp, {1, 0}] + RotateLeft[tmp, {0, -1}] + RotateLeft[tmp, {-1, 0}]; r = ArrayPad[r, -1]; ]; sp[r] ] What is done here, is the following: 0. Add up the raw matrices 1. While there is a number still above 3 loop: 2. Pad the entire matrix with 0s around it 3. Calculate Floor[values/4], this is done using quotient, and gives a matrix of the number that can be toppled, and how many times it can be toppled. 4. Subtract 4 times this matrix. 5. Add shifted version of this matrix to redistribute the sand to the neighbours (using RotateLeft). 6. Remove the padding again using Arraypad[...,-1] Note that I have to use :^= rather than := because **Plus** is protected by default. Moreover, I don't want to touch the definition of **Plus**, so by using ^:= the definition is added to sp rather than Plus. I also tried out several other different methods, I found this was one of the fastest ways. Other options included using **Position**, finding the neighbours and subtracting manually, convolutions, or using **BlockMap**. Perhaps one could even coerce **CellularAutomaton** to do it for you. Now that we have addition figures out, we can re-execute our above code: a = sp[{{3, 3, 3}, {3, 3, 3}, {3, 3, 3}}]; b = sp[{{0, 0, 0}, {0, 1, 0}, {0, 0, 0}}]; c = a + b sp[{{1, 3, 1}, {3, 0, 3}, {1, 3, 1}}] So it is working! Now make some convenient functions to make it look nicer: colorrules = {0 -> Black, 1 -> Yellow, 2 -> Blue, 3 -> Red, _Integer -> Pink}; Format[sp[t_]] := ArrayPlot[t /. colorrules, ImageSize -> 200, Frame -> False] Using **Format** we can tell the Wolfram Language how to show an sp object. Re-executing now gives us an image, rather than a dull matrix: ![enter image description here][7] However we can not get the data from such an image any more, so it is a good idea to define a Normal and some other functions as well, here the total code: ClearAll[sp] sp[x_SparseArray]:=sp[Normal[x]] Normal[sp[s_List]]^:=s sp[s_List]+sp[n_Integer]^:=sp[s]+sp[ConstantArray[n,Dimensions[s]]] sp[s_List]+sp[t_List]^:=Module[{dim,r,tmp,neighbours}, dim=Dimensions[s]; r=s+t; While[Max[r]>3, r=ArrayPad[r,1,0]; tmp=Quotient[r,4]; r-=4tmp; r+=RotateLeft[tmp,{0,1}]+RotateLeft[tmp,{1,0}]+RotateLeft[tmp,{0,-1}]+RotateLeft[tmp,{-1,0}]; r=ArrayPad[r,-1]; ]; sp[r] ] colorrules={0->Black,1->Yellow,2->Blue,3->Red,_Integer->Pink}; Format[sp[t_]]:=ArrayPlot[t/.colorrules,ImageSize->200,Frame->False] Now we can type: Normal[c] to get the values again: {{1, 3, 1}, {3, 0, 3}, {1, 3, 1}} Or add a constant sandpile: sp[{{3, 3, 3}, {3, 3, 3}, {3, 3, 3}}] + sp[1] ![enter image description here][8] So let's create the iconic image the Numberphile video showed: n = 100; u = sp[ConstantArray[6, {n, n}]]; start = AbsoluteTime[]; u = u + sp[0]; (* the addition of 0 will trigger the toppling *) out = u = sp[ConstantArray[6, {n, n}] - Normal[u]] + sp[0] {n, AbsoluteTime[] - start} Letting it run takes a few seconds: ![enter image description here][9] Or run it for large n = 512: ![enter image description here][10] The authors also shows what happens when you put a large pile of sand on a single cell and see how it spreads, we can do that too: u = sp[CenterArray[50000, {201, 201}]]; AbsoluteTiming[out = u + sp[0];] out ![enter image description here][11] Note that for larger numbers of sand it will take longer and longer to converge; this is because sand will take a long time to reach the edge of the matrix. The grid increases as n^2, but the border only as n. So it becomes harder and harder to lose sand. I'm not completely sure how to speed up the code without going through all the calculations... Hope you enjoyed this, now that you have the basic code, one can try non-rectangular patterns, different neighbourhoods, et cetera. Also check out the other Numberphile inspired posts: - [[Numberphile] - Frog Jumping - Solving the puzzle][12] - [[Numberphile] - The Illumination Problem][13] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=open.png&userId=73716 [2]: http://community.wolfram.com/groups/-/m/t/1055504 [3]: https://www.youtube.com/watch?v=1MtEUErz7Gg [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=YT.png&userId=73716 [5]: https://www.youtube.com/watch?v=1MtEUErz7Gg [6]: http://community.wolfram.com/web/lvveen [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=31021.png&userId=73716 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=94402.png&userId=73716 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=22313.png&userId=73716 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=43594.png&userId=73716 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=108995.png&userId=73716 [12]: http://community.wolfram.com/groups/-/m/t/1055504 [13]: http://community.wolfram.com/groups/-/m/t/1048489 Sander Huisman 2017-04-10T20:23:40Z https://community.wolfram.com/groups/-/m/t/974734 It seems like there is an ABC book about everything, so I thought I'd make one for Wolfram Language ([**attached**][1] below). Turns out that many of the key concepts can be covered (see [EIWL][2] for a more grown up introduction) and it makes a gentle introduction. I tried it out on my 5 year old kids. Amusingly, they thought "Union" was "Annoyance". More seriously, there is a general point to introduce words to children so that they become familiar with them. While there are lots of words that are not taught in early education, the list used as common function names is pretty small and manageable. As usual here, there is the metapoint that you can make your own list. For some letters there are many symbols to choose from, and for others there are very few. For "X" I picked [Xor][3] and for "Z" I picked [Zeta][4], the only really math one that I picked out, because there weren't any WL-common alternatives. I made heavy use of Names. Anybody have some other choices? Here is an image from the start of the notebook.![enter image description here][5] [1]: http://community.wolfram.com/groups?p_auth=RdJw1UCY&p_p_id=19&p_p_lifecycle=1&p_p_state=exclusive&p_p_mode=view&p_p_col_id=column-1&p_p_col_pos=1&p_p_col_count=3&_19_struts_action=/message_boards/get_message_attachment&_19_messageId=974734&_19_attachment=Wolfram-Language-ABCs.nb [2]: http://wolfram.com/language/elementary-introduction/ [3]: http://reference.wolfram.com/language/ref/Xor.html [4]: http://reference.wolfram.com/language/ref/Zeta.html [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Wolfram-Language-ABCs-image.jpeg&userId=23275 Todd Rowland 2016-12-06T02:42:00Z https://community.wolfram.com/groups/-/m/t/2030201 &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/e9934595-75e0-42eb-92bc-ae38528364a7 [Original]: https://www.wolframcloud.com/obj/ss8659/Published/WSS20-Level-Index-Arithmetic-5.nb Swastik Banerjee 2020-07-14T17:07:16Z https://community.wolfram.com/groups/-/m/t/2151938 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Shinto2.gif&userId=20103 [2]: https://www.wolframcloud.com/obj/9b0e0bf0-9244-4141-8d12-c63b73b662ea Shenghui Yang 2021-01-01T03:02:18Z https://community.wolfram.com/groups/-/m/t/1824481 &[embedded notebook][1] [1]: https://www.wolframcloud.com/obj/23a8ab7b-3dd4-4d06-80d8-f2f198b85966 Seth Chandler 2019-11-13T16:01:24Z 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=1013863 Kotaro Okazaki 2019-04-20T14:42:58Z https://community.wolfram.com/groups/-/m/t/550504 ![Look familiar...?][1] When last did you solve a quadratic equation by hand? Probably not since school, I'm guessing. It's an open secret that maths education is way behind the times, failing to equip kids with skills they need in the real world. As a Wolfram Community member, you may well have come across the [Computer-Based Maths initiative][2], driven by Conrad Wolfram. For those who don't know, it's a programme designed to bring coding and computers into school maths curricula worldwide, using Wolfram technology. And now the CBM team wants *your* ideas ahead of the fourth [CBM Summit in London on 19-20 November][3]. We already have Jaak Aaviksoo, Simon Peyton Jones and Raspberry Pi's Eben Upton, who [spoke at the last CBM Summit][4] in 2013. Now we'd like to hear from you... - Who would *you* like to hear speaking on this subject? - Do you have something you'd like to present yourself? - What are the most important topics that should be covered? Think about your country and your workplace too: - Are there thought leaders, education revolutionaries or forward-thinking math education projects the CBM team should know about? I'm looking forward to your comments...and maybe see you in London! [![CBM Summit, London, 19-20 November][5]][6] [1]: /c/portal/getImageAttachment?filename=_thumb_117376.png&userId=383623 [2]: https://www.computerbasedmath.org/ [3]: http://www.computerbasedmath.org/events/maths-education-summit-2015/ [4]: https://www.youtube.com/watch?v=NZvttwpeVrc&list=PLzKFBYmW-UKpLGkkprg5LkHUVPaCV85R1&index=35 [5]: /c/portal/getImageAttachment?filename=SummitFooterFullSize.jpg&userId=383623 [6]: http://www.computerbasedmath.org/events/maths-education-summit-2015/ Richard Asher 2015-08-20T15:52:37Z https://community.wolfram.com/groups/-/m/t/64865 I know this is early days for this community, but I have a request! I have been using Mathematica in high school mathematics lessons for the past academic year, not just for demonstrations, but to introduce my pupils to the basics of programming, and how we can use computers in problem solving. I am wondering if there are any examples of good practice, resources or just advice from people who are doing, or who have done, similar things. I am familiar with the Demonstrations project, but I am looking more at how I can get my students to be creative with Mathematica.  I have some resources of my own which I am happy to share as well. Thanks, Nick  Nick James 2013-07-23T22:08:00Z https://community.wolfram.com/groups/-/m/t/945046 *NOTE: the notebook with Wolfram Language code is attached at the end of the post* ---------- ![enter image description here][1] It's time to embrace matrix products. They strictly generalize infinite series, products, and continued fractions. Here are two examples where they efficiently represent the Fourier coefficients of fractals which apparently lack the traditional representations. By the way, in response to the this, [Robert Fathauer][2] sent the photo below (left) of the objects he apparently makes from porcelain. It is a 3D print that was collaborative work with [Henry Segerman][3] and [David Bachman][4]. On the right is the image from Robert Fathauer's [website][5]. ![enter image description here][6] Example 1 --------- The sweep of the 2D subset of the complex plane representable in the base 2 using the digits 0, 1, and $(-1)^{\pm 2/3}$. This is $2m = six$ Sierpi?ski Gasket sweeps arranged alternately inward and outward around a regular 2m-gon. Found originally as a 3*3 product by Julian Ziegler Hunts. The $Subscript_{1,1}$ indicates the upper left element of the infinite product. ![enter image description here][7] ![enter image description here][8] ![enter image description here][9] ParametricPlot[{Re[#], Im[#]} &@base2[t, -239, 239], {t, 0, 6}, PlotPoints -> 3^7, Axes -> None] ![enter image description here][10] ParametricPlot3D[{Re[#], Im[#], Log[1 + j]} &@ base2[t, Ceiling[-j/2], Floor[(j + 1)/2]], {t, 0, 6}, {j, 0, 69}, PlotPoints -> {129, 70}] ![enter image description here][11] ![enter image description here][12] ParametricPlot3D[{Re[#], Im[#], Log[1 + j]} &@ base2[t, Ceiling[-j/2], Floor[(j + 1)/2]], {t, 0, 6}, {j, 0, 239}, PlotPoints -> {239, 70}] ![enter image description here][13] Example 2 --------- The Twindragon Sweep. $\alpha = half the fold angle = \pi/4$ in the space-filling case. The Twindragon fills the subset of the complex plane representable base i-1 using the digits 0 and 1. The function BProd returns the upper right element of the approximate infinite matrix product. ![enter image description here][14] ![enter image description here][15] ![enter image description here][16] ![enter image description here][17] ![enter image description here][18] ![enter image description here][19] ![enter image description here][20] ParametricPlot3D[{Re[#], Im[#], Log[1 + n]} &@ drag[t, Ceiling[-n/2], Floor[(n + 1)/2]], {t, 0, 4}, {n, 0, 239}, PlotPoints -> {239, 70}] ![enter image description here][21] ![enter image description here][22] Example 3 (surprise!) --------------------- Here is a 3D print by Neil Bickford of a Fudgeflake Sweep sweep (sic), with a Fourier coefficient derived as a matrix product that happened to telescope to an ordinary product. This m=3 case may be thought of as three Triadic Dragons in a triangular loop. ![enter image description here][23] ![enter image description here][24] Example 4 ---------- As in Example 3, a matrix product telescopes to give the Fourier series for a class of fractals including both the Snowflake curve (m=3, s= 1/Sqrt[3]) and Sierpi?ski's squarefill (m=2, s=1). ![enter image description here][25] ![enter image description here][26] ![enter image description here][27] ![enter image description here][28] ![enter image description here][29] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=SDFSDR43T5GEFD.png&userId=11733 [2]: http://robertfathauer.com [3]: http://www.segerman.org [4]: http://davidbachman.org [5]: http://robertfathauer.com/ [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-17at12.32.06PM.png&userId=11733 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-17at9.04.03AM.png&userId=11733 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-17at9.05.51AM.png&userId=11733 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sdaf23regaa.png&userId=11733 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=SDF324FGSDALFG.png&userId=11733 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-17at9.16.20AM.png&userId=11733 [12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-17at9.14.50AM.png&userId=11733 [13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=4902ScreenShot2016-10-17at9.19.19AM.png&userId=11733 [14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-17at9.57.56AM.png&userId=11733 [15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-17at9.24.06AM.png&userId=11733 [16]: http://community.wolfram.com//c/portal/getImageAttachment?filename=asdf234tregrafaDFSA.png&userId=11733 [17]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-17at9.26.47AM.png&userId=11733 [18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-17at9.27.47AM.png&userId=11733 [19]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-17at9.29.17AM.png&userId=11733 [20]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-17at9.30.24AM.png&userId=11733 [21]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-17at9.31.52AM.png&userId=11733 [22]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-17at9.33.03AM.png&userId=11733 [23]: http://community.wolfram.com//c/portal/getImageAttachment?filename=SDFSDR43T5GEFD.png&userId=11733 [24]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-17at9.36.09AM.png&userId=11733 [25]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-17at9.40.36AM.png&userId=11733 [26]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-17at9.41.35AM.png&userId=11733 [27]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-17at9.43.29AM.png&userId=11733 [28]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-17at9.44.27AM.png&userId=11733 [29]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2016-10-17at9.45.47AM.png&userId=11733 Bill Gosper 2016-10-17T14:58:50Z https://community.wolfram.com/groups/-/m/t/790393 And here it is: ![solid of constant width on 76 points][1] A [curve of constant width](http://demonstrations.wolfram.com/ArbitraryCurvesOfConstantWidth/), such as the [Reuleaux triangles](http://demonstrations.wolfram.com/CurvesAndSurfacesOfConstantWidth/), can be generated from any polygon. From any point there is another point at distance 1 with no points at a greater distance. In 3D, the problem is much harder. The sphere is a solid of constant width. If spherical curves are added to a tetrahedron, midpoints of opposing edges are at a distance greater than 1 apart. This flaw can be fixed with the special curve-smoothing techniques of the [Meissner tetrahedra](http://demonstrations.wolfram.com/MeissnerTetrahedra/). Several curves of constant width can be the basis of a [solid of revolution](http://demonstrations.wolfram.com/SolidOfRevolution/) to produce a solid of constant width. According to the paper ["On Curves and Surfaces of Constant Width"](http://arxiv.org/abs/1504.06733) by Howard L. Resnikoff, that's pretty much it. His paper introduces a few new possible surfaces, such as this one. SphericalPlot3D[1 + 1/10 Cos[3 t] Sin[3 u] Sin[u]^2, {u, -Pi, Pi}, {t, -Pi, Pi}, Boxed -> False, SphericalRegion -> True, ViewAngle -> Pi/10, ImageSize -> {600, 600}, Mesh -> None, Axes -> False, PlotPoints -> 200] ![Resnikoff surface][2] Is that really a solid of constant width? Let's make a function to find farthest points. FarthestPoints[pts_List, singlepoint_, num_] := SortBy[Complement[pts, Nearest[pts, singlepoint, Length[pts] - num ]], -MyEuclidean[singlepoint, #] &]; Then we generate many points on this surface, and find the point that is farthest away. resni = Flatten[Table[FromSphericalCoordinates[{(1 + 1/10 Cos[3 t] Sin[3 u] Sin[u]^2), u, t}], {u, .001, 3.14, .05}, {t, -3.14, 3.14, .1}], 1]; dists = Monitor[Table[EuclideanDistance[resni[[k]],FarthestPoints[resni,resni[[k]],1][[1]]],{k,1,Length[resni]}],k]; MinMax[dists] {1.99925, 2.07099} Not the desired result. It's close to being a solid of constant width, but not nearly close enough. Eleven months ago, I opened up the discussion [Biggest Little Polyhedra](http://community.wolfram.com/groups/-/m/t/463699), which led to a blog article on [biggest little polyhedra](http://blog.wolfram.com/2015/05/20/biggest-little-polyhedronnew-solutions-in-combinatorial-geometry/), and eventually I improved results and made a Demonstration for [biggest little polyhedra](http://demonstrations.wolfram.com/BiggestLittlePolyhedron/). I've had 1-3 computers steadily improving the results for nearly a year now. In short, you have $n$ points in 3 space, no two more than 1 apart. What is the greatest volume that can be bounded with the $n$ points with unit diameter? The classic solution, widely published, is to use the [Thomson problem](http://demonstrations.wolfram.com/ThomsonProblemSolutions/) solutions, but they are far from optimal. For example, with Thomson, 121 points are needed to bound a volume of 1/2. It turns out that 84 points with diameter 1 will suffice. One feature of the biggest little polyhedra is that they have lots and lots of unit length diagonals. Can they be used to make solids of constant width? With most of my smallest solutions there are problems similar to the trouble the tetrahedron has. There may be Meissner-like methods for fixing the flaws, but I haven't explored that yet. During the long search, I came across the page [Greater Self-Dual Solids](http://dmccooey.com/polyhedra/GreaterSelfDual.html). I especially liked the Self-Dual Icosioctahedron #4, and found that I could make a [caltrop](http://math.stackexchange.com/questions/1602770/any-other-caltrops) out of it, where every vertex was a unit distance from all corners of the opposing face. But it wasn't the optimal way to bound space with 28 points. Extending it to a solid of constant width caused the same sorts of flaws as the tetrahedron. ![28 vertex caltrop][3] I extended that self dual polyhedron to one on 76 points with tetrahedral symmetry. Points 1, 13, 25, 29, 41, and 53 are as follows: {{0.0833`, 0.0833`, 0.4930122817942774`}, (*{C1, C1, C4}*) {0.32530527130128584`, -0.20709494964790603`, 0.32530527130128584`}, (*{C3, -C0, C3}*) {0.28875291001058745`, 0.28875291001058745`, 0.28875291001058745`}, (*{C2, C2, C2}*) {-0.2142`, 0.40369721678726284`, -0.2142`}, (*{-C6, C5, -C6}*) {-0.07272969962634213`, 0.35355339059327373`, -0.35355339059327373`}, (*{-C7, C8, -C8}*) {0.07587339432355446`, 0.44185`, -0.23402687345687453`}} (*{C9, C10, -C11}*) The full vertices are as follows. There is something more elegant using the tetrahedral group, but I haven't gotten to that yet. cal76 ={{C1,C1,C4},{C1,-C1,-C4},{-C1,-C1,C4},{-C1,C1,-C4},{C4,C1,C1},{C4,-C1,-C1},{-C4,-C1,C1},{-C4,C1,-C1},{C1,C4,C1},{C1,-C4,-C1},{-C1,-C4,C1},{-C1,C4,-C1}, {C3,-C0,C3},{C3,C0,-C3},{-C3,C0,C3},{-C3,-C0,-C3},{C3,-C3,C0},{C3,C3,-C0},{-C3,C3,C0},{-C3,-C3,-C0},{C0,-C3,C3},{C0,C3,-C3},{-C0,C3,C3},{-C0,-C3,-C3}, {C2,C2,C2},{C2,-C2,-C2},{-C2,-C2,C2},{-C2,C2,-C2}, {-C6,C5,-C6},{-C6,C6,-C5},{-C5,C6,-C6},{-C6,-C5,C6},{-C6,-C6,C5},{-C5,-C6,C6},{C6,-C5,-C6},{C6,-C6,-C5},{C5,-C6,-C6},{C6,C5,C6},{C6,C6,C5},{C5,C6,C6}, {-C7,C8,-C8},{-C8,C8,-C7},{-C8,C7,-C8},{-C7,-C8,C8},{-C8,-C8,C7},{-C8,-C7,C8},{C7,-C8,-C8},{C8,-C8,-C7},{C8,-C7,-C8},{C7,C8,C8},{C8,C8,C7},{C8,C7,C8}, {C9,C10,-C11},{C9,C11,-C10},{-C10,C11,C9},{-C11,C10,C9},{-C11,-C9,-C10},{-C10,-C9,-C11},{C9,-C10,C11},{C9,-C11,C10},{-C10,-C11,-C9},{-C11,-C10,-C9},{-C11,C9,C10},{-C10,C9,C11},{-C9,-C10,-C11},{-C9,-C11,-C10},{C10,-C11,C9},{C11,-C10,C9},{C11,C9,-C10},{C10,C9,-C11},{-C9,C10,C11},{-C9,C11,C10},{C10,C11,-C9},{C11,C10,-C9},{C11,-C9,C10},{C10,-C9,C11}}; Here's what it looks like with all 150 unit diagonals added. ![caltrop 76 with unit diagonals][4] With the Farthest Point function from earlier, random points at unit distance can be added. For each random point on a sphere, we move it closer or farther from the origin so that the farthest point is at distance 1. The polar opposite is also generated. randomUnitDistancePointPolar[pointset_] := Module[{k},With[{randomspherepoint = .54 coord[{RandomReal[{0,2Pi}],RandomReal[{-1,1}],1}]},{randomspherepoint(k/.Quiet[Solve[{MyEuclidean[k randomspherepoint, FarthestPoints[pointset,randomspherepoint,1][[1]]]==1,0<k<2}]][[1,1]]),(-randomspherepoint)(k/.Quiet[Solve[{MyEuclidean[k (-randomspherepoint), FarthestPoints[pointset,(-randomspherepoint),1][[1]]]==1,0<k<2}]][[1,1]])}]]; Using the 76 points, a lot more points can be added. is76scw = Table[randomUnitDistancePointPolar[cal76], {10000}]; The crucial check -- are any two polar opposites more than 1 apart? Select[is76scw, EuclideanDistance[#[[1]], #[[2]]] > 1 &] There are no flaws. So far as I know, this is the first solid of constant width that has been found with tetrahedral symmetry. To generate the image at the top, use Graphics3D[ConvexHullMesh[Join[cal76,Flatten[is76scw,1]]]["GraphicsComplex"], Boxed-> False, ViewAngle-> Pi/10, ImageSize->{600,600} ] And there you have it, a new solid of constant width. It's also the best known way to bound space with 76 points. Mathematica just needed to make a few trillion calculations, optimizations, and improvements over an eleven month period to find it. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=solid76.jpg&userId=21530 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ResnikoffSurface.jpg&userId=21530 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=caltrop.gif&userId=21530 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=caltrop76unitdiagonals.jpg&userId=21530 Ed Pegg 2016-02-09T21:54:47Z https://community.wolfram.com/groups/-/m/t/2090703 [![enter image description here][1]][2] [![enter image description here][3]][4] &[Wolfram Notebook][5] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=frontback.jpeg&userId=20103 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=frontback.jpeg&userId=20103 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2020-10-07at1.48.05PM.jpg&userId=20103 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2020-10-07at1.48.05PM.jpg&userId=20103 [5]: https://www.wolframcloud.com/obj/0746a0c7-f2fa-4360-a96d-e3adbbed20e8 Galina Filipuk 2020-10-07T18:13:54Z