https://community.wolfram.com RSS Feed for Wolfram Community showing any discussions tagged with Computer-Based Maths sorted by most viewed. 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/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/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/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/2983903 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=SudokuBlog-heroimage.png&userId=2028758 [2]: https://www.wolframcloud.com/obj/b9ea0b6a-1200-4c69-bd69-1e27edaa0a1b Alejandra Ortiz Duran 2023-08-04T23:54:58Z 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/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/1670775 ##Introduction## You may have noticed that the factorial function for integers generates a lot of trailing zeros at the end e.g. 100! evaluates to 9332621544394415268169923885626670049071596826438162146859296389521759\ 9993229915608941463976156518286253697920827223758251185210916864000000\ 000000000000000000 That's 24 zeros right there. Maybe you would like to figure out how to calculate the exact number for arbitrary input integers? And then maybe for any chosen radix as well i.e. not using the decimal representation? I don't want to spoil the fun for you, so please go chew away at this nice little mathematical diversion. The asymptotic "TZF" function for large integers is really compute-friendly, so for "easy" large integers you will be able to do the algebra just using a simple rule. Well and then it is always possible I have made a mistake, so I include my notebook on this problem for you to compare. Have fun! ![enter image description here][1] In the seventies when I got my first TI pocket calculator in school I developed a certain fascination for the factorial function. It was basically the most dangerous function around because if you entered any integer larger than 69 it would blow up with an error because it could not calculate numbers with more than two digits in the base-10 exponent and for most of them it could of course only show the first few most significant digits. So it took me almost 40 years and the mind-boggling capacity of WL to handle arbitrary-sized integers (well almost) to ask the following question: What is the number of trailing zeros in $n$ factorial? As a short reminder n! is the mathematical notation for the product of all positive integers less or equal to n. As you can easily see from an example there are plenty of trailing zeros in the factorial of reasonably-sized integers: 100! > `9332621544394415268169923885626670049071596826438162146859296389521759\ 9993229915608941463976156518286253697920827223758251185210916864000000\ 000000000000000000` Well to answer the question above we reformulate it as the number of sought zeros is equal to how many times n factorial can be divided (meaning integer division) by ten without getting a remainder. But for getting a factor of 10 there needs to be a corresponding factor of 5 and one factor of 2 in the prime factorization of $n$ factorial. Since every other number contains at least a factor of 2 in its prime factorization we can safely count only the factors of 5 in the factorization of the first n integers so we get a first (very functional and "pattern matchy" way to calculate the trailing zero function TZF: TZF1[n_] := Flatten[FactorInteger[Range[n]] , 1] // Cases[{5, a_} -> a] // Total ListPlot[Table[TZF1[n], {n, 100}], Joined -> True, ImageSize -> Large, PlotRange -> All] ![enter image description here][2] Well it looks pretty step-like with regular intervals so let's plot the differences: ListPlot[Differences[Table[TZF1[n], {n, 100}]], Joined -> True, ImageSize -> Large, PlotRange -> All] ![enter image description here][3] Aha! For each $5^i$ we get i new trailing zeros, but that is then equal to just summing the integer quotients of dividing n by increasing powers of $5^i$. So we have another candidate for the trailing zeros which definitely looks much more procedural: TZF2[n_] := Module[{i = 1, result = 0}, While[5^i <= n, result += Quotient[n, 5^i]; i++]; result] And finally we might always have done a mistake so let's just see how long the last group of digits is for any n larger than 4, which is the brute force way to get the answer: TZF3[n_] := If[n < 5, 0, IntegerDigits[Factorial[n]] // SplitBy[#, 1] & // Part[#, -1] & // Length] m = 150; ListPlot[{Table[TZF1[n], {n, m}], Table[TZF2[n], {n, m}], Table[TZF3[n], {n, m}]}, Joined -> True, ImageSize -> Large, PlotRange -> All] ![enter image description here][4] All well it seems, of course not everything worked out right at first trial, but now that all three seem to coincide, it seems pretty watertight right? So then let's see which form might be most efficient to calculate the TZF function: n = 10000; Timing[TZF1[n]] Timing[TZF2[n]] Timing[TZF3[n]] {0.041059, 2499} {0.000055, 2499} {0.043205, 2499} So you see functional is not always faster unfortunately, but it is also surprising to see that taking the long detour to calculate the whole factorial does equally well roughly as the first variant which only factorizes rather small numbers. But back to the original question we can see that we answer the original question pretty accurately by calculating the TZF function divided by n as a geometric sum: n =.; Sum[1/5^i, {i, 1, \[Infinity]}] > 1/4 So the trailing number of zeros of n factorial is approximately $n/4$ for large n (to be more accurate take one less). So if you get the question at the next party "how many trailing zeros are there in 10000 factorial?" just say "2499 of course"! So what about other radices (plural for radix or base of the integer digit representation)? To find an the answer we have to consider the prime factorization of the radix which then of course can have more (or less) than two prime factors and each with a separate multiplicity to form the radix as a product. So for each of these prime factors of the radix $p^k$ we then have to calculate how many times p appears in the positive integer numbers smaller or equal to n and find the integer quotient when dividing by k. The smallest of these is then our trailing zeros count. TZF4[n_, r_] := Quotient[Total[ Cases[Flatten[FactorInteger[Range[n]] , 1] , {#[[1]], a_} -> a]], #[[2]]] & /@ FactorInteger[r] // Min TZF5[n_, r_] := Module[{f = FactorInteger[r], q = Table[0, Length[FactorInteger[r]]], i, p, q0}, Do[i = 1; p = f[[j, 1]]; q0 = 0; While[p^i <= n, q0 += Quotient[n, p^i]; i++]; q[[j]] = q0 , {j, Length[f]}]; If[Min[q] > 0, Min[Quotient[q, f[[;; , 2]]]], 0] ] TZF6[n_, r_] := IntegerDigits[Factorial[n], r] // SplitBy[#, 1] & // If[Part[#, -1][[1]] == 0, Length[Part[#, -1]], 0] & Let's see if these agree to iron out obvious mistakes by feeding random samples. But beware, the factorial is still dangerous and will exhaust your physical memory if you throw in too big numbers or too small radices. Table[{n = RandomInteger[10000], r = RandomInteger[{5, 30}], TZF4[n, r], TZF5[n, r], TZF6[n, r]}, 10] // TableForm ![enter image description here][5] Table[{n = RandomInteger[10000], TZF1[n], TZF2[n], TZF3[n], TZF4[n, 10], TZF5[n, 10], TZF6[n, 10]}, 10] // TableForm ![enter image description here][6] In order to get asymptotic values of the trailing zeros you now need to divide n by $(p-1) k$. You have to do this only with the prime factor that results in the largest value of $(p-1) k$ of course. Then you round down again and you will be mostly very accurate. So let's do an example: TZF5[10000, 72] > 2498 For radix 72 the prime decomposition is $2^3 3^2$, so again it's a division by four (from the first factor) but now we'd actually would have to subtract 2 to get the right number. If you end up with a tricky radix decomposition for the party trick you might actually have to consult the pocket calculator on your smartphone for the division. To close out I have to confess that I still own a working HP-15C, an icon of computation devices and a testament to solid engineering: Well I am looking forward to the day when we are going to have hardware that durable again and being able to run WL from it. If you liked this piece and want to explore further, why not generalizing the TZF functions above to mixed radix representations or make your own variant of them to optimize code, memory or performance. ![enter image description here][7] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=42551.png&userId=20103 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=65422.png&userId=20103 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=64973.png&userId=20103 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=78994.png&userId=20103 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=54855.png&userId=20103 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=44026.png&userId=20103 [7]: https://community.wolfram.com//c/portal/getImageAttachment?filename=44607.png&userId=20103 Fabian Wenger 2019-04-27T18:17:05Z https://community.wolfram.com/groups/-/m/t/1732367 ## Abstract This project is a visualization of Shephard's conjecture, which states that every convex polyhedron admits a self-nonoverlapping unfolding. The conjecture remains unsolved to this day. Currently, there exists unfolding data for several predefined polyhedra in the Wolfram Language, and my goal is to create a function that can do this for any random convex polyhedron. I chose this project because of my love for origami and art, and my interest in 3D visualization. ## Generating a Graph for Connectivity Between Faces The first step was to create a graph that captures the relationship between faces of the polyhedron so that it could be used later to generate the net. The built-in function DualPolyhedron converts the polyhedron to one where each vertex corresponds to a face on the original. I then extracted the vertices of the dual polyhedron and partitioned and sorted them, allowing me to create a graph using those vertices. polyhedronfacegraph[polyhedron_]:= Block[{dualpolyhedron, vertexlist, vertexpairings, sortedvertices}, dualpolyhedron = DualPolyhedron[polyhedron]; vertexlist = dualpolyhedron[[2]]; vertexpairings = Flatten[Table[Append[ Partition[vertexlist[[n]], 2, 1], {Last[vertexlist[[n]]], First[vertexlist[[n]]]}], {n, 1, Length[vertexlist]}], 1]; sortedvertices = Sort /@ vertexpairings // DeleteDuplicates; Graph[UndirectedEdge@@@sortedvertices,VertexLabels -> "Name"] ] A random polyhedron and the graph of its dual: ![enter image description here][1] ## Generating Spanning Trees I then used the graph to generate different paths in which a polyhedron could unfold. One way to do this is by using a spanning tree, a tree generated from a graph that retains the same amount of vertices while having the minimum amount of edges. This essentially creates a simple version of what the final net should look like. Each vertex represents a face, and connections between them signify that they are adjacent. It is important to note that not every spanning tree will correspond to a non-overlapping net, which is why I generate a spanning tree from every possible vertex. generatetrees[graph_] := Table[FindSpanningTree[{graph, n}], {n, 1, VertexCount[graph]}] Five of the spanning trees of the previous polyhedron: ![enter image description here][2] ## Generating Net Coordinates To create the net of the polyhedron, I had to implement an unfolding algorithm. My first approach was to extract each face individually, but that ended up complicating the transformations. My final algorithm consisted of applying one transformation to move one face to the xy plane, then unfolding using connections between vertices from the spanning tree. I first created a function to find the normal vector to a plane using the cross product. normvector[coords_] := Cross[coords[[2]] - coords[[1]], coords[[3]] - coords[[1]]]; I then use transformation matrices so that one face is lying on the xy plane, and convert the new mesh into a list of its primitives. The next step is to begin unfolding the polyhedron from its bottom face using the list of spanning trees. To perform an algorithm on each step of the unfolding process, I use the function BreadthFirstScan, which can call the unfold function (discussed next) whenever a new vertex is reached. Finally, the function returns a list of coordinates of the completed net. generatenetcoords[mesh_, tree_]:= Block[{transformations, transformedmesh, meshlist, transformedmeshlist, normals, polygonfaces, transformedrotation}, polygonfaces = Reap[ meshlist = MeshPrimitives[mesh, 2][[All, 1]]; transformations = RotationTransform[{normvector[meshlist[[1]]], {0, 0, -1}}] @* TranslationTransform[-PropertyValue[{mesh, {2, 1}}, MeshCellCentroid]]; transformedmesh = TransformedRegion[mesh, transformations]; transformedmeshlist = MeshPrimitives[transformedmesh, 2][[All, 1]]; normals = normvector[#] &/@ transformedmeshlist; Sow[transformedmeshlist[[1]], "flat"]; transformedrotation[1] = TransformationFunction[IdentityMatrix[4]]; BreadthFirstScan[tree, 1, "DiscoverVertex" -> unfold[transformedmeshlist, normals, transformedrotation]];, {"flat"}][[-1, All, 1]]; Chop[polygonfaces] ] The unfold function operates by finding the intersection of two polygons, calculating the angle between them, and applying transformations using normal vectors to unfold the face. The function returns coordinates of the transformed polygons. unfold[meshlist_, normals_, transformedrotation_][u_, v_, _] /; (u =!= v) := Block[{edgecoord1, edgecoord2, angle, rotation}, {edgecoord1, edgecoord2} = Intersection @@ meshlist[[{u, v}]]; angle = DihedralAngle[{edgecoord1, edgecoord2}, normals[[{u, v}]]]; rotation = RotationTransform[angle, edgecoord2 - edgecoord1, Mean[{edgecoord1, edgecoord2}]]; transformedrotation[u] = transformedrotation[v] @* rotation; Sow[transformedrotation[u] @ meshlist[[u]], "flat"]; ] ## Generating Possible Nets Finally, we put all the functions together. The program iterates through every spanning tree to produce nets using netcoordinates. The third element of each coordinate is deleted to convert the net to 2D. Each net is then tested for overlap by calculating the surface area of the original polyhedron and comparing it to the surface area of the net. Only nets where the two surface areas are equal are appended to the list that is returned. generateallnets[polyhedron_] := Block[{netcoords, trees, graph, mesh, surfacearea, netsurfacearea, goodnets}, mesh = BoundaryDiscretizeGraphics[polyhedron]; graph = polyhedronfacegraph[polyhedron]; trees = generatetrees[graph]; goodnets = {}; Table[ netcoords = First@generatenetcoords[mesh, trees[[treeposition]]]; netcoords = Table[Delete[netcoords[[n, m]], {3}], {n, 1, Length[netcoords]}, {m, 1, 3}]; surfacearea = SurfaceArea[polyhedron]; netsurfacearea = RegionMeasure[RegionUnion[Polygon /@ netcoords]]; If[surfacearea == netsurfacearea, AppendTo[goodnets, Graphics[{Hue[0.94, 0.22, 1.], EdgeForm[{Thin, Pink}], Polygon /@ netcoords}]] ];, {treeposition, 1, Length[trees]} ]; Row[{Graphics3D[polyhedron], goodnets}] ] ## Outputs Upon taking a polyhedron object in as its argument, the final output of the function is a 3D graphic of the original polyhedron and a list of all possible nets. <br> <br> An output of a random polyhedron: ![enter image description here][3] ## Summary With the help of my mentor, I was able to create a program that creates non-overlapping nets for random polyhedra. The process consisted of extracting graphs, creating spanning trees, generating nets, and checking for overlap. The function returns several successful results for every random polyhedron that I tested, although the program does run quite slowly for polyhedra with high numbers of faces, as the complexity of the graph and number of spanning trees increase drastically as the number of faces increase. From this project, I acquired knowledge of many aspects of three-dimensional modeling and geometric transformations, and I hope to work on extensions of this project in the future. ## Future Work A possible extension would be applying a similar algorithm to non-convex polyhedra and showing that it is impossible to generate a non-overlapping net in some cases. Additionally, optimization algorithms could also be implemented to speed up the unfolding process. For example, another function could also be created to generate the first net that is valid, which would greatly increase speed if only one net is desired. ## Acknowledgements I would like to sincerely thank my mentor, Jeremy Stratton-Smith, for providing invaluable advice and help throughout the entire project process. I would also like to thank Chip Hurst for his unfolding algorithm and tips for 3D transformations. Lastly, I would like to thank the Wolfram Summer Camp team for providing me with this opportunity to pursue a project of my choice. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=polygraph.PNG&userId=1622104 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=graphs.PNG&userId=1622104 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=image.PNG&userId=1622104 Sunny Wang 2019-07-12T01:09:08Z 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/1732406 # Introduction ---------- ## What Are Polycubes? Polyomino tiles are 2-D tiles formed from a set of *n* square tiles. In this project I worked with polycubes, their 3-D cousins, which are composed of cubes as opposed to squares. They look something like this: ![8-cube polycube][1] My goal over the course of this project was to enumerate complete sets of polycubes. That is, given *n* cubes, I wanted to be able to generate a list of every possible arrangement, and a count of how many exist. # Methods ---------- ## Basic Functionality __Representing Polycubes Internally__: A 'polycube' as represented in my code is simply a list of points in 3-D space where cubes should be placed. For example, a 1 x 1 x 2 polycube (*n* = 2) can be represented as {{1, 1, 1}, {1, 1, 2}}. These points can be converted into 3-D sparse arrays (3rd order tensors), where 1s represent cubes and 0s represent empty space. __Rendering__: For debugging purposes, it's difficult to look at lists of numbers and determine whether or not your code is working. Looking at nice graphical representations is both easier and a lot more satisfying. So this: {{1, 1, 1}, {1, 2, 1}, {1, 3, 1}, {1, 2, 2}} Becomes this: ![rendered polycube][2] ## Processing __Checking Connections__: In order to be considered a valid polycube, all cubes in the form must be connected. To ensure all returned polycubes were valid, I implemented a helper function: *valid\[pc\]*. This function selects one cube from the polycube as a start block, and ensures that every other block in the form can in some way be connected back to that initial block. Every time the function finds a block that has a neighbor already included in the 'valid' chunk of blocks, that block and its neighbors are 'validated'. If all blocks can be 'validated', the form itself is a 'valid' polycube. __Removing Duplicates__: This was one of the most challenging parts of my project, as there are so many factors to account for when removing duplicates. I ended up dividing the work into two functions. The first is something called *relocate*, which moves a polycube on my coordinate system so it is pressed up against the edges of a box located at {*n*, *n*, *n*}. By doing this, I make certain that any similarly structured and oriented polycubes will look the same if compared. For example, the structures {{1, 1, 1}, {1, 1, 2}} and {{1, 1, 2}, {1, 1, 3}} are the same, but they would not be considered duplicates at a computer since they're at different positions. In such a scenario, *relocate* could move the second structure -1 in the z axis, after which they could be considered identical. The second function is *rotate*, and is used by my program to generate rotations of polycubes (in increments of 90 degrees) by multiplying each point on the polycube by a rotation matrix. (* Rotation Matrices *) xrot[\[Theta]_] := {{1, 0, 0}, {0, Cos[\[Theta]], -Sin[\[Theta]]}, {0, Sin[\[Theta]], Cos[\[Theta]]}} yrot[\[Theta]_] := {{Cos[\[Theta]], 0, Sin[\[Theta]]}, {0, 1, 0}, {-Sin[\[Theta]], 0, Cos[\[Theta]]}} zrot[\[Theta]_] := {{Cos[\[Theta]], -Sin[\[Theta]], 0}, {Sin[\[Theta]], Cos[\[Theta]], 0}, {0, 0, 1}} (* Rotate a polycube about the a axis by \[Theta] degrees *) (* NOTE: x = 1 | y = 2 | z = 3 *) rotate[pc_, axis_, \[Theta]_] := Dot[{xrot, yrot, zrot}[[axis]][\[Theta]], #] & /@ pc ## Complete Search The first step was to produce a 'minimum viable product', something that could technically complete the task, and would be fast to implement. This allowed me to quickly develop and test a way to find and remove duplicates, without worrying about runtime optimizations. Below is the function I wrote to generate polycube sets through a complete search of possibilities in *n* x *n* x *n* space. polycubeSet[n_Integer] := Block[{allPoints, final, res}, allPoints = Table[{x, y, z}, {x, n}, {y, n}, {z, n}] // Flatten[#, 2] &; final = Select[(Sort /@ Permutations[allPoints, {n}]) // DeleteDuplicates, valid[#] &]; res = (relocate /@ final) // DeleteDuplicates // unique; Print[Style["COUNT \[DoubleRightArrow] ", Bold], Length@res]; res ] The above code generates all permutations of *n* points within the space, and tests each one for uniqueness and validity. With this method, I was only able to generate polycube sets up to *n* = 3 cubes. ![3-cube set][3] ## Confined Boxes Search While examining the shapes of the polycubes I was generating, I noticed that every polycube generated for a certain *n* could be fit inside a box of dimensions that summed to no more than *n* + 2. For example, the dimensions of a box containing an *n* = 3 polycube could be 1 x 1 x 3 or 1 x 2 x 2. In order to use this information to my advantage, I wrote a function that would generate a list of valid boxes, and then run a complete search within each of them. polycubeBoxSet[n_] := Block[{grids, res, set}, grids = Sort /@ Select[ Permutations[Join[Range[n], Range[n], Range[n]], {3}], Total[#] == (n + 2) &] // DeleteDuplicates; set = ((gridSet[#, n] & /@ grids) // Flatten[#, 1] &) // removeDuplicates; res = Select[set, valid[#] &]; Print[Style["COUNT \[DoubleRightArrow] ", Bold], Length@res]; res ] gridSet[grid_, n_] := Block[{pts, pcs}, pts = Table[{x, y, z}, {x, grid[[1]]}, {y, grid[[2]]}, {z, grid[[3]]}] // Flatten[#, 2] &; (relocate /@ Permutations[pts, {n}]) // DeleteDuplicates ] A confined search proved to be much faster than a complete search, and allowed me to generate polycube sets up to *n* = 5 cubes. ![5-cube set][4] ## Exploration Search My final attempt (for now) is a method that works by processing structures in 'generations'. The function generates a complete set for each *n* up to the desired value, and then proceeds to the next set by returning every form that can be obtained by adding one cube to any open location. Since the structures are built upon each other, this approach removes the need to check whether or not all cubes are connected in a given polycube. polycubeExploreSet[n_] := Block[{new, pt, res}, new = res = {{{n, n, n}}};(* Allow building on all faces *) While[Length@First@res < n, new = Sort /@ relocate /@ (explore /@ res // Flatten[#, 1] &) // DeleteDuplicates // unique; res = relocate[#, 2] & /@ new; ]; Print[Style["COUNT \[DoubleRightArrow] ", Bold], Length@res]; res ] explore[pc_] := Block[{t}, t = generateTensor[pc, Max@*Flatten@pc + 1]; Join[pc, {#}] & /@ (openConnections[#, t] & /@ pc // DeleteDuplicates // Flatten[#, 1] &) ] By cutting out the processing of extra possibilities, this approach managed to generate much larger sets (up to *n* = 8, a set of 6922 distinct polycubes). Below are some of my favorites... ![Some 8-cube polycubes][5] ![Some 8-cube polycubes][6] ![Some 8-cube polycubes][7] ![Some 8-cube polycubes][8] ---------- # Results The number of distinct polycubes possible for *n* cubes. ![Table of results because Wolfram Community uses fake markdown][9] ---------- # Notebook The notebook containing my results can be found [HERE][10]. [1]: https://github.com/noelle-crawfish/Enumerating-Polycubes/blob/master/Wolfram%20Community%20Post/images/8cube.png?raw=true [2]: https://github.com/noelle-crawfish/Enumerating-Polycubes/blob/master/Wolfram%20Community%20Post/images/4omino.png?raw=true [3]: https://github.com/noelle-crawfish/Enumerating-Polycubes/blob/master/Wolfram%20Community%20Post/images/3cube.png?raw=true [4]: https://github.com/noelle-crawfish/Enumerating-Polycubes/blob/master/Wolfram%20Community%20Post/images/5cubes.png?raw=true [5]: https://github.com/noelle-crawfish/Enumerating-Polycubes/blob/master/Wolfram%20Community%20Post/images/8cubes1.png?raw=true [6]: https://github.com/noelle-crawfish/Enumerating-Polycubes/blob/master/Wolfram%20Community%20Post/images/8cubes2.png?raw=true [7]: https://github.com/noelle-crawfish/Enumerating-Polycubes/blob/master/Wolfram%20Community%20Post/images/8cubes3.png?raw=true [8]: https://github.com/noelle-crawfish/Enumerating-Polycubes/blob/master/Wolfram%20Community%20Post/images/8cubes4.png?raw=true [9]: https://github.com/noelle-crawfish/Enumerating-Polycubes/blob/master/Wolfram%20Community%20Post/images/polycube_table.png?raw=true [10]: https://github.com/noelle-crawfish/Enumerating-Polycubes Noelle Crawford 2019-07-11T23:36:19Z 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/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/188120 Hi everyone! Just wanted to let you know that Wolfram will be hosting a FREE Virtual Conference for STEM Education January 28th. During the conference there are two tracks to choose from, one dedicated to amplifying your current classroom and the other focused on fortifying your curriculum with new technologies. Our virtual conference interface lets you join talks from either track. We'll also be talking about products that haven't even been released yet! You have to come and check it out! Use this thread for: [list] [*]questions that you have about the conference [*]comments about Wolfram tech in education [*]questions for the conference's Q&A [*]follow-up questions to the conference [/list]If your questions didn't get answered during the Q&A, post it here and get it answered by the presenters! We'll be monitoring the thread. To see the full schedule and to register for the event, visit the [url=http://www.wolfram.com/events/virtual-conference/stem-education-jan-2014/]conference page[/url]. Can't wait to see you all there! [url=http://www.wolfram.com/events/virtual-conference/stem-education-jan-2014/][img=width: 663px; height: 153px;]/c/portal/getImageAttachment?filename=stem2014.png&userId=21124[/img][/url] Adriana O'Brien 2014-01-20T18:42:47Z https://community.wolfram.com/groups/-/m/t/58027 In order to contextualize the question, let us first examine some examples.  Function Nest is useful to generate the multiple compositions of a given function: [mcode] NestList[f, x, 5] {x, f[x], f[f[x]], f[f[f[x]]], f[f[f[f[x]]]], f[f[f[f[f[x]]]]]} [/mcode] For instance, if  f (x) = 2 x + 1 [mcode] Simplify[NestList[2 # + 1 &, x, 5]] {x, 1 + 2 x, 3 + 4 x, 7 + 8 x, 15 + 16 x, 31 + 32 x} [/mcode] Given the equation f (f (x)) = a x + b, with a > 0 its solution can be readily verified  to be: [mcode] Simplify[Sqrt[a] x + b/(1 + Sqrt[a]) /. x -> Sqrt[a] x + b/(1 + Sqrt[a])] b + a x [/mcode] or alternatively : [mcode] Simplify[Nest[Sqrt[a] # + b/(1 + Sqrt[a]) &, x, 2], a > 0] b + a x [/mcode] To obtain the solution to f (f (f (x))) = a x + b we use Reduce [mcode] Reduce[Nest[c # + d &, x, 3] == a x + b, {x}] [/mcode] [img=width: 454px; height: 46px;]/c/portal/getImageAttachment?filename=pic032.png&userId=57966[/img] and verify the answer [mcode] FullSimplify[  Nest[(Power[a, (3)^-1] # + b/(      1 + Power[a, (3)^-1] + Power[a^2, (3)^-1])) &, x, 3], a > 0] b + a x [/mcode] Now let us consider quadratic equations. Consider solving the equation f (f (x)) = x^2. Martin Gardner solved it a while ago but do not look it up!.  It would be worthwhile the time you spend in trying to solve it. After you have solved it, consider now the equation f (f (x)) = x^2 + 1. How can we solve it? Do we need to consider the complex domain, that is f (f (z)) = z^2 + 1? Do we have to resort to numerical methods, at least to have an idea of what it looks like? If so, I would still be interested. Jaime Rangel-Mondragon 2013-07-15T05:29:14Z 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/210810 Hello Community, I have been constructing a set of tutorial notebooks for teaching materials science. Students are given some material and programming assignments. I've trying create a method to pace the students' progress through the notebook--[i]I'd like them to stop and think before they can proceed[/i]. Here is a simplified example of a modal multiple choice interface:[mcode]DialogInput[ Column[{ "What is 3 times 2?", TabView[{3 -> Tooltip["Wrong", "Oh you are just being silly"], Exp[3] -> "Wrong", 6 -> DefaultButton["Correct", DialogReturn[True]], Cos[Pi/6] -> "Note quite", "VI" -> DefaultButton["Tu sunt rectam, sed asinus sapien.", DialogReturn[True], ImageSize -> Full]}, None] } ], Modal -> True];[/mcode] Note modal is not a supported option for DialogInput, but it works anyways. In the ultimate version, the DefaultButton would programmatically open subsequent cells that will allow the students to proceed (I've seen a thread someplace that shows how to do this, but can't find it now). Here is where I am stuck: I'd like to embed this a button in the tutorial notebook.  This is the functionality that I'd like to have, but it hangs and complains about a Dynamic which doesn't evaluate (I don't see a Dynamic, but perhaps ToolTip invokes one). Here is an example, but [b]warning[/b], if you evaluate the following you will have to try to abort the process 3 times. [mcode]Button["Press Here to Continue", DialogInput[ Column[{ "What is 3 times 2?", TabView[{3 -> Tooltip["Wrong", "Oh you are just being silly"], Exp[3] -> "Wrong", 6 -> DefaultButton["Correct", DialogReturn[True]], Cos[Pi/6] -> "Note quite", "VI" -> DefaultButton["Tu sunt rectam, sed asinus sapien.", DialogReturn[True], ImageSize -> Full]}, None] } ], Modal -> True]; ][/mcode] Can anyone see a way to acheive my multiple choice blocking dialog?  (And, if you could see a way for cumulative progress to be related to an instructor, that would be terrific.) WCC W. Craig Carter 2014-03-02T17:41:29Z https://community.wolfram.com/groups/-/m/t/1491903 The [Algorithmic Information Dynamics course][1] promoted and distributed by the Santa Fe Institute is coming to an end. Sponsored by Wolfram Research, the course students made heavy use of the **Wolfram Language** to follow lectures, read, write and share code from the cloud. This has been an enriching experience for both instructors and students and people may want to share their thoughts about it. [![enter image description here][2]][1] ### **About the Course:** Probability and statistics have long helped scientists make sense of data about the natural world — to find meaningful signals in the noise. But classical statistics prove a little threadbare in today’s landscape of large datasets, which are driving new insights in disciplines ranging from biology to ecology to economics. It's as true in biology, with the advent of genome sequencing, as it is in astronomy, with telescope surveys charting the entire sky. The data have changed. Maybe it's time our data analysis tools did, too. During this three-month online course, starting June 11th, instructors Hector Zenil and Narsis Kiani will introduce students to concepts from the exciting new field of Algorithm Information Dynamics to search for solutions to fundamental questions about causality — that is, why a particular set of circumstances lead to a particular outcome. Algorithmic Information Dynamics (or Algorithmic Dynamics in short) is a new type of discrete calculus based on computer programming to study causation by generating mechanistic models to help find first principles of physical phenomena building up the next generation of machine learning. The course covers key aspects from graph theory and network science, information theory, dynamical systems and algorithmic complexity. It will venture into ongoing research in fundamental science and its applications to behavioral, evolutionary and molecular biology. [1]: https://www.complexityexplorer.org/courses/63-algorithmic-information-dynamics-a-computational-approach-to-causality-and-living-systems-from-networks-to-cells [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-10-10at4.41.08PM.png&userId=20103 Hector Zenil 2018-10-03T09:15:56Z https://community.wolfram.com/groups/-/m/t/833173 After reading about [this article][1] on testing the educational benefits of chess, I was wondering what would constitute a decent experiment for the benefits of learning [Wolfram Language][2]? Certainly there is a lot of common sense behind [Wolfram's educational initiatives][3] and [Computer based maths][4]. Teach some useful skills with powerful software, possibly even in place of traditional mathematical education. Among the range of alternatives to traditional education the possibility here is positive. More fun than memorizing facts and logical rules. One could just drop math altogether, but instead this is a way to still do math, just in a modern sort of way. I am not alone with anecdotal evidence that learning Wolfram language can make you smarter. I've seen a high school dropout who did not know the line-slope formula (or any formula) pick up Wolfram Language and become very productive. But how could one measure it? It would seem wrong to measure something like the learning of formulas that the student no longer needs to learn. [The article by Sala and Gobet][5] offers perhaps a bit of caution comes from its observation that the improvements might not be as great as other things, like learning music. [1]: http://www.sciencedirect.com/science/article/pii/S1747938X16300112 [2]: http://www.wolfram.com/language/ [3]: http://www.wolfram.com/education/ [4]: http://computerbasedmath.org/ [5]: http://www.sciencedirect.com/science/article/pii/S1747938X16300112 Todd Rowland 2016-04-04T00:52:19Z https://community.wolfram.com/groups/-/m/t/2981266 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=timsqueen.png&userId=20103 [2]: https://www.wolframcloud.com/obj/04ecc5b1-5827-48ad-ad72-2f02dd8e2547 Alejandra Ortiz Duran 2023-08-01T21:56:03Z