https://community.wolfram.com RSS Feed for Wolfram Community showing ideas tagged with Geometry sorted by most replies. https://community.wolfram.com/groups/-/m/t/2593151 **Introducing our brand new YouTube channel, [Wolfram R&D][1]! Our channel features livestreams, behind-the-scenes creator presentations, insider videos, and more.** ---------- Join us for the unique Wolfram R&D livestreams on [Twitch][2] and [YouTube][3] led by our developers! You will see **LIVE** stream indicators on these channels on the dates listed below. The live streams provide tutorials and behind the scenes look at Mathematica and the Wolfram Language directly from developers. Join our livestreams every Wednesday at 11 AM CST and interact with developers who work on data science, machine learning, image processing, visualization, geometry, and other areas. ---------- ⭕ **UPCOMING** EVENTS - Jan 29 -- Reinforcement Learning Applied to Feedback Control with [Suba Thomas][61] ---------- ✅ **PAST** EVENTS - April 24 -- [FeynCalc][60] - April 3 -- [Explore the Total Solar Eclipse of April 2024][59] - Mar 22 -- [20 Years of xAct Tensor Computer Algebra][58] - Feb 28 -- [Zero Knowledge Authentication][57] - Jan 17 -- [Nutrients by the Numbers][56] - Dec 13 -- [Understanding Graphics][55] - Oct 18 -- [Overview of Number Theory][54] - Sep 27 -- [QMRITools: Processing Quantitative MRI Data][52] - Sep 13 -- [Make High Quality Graph Visualization][51] - Sep 6 -- [Insider's View of Graphs & Networks][53] - Aug 30 -- [Labeling Everywhere][49] - Aug 22 -- [Equation Generator for Equation-of-Motion Coupled Cluster Assisted by CAS][48] - Aug 16 -- [Foreign Function Interface][4] - July 26 -- [Modeling Fluid Circuits][6] - July 19 -- [Geocomputation][5] - July 5 -- [Protein Visualization][7] - Jun 14 -- [Chat Notebooks bring the power of Notebooks to LLMs][8] - May 31-- [Probability and Statistics: Random Sampling][9] - May 24 -- [Problem Solving][10] - May 17 -- [The state of Optimization][11] - May 10 -- [Building a video game with Wolfram notebooks][12] - April 26 -- [Control Systems: An Overview][13] - April 19 -- [MaXrd: A crystallography package developed for research support][14] - April 5th -- [Relational database in the Wolfram Language][15] - Mar 29th -- [Build your first game in the Wolfram Language with Unity game engine] [16] - Mar 22nd -- [Everything to know about Mellin-Barnes Integrals - Part II][17] - Mar 15th -- [Building your own Shakespearean GPT - a ChatGPT like GPT model][18] - Mar 8th -- [Understand Time, Date and Calendars][19] - Mar 1st -- [Introducing Astro Computation][20] - Feb 22nd -- [Latest features in System Modeler][21] - Feb 15th -- [Everything to know about Mellin-Barnes Integrals][22] - Feb 8th -- [Dive into Video Processing][23] - Feb 1st -- [PDE Modeling][24] - Jan. 25th -- [Ask Integration Questions to Oleg Marichev][25] - Jan. 18th -- [My Developer Tools][26] - Jan. 11th -- [Principles of Dynamic Interfaces][27] - Dec. 14th -- [Wolfram Resource System: Repositories & Archives][28] - Dec. 7th -- [Inner Workings of ImageStitch: Image Registration, Projection and Blending][29] - Nov. 30th -- [Q&A for Calculus and Algebra][30] - Nov. 23rd -- [xAct: Efficient Tensor Computer Algebra][31] - Nov. 16th -- [Latest in Machine Learning][32] - Nov. 9th -- [Computational Geology][33] - Nov. 2nd -- [Behind the Scenes at the Wolfram Technology Conference 2022][34] - Oct 26th -- [Group Theory Package (GTPack) and Symmetry Principles in Condensed Matter][35] - Oct 12th -- [Tree Representation for XML, JSON and Symbolic Expressions][36] - Oct. 5th -- [A Computational Exploration of Alcoholic Beverages][37] - Sept. 28th -- [Q&A with Visualization & Graphics Developers][38] - Sept. 14th -- [Paclet Development][39] - Sept. 7th -- [Overview of Chemistry][40] - Aug. 24th -- [Dive into Visualization][41] - Aug. 17th -- [Latest in Graphics & Shaders][42] - Aug. 10th -- [What's new in Calculus & Algebra][43] > **What are your interests? Leave a comment here on this post to share your favorite topic suggestions for our livestreams.** **Follow us on our live broadcasting channels [Twitch][44] and [YouTube][45] and for the up-to-date announcements on our social media: [Facebook][46] and [Twitter][47].** [1]: https://wolfr.am/1eatWLcDA [2]: https://www.twitch.tv/wolfram [3]: https://wolfr.am/1eatWLcDA [4]: https://www.youtube.com/watch?v=C82NHpy7D6k [5]: https://community.wolfram.com/groups/-/m/t/2985580 [6]: https://community.wolfram.com/groups/-/m/t/2982197 [7]: https://community.wolfram.com/groups/-/m/t/2982114 [8]: https://youtu.be/ZqawtrWwE0c [9]: https://community.wolfram.com/groups/-/m/t/2946101 [10]: https://community.wolfram.com/groups/-/m/t/2925156 [11]: https://community.wolfram.com/groups/-/m/t/2921756 [12]: https://community.wolfram.com/groups/-/m/t/2918746 [13]: https://community.wolfram.com/groups/-/m/t/2917597 [14]: https://community.wolfram.com/groups/-/m/t/2911327 [15]: https://community.wolfram.com/groups/-/m/t/2907390 [16]: https://community.wolfram.com/groups/-/m/t/2921593 [17]: https://community.wolfram.com/groups/-/m/t/2861119 [18]: https://community.wolfram.com/groups/-/m/t/2847286 [19]: https://community.wolfram.com/groups/-/m/t/2851575 [20]: https://community.wolfram.com/groups/-/m/t/2852934 [21]: https://community.wolfram.com/groups/-/m/t/2842136 [22]: https://community.wolfram.com/groups/-/m/t/2838335 [23]: https://community.wolfram.com/groups/-/m/t/2827166 [24]: https://community.wolfram.com/groups/-/m/t/2823264 [25]: https://community.wolfram.com/groups/-/m/t/2821053 [26]: https://youtu.be/istKGqpDUsw [27]: https://community.wolfram.com/groups/-/m/t/2777853 [28]: https://youtu.be/roCkXVkDuLA [29]: https://youtu.be/pYHAz-NatXI [30]: https://youtu.be/r7Hjdr_D7c4 [31]: https://community.wolfram.com/groups/-/m/t/2713818 [32]: https://community.wolfram.com/groups/-/m/t/2705779 [33]: https://community.wolfram.com/groups/-/m/t/2701172 [34]: https://youtu.be/UrM-OBu3H9o [35]: https://community.wolfram.com/groups/-/m/t/2678940 [36]: https://community.wolfram.com/groups/-/m/t/2649407 [37]: https://community.wolfram.com/groups/-/m/t/2635049 [38]: https://community.wolfram.com/groups/-/m/t/2618033 [39]: https://community.wolfram.com/groups/-/m/t/2616863 [40]: https://community.wolfram.com/groups/-/m/t/2613617 [41]: https://community.wolfram.com/groups/-/m/t/2605432 [42]: https://community.wolfram.com/groups/-/m/t/2600997 [43]: https://community.wolfram.com/groups/-/m/t/2596451 [44]: https://www.twitch.tv/wolfram [45]: https://wolfr.am/1eatWLcDA [46]: https://www.facebook.com/wolframresearch [47]: https://twitter.com/WolframResearch [48]: https://www.youtube.com/live/ElP55ZILxPw?si=nsAPOQ3u-RbvuGKX [49]: https://community.wolfram.com/groups/-/m/t/3007543 [50]: https://community.wolfram.com/web/charlesp [51]: https://community.wolfram.com/groups/-/m/t/3019288 [52]: https://www.youtube.com/live/KM1yWHRrF2k?si=g2R7rHB2IinVRpo6 [53]: https://community.wolfram.com/groups/-/m/t/3009184 [54]: https://community.wolfram.com/groups/-/m/t/3064700 [55]: https://community.wolfram.com/groups/-/m/t/3084291 [56]: https://community.wolfram.com/groups/-/m/t/3104670 [57]: https://community.wolfram.com/groups/-/m/t/3164204 [58]: https://youtube.com/playlist?list=PLdIcYTEZ4S8TSEk7YmJMvyECtF-KA1SQ2&si=paXZHs0ZzGdB7y1y [59]: https://youtube.com/playlist?list=PLdIcYTEZ4S8RyjEB7JSAsGerbYHl5xXeJ&si=xkNtkIDvKHFWHVmD [60]: https://youtu.be/KUWK19Gx2LE?si=qbKISbL8FtvweSWo [61]: https://community.wolfram.com/web/subat Charles Pooh 2022-08-05T21:37:19Z https://community.wolfram.com/groups/-/m/t/463699 The [biggest little polygon][1] is the *n*-gon with maximum diameter 1 that has the greatest volume. I've often wondered the same problem about polyhedra, and posted a [biggest little polyhedron][2] question on StackExchange, where it got no answers. *Mathematica* 10 has Volume[] and ConvexHullMesh[]. Calculating the volume of the convex hull of 20 random points is as simple as Volume[ConvexHullMesh[RandomReal[{-1, 1}, {20, 3}]]] so I decided to solve the problem myself. First, I used some code like the below to find the solution randomly, with a bit of anealling. numpts = 5; maxvol = .05; count = 0; div = 1; pts = RandomReal[{-1, 1}, {numpts, 3}]; Monitor[Do[ kk = RandomReal[{-1, 1}, {numpts, 3}]/div + pts; maxlen = Max[EuclideanDistance[#[[1]], #[[2]]] & /@ Subsets[kk, {2}]]; vol = Volume[ConvexHullMesh[kk/maxlen]]; If[vol > maxvol, count = 0; maxvol = vol; pts = kk/maxlen, count = count + 1]; If[count > 1000, count = 0; div = 1.3 div; Print[{maxvol, pts}]], {gg, 1, 100000}], {count, maxvol, pts}] The best solution for 4 points is the regular tetrahedron with edge lengths 1. The best solutions I could find for 5 through 12 points were considerably stranger. Red lines indicate a distance of 1. Volumes appear underneath. ![biggest little polyhedra][3] Most of these solutions could doubtlessly be improved or made more exact. If anyone can provide any improvements, please post them. [1]: http://mathworld.wolfram.com/BiggestLittlePolygon.html "biggest little polygon" [2]: http://math.stackexchange.com/questions/434002/biggest-little-polyhedron "biggest little polyhedron" [3]: /c/portal/getImageAttachment?filename=10774biggestlittlepolyhedron.jpg&userId=21530 Ed Pegg 2015-03-20T20:16:46Z https://community.wolfram.com/groups/-/m/t/813449 ![enter image description here][1] The other day I was thinking, could I make a certain plot in Lego? Well, Let's start at the start and make a simple n*m lego-brick. The basic measurements are: brickstyle=Sequence[Red,EdgeForm[AbsoluteThickness[1]]]; gropts=Sequence[Boxed->False,ViewVector->(10{2.4, -1.3, 2.}),ViewAngle->8*Degree]; dims={dimx,dimy,dimz}={8.0,8.0,9.6}/8; (* size of a unit cell in lego-world *) knobd=4.8/8; (* knob diameter *) knobh=1.8/8; (* knob height *) botdi=4.8/8; (* bottom pillar inner diameter*) botdo=6.51/8; (* bottom pillar outer diameter*) wall=1.2/8; (* wall thickness*) thickness=1.0/8; (* top thickness *) And here a function that will make simple brick: ClearAll[DrawLego] DrawLego[{nx_Integer,ny_Integer,nz_Integer:1},detailed:(True|False|None):True]:=Module[{ptsout,ptsin,sides,bottom,rimi,rimo,knobs,knobs2}, ptsout=Tuples[{{0,0,0},{nx,ny,nz}dims}\[Transpose]]; ptsin=Tuples[{{wall,wall,0},{nx,ny,nz}dims-{wall,wall,thickness}}\[Transpose]]; sides=If[BooleanQ[detailed],If[TrueQ[detailed],{ptsin,ptsout},{ptsout}],{ptsout}]; sides=GraphicsComplex[#,{Polygon[{1,2,6,5}],Polygon[{3,4,8,7}],Polygon[{1,2,4,3}],Polygon[{5,6,8,7}],Polygon[{2,4,8,6}]}]&/@sides; If[TrueQ[detailed], ptsout=Tuples[{{0,0,0},{nx,ny,0}dims}\[Transpose]]; ptsin=Tuples[{{wall,wall,0},{nx,ny,nz}dims-{wall,wall,thickness}}\[Transpose]]; rimo=ptsout[[1;;;;2]][[{1,3,4,2}]]; rimi=ptsin[[1;;;;2]][[{1,3,4,2}]]; rimo=Partition[rimo,2,1,1]; rimi=Partition[rimi,2,1,1]; bottom=MapThread[Polygon[#1~Join~Reverse[#2]]&,{rimo,rimi}]; ]; If[BooleanQ[detailed], knobs=Tuples[Range[1,#]&/@({nx,ny})]-1/2; knobs=Cylinder[{Append[#{dimx,dimy},nz dimz],Append[#{dimx,dimy},nz dimz+knobh]}&/@knobs,knobd/2]; ]; If[TrueQ[detailed], knobs2=Tuples[Range[1,#]&/@({nx,ny}-1)]; knobs2=Tube[{Append[#{dimx,dimy},0],Append[#{dimx,dimy},nz dimz-thickness]}&/@knobs2,botdo/2]; ]; If[BooleanQ[detailed], If[TrueQ[detailed], {sides,bottom,knobs,{CapForm[None],knobs2}} , {sides,knobs} ] , {sides} ] ] DrawLego[{nx_Integer,ny_Integer,nz_Integer:1},p:{px_,py_,pz_},detailed_:True]:=Translate[DrawLego[{nx,ny,nz},detailed],p{1,1,dimz}-{0.5,0.5,0}] So we can draw any brick now, at any place, and we have the option to have it detailed or not... Graphics3D[{brickstyle, DrawLego[{4, 2}]}, Lighting -> "Neutral", Boxed -> False, Axes -> True] Graphics3D[{brickstyle, DrawLego[{4, 2, 1}]}, Lighting -> "Neutral", Boxed -> False, Axes -> True] Graphics3D[{brickstyle, DrawLego[{4, 2, 1}, {1, 1, 1}]}, Lighting -> "Neutral", Boxed -> False, Axes -> True] Graphics3D[{brickstyle, DrawLego[{4, 2, 1}, {1, 1, 1}, False]}, Lighting -> "Neutral", Boxed -> False, Axes -> True] Graphics3D[{brickstyle, DrawLego[{4, 2, 1}, {1, 1, 1}, None]}, Lighting -> "Neutral", Boxed -> False, Axes -> True] giving: ![enter image description here][2] So now that we can 'plot' any brick we can make a function that will cover a layer in brick-world with bricks of decreasingly smaller sizes iteratively, and will alternately go in the horizontal x and y directions: ClearAll[TileWithLego,CreateLegos,TransformLego] TileWithLego[slice_List/;MatrixQ[slice],sizes_List,greedy:(True|False),bricks_List:{}]:=Module[{size,bounds,sizex,sizey,shift,dims,dimx,dimy,greedy\[Lambda],stepi,stepj,newarr,part,newbricks}, size={sizex,sizey}=First[sizes]; dims={dimy,dimx}=Dimensions[newarr=slice]; shift=Floor[First[size]/2]; {stepi,stepj}=If[greedy,{1,1},{sizex,sizey}]; greedy\[Lambda]=Boole[!greedy]; newbricks=Reap[Do[ bounds={{j,j+sizey-1},{i,i+sizex-1}}; part=Take[newarr,##]&@@bounds; If[Total[part,2]===sizex sizey, newarr[[Span@@bounds[[1]],Span@@bounds[[2]]]]=0; Sow[bounds]; ] , {j,1,dimy-sizey+1,stepj} , {i,1+greedy\[Lambda] Mod[(j-1)/sizey,2]shift,dimx-sizex+1,stepi} ]][[2]]; If[newbricks==={},newbricks={{}}]; newbricks=bricks~Join~newbricks[[1]]; If[Length[sizes]>1, TileWithLego[newarr,Rest[sizes],greedy,newbricks] , Reverse/@newbricks ] ] CreateLegos[slice_List/;MatrixQ[slice],sizes_List,rotate:(True|False),greedy:(True|False)]:=If[rotate,Reverse/@TileWithLego[slice\[Transpose],sizes,greedy],TileWithLego[slice,sizes,greedy]] TransformLego[slices_List,bricks_List,greedy:(True|False|Automatic)]:=Module[{len,greedies,heights,rotates,brickies,brickspec}, len=Length[slices]; heights=Range[len]; rotates=(#=!=0)&/@Mod[heights,2]; greedies=Switch[greedy,True,ConstantArray[True,len],False,ConstantArray[False,len],_,Switch[len,1,{False},2,{False,False},_,{False,False}~Join~ConstantArray[True,len-2]]]; brickies=MapThread[CreateLegos[#1,bricks,#2,#3]&,{slices,rotates,greedies}]; brickspec=MapThread[{#1[[All,All,2]]-#1[[All,All,1]]+1,{#1[[All,All,1]],ConstantArray[#2,Length[#1]]}\[Transpose]}\[Transpose]&,{brickies,heights}]; brickspec=Catenate[brickspec]; brickspec[[All,2]]=Flatten/@brickspec[[All,2]]; brickies=DrawLego[#1,#2,False (* detailed *)]&@@@brickspec; {Graphics3D[{brickstyle,brickies},Boxed->False,ImageSize->700],brickspec} ] Let's turn a simple plot in to its Lego-presentation: heightmap=Table[8+Round[3.5Sin[0.1(0.1x^2+y)]/1.2],{x,-15,24,2},{y,-30,28,2}]; ListPlot3D[%,Mesh->None,InterpolationOrder->0] minmax=MinMax[heightmap]+0.5{-1,1}; slices=UnitStep[heightmap-#+1]&/@Range@@minmax; {gr,bricks}=TransformLego[slices,{{4,2},{3,2},{2,2},{4,1},{3,1},{2,1},{1,1}},Automatic]; gr giving: ![enter image description here][3] ![enter image description here][4] We can try different shapes, namely a sphere: slices=DiskMatrix[{9/dimz,9,9},20]; {gr,bricks}=TransformLego[slices,{{4,2},{3,2},{2,2},{4,1},{3,1},{2,1},{1,1}},Automatic]; gr ![enter image description here][5] Or a pyramid: slices=DiamondMatrix[{8,8,8},18][[10;;]]; {gr,bricks}=TransformLego[slices,{{4,2},{3,2},{2,2},{4,1},{3,1},{2,1},{1,1}},Automatic]; gr ![enter image description here][6] The price (according to the online lego shop), would be: prices = {{2, 4} -> 0.23, {1, 2} -> 0.11, {1, 1} -> 0.08, {1, 3} -> 0.15, {1, 4} -> 0.15, {2, 2} -> 0.15, {2, 3} -> 0.19}; Total[(Sort /@ bricks[[All, 1]]) /. prices] 18.76 We can go now and make some instructions for making this pyramid! Because I can't build something without instructions. Let's create some layer-by-layer instructions: ClearAll[CreatePage,CreatePages] CreatePage[slices_List,pagenumber_Integer]:=Module[{add,old,image,gr,gr3,opts,width=500}, {add,old}=TakeDrop[slices,-1]; image=(DrawLego[#1,#2,False]&@@@#)&/@slices; add=Flatten[add,1]; add=SortBy[Minus@*First][Reverse/@Tally[Sort/@add[[All,1]]]]; add[[All,1]]=Style[Row[{#,"\[Cross]"}],16,Black]&/@add[[All,1]]; add[[All,2]]=Graphics3D[{brickstyle,DrawLego[#]},gropts,ImageSize->50,Background->None]&/@add[[All,2]]; add=Grid[add]; gr3=Graphics3D[{brickstyle,image},Boxed->False,ViewPoint->(10{2.4, -1.3, 2.}),ImageSize->2width/3]; gr=Graphics[ {LightBlue,Rectangle[{0,0},{1,1.5}], Inset[gr3,Scaled@{0.5,0.5}], Inset[Style[ToString[pagenumber],30,Black],Scaled@{0.5,0.05},Scaled@{0.5,0}], Inset[add,Scaled@{0.05,1},Scaled@{0,1}] }, Axes->False, Frame->False, ImageSize->(width{1,1.5}), PlotRange->{{0,1},{0,1.5}}, AspectRatio->Full ] ] CreatePages[bricks_List]:=Module[{brickslices,out}, brickslices=SortBy[Part[#,1,-1,-1]&][GatherBy[bricks,Part[#,-1,-1]&]]; out = Map[CreatePage[brickslices[[;;#]],#]&,Range[Length[brickslices]]]; Rasterize[#,"Image"]& /@ out ] So let's call the function: CreatePages[bricks] ![enter image description here][7] gives me back 8 pages of instructions, including the bricks I need for that 'layer' ! Lastly, let's make one from a 3D model: brickstyle=Sequence[RGBColor[0.55,0.38,0.19],EdgeForm[AbsoluteThickness[1]]]; bg=ExampleData[{"Geometry3D","Triceratops"},"BoundaryMeshRegion"] bounds={xbounds,ybounds,zbounds}=CoordinateBounds[ExampleData[{"Geometry3D","Triceratops"},"VertexData"]]; rmf=RegionMember[bg]; \[Delta]=2^-3; alldata=Boole[Table[rmf[{x,y,z}],{x,xbounds[[1]],xbounds[[2]],\[Delta]},{y,ybounds[[1]],ybounds[[2]],\[Delta]},{z,zbounds[[1]],zbounds[[2]],\[Delta]}]]; alldata=Transpose[alldata,{3,2,1}]; {gr,bricks}=TransformLego[alldata,{{4,2},{3,2},{2,2},{4,1},{3,1},{2,1},{1,1}},False]; gr ![enter image description here][8] Now feel free to turn your own plots, 3d-scans, and models to Legos! ![enter image description here][9] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ezgif-7-d6220bc85b47.gif&userId=11733 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=106061.png&userId=73716 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=39362.png&userId=73716 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=65983.png&userId=73716 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=15884.png&userId=73716 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=73285.png&userId=73716 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=16926.png&userId=73716 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=18467.png&userId=73716 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=3141out.gif&userId=73716 Sander Huisman 2016-02-29T21:57:12Z https://community.wolfram.com/groups/-/m/t/2153362 *Wolfram notebook is attached at the end of the post.* ---------- ![enter image description here][1] This post is about FEM simulation of violin vibration modes in 3D. As well known there are Helmholtz resonances of air inside the violin body with frequencies dependent on geometry of f-holes. This is the main reason why violin has so pronounced sound. To simulate these modes with Mathematica FEM we first define the body geometry (this is my design with given volume and area of f-holes, but it taken from the real violin): xy = {{3.805405405405406`,3.34954954954955`},{3.8252252252252257`,6.6990990990991`},{3.9441441441441443`,7.9081081081081095`}, {4.47927927927928`,8.601801801801802`},{5.014414414414414`,8.264864864864865`},{4.816216216216216`,7.8882882882882885`}, {4.895495495495496`,7.630630630630631`},{5.232432432432433`,7.432432432432433`},{5.47027027027027`,7.491891891891892`}, {5.648648648648649`,7.8882882882882885`},{5.668468468468468`,8.046846846846847`},{5.56936936936937`,8.403603603603605`}, {5.252252252252252`,8.681081081081082`},{4.855855855855856`,8.780180180180182`},{4.518918918918919`,8.8`}, {3.9639639639639643`,8.522522522522523`},{3.567567567567568`,7.967567567567568`},{3.3693693693693696`,7.372972972972973`}, {3.2306306306306305`,6.67927927927928`},{3.1513513513513516`,3.3693693693693696`},{3.1513513513513516`,2.655855855855856`}, {2.9729729729729732`,1.783783783783784`},{2.8738738738738743`,1.4666666666666668`},{2.100900900900901`,0.7927927927927928`}, {1.7243243243243245`,1.3081081081081083`},{2.021621621621622`,1.7639639639639642`},{2.0414414414414415`,2.0414414414414415`}, {1.9621621621621623`,2.23963963963964`},{1.6648648648648652`,2.4378378378378383`},{1.4666666666666668`,2.5171171171171176`}, {1.10990990990991`,2.338738738738739`},{0.891891891891892`,1.9423423423423425`},{0.9315315315315316`,1.4072072072072073`}, {1.5657657657657658`,0.7927927927927928`},{2.081081081081081`,0.6342342342342343`},{2.5963963963963965`,0.7927927927927928`}, {3.0918918918918923`,1.2090090090090093`},{3.5081081081081082`,1.902702702702703`},{3.706306306306306`,2.6954954954954955`}}; reg1 = RegionUnion[Disk[{0, 19.5/2}, 19.5/2], Disk[{0, 36 - 15.5/2}, 15.5/2], Rectangle[{-10, 15}, {10, 25}]]; reg2 = RegionDifference[reg1, RegionUnion[Disk[{-10, 20}, 9.5/2], Disk[{10, 20}, 9.5/2]]]; c0 = {0, 36 - 15.5/2}; c1 = {7.03562, 25}; f[x_] := c0[[2]] + x (c1[[2]] - c0[[2]])/(c1[[1]] - c0[[1]]); r1 = Norm[c1 - {10, f[10]}]; reg3 = RegionDifference[reg2, Disk[{10, f[10]}, r1]]; f1[x_] := c0[[2]] - x (c1[[2]] - c0[[2]])/(c1[[1]] - c0[[1]]); reg4 = RegionDifference[reg3, Disk[{-10, f1[-10]}, r1]]; c10 = {0, 19.5/2}; c11 = {8.215838362577491`, 15}; f11[x_] := c10[[2]] + x (c11[[2]] - c10[[2]])/(c11[[1]] - c10[[1]]); r2 = Norm[c11 - {10, f11[10]}]; reg5 = RegionDifference[reg4, Disk[{10, f11[10]}, r2]]; f12[x_] := c10[[2]] - x (c11[[2]] - c10[[2]])/(c11[[1]] - c10[[1]]); reg6 = RegionDifference[reg5, Disk[{-10, f12[-10]}, r2]]; p6 = RegionPlot[reg6, AspectRatio -> Automatic]; fh[xf_, yf_] := RegionUnion[ Polygon[Table[{xy[[i, 1]] - xf, xy[[i, 2]] + yf}, {i, Length[xy]}]], Polygon[Table[{-xy[[i, 1]] + xf, xy[[i, 2]] + yf}, {i, Length[xy]}]]]; General view of the violin body from the front and back side Show[p6, Graphics[fh[7, 12], AspectRatio -> Automatic]] dz = 3.79; reg8 = ImplicitRegion[Element[{x, y}, reg6] && 0 <= z <= dz, {x, y, z}]; mesh3d1 = DiscretizeRegion[reg8, {{-10, 10}, {0, 36}, {0, dz}}] ![Figure 1][2] Next step is the computation of air modes in the violin body with using ` NDEigensystem[]` as follows ca = 34321(*T=20C*); L = -Laplacian[u[x, y, z], {x, y, z}]; {vals, funs} = NDEigensystem[{L, DirichletCondition[u[x, y, z] == 0, Element[{x, y}, fh[7, 11.49]] && z == dz]}, u, Element[{x, y, z}, mesh3d1], 15]; Finally we visualize first 5 modes and the main mode in 3D {Table[DensityPlot[funs[[i]][x, y, dz/2], {x, -10, 10}, {y, 0, 36}, PlotRange -> All, PlotLabel -> ca Sqrt[vals[[i]]]/(2 Pi), ColorFunction -> "Rainbow", AspectRatio -> Automatic], {i, 1, 5}], DensityPlot3D[ funs[[1]][x, y, z], {x, -10, 10}, {y, 0, 36}, {z, 0, dz}, PlotRange -> All, PlotLabel -> ca Sqrt[vals[[1]]]/(2 Pi), ColorFunction -> "Rainbow", AspectRatio -> Automatic, PlotLegends -> Automatic, PlotPoints -> 100, BoxRatios -> Automatic, OpacityFunction -> None, Boxed -> False]} ![Figure 2][3] Therefore the first mode of 440.033 Hz is close to "A4" (440 Hz) tone. But we expecting "C4" (261.626 Hz), or "C#4" (277.183 Hz). The main reason of this discrepancies could be the wood plate vibration from the back side. Thus we define mesh, parameters of the wood plate and modes as follows dreg = DiscretizeRegion[reg6, {{-10, 10}, {0, 36}}, MaxCellMeasure -> .05] Y = 10.8*10^9; nu = 31/100; rho = 500; h = .003; d = 10^4 Sqrt[Y h^2/(12 rho (1 - nu^2))];Ld2 = {Laplacian[-d u[x, y], {x, y}] + v[x, y], -d Laplacian[v[x, y], {x, y}]}; {vals, funs} = NDEigensystem[{Ld2, DirichletCondition[u[x, y] == 0, True]}, {u, v}, Element[{x, y}, dreg], 5]; Table[DensityPlot[Re[funs[[i, 1]][x, y]], {x, y} \[Element] dreg, PlotRange -> All, PlotLabel -> vals[[i]]/(2 Pi), ColorFunction -> "Rainbow", AspectRatio -> Automatic], {i, 2, Length[vals]}] ![Figure 3][4] Hence for wood plate we have mode of 259.394 Hz and it is close to C4 tone. [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2021-01-04at1.47.31PM.jpg&userId=20103 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=bd9Wx.png&userId=1218692 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=w7dPm.png&userId=1218692 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=qb3HU.png&userId=1218692 Alexander Trounev 2021-01-03T23:13:58Z https://community.wolfram.com/groups/-/m/t/1659553 Dear all, inspired by another [great post][1] of [@Anton Antonov][at0] and in particular there by a remark of [@Vitaliy Kaurov][at1] pointing to [the art of knitting images][2] I could not resist trying with Mathematica. Clearly - this problem is crying out loudly for **Radon transform**! ![enter image description here][3] I start by choosing some example image, convert it to inverse grayscale and perform the Radon transform. ClearAll["Global`*"] img0 = RemoveBackground[ ImageTrim[ ExampleData[{"TestImage", "Girl3"}], {{80, 30}, {250, 240}}], {"Background", {"Uniform", .29}}]; img1 = ImageAdjust[ColorNegate@ColorConvert[RemoveAlphaChannel[img0], "Grayscale"]]; {xDim, yDim} = {180, 400}; (* i.e. angles between 1\[Degree] and 180\[Degree] *) rd0 = Radon[img1, {xDim, yDim}]; ImageCollage[{img0, ImageAdjust@rd0}, Method -> "Rows", Background -> None, ImagePadding -> 10] ![enter image description here][4] Every column of the Radon image represents a different angle of projection. So next I separate these columns into (here 180) single Radon images and do an inverse Radon transform on each: maskLine[a_] := Table[If[a == n, 1, 0], {n, 1, xDim}]; maskImg = Table[Image[ConstantArray[maskLine[c], yDim]], {c, 1, xDim}]; rdImgs = rd0 maskImg; ProgressIndicator[Dynamic[n], {1, xDim}] invRadImgs = Table[{ImageApply[If[# > 0, #, 0] &, InverseRadon[rdImgs[[n]]]], -(n - 91) \[Degree]}, {n, 1, xDim}]; These data already represent the angle dependent intensities for backpropagation. Now one just has *somehow* to translate these intensities into discretely spaced lines (because this is the actual task in analogy to the above mentioned knitting ). Here is my simple attempt, which e.g. for 69° gives the following result (I am not really happy with this - there is definitely room for improvement!): ![enter image description here][5] valsAngle[invRads_] := Module[{img, angle, data, l2}, angle = Last@invRads; data = Max /@ (Transpose@*ImageData@*ImageRotate @@ invRads); l2 = Round[Length[data]/2]; data = MapIndexed[{First[#2] - l2, #1} &, data]; {Select[ Times @@@ ({#1, If[#2 > .0003, 1, 0]} & @@@ ((Mean /@ # &)@*Transpose /@ Partition[data, 5])), # != 0 &], angle} (* limiting value of 0.0003 is just empirical! *) ]; va = valsAngle /@ invRadImgs; graphicsData[va_] := Module[{u, angle}, {u, angle} = va; InfiniteLine[# {Cos[angle], -Sin[angle]}, {Sin[angle], Cos[angle]}] & /@ u]; gd = graphicsData /@ va; Graphics[{Thickness[.0003], gd}, ImageSize -> 600, PlotRange -> {{-170, 170}, {-220, 220}}] ... and the result is a bunch of lines: ![enter image description here][6] [at0]: https://community.wolfram.com/web/antononcube [at1]: https://community.wolfram.com/web/vitaliyk [1]: https://community.wolfram.com/groups/-/m/t/1555648?p_p_auth=T7A50bYl [2]: http://artof01.com/vrellis/works/knit.html [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ImageOfLines.gif&userId=32203 [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=img0rd0.jpg&userId=32203 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=linesample.png&userId=32203 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ImageOfLines.png&userId=32203 Henrik Schachner 2019-04-13T20:01:08Z https://community.wolfram.com/groups/-/m/t/932548 #Introduction I recently saw a TV show set at Four Corners USA, the point where Utah, Colorado, Arizona, and New Mexico meet: ![enter image description here][1] It made me wonder how frequent 4 or more geographical borders meet at one point. According to [Wikipedia][2], 4 borders meeting at a point is called a ***quadripoint***, 5 borders meeting is called a ***quintipoint***, and in general it's called a ***multipoint***. The entry only lists one quintipoint and goes on to say > Perhaps a dozen quintipoints of various levels of geopolitical subdivisions are scattered around the world; This piqued my interest to find all multipoints, using the Wolfram Language. -------- #Results Before I give the details on how to detect multipoints, I'd like to showcase the results. ###Summary - Since borders are not always precise (or even well defined at times), I allowed for an error up to ~100 meters when classifying points. - The polygons were obtained from the `"Country"` and `"AdministrativeDivision"` `Entity` types (about 40,000 in total). - There are a total of **724 quadripoints** in this dataset. - There are a total of **13 quintipoints** in this dataset. - There is **1 *10-point*** in this dataset! - There are **only 6 multipoints** in the dataset whose regions *don't* share the same parent region. ###Quadripoints With **724 quadripoints**, there are too many to list here, but here are a few interesting ones. - The only countries to form a quadripoint are **Namibia, Botswana, Zambia, and Zimbabwe**. ![enter image description here][3] - There are a considerable amount of **counties in Iowa and Texas** that are apart of multiple quadripoints, i.e. more than one corner is a quadripoint. This is because they are roughly arranged in a rectangular grid. ![enter image description here][4] - There were only 6 quadripoints found whose parent regions differ: ![enter image description here][5] - Here's a visual summary of all quadripoints found (note the level 3 regions were heavily thickened to become visible): ![enter image description here][6] ###Quintipoints Here are all **13 quintipoints** found: - **Saint Kitts and Nevis**: Saint George Gingerland - Saint James Windward - Saint John Figtree - Saint Paul Charlestown - Saint Thomas Lowland - **Boyaca, Colombia**: Chinavita - Garagoa - Miraflores - Ramiriquí - Zetaquirá - **Counties in Florida, USA**: Glades - Hendry - Martin - Okeechobee - Palm Beach - **Usulutan, El Salvador**: California - Ozatlán - Santa Elena - Tecapán - Usulután - **Arequipa, Arequipa, Peru**: Alto Selva Alegre - Cayma - Chiguata - Miraflores - San Juan de Tarucani - **Cuenca, Azuay, Ecuador**: Chiquintad - Cuenca - Ricaurte - Sidcay - Sinicay - **Pea Reang, Prey Vêng, Cambodia**: Kampong Popil - Mesa Prachan - Prey Sralet - Reab - Roka - **Rieti, Lazio, Italy**: Borgo Velino - Castel Sant' Angelo - Cittaducale - Micigliano - Rieti - **Cosenza, Calabria, Italy**: Marano Marchesato - Marano Principato - Rende - San Fili - San Lucido - **Napoli, Campania, Italy**: Boscotrecase - Ercolano - Ottaviano - Torre Del Greco - Trecase - **Savona, Liguria, Italy**: Bardineto - Boissano - Giustenice - Loano - Pietra Ligure - **Torino, Piemonte, Italy**: Cuceglio - Mercenasco - Montalenghe - Scarmagno - Vialfrè - **Viterbo, Lazio, Italy**: Bolsena - Capodimonte - Gradoli - Montefiascone - San Lorenzo Nuovo As you can see, Italy takes the cake with 6 quintipoints! Here's a visual of these quintipoints, along with the error allowing them to be classified as such: ![enter image description here][7] ###A Near 6-point Notice in the top right map above, it looks like there is room for one more region in Viterbo, Lazio, Italy, which would make it a 6-point. Here's the 6th region (Grotte Di Castro) in black: ![enter image description here][8] It turns out Grotte Di Castro is about 700 meters from the quintipoint, making this only a ***near* 6-point**: ![enter image description here][9] ###10-point As mentioned in the [Wikipedia entry][10], there is a 10-point in Italy at the summit of [Mount Etna][11]: - **Catania, Sicily, Italy**: Adrano - Belpasso - Biancavilla - Bronte - Castiglione Di Sicilia - Maletto - Nicolosi - Randazzo - Sant' Alfio - Zafferana Etnea ![enter image description here][12] ###Allowing for more error If we allow for more error, we can find ***near-multipoints*** - regions that almost have a multipoint, but clearly don't. For example, there is a near-quintipoint in Texas, USA: ![enter image description here][13] -------- #Code The idea to find multipoints within a collection of regions is as follows: 1. Obtain the `Polygon` for each region. 2. For each pair of regions, if there's a vertex from one of the polygons which is "close" to the other, mark these regions as touching. `RegionDistance` can be used for this. 3. The relation of touching between pairs forms an adjacency matrix. From this, form a `Graph` and use `FindClique` to find all multipoints in this collection. Here is code that does just that: discretize[Polygon[pts_?MatrixQ]] := MeshRegion[pts, Polygon[Range[Length[pts]]]] discretize[Polygon[pts_?(VectorQ[#, MatrixQ] &)]] := With[{pts2 = Select[pts, Length[#] > 2 &]}, MeshRegion[Join @@ pts2, Polygon[Range[# + 1, #2] & @@@ Partition[Prepend[Accumulate[Map[Length, pts2]], 0], 2, 1]]] ] discretize[expr_] := With[{mr = DiscretizeGraphics[Graphics[expr]]}, mr /; MeshRegionQ[mr] ] discretize[_] = $Failed; polyLookup = discretize /@ (Join[ EntityValue["Country", "Polygon", "EntityAssociation"], EntityValue["AdministrativeDivision", "Polygon", "EntityAssociation"] ] /. GeoPosition -> Identity); MultiPoints[divs_List, n_] /; Length[divs] < n = {}; MultiPoints[divs_List, n_] := Block[{polys, disj, cands}, polys = polyLookup /@ divs; ( disj = Boole[Outer[CoordinateNear, polys, polys]] - IdentityMatrix[Length[divs]]; ( cands = FindClique[AdjacencyGraph[divs, disj], {n, Infinity}, All]; resolveMultiPoints[cands, AssociationThread[divs, polys]] ) /; MatrixQ[disj, IntegerQ] ) /; VectorQ[polys, MeshRegionQ] ] MultiPoints[___] = {}; $tol = 0.001; CoordinateNear[mr1_, mr2_, tol_:$tol] := With[{d = {{-tol, tol}, {-tol, tol}}}, And[ NoneTrue[Transpose[{d+RegionBounds[mr1], d+RegionBounds[mr2]}], #1[[2,1]] > #1[[1,2]] || #1[[1,1]] > #1[[2,2]]&], Min[RegionDistance[mr1, MeshCoordinates[mr2]]] < tol ] ] resolveMultiPoints[{}, _] = {}; resolveMultiPoints[cands_List, passoc_?AssociationQ] := Select[cands, MultiPointQ[#, passoc]&] MultiPointQ[cands_, passoc_?AssociationQ, tol_:$tol] := Block[{coords, mrs}, mrs = passoc /@ cands; coords = Union @@ MeshCoordinates /@ mrs; Or @@ Thread[And @@ (Thread[RegionDistance[#, coords] < tol]& /@ mrs)] ] Now here's all multipoints formed from countries: ![enter image description here][14] Now to explore all cases, we can start off by looking for multipoints in all subdivisions of a given region, e.g. given Florida, find all multipoints within the counties of Florida. This can be achieved by building a hierarchical graph connecting countries and administrative divisions. Then for a given region, this graph can be used to find all subdivisions and the above code can be used to find the multipoints. ad = AdministrativeDivisionData[]; pr = EntityValue["AdministrativeDivision", "ParentRegion"]; $ADNetwork = Graph[Join[ Thread["NullPointer" -> EntityList["Country"]], DeleteCases[Thread[pr -> ad], Rule[_Missing, _]] ]]; ChildrenMultiPoints[reg_] := ChildrenMultiPoints[reg, 4] ChildrenMultiPoints[reg_, o___] := MultiPoints[Rest[VertexOutComponent[$ADNetwork, reg, 1]], o] ![enter image description here][15] Lastly, to cover all cases we need to consider sets of regions that have differing parent regions. To do this, for a given parent region $P$, first find all other regions $R_i$ (on the same level) that touch this region. Then simply run `MultiPoints` on all subdivisions in $P \cup R_i$. I omit this code here, as there were only 6 instances that came out of this case. [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=7535fourcorners.png&userId=46025 [2]: https://en.wikipedia.org/wiki/Quadripoint [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=countryquadripoint.png&userId=46025 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=2008squarequadripoints.png&userId=46025 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=crossregionquadripoints.png&userId=46025 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=allquadripoints.png&userId=46025 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=4697quintipoints.png&userId=46025 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=8873almostsixpoint.png&userId=46025 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=9086almostsixpointzoom.png&userId=46025 [10]: https://en.wikipedia.org/wiki/Quadripoint#Multipoints_of_greater_numerical_complexity [11]: https://en.wikipedia.org/wiki/Mount_Etna#Geopolitical_oddity [12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=3719tenpoint.png&userId=46025 [13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=4645almostquintpoint.png&userId=46025 [14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2016-10-0117.18.37.png&userId=46025 [15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2016-10-0117.27.16.png&userId=46025 Greg Hurst 2016-10-01T22:56:22Z https://community.wolfram.com/groups/-/m/t/2451238 ![enter image description here][1] ![enter image description here][2] An [n-gonal antiprism or n-antiprism][3] is a polyhedron composed of two parallel copies of an n-sided polygon, connected by a band of 2n triangles. Grid@Transpose@Table[PolyhedronData[{"Antiprism",k},#]&/@{"Image","Net"},{k,3,7}] ![enter image description here][4] To form an almost perfect ring of 4-antiprisms firstly we need a set of vertices and coordinates: offset =#+{0,0,Sqrt[1-1/4 Sec[π/8]^2]+4.05} &/@(2PolyhedronData[{"Antiprism",4}, "VertexCoordinates"]); face={{5,1,2,6},{8,4,7,3},{6,4,8},{2,7,4},{1,3,7},{5,8,3},{6,2,4},{2,1,7},{1,5,3},{5,6,8}}; Then we can make 13 copies: Graphics3D[ Table[GraphicsComplex[RotationMatrix[k 2 Pi/13,{0,1,0}].#&/@offset,Polygon/@face],{k,0,12}], Boxed-> False, SphericalRegion->True] ![13 antiprisms][5] This is **not** exact, but it's very close. ![13 antiprisms side][6] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=antiptism4.gif&userId=11733 [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=asdf43qasdf.jpg&userId=11733 [3]: https://mathworld.wolfram.com/Antiprism.html [4]: https://community.wolfram.com//c/portal/getImageAttachment?filename=sdfq3dfag43.jpg&userId=11733 [5]: https://community.wolfram.com//c/portal/getImageAttachment?filename=13anti.jpg&userId=21530 [6]: https://community.wolfram.com//c/portal/getImageAttachment?filename=13antiside.jpg&userId=21530 Ed Pegg 2022-01-20T20:12:49Z https://community.wolfram.com/groups/-/m/t/870698 **Easy Cube** is a reflexion game from Japan. It consists of a set of 7 pieces which are "tetris"-like (each piece is a simple geometrical shape made from 3,4 or 5 cubes), and a collection of 48 problems, where the goal is to use the pieces to fill a given shape (in 2d, or in 3d for the hardest problems). The game box ![enter image description here][1] The 7 pieces ![enter image description here][2] 2 examples of problems ![enter image description here][3] It is pleasant to play, with the difficulty slowly increasing whit the hardest problems. I decided to try to solve it using Mathematica. I did not use any advanced mathematics for this (which anyway I would not know :-)), and I wanted a method general enough so it could solve all the problems without any specific adpatation. I went for a purely random method, where the program places a first piece at random, then try to put a second piece, etc. When it fails to add a piece after a fixed number of attemps, it simply starts the whole process again. So this program does not learn anything... It just tries many many different possibilities, until it finds a solution ! Using Wolfram language, the code to make it and to vizualize to result was quite simple and effective (I show the code details at the end of this post for people interested). In particular, going from the 2d case to the 3d case needed very small changes only. The two followings animations show the program in action for a 2d problem and a 3d problem ![enter image description here][4] ![enter image description here][5] The number of attempts needed to reach a solution is of course random, and depends on the difficulty of the problem. Typically, it takes between a few hundreds and a few thousands iterations, which takes between a few seconds to 1-2 minutes. Here a sample of 4 solutions found for a 2d problem : ![Sample solutions from a 2d problem][6] And 2 solutions from a 3d problem : ![Sample solutions from a 2d problem][7] Finally, I considered it if was possible to use this method to find **all solutions** for a given problem (the number of different solutions is an info given on the description of each problem). In principle, because the method is random, it is not well suited for this (one can never be sure that all solutions have been found). However, since the method is quite fast, I decided to try anyway. For a given problem, I computed 10000 solutions. Here is a plot of the number of attempts needed for each solution, and a histogram of this: ![Number of attempts for 10000 solutions][8] On average, finding a solution to this problem requested 2882 attempts... From the 10000 solutions, one wants only different solutions. This is easily done with the **DeleteDuplicates** command: SolgridQ26ListMReduced = DeleteDuplicates@SolgridQ26ListM; Length@SolgridQ26ListMReduced 362 which gives 362 different solutions. However, since this problem geometry has a simple central symmetry, one also want to get rid of "symmetric copies" of the solutions. Defining the symmetry operation as the GsymGrid function, this is again done with a **DeleteDuplicates** command : SolgridQ26ListMReducedSym = DeleteDuplicates[ SolgridQ26ListMReduced, #2 == GSymGrid[#1] &]; Length@SolgridQ26ListMReducedSym 188 which gives 188 unique solutions. This is precisely the number which is given in the problem description ! So the method was able to find all solutions. Here is plot with the 188 solutions: ![all solutions][9] ---------- Details of the code ------------------- **Definition of the pieces** (2d case). Each piece is a simple list of the points make the piece. When then construct, for each piece, a list of copies of it with all possible orientations. Pieces Definitions PTriangle = {{0, 0}, {0, 1}, {1, 0}}; PSquare = {{0, 0}, {0, 1}, {1, 0}, {1, 1}}; PLine = {{0, 0}, {0, 1}, {0, 2}}; PL = {{0, 0}, {0, 1}, {1, 0}, {2, 0}}; PPodium = {{0, 0}, {0, 1}, {-1, 0}, {1, 0}}; PSnake = {{0, 0}, {0, 1}, {1, 0}, {-1, 1}}; PBulky = {{0, 0}, {1, 0}, {0, 1}, {1, 1}, {-1, 1}}; (* Rotation by angle \[Pi]/2 matrix*) Mrot = {{0, 1}, {-1, 0}}; (* Reflection by y-axis matrix *) Mref = {{-1, 0}, {0, 1}}; MUnit = {{1, 0}, {0, 1}}; (*Operators which perform a given number of rotation, and of \ reflection*) RotatePiece[piece_, n_] := Nest[Mrot.# &, #, n] & /@ piece ReflectPiece[piece_, n_] := If[n == 0, (MUnit.#) & /@ piece, (Mref.#) & /@ piece] Each piece with all the possible orientations PTriangleAll = {PTriangle, RotatePiece[PTriangle, 1], RotatePiece[PTriangle, 2], RotatePiece[PTriangle, 3]}; PSquareAll = {PSquare}; PLineAll = {PLine, RotatePiece[PLine, 1]}; PLAll = Module[{PLr = ReflectPiece[PL, 1]}, {PL, RotatePiece[PL, 1], RotatePiece[PL, 2], RotatePiece[PL, 3], PLr, RotatePiece[PLr, 1], RotatePiece[PLr, 2], RotatePiece[PLr, 3]}]; PPodiumAll = {PPodium, RotatePiece[PPodium, 1], RotatePiece[PPodium, 2], RotatePiece[PPodium, 3]}; PSnakeAll = {PSnake, RotatePiece[PSnake, 1], ReflectPiece[PSnake, 1], RotatePiece[ReflectPiece[PSnake, 1], 1]}; PBulkyAll = Module[{PBulkyr = ReflectPiece[PBulky, 1]}, {PBulky, RotatePiece[PBulky, 1], RotatePiece[PBulky, 2], RotatePiece[PBulky, 3], PBulkyr, RotatePiece[PBulkyr, 1], RotatePiece[PBulkyr, 2], RotatePiece[PBulkyr, 3]}]; tPieces = {PBulkyAll, PLAll, PPodiumAll, PSnakeAll, PSquareAll, PLineAll, PTriangleAll}; tPiecesNames = {"Bu", "Ll", "Po", "Sn", "Sq", "Li", "Tr"}; **Functions which place the pieces** Piece placement functions PutPiece[piece_, piecename_, grid_] := Module[{IniPt, IniPtxy, Pts, Vcheck, PtsinGrid, Pos, i, gridx}, gridx = grid; IniPt = RandomChoice[Position[gridx, 0]]; Pts = Map[IniPt + # &, RandomChoice[piece]]; PtsinGrid = gridx[[Sequence @@ #]] & /@ Pts; Vcheck = If[PtsinGrid == Table[0, Length[PtsinGrid]], "success", "failure"]; If[Vcheck == "success", Do[gridx[[Sequence @@ Pts[[i]]]] = piecename, {i, Length[Pts]}]; {"success", gridx}, {"failure", gridx}] ] AddOnePiece[gridin_, piece_, piecename_, nmax_] := Module[{cc = "failure", nn = 0, aa}, While[(cc != "success") && (nn < nmax), aa = PutPiece[piece, piecename, gridin]; cc = aa[[1]]; nn = nn + 1]; aa] **Grid definition, and plotting functions** The initial grid is a ensemble of 0, embedded in a series of 1, forming a matrix. When a piece is placed the 0's it occupies are replaced by the name of the piece General Grid Definitions TheGrid0 = Table[1, {i, -6, 6, 1}, {j, -6, 6, 1}]; GridDefine[coord_] := Module[{gridout}, gridout = TheGrid0; Do[gridout[[Sequence @@ (coord[[i]] + {7, 7}) ]] = 0, {i, Length[coord]}]; gridout] DrawPieceRectangle[piecename_, grid_, color_] := {color, Map[Rectangle[{#[[1]] - 0.5 - 7, #[[2]] - 0.5 - 7}, {#[[1]] + 0.5 - 7, #[[2]] + 0.5 - 7}, RoundingRadius -> 0.] &, Position[grid, piecename]]} mycolors = ColorData[24]; PlotGrid[grid_, plotrange_] := Graphics[{{White, Rectangle[{-6, -6}, {6, 6}]}, DrawPieceRectangle[0, grid, White], DrawPieceRectangle[1, grid, Black], DrawPieceRectangle[tPiecesNames[[#]], grid, mycolors[If[# != 6, #, # + 4]]] & /@ Range[7]}, PlotRange -> plotrange] **The final solving functions** Full solving function Get the solution, and at each step provides a plot named p, which can be dynamically visualized using a cell with Dynamic[p] SolveGrid[InitGrid_, plotrange_] := Module[{imax, nattempt, grid, i, vc}, imax = 0; nattempt = 0; While[imax < 8, grid[1] = InitGrid; i = 1; vc = "success"; While[(i < 8) && (vc == \!\(\* TagBox[ StyleBox["\"\<success\>\"", ShowSpecialCharacters->False, ShowStringCharacters->True, NumberMarks->True], FullForm]\)), {vc, grid[i + 1]} = AddOnePiece[grid[i], tPieces[[i]], tPiecesNames[[i]], 30]; p = PlotGrid[grid[i + 1], plotrange]; If[vc == "success" || i < 7, i++; imax = i, i++]]; nattempt++]; Print[nattempt]; PlotGrid[grid[8], plotrange]; grid[8]] Get ony the solution, without final plot, nor dynamical vizualisation SolveGridBare[InitGrid_] := Module[{imax, nattempt, grid, i, vc}, imax = 0; nattempt = 0; While[imax < 8, grid[1] = InitGrid; i = 1; vc = "success"; While[(i < 8) && (vc == \!\(\* TagBox[ StyleBox["\"\<success\>\"", ShowSpecialCharacters->False, ShowStringCharacters->True, NumberMarks->True], FullForm]\)), {vc, grid[i + 1]} = AddOnePiece[grid[i], tPieces[[i]], tPiecesNames[[i]], 30]; If[vc == "success" || i < 7, i++; imax = i, i++]]; nattempt++]; Print[nattempt]; grid[8]] SolveGridBare2[InitGrid_] := Module[{imax, nattempt, grid, i, vc}, imax = 0; nattempt = 0; While[imax < 8, grid[1] = InitGrid; i = 1; vc = "success"; While[(i < 8) && (vc == \!\(\* TagBox[ StyleBox["\"\<success\>\"", ShowSpecialCharacters->False, ShowStringCharacters->True, NumberMarks->True], FullForm]\)), {vc, grid[i + 1]} = AddOnePiece[grid[i], tPieces[[i]], tPiecesNames[[i]], 30]; If[vc == "success" || i < 7, i++; imax = i, i++]]; nattempt++]; {grid[8], nattempt}] **Example of use** coordQ35 = Join[Table[{i, 2}, {i, -2, 3}], Table[{i, -2}, {i, -2, 3}], Table[{i, 1}, {i, 0, 3}], Table[{i, 0}, {i, 0, 3}], Table[{i, -1}, {i, 0, 3}], Table[{-2, j}, {j, -1, 1}]]; TheGridQ35 = GridDefine[coordQ35]; SolgridQ35ex1 = SolveGridBare[TheGridQ35]; PlotGrid[SolgridQ35ex1, {{-3.5, 4.5}, {-3.5, 3.5}}] A dynamic view of the process (similar to the animations shown above) is obtained by running a cell "**Dynamic[p]**" before calling SolveGrid[TheGridQ35,{{-3.5, 4.5}, {-3.5, 3.5}}] **Pieces definition for the 3 case** (here all the possible orientations are obtained by applying randomly rotations and reflection on the initial piece) Pieces Definitions PTriangle = {{0, 0, 0}, {0, 1, 0}, {1, 0, 0}}; PSquare = {{0, 0, 0}, {0, 1, 0}, {1, 0, 0}, {1, 1, 0}}; PLine = {{0, -1, 0}, {0, 0, 0}, {0, 1, 0}}; PL = {{0, 0, 0}, {0, 1, 0}, {1, 0, 0}, {2, 0, 0}}; PPodium = {{0, 0, 0}, {0, 1, 0}, {-1, 0, 0}, {1, 0, 0}}; PSnake = {{0, 0, 0}, {0, 1, 0}, {1, 0, 0}, {-1, 1, 0}}; PBulky = {{0, 0, 0}, {1, 0, 0}, {0, 1, 0}, {1, 1, 0}, {-1, 1, 0}}; (* Rotation by angle \[Pi]/2 matrix*) Mrotz = {{0, 1, 0}, {-1, 0, 0}, {0, 0, 1}}; Mrotx = {{1, 0, 0}, {0, 0, 1}, {0, -1, 0}}; Mrotx = {{0, 0, -1}, {0, 1, 0}, {1, 0, 0}}; (* Reflection matrix *) Mrefx = {{-1, 0, 0}, {0, 1, 0}, {0, 0, 1}}; Mrefy = {{1, 0, 0}, {0, -1, 0}, {0, 0, 1}}; Mrefz = {{1, 0, 0}, {0, 1, 0}, {0, 0, -1}}; MUnit = {{1, 0, 0}, {0, 1, 0}, {0, 0, 1}}; (*Operators which perform a given number of rotation, and of \ reflection*) RotatePiecex[piece_, n_] := Nest[Mrotx.# &, #, n] & /@ piece RotatePiecey[piece_, n_] := Nest[Mrotx.# &, #, n] & /@ piece RotatePiecez[piece_, n_] := Nest[Mrotz.# &, #, n] & /@ piece ReflectPiecex[piece_, n_] := If[n == 0, (MUnit.#) & /@ piece, (Mrefx.#) & /@ piece] ReflectPiecey[piece_, n_] := If[n == 0, (MUnit.#) & /@ piece, (Mrefy.#) & /@ piece] ReflectPiecez[piece_, n_] := If[n == 0, (MUnit.#) & /@ piece, (Mrefz.#) & /@ piece] Each piece with all the possible orientations MakeAllPieces[piece_] := DeleteDuplicates@ Table[Module[{Rota, Rotb, Rotc, Refa, Refb, Refc, na, nb, nc, ma, mb, mc}, Rota = RandomChoice[{RotatePiecex, RotatePiecey, RotatePiecez}]; Rotb = RandomChoice[{RotatePiecex, RotatePiecey, RotatePiecez}]; Rotc = RandomChoice[{RotatePiecex, RotatePiecey, RotatePiecez}]; Refa = RandomChoice[{ReflectPiecex, ReflectPiecey, ReflectPiecez}]; Refb = RandomChoice[{ReflectPiecex, ReflectPiecey, ReflectPiecez}]; Refc = RandomChoice[{ReflectPiecex, ReflectPiecey, ReflectPiecez}]; na = RandomInteger[{0, 3}]; nb = RandomInteger[{0, 3}]; nc = RandomInteger[{0, 3}]; ma = RandomInteger[{0, 1}]; mb = RandomInteger[{0, 1}]; mc = RandomInteger[{0, 1}]; Refc[Rotc[Refb[Rotb[ Refa[Rota[piece, na], ma], nb], mb], nc], mc]], {i, 1, 2000}] PTriangleAll = MakeAllPieces[PTriangle]; Length@PTriangleAll 24 PSquareAll = MakeAllPieces[PSquare]; Length@PSquareAll 24 PLineAll = MakeAllPieces[PLine]; Length@PLineAll 6 PLAll = MakeAllPieces[PL]; Length@PLAll 24 PPodiumAll = MakeAllPieces[PPodium]; Length@PPodiumAll 24 PSnakeAll = MakeAllPieces[PSnake]; Length@PSnakeAll 24 PBulkyAll = MakeAllPieces[PBulky]; Length@PBulkyAll 24 tPieces = {PBulkyAll, PLAll, PPodiumAll, PSnakeAll, PSquareAll, PLineAll, PTriangleAll}; tPiecesNames = {"Bu", "Ll", "Po", "Sn", "Sq", "Li", "Tr"}; **Grid definition and visualisation for the 3d case** General Grid Definitions TheGrid0 = Table[1, {i, -6, 6, 1}, {j, -6, 6, 1}, {k, -6, 6, 1}]; GridDefine[coord_] := Module[{gridout}, gridout = TheGrid0; Do[gridout[[Sequence @@ (coord[[i]] + {7, 7, 7}) ]] = 0, {i, Length[coord]}]; gridout] DrawPieceCube[piecename_, grid_, color_] := {Glow[color], Opacity[0.75], Specularity[0], EdgeForm[Thick], Map[Cuboid[{#[[1]] - 0.5 - 7, #[[2]] - 0.5 - 7, #[[3]] - 0.5 - 7}] &, Position[grid, piecename]]} mycolors = ColorData[24]; PlotGrid3D[grid_, plotrange_] := Graphics3D[{(*{White,Cuboid[{-6,-6,-6},{6,6,6}]},*) DrawPieceCube[0, grid, White],(*DrawPieceCube[1,grid,Black],*) DrawPieceCube[tPiecesNames[[#]], grid, mycolors[If[# != 6, #, # + 4]]] & /@ Range[7]}, PlotRange -> plotrange, Lighting -> None, Boxed -> False] PlotGrid3D[grid_, plotrange_, pov_] := Graphics3D[{(*{White,Cuboid[{-6,-6,-6},{6,6,6}]},*) DrawPieceCube[0, grid, White],(*DrawPieceCube[1,grid,Black],*) DrawPieceCube[tPiecesNames[[#]], grid, mycolors[If[# != 6, #, # + 4]]] & /@ Range[7]}, PlotRange -> plotrange, Lighting -> None, Boxed -> False, ViewPoint -> pov] [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=IMG_3757small.JPG&userId=867329 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=IMG_3758small.JPG&userId=867329 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=IMG_3756small.JPG&userId=867329 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=PlacePieces_Q35_anim.gif&userId=867329 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=PlacePieces_Q48_anim.gif&userId=867329 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=solutionExample1.png&userId=867329 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=solutionExample2.png&userId=867329 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=solutionHisto.jpg&userId=867329 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=PlacePieces_Q26_allsoluces.gif&userId=867329 Thibaut Jonckheere 2016-06-11T13:29:52Z https://community.wolfram.com/groups/-/m/t/2029621 ![enter image description here][2] &[Wolfram Notebook][1] [1]: https://www.wolframcloud.com/obj/a47a8852-7ac2-41d2-86f6-0dcfefb86b7a [2]: https://community.wolfram.com//c/portal/getImageAttachment?filename=mainpic.jpg&userId=2025530 Yury POLYACHENKO 2020-07-14T16:48:25Z 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/1023763 Considered as a series reversion ( Cf. [Mathworld][1], [A&S][2] ) of implicit equation $$E = \frac{1}{2}\Psi^2 + \sum_{n=3}^{\infty} f_n(\phi,\theta,\ldots)\;\Psi^n,$$ function [A276738][3] determines the radius $\Psi$ of a hypersurface that limits in small $E$ to the shape of a perfect hypersphere, a circle, a sphere, etc... Examples in 2,3 dimensions lend themselves well to depiction. Let's see the Henon Heiles Potential, and an octahedral Energy Surface. ## Basic Functions ## RExp[n_] := Expand[b Plus[R[0], Total[b^# R[#] & /@ Range[n]]]] RCalc[n_] := With[{basis = Subtract[Tally[Join[Range[n + 2], #]][[All, 2]], Table[1, {n + 2}]] & /@ IntegerPartitions[n + 2][[3 ;; -1]]}, Total@ReplaceAll[Times[-2, Multinomial @@ #, v[Total[#]], Times @@ Power[RSet[# - 1] & /@ Range[n + 2], #]] & /@ basis, {Q^2 -> 1, v[2] -> 1/4}]] AbsoluteTiming[RSet[0] = 1; Set[RSet[#], Expand@RCalc[#]] & /@ Range[20];][[1]] Surface[Nexp_, rep_] := RExp[Nexp] /. R -> RSet /. v[n_] :> Function[{a}, Total[v[#, a - #] Q^# P^(a - #) & /@ Range[0, a]]][n] /. rep /. {P -> Sin[\[Phi]], Q -> Cos[\[Phi]]}; HyperSurface[Nexp_, rep_] := RExp[Nexp] /. R -> RSet /. v[n_] :> Function[{a}, Total[Flatten@ Table[v[a - i - j, i, j] X^(a - i - j) Y^i Z^j, {i, 0, a}, {j, 0, a - i}]]][n] /. rep /. {X -> Sin[\[Theta]] Cos[\[Phi]], Y -> Sin[\[Theta]] Sin[\[Phi]], Z -> Cos[\[Theta]]}; ## Print Pictures ## ViewV = {1, 2, 2}; TrigWords = Flatten[Expand[ Surface[20, {v[2, 1] -> 3 \[Epsilon], v[0, 3] -> -\[Epsilon], v[_, _] -> 0}]] /. Plus -> List /. Times -> List]; TrigLines20 = With[{surf = Surface[20, {v[2, 1] -> 1/2, v[0, 3] -> -1/3/2, v[_, _] -> 0}]}, (surf /. b -> (#/10)) & /@ Range[5]]; g1 = Show[ Graphics[{Lighter@Gray, Text[#, RandomReal[{-1/2, 1}, 2]] & /@ TrigWords}, PlotRange -> {{-1/2, 1}, {-1/2, 1}}], Graphics[{Thick, {Dashed, Line[Part[RotationMatrix[{{0, 0, 1}, ViewV}].#, 1 ;; 2] & /@ {{0, 0, -1/4}, {0, 0, 5/4}}]}, Thickness[.005], MapThread[ Line[Function[{a}, N[Part[RotationMatrix[{{0, 0, 1}, ViewV}].{#1 Cos[\[Phi]], #1 Sin[\[Phi]], #2/ 10} /. {\[Phi] -> a}, 1 ;; 2]]] /@ (Range[0, 200]/ 200 2 Pi)] &, {TrigLines20, Range[5]}]}], ImageSize -> 800]; OctSurf6 = HyperSurface[ 20, {v[4, 0, 0] -> \[Epsilon] 2/5, v[0, 4, 0] -> \[Epsilon] 2/5, v[0, 0, 4] -> \[Epsilon] 2/5, v[2, 2, 0] -> \[Epsilon] 6/5, v[2, 0, 2] -> \[Epsilon] 6/5, v[0, 2, 2] -> \[Epsilon] 6/5, v[_, _, _] -> 0} /. {\[Epsilon] -> -1/2}] /. b -> 6/10; OctSurf3 = HyperSurface[ 20, {v[4, 0, 0] -> \[Epsilon] 2/5, v[0, 4, 0] -> \[Epsilon] 2/5, v[0, 0, 4] -> \[Epsilon] 2/5, v[2, 2, 0] -> \[Epsilon] 6/5, v[2, 0, 2] -> \[Epsilon] 6/5, v[0, 2, 2] -> \[Epsilon] 6/5, v[_, _, _] -> 0} /. {\[Epsilon] -> -1/2}] /. b -> 3/10; OctWords = Flatten[Expand[ HyperSurface[ 10, {v[4, 0, 0] -> \[Epsilon] 2, v[0, 4, 0] -> \[Epsilon] 2, v[0, 0, 4] -> \[Epsilon] 2 , v[2, 2, 0] -> \[Epsilon] 6 , v[2, 0, 2] -> \[Epsilon] 6 , v[0, 2, 2] -> \[Epsilon] 6 , v[_, _, _] -> 0}]] /. Plus -> List /. Times -> List]; g2 = Show[ Graphics[{Lighter@Gray, Text[#, RandomReal[{-2, 2}, 2]] & /@ OctWords}, PlotRange -> 2 {{-1, 1}, {-1, 1}}], Graphics[{ Thick, {Dashed, Line[Part[RotationMatrix[{{0, 0, 1}, ViewV}].#, 1 ;; 2] & /@ {{0, 0, 2}, {0, 0, -2}}]}, Thickness[.005], Line /@ Outer[N[Part[ RotationMatrix[{{0, 0, 1}, ViewV}].{Sin[\[Theta]] Cos[\[Phi]], Sin[\[Theta]] Sin[\[Phi]], Cos[\[Theta]]} OctSurf3 /. {\[Theta] -> #1, \[Phi] -> #2}, 1 ;; 2]] &, Range[1, 9] Pi/10, Range[0, 100] 2 Pi/100, 1], Line /@ Outer[N[Part[ RotationMatrix[{{0, 0, 1}, ViewV}].{Sin[\[Theta]] Cos[\[Phi]], Sin[\[Theta]] Sin[\[Phi]], Cos[\[Theta]]} OctSurf6 /. {\[Theta] -> #1, \[Phi] -> #2}, 1 ;; 2]] &, Range[1, 9] Pi/10, Range[0, 200] 2 Pi/200, 1] }], ImageSize -> 800]; ## Henon Heiles ## ![Henon Heiles][4] ## Octahedral ## ![enter image description here][5] What's more curious than these graphics? The **new conjecture**: that [A276738][6] can be defined in terms of [A028338][7]. [1]: http://mathworld.wolfram.com/SeriesReversion.html [2]: http://people.math.sfu.ca/~cbm/aands/page_16.htm [3]: https://oeis.org/A276738 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=HenonHeiles.png&userId=234448 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Octahedral.png&userId=234448 [6]: https://oeis.org/A276738 [7]: http://oeis.org/A028338 Brad Klee 2017-03-01T20:15:02Z https://community.wolfram.com/groups/-/m/t/953623 ![Image morph][8] **A to Z** I've mentioned before that there's a construction which gives a correspondence between points on the Grassmann manifold $G_2(\mathbb{R}^n)$ of 2-dimensional linear subspaces of $\mathbb{R}^n$ and planar $n$-gons; details at [1][1], [2][2], [3][3], [4][4], [5][5], [6][6]. In particular, this gives a way of morphing between any two (discrete) shapes you like; this animation shows the shortest path from A to Z. Here's the code; notice that I use the [`smootheststep` function][7]: ProjectionBasis[{A_, B_}, {C_, D_}] := Normalize[#] & /@ Eigenvectors[ Transpose[Transpose[{A, B}].{A, B}.Transpose[{C, D}].{C, D}], 2]; PlaneGeo[{A_, B_}, {C_, D_}, t_] := Module[{a, b, c, d, cPerp, dPerp, dist1, dist2}, {a, b} = ProjectionBasis[{C, D}, {A, B}]; {c, d} = ProjectionBasis[{A, B}, {C, D}]; {cPerp, dPerp} = {Normalize[c - (c.a)*a], Normalize[d - (d.b)*b]}; dist1 = ArcCos[a.c]; dist2 = ArcCos[b.d]; {Cos[t*dist1]*a + Sin[t*dist1]*cPerp, Cos[t*dist2]*b + Sin[t*dist2]*dPerp} ]; MakePoly[data_] := Normalize[#] & /@ Transpose[{Re[#], Im[#]} & /@ Sqrt[Table[#[[n]][[1]] + I*#[[n]][[2]], {n, 1, Length[#]}] &[ RotateLeft[#] - # &[data]]]]; RawAData = {{-3., .9}, {1.07, 8.18}, {1.85, 8.2}, {5.96, 0.86}, {4.89, 0.86}, {1.77, 6.6}, {1.18, 6.6}, {.12, 4.58}, {2.87, 4.6}, {3.35, 3.76}, {-.18, 3.76}, {-1.72, .94}}; RawZData = {{0.82, 7.26}, {7.61, 7.32}, {7.65, 6.04}, {1.92, -.06}, {7.76, -.02}, {7.8, -1.16}, {.71, -1.12}, \ {.71, .02}, {6.36, 6.12}, {.85, 6.12}, {.82, 6.12}, {.82, 7.26}}; ToPol[frame_] := Accumulate[ReIm[(Complex @@ #)^2] & /@ Transpose[frame]]; smootheststep[t_] := -20 t^7 + 70 t^6 - 84 t^5 + 35 t^4; DynamicModule[{cols = RGBColor /@ {"#f77e5e", "#3dbd5d", "#303030"}, centeredpoints, s}, Manipulate[ s = smootheststep[t]; centeredpoints = # - ConstantArray[Mean[#], Length[#]] &[ RotationTransform[(26 - 44 s) Degree][ Prepend[ToPol[ PlaneGeo[MakePoly[RawAData], MakePoly[RawZData], s]], {0, 0}]]]; Graphics[{Thickness[.008], JoinForm["Round"], Blend[cols[[;; 2]], s], Line[centeredpoints]}, ImageSize -> {540, 540}, PlotRange -> {{-.26 + .02 s, .29 + .02 s}, {-.28 - .065 s, .32 - .065 s}}, Background -> cols[[-1]]], {t, 0, 1}] ] [1]: http://community.wolfram.com/groups/-/m/t/760148 [2]: http://community.wolfram.com/groups/-/m/t/782316 [3]: http://community.wolfram.com/groups/-/m/t/783758 [4]: http://community.wolfram.com/groups/-/m/t/785078 [5]: http://community.wolfram.com/groups/-/m/t/787596 [6]: http://community.wolfram.com/groups/-/m/t/865171 [7]: https://en.wikipedia.org/wiki/Smoothstep [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=azdance2.gif&userId=610054 Clayton Shonkwiler 2016-11-01T22:22:30Z https://community.wolfram.com/groups/-/m/t/1214169 ![enter image description here][1] Dear all, from the resemblance of a Voronoi mesh to a jigsaw puzzle I came to the idea for the following little program I want to share. The essential function is (* in: points p1, p2; out: BSplineCurve = jigsaw side if distance > minLength; *) jigsawSide[minLength_][pts : {p1_, p2_}] := Module[{m, u, o, vx, vy, n, dist, r, c, angle0, cPts}, dist = EuclideanDistance @@ pts; If[dist < minLength, Return[Line[pts]]]; (* avoid borders: *) If[Times @@ (p2 - p1) == 0, Return[Line[pts]]]; m = Mean[pts]; {u, o} = SortBy[pts, Last]; (* lower/upper point *) {vx, vy} = o - u; n = {vy, -vx}; (* normal vector *) r = .15 dist; (* radius *) c = m + n/4.; (* center *) angle0 = Sign[Last[n]] VectorAngle[{1, 0}, n]; (* points on circle: *) cPts = c + r {Cos[angle0 + #], Sin[angle0 + #]} & /@ (60 \[Degree] {-2, -1, 0, 1, 2}); Return[BSplineCurve[{u, m, Sequence @@ cPts, m, o}]] ] which connects two points with a `BSplineCurve` having the typical elementary shape of a jigsaw puzzle. If the distance is too short then the connection becomes a straight line. The same happens if the points share the same x- or y-coordinate to exclude the jigsaws borders. Here is a simple test of the function: ![enter image description here][2] Anything else is straightforward: - start with "randomized" lattice points; - from these a Voronoi mesh is created; - extract its polygons; - convert the polygon sides into the new (puzzle) shape; - build new polygons out of these sides; - apply a texture. The result is a bunch of jigsaw pieces one can play with: ![enter image description here][3] I was impressed by the consistent behavior of `Texture`. The whole (short) code is attached. Best regards -- Henrik [1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=9927ezgif.com-optimize.gif&userId=11733 [2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=PieceSide.gif&userId=32203 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=JigsawsExample.png&userId=32203 Henrik Schachner 2017-11-04T19:25:59Z https://community.wolfram.com/groups/-/m/t/2858759 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=HattilingsviaHTPFequivalence.png&userId=20103 [2]: https://www.wolframcloud.com/obj/8834ec94-ab97-4b06-9446-1654c806e062 Brad Klee 2023-03-24T23:19:15Z https://community.wolfram.com/groups/-/m/t/2944810 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=g43tgeffqv.jpeg&userId=11733 [2]: https://www.wolframcloud.com/obj/3b67604b-43d1-492d-b1c5-13046827d805 Michael Trott 2023-06-27T16:24:23Z https://community.wolfram.com/groups/-/m/t/1561288 **[Open in Cloud][1] | [See Original][2] | Download to Desktop via Attachments Below** ![enter image description here][3] &[Wolfram Notebook][4] [1]: https://www.wolframcloud.com/objects/wolfram-community/3D-version-of-the-built-in-VoronoiDiagram-by-Chip-Hurst [2]: https://mathematica.stackexchange.com/questions/18893/how-can-i-define-a-3d-version-of-the-built-in-voronoidiagram-voronoimesh-in-v10 [3]: https://community.wolfram.com//c/portal/getImageAttachment?filename=chip2.png&userId=20103 [4]: https://www.wolframcloud.com/obj/fcd0f8eb-5939-43fa-a040-4b0705220700 Greg Hurst 2018-11-28T19:03:50Z https://community.wolfram.com/groups/-/m/t/1025180 EDIT: See also the follow up posts [here.][1] and [here][2]. ![enter image description here][3] Roughly 8-9 years ago a friend of mine told me I could make the Sierpinski triangle by starting at one of the vertices of an equilateral triangle, and then repeatedly jump half-way to one of the (randomly chosen) vertices. ## 0 memory ## The following code will accomplish that: ClearAll[sequence] sequence[n_,m_]:=RandomChoice[Range[n],m] pts=N@CirclePoints[3]; pts=FoldList[(#1+pts[[#2]])/2&,RandomChoice[pts],sequence[3,10]] Graphics[{{FaceForm[],EdgeForm[Black],RegularPolygon[3]},Red,Arrow[Partition[pts,2,1]]}] giving: ![enter image description here][4] If one does this 1000s of time, and only mark the viewed points, one will get: ClearAll[sequence] sequence[n_,m_]:=RandomChoice[Range[n],m] pts=N@CirclePoints[3]; pts=FoldList[(#1+pts[[#2]])/2&,RandomChoice[pts],sequence[3,25000]]; Graphics[{FaceForm[],EdgeForm[Black],RegularPolygon[3],PointSize[0.001],Point[pts]}] giving: ![enter image description here][5] Which will indeed show that by randomly choosing a vertex we can still get structure! Quite a surprise! Of course we can do this with squares, pentagons, hexagons et cetera: ClearAll[sequence] sequence[n_,m_]:=RandomChoice[Range[n],m] Table[ circlepoints=N@CirclePoints[n]; pts=FoldList[(#1+circlepoints[[#2]])/2&,RandomChoice[circlepoints],sequence[n,50000]]; Rasterize[Graphics[{FaceForm[],EdgeForm[Black],RegularPolygon[n],PointSize[0.001],Point[pts]},ImageSize->500,PlotRange->1.1],"Image"] , {n,3,8} ] // Partition[#, 3] & // ImageAssemble giving: ![enter image description here][6] Very neat! (apart from 4, which just gives a homogeneous distribution of points). Here I run the pentagon many many points and high resolution to get: ![enter image description here][7] Where now the gray-color represents the density of points. ## 0 memory - restricted ## Now we can make the dynamics a bit more interesting by not moving to any other vertex but to only specific vertices. Imagine that we are at some position p, then we always have n choices (n being the number of sides): we can jump to the vertex 1 ahead, 2 ahead, .... n ahead (same as last time). ClearAll[CreateSequence,CreateSequenceImage] CreateSequence[n_,steps_,choices_]:=Mod[Accumulate[RandomChoice[choices,steps-1]~Prepend~1],n,1] CreateSequenceImage[n_,m_,choices_]:=Module[{seq,pts}, seq=CreateSequence[n,m,choices]; pts=N@CirclePoints[n]; seq=FoldList[(#1+pts[[#2]])/2&,First[pts],seq]; Rasterize[Graphics[{PointSize[0.001],Point[seq]},ImageSize->500,PlotRange->1],"Image",RasterSize->{300,300}] ] For a 3 sided polygon (i've been told these are called triangles) we can jump 1, 2, or 3 ahead or subsets of that: Grid[Join@@@Partition[{#,CreateSequenceImage[3,10^5,#]}&/@Subsets[Range[3],{1,\[Infinity]}],UpTo[3]],Frame->All] ![enter image description here][8] Some interesting structure can be seen for some of the subsets. For squares: Grid[Join@@@Partition[{#,CreateSequenceImage[4,10^5,#]}&/@Subsets[Range[4],{1,\[Infinity]}],UpTo[4]],Frame->All] ![enter image description here][9] and for pentagons: Grid[Join@@@Partition[{#,CreateSequenceImage[5,10^5,#]}&/@Subsets[Range[5],{1,\[Infinity]}],UpTo[4]],Frame->All] ![enter image description here][10] the higher the number of sides, the more subsets we can choose. The number of subsets scales as 2^n -1 (minus one because the set can not be empty; we have to jump somewhere!). Lastly, for hexagons: Grid[Join@@@Partition[{#,CreateSequenceImage[5,10^5,#]}&/@Subsets[Range[5],{1,\[Infinity]}],UpTo[4]],Frame->All] ![enter image description here][11] Ok, you can try polygons with large number of sides on your own, but note that the number of subsets doubles every time. ## 1 memory - restricted ## We can even go beyond this, and consider the position of the penultimate vertex as well: ![enter image description here][12] We can consider 5 cases for a pentagon (or, in general, n cases). We will consider the last point to be at position 0 (or n), now the penultimate vertex could be in 5 different positions. For each of these combinations we can choose a different subset of {1,2,3,4,5}. Just to get an idea how many possibilities we now have: the number of subsets is 2^n - 1, and we have to choose n of these, so there will be (2^n-1)^n different systems to explore: Table[{n, (2^n - 1)^n}, {n, 3, 8}] // Grid ![enter image description here][13] as one can see, the combination grow very quickly. ClearAll[Stamp,CreateSequence2,CreateSequenceImage2] CreateSequence2[n_,m_,start:{start1_,start2_},choices_]:=Module[{out,last, penultimate,new,pos2}, {penultimate,last}=out=start; out=Reap[Do[ pos2=Mod[penultimate-last,n,1]; new=Mod[last+RandomChoice[choices[[pos2]]],n,1]; penultimate=last; last=new; Sow[new] , {m-2} ]][[2,1]]; Join[start,out] ] Stamp[n_,choices_]:=Module[{}, Image[Normal[SparseArray[Thread[Join@@MapThread[Thread[{#1,#2}]&,{Range[Length[choices]],choices}]->1],{n,n}]]] ] CreateSequenceImage2[n_,m_,start:{start1_,start2_},choices_]:=Module[{seq,pts,ras,stamp}, seq=CreateSequence2[n,m,start,choices]; pts=N@CirclePoints[n]; seq=FoldList[(#1+pts[[#2]])/2&,First[pts],seq]; ras=Rasterize[Graphics[{PointSize[0.001],Point[seq]},ImageSize->500,PlotRange->1],"Image",RasterSize->{300,300}]; stamp=ImagePad[Stamp[n,choices],1,Red]; ImageCompose[ras,stamp,{Center,Bottom},{Center,Bottom}] ] Before looking at the general case, we can look at a small subset, namely one can **not** jump i ahead from the last, and j ahead from the penultimate. Here the example for i=1, and j =3: ClearAll[JumpPos2] JumpPos2[n_,{d1_,d2_}]:=Module[{pos}, pos=Range[n]; pos=DeleteCases[pos,d1]; DeleteCases[pos,Mod[d2+#,n,1]]&/@Range[n] ] CreateSequenceImage2[4,10^4,{1,2},JumpPos2[4,{1,3}]] ![enter image description here][14] Very neat structure! Of course we can try all i and j from the set {1,2,3,4}: delta=Tuples[Range[4],2]; deltas=JumpPos2[4,#]&/@delta; Grid[Join@@@Table[{{i,j},CreateSequenceImage2[4,10^4,{1,2},JumpPos2[4,{i,j}]]},{i,4},{j,4}],Frame->All] ![enter image description here][15] All very neat, but it is just a small subset of the 50625 possibilities. Here let's try 64 random ones: sc=Reverse@Subsets[Range[4],{1,\[Infinity]}]; Table[ CreateSequenceImage2[4,10^4,{1,2},RandomChoice[sc,4]] , {64} ] // Partition[#,8]& // ImageAssemble ![enter image description here][16] As you can see very nice and rich structure! Notice that I 'stamped' all of them with their 'input': CreateSequenceImage2[4, 10^4, {1, 2}, {{1, 4}, {3}, {1, 3, 4}, {1, 2, 3}}] ![enter image description here][17] And if one looks closely (save the image and zoom), one will see the 'stamp' (or the rule) at the bottom: ![enter image description here][18] This can be read as follows: - The first (top) line, the white pixels are in places 1 and 4, so if the penultimate vertex was '1', move 1 or 4 places from the last vertex - The 2nd line, the white pixel is in place 3, jump the position 3 ahead compared to last vertex - 3rd line, white pixel at 1,3, and 4. - 4th line 1, 2, or 3. Basically the nth line corresponds to the position of the penultimate vertex. and the white pixels corresponds to 'allowed' number of jumps. I'll stop here for now. There are many more ideas to explore, I'll name a few: - <s>3D positions, 3D images</s> See below the post of Henrik! - Anything other than regular polygons - Have different probabilities for each of the vertices... - Move in the perpendicular direction - ... See also the follow up posts [here.][19] and [here][20] and some additional visualizations below! [1]: http://community.wolfram.com/groups/-/m/t/1039030 [2]: http://community.wolfram.com/groups/-/m/t/1047603 [3]: http://community.wolfram.com//c/portal/getImageAttachment?filename=opener.png&userId=73716 [4]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial1.png&userId=73716 [5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial2.png&userId=73716 [6]: http://community.wolfram.com//c/portal/getImageAttachment?filename=3446trial3.png&userId=73716 [7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial4b.jpg&userId=73716 [8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial5.png&userId=73716 [9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial6.png&userId=73716 [10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial7.png&userId=73716 [11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial8.png&userId=73716 [12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=explanation-01.png&userId=73716 [13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial9.png&userId=73716 [14]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial10.png&userId=73716 [15]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial11.png&userId=73716 [16]: http://community.wolfram.com//c/portal/getImageAttachment?filename=5983trial12.png&userId=73716 [17]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial13.png&userId=73716 [18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=trial14.png&userId=73716 [19]: http://community.wolfram.com/groups/-/m/t/1039030 [20]: http://community.wolfram.com/groups/-/m/t/1047603 Sander Huisman 2017-03-04T21:41:21Z https://community.wolfram.com/groups/-/m/t/3545275 ![Bloom pattern for flat-foldable origami orbital solar sail or solar shield][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=8711FoldingPanel1.gif&userId=20103 [2]: https://www.wolframcloud.com/obj/d629766d-966c-4dcb-8880-894747e31c6d Gilmer Gary 2025-09-14T03:12:52Z https://community.wolfram.com/groups/-/m/t/2142619 ![enter image description here][1] &[Wolfram Notebook][2] [1]: https://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2020-12-19at3.59.46PM.jpg&userId=20103 [2]: https://www.wolframcloud.com/obj/4e3fd64d-1b64-4070-8b33-defd8a719cc5 [Original]: https://www.wolframcloud.com/obj/wolfram-community/Published/LoveHeartJewelry_1.nb Frederick Wu 2020-12-19T18:18:44Z 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