https://community.wolfram.com RSS Feed for Wolfram Community showing any discussions tagged with Computer-Based Maths sorted by most replies. 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/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/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/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/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/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/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/2098696 deleted David Ameneyro 2020-10-21T05:05:58Z 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/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/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/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/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/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/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/565372 The OECD has just released a [report][1] on the success (or otherwise) of technology in education, at least in terms of PISA results. This report is now being being widely quoted by media. For example, here's a [BBC][2] story on it, and another one from the [Irish Times][3]. The BBC story references a [second BBC story][4] from today, written by OECD Education Director Andreas Schleicher himself. Conrad Wolfram has today responded that the report largely misses the point, which is that computers are being used to teach the wrong subject. You can read his post here: [COMPUTERS IN EDUCATION: GREAT MACHINES, WRONG RESULTS][5] Having read a couple of viewpoints, where do you stand on this issue? [1]: http://www.oecd.org/education/students-computers-and-learning-9789264239555-en.htm [2]: http://www.bbc.com/news/business-34174796 [3]: http://www.irishtimes.com/news/education/lack-of-computers-in-schools-may-be-a-blessing-oecd-report-1.2351683 [4]: http://www.bbc.com/news/business-34174795 [5]: http://www.conradwolfram.com/home/2015/9/15/computers-in-education-great-machines-wrong-results Richard Asher 2015-09-15T16:56:50Z https://community.wolfram.com/groups/-/m/t/2801704 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=Lead_image_1.png&userId=20103 [2]: https://www.wolframcloud.com/obj/bdb1c704-0166-4a89-844c-52935dbafdd7 JOSÉ GUILLERMO SÁNCHEZ LEÓN 2023-01-22T09:08:16Z 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/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/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