Community RSS Feed
http://community.wolfram.com
RSS Feed for Wolfram Community showing any discussions in tag Recreation sorted by active[Numberphile] - The Square-Sum Problem
http://community.wolfram.com/groups/-/m/t/1264240
As part of my Numberphile series of posts:
- [\[Numberphile\] - Frog Jumping - Solving the puzzle][1]
- [\[Numberphile\] - The Illumination Problem][2]
- [\[Numberphile\] - Sandpiles - Done in the Wolfram Language][3]
here is another one about a recent video called [The Square-Sum Problem][4]
[![enter image description here][5]][6]
The question is: if you have the integers 1 through n, can you arrange that list in such a way that every two adjacent ones sum to a square number. As seen in the video and the [extra footage][7].
We can easily check this in the Wolfram Language:
Let's see which number can pair up to a pair:
SquareEdges[n_Integer?Positive]:=Reap[Do[If[IntegerQ[Sqrt[i+j]],Sow[{i,j}]],{i,n-1},{j,i+1,n}]][[2,1]]
Now let's try for 15, as in the main video:
n = 15;
poss = SquareEdges[n];
gr = Graph[TwoWayRule @@@ poss, VertexLabels -> Automatic];
path = FindHamiltonianPath[gr, PerformanceGoal :> "Speed"]
HighlightGraph[gr, BlockMap[Rule @@ # &, path, 2, 1]]
giving:
{9, 7, 2, 14, 11, 5, 4, 12, 13, 3, 6, 10, 15, 1, 8}
![enter image description here][8]
In the extra footage, it is revealed that they found the solution for up to n=299. Can we do better? Yes we can! Changing n to 300 in the above code and rerunning gives us the solution in 0.28 sec on my laptop.
{289,35,65,259,30,294,67,257,32,292,69,100,44,125,71,154,135,189,211,113,248,8,281,119,205,195,166,158,283,6,250,191,133,156,285,4,252,277,12,244,117,207,193,168,273,16,240,160,164,236,20,269,131,94,230,59,197,92,232,57,199,90,234,22,267,217,224,137,152,73,123,46,150,75,121,48,148,77,179,110,214,270,19,237,163,161,239,17,272,128,41,103,297,27,262,62,227,97,99,190,210,114,175,50,146,79,177,112,212,188,253,3,286,155,134,266,23,233,91,198,58,231,93,196,60,229,95,130,159,165,276,13,243,118,206,194,167,274,15,241,288,1,255,186,138,223,218,143,181,108,88,201,55,170,86,203,53,172,84,37,107,182,142,299,25,264,220,221,140,184,216,225,64,36,85,171,54,202,87,169,56,200,89,235,21,268,132,157,284,5,251,278,11,245,116,208,192,249,7,282,247,9,280,204,120,136,153,72,124,45,151,74,122,47,149,76,180,109,215,185,139,222,219,265,24,300,141,183,106,38,83,173,52,144,81,40,104,296,28,261,63,226,98,127,42,102,298,26,263,61,228,96,129,271,18,238,162,279,10,246,115,209,275,14,242,287,2,254,187,213,111,178,78,147,49,176,80,145,51,174,82,39,105,295,29,260,101,43,126,70,291,33,256,68,293,31,258,66,34,290}
and a completely mess of a graph:
![enter image description here][9]
Can we go beyond? Let's optimize a code a bit, and let's find the solution for larger n:
Let's store our intermediate results in the association **db**:
SetDirectory[NotebookDirectory[]];
$HistoryLength=1;
db=If[FileExistsQ["squaresumdb.mx"],
Import["squaresumdb.mx"]
,
<||>
];
And now our main code:
ClearAll[SquareEdges,SquareEdges2,CheckSol,TryToFind]
SquareEdges[n_Integer?Positive]:=Reap[Do[If[IntegerQ[Sqrt[i+j]],Sow[{i,j}]],{i,n-1},{j,i+1,n}]][[2,1]]
SquareEdges2[n_Integer]:=Module[{tmp},
tmp=Table[
{i,#}&/@(Range[Ceiling[Sqrt[2 i]],Floor[Sqrt[i+n]]]^2-i)
,
{i,1,n-1}
];
tmp=Join@@tmp;
Select[tmp,Less@@#&]
]
CheckSol[l_List]:=Sort[l]===Range[Length[l]]\[And](And@@BlockMap[IntegerQ@*Sqrt@*Total,l,2,1])
TryToFind[n_Integer?Positive]:=Module[{edges,out},
If[!KeyExistsQ[db,n],
edges=SquareEdges2[n];
If[Union[Flatten[edges]]===Range[n],
edges=TwoWayRule@@@edges;
edges=RandomSample[edges];
Do[
out=TimeConstrained[FindHamiltonianPath[Graph[edges],PerformanceGoal:>"Speed"],5+i,$Failed];
If[out=!=$Failed,
If[Length[out]==0,
Print[Style["No solution for ",Red],n];
,
status=Row[{"Found solution for ",n,":",i}];
];
AssociateTo[db,n->out];
Break[]
];
Print["Failed ",n,":",i];
edges=RandomSample[edges];
,
{i,5}
]
,
Print["Edges are not connected for ",n];
AssociateTo[db,n->{}]
]
]
]
Let's scan the first 1000:
Dynamic[status]
status = "";
Do[TryToFind[k], {k, 3, 1000}]
Export["squaresumdb.mx", db];
Note that if finding the Hamiltonian path takes too long I mix the edges and try again, sometimes, seemingly random, it then finds the solution quickly.
I can tell you now that all of them have a solution. In fact I went up to larger numbers and found that all up to 2667 have a solution, and possibly beyond. I attached the notebook and the solutions in form of a mx file.
[1]: http://community.wolfram.com/groups/-/m/t/1055504
[2]: http://community.wolfram.com/groups/-/m/t/1048489
[3]: http://community.wolfram.com/groups/-/m/t/1058615
[4]: https://www.youtube.com/watch?v=G1m7goLCJDY
[5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-01-11at23.36.51.png&userId=73716
[6]: https://www.youtube.com/watch?v=G1m7goLCJDY
[7]: https://www.youtube.com/watch?v=7_ph5djCCnM
[8]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-01-11at23.43.52.png&userId=73716
[9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2018-01-11at23.46.51.png&userId=73716Sander Huisman2018-01-11T23:29:05ZMathematica 11.3's new DeBruijnSequence: adding new dimensions
http://community.wolfram.com/groups/-/m/t/1301267
Introduction
----------
The new version of Mathematica (11.3) introduces a whole range of interesting new functionality. Some functions like [FindTextualAnswer][1] and [FindEquationalProof][2] quite clearly open up new possibilities and provide tools of enormous power. But MMA 11.3 also introduces a huge range of other functionality that might go a bit unnoticed but also is highly interesting. Here I show the example of [DeBruijnSequence][3] and [DeBruijnGraph][4] which are interesting not only for safe busters.
Suppose we have a lock like this one:
![enter image description here][5]
Suppose we have to enter a 4 digit code. There are $10^4=10000$ combinations, starting at 0000, 0001, ..., 9999. Each has 4 digits so if I want to test all combinations I will need 40000 keystrokes.
Let's suppose that the key lock is stupid, and only remembers the last for digits you entered. So if you entered 207689, it would have tested the combinations 2076, 0768, and 7689. So I only needed to type in 6 keystrokes instead of 12. We want to ask the following question:
> What is the shortest sequence of digits (keystrokes) that will contain
> all possible combination of 4 digits as subsequences?
The answer is given by the DeBruijnSequence, named after the Dutch mathematician [Nicolaas Govert (Dick) de Bruijn][6] (9 July 1918 – 17 February 2012).
Entity["Person", "NicolaasGovertDeBruijn::3s54p"][{"Image", "BirthDate", "DeathDate"}]
![enter image description here][7]
As my explanation of the problem is not good, I recommend [this video][8] where someone explains the whole thing much better than me.
A simpler problem
----------
Let's make the whole problem a bit simpler. Suppose I only have two digits 1 and 2 and I want to find all possible combinations of 2.
Tuples[{1, 2}, 2]
(*{{1, 1}, {1, 2}, {2, 1}, {2, 2}}*)
So there are 4 tuples of length 2, which require me to type in 8 keystrokes. Let's see if we can do better if the lock remembers only the last for digits entered. The sequence
1, 1, 2, 2,1
solves this problem. If I partition it and always shift by one I get:
Partition[{1, 1, 2, 2, 1}, 2, 1]
(*{{1, 1}, {1, 2}, {2, 2}, {2, 1}}*)
All combinations of subsequences. It turns out that the sequence 1,1,2,2,1 is a DeBruijnSequence:
DeBruijnSequence[{1, 2}, 2]
(*{1, 1, 2, 2}*)
Note that I have to read the sequence cyclically, i.e. when I reach the end I have to keep typing (length of required sequences)-1 digits from the beginning. In this case the length the subsequences is 2 so I need to add the first digit to the end:
1,1,2,2,1
How can we find such a sequence? Well, one way is to write down all the tuples of two digits:
Tuples[{1, 2}, 2]
(*{{1, 1}, {1, 2}, {2, 1}, {2, 2}}*)
We then look for "overlapping sequences". So for example takes the first element of the tuple list {1,1}, delete its first entry {1} and then take all list that you can construct by adding one digit to the end: {1,1} and {1,2}. This gives two links in a graph {1,1}->{1,1} and {1,1}->{1,2}. We then proceed like that for all other tuples, i.e. we link them to those tuples that can be generated by deleting the first entry and adding any of the available digits:
DeleteCases[Flatten[Outer[If[Drop[#1, 1] == Drop[#2, -1], #1 -> #2] &, tuples, tuples, 1], 1], Null]
(*{{1, 1} -> {1, 1}, {1, 1} -> {1, 2}, {1, 2} -> {2, 1}, {1, 2} -> {2, 2}, {2, 1} -> {1, 1}, {2, 1} -> {1, 2}, {2, 2} -> {2, 1}, {2, 2} -> {2, 2}}*)
The respective graph looks like this:
g = Graph[DeleteCases[Flatten[Outer[If[Drop[#1, 1] == Drop[#2, -1], #1 -> #2] &, tuples, tuples, 1], 1], Null], PlotTheme -> "Scientific"]
![enter image description here][9]
Next we need to find a HamiltonianPath, i.e. a path that visits every note exactly once:
hamiltonpath = FindHamiltonianPath[g]
(*{{1, 1}, {1, 2}, {2, 2}, {2, 1}}*)
The rule to construct the DeBruijnSequence is then easy. We use the first entry of the path, i.e. {1,1} and then add one by one the second elements of all tuples in the list:
sequence = Join[hamiltonpath[[1]], hamiltonpath[[2 ;;, 2]]]
(*{1, 1, 2, 2, 1}*)
Note that the DeBruijnSequence that Mathematica gives is one shorter, i.e. cyclic, ours just reconstructed sequence is not!
The Wolfram Language also has a function that directly constructs the Graph:
DeBruijnGraph[2, 2, PlotTheme -> "Scientific"]
![enter image description here][10]
This graph looks different from the one we constructed above, but this is just its layout. In fact the graphs are isomorphic:
IsomorphicGraphQ[DeBruijnGraph[2, 2], g]
evaluates to "True".
A slightly more complicated example
----------
Ok. Let's do one more example. We are looking for sequences of length 2 on an alphabet of three digits, 1,2, and 3.
tuples = Tuples[{1, 2, 3}, 2];
g = Graph[DeleteCases[Flatten[Outer[If[Drop[#1, 1] == Drop[#2, -1], #2 -> #1] &, tuples, tuples, 1], 1], Null], PlotTheme -> "Scientific"]
![enter image description here][11]
which turns out to be isomorphic to
DeBruijnGraph[3, 2, PlotTheme -> "Scientific"]
![enter image description here][12]
so that
IsomorphicGraphQ[DeBruijnGraph[3, 2], g]
gives "True".
Solution to our problem
----------
We are not ready to solve our key lock problem. We are looking for the DeBruijnSequence for string length 4 and on the 10 digits 0,1,2,...,9.
DeBruijnSequence[10, 4]
![enter image description here][13]
The sequence is
DeBruijnSequence[10, 4] // Length
10000 long, but it's cyclic so we have to add the first three digits to the end to have all combinations. This means that 10003 keystrokes are enough, which has just saved us nearly 30000 keystrokes!!!! This is fantastic if you want to bust a safe.
For those interested: [here is the explanation by a professional][14].
Note, that this is quite useful for [DNA sequencing][15], too.
Extending the DeBruijnSequence to more dimensions
----------
Of course, a mathematician always asks whether we can generalise this. Let's try to generate a two dimensional DeBruijn sequence, i.e. a torus instead of a cycle like before (remember that the sequence that the Wolfram Langauge generates has to be considered to be cyclic!). Again you can find the main idea on [this website][16].
It turns out that there is, of course, maths for this: [Toroidal tilings from de Bruijn-Good cyclic sequences][17]. The algorithm is a bit technical, but at the end we obtain:
deBruijn2D[symbols_, l_, w_] :=
Module[{column1, shifts, solution},
column1 = DeBruijnSequence[symbols , l];
shifts = DeBruijnSequence[symbols^l, w - 1];
solution = Transpose[FoldList[RotateLeft, column1, shifts][[;; -2]]];
If[EvenQ[symbols] && w == 2, Join[#, {#[[1]]}] &@Transpose[Join[Transpose[solution], {RotateLeft[Transpose[solution][[1]], 1/2 symbols^l]}]],
Join[#, {#[[1]]}] &@Transpose[Join[Transpose[solution], {Transpose[solution][[1]]}]]]]
The input slots are:
- symbols : number of different symbols (will be represented as digits starting at zero.
- length: length of the sequences; similar to the one dimensional case ("of length 4").
- width: similar to length but for the second direction; refer to paper.
In fact if length_ is m, width_ is n and we have an alphabet of c numbers, then we obtain an array of size: $c^m \times c^{m(n-1)}$. So here is the DeBruijn tiling in two dimensions, on two digits where the length and width are both 2.
deBruijn2D[2, 2, 2] // MatrixForm
![enter image description here][18]
Here is a more colourful representation:
ArrayPlot[deBruijn2D[2, 2, 2] /. {0 -> Red, 1 -> Green}]
![enter image description here][19]
This is actually quite useful. Every 2 by 2 square is unique in the plane and all combinations occur. This means that if I know the colours of the tiles in one 2 by 2 square I know where I am on the plane!!!!
More symbols/larger systems
----------
Let's look at a system with 4 symbols and 2 by 2 square tiles.
solution=deBruijn2D[4, 2, 2]
Here is a nice representation of that (in which I have "added" a column/row to take care of the cyclicity):
Grid[Partition[Grid /@ Flatten[Partition[solution /. {0 -> White, 1 -> Green, 2 -> Blue, 3 -> Red}, {2, 2}, 1], 1], 16], Frame -> All]
![enter image description here][20]
Modulo bugs in my code, each of these 2-by-2 squares should be "unique". There should be $4^4=256$ different 2-by-2 tiles:
Length[Flatten[Partition[solution2, {2, 2}, 1], 1] // DeleteDuplicates]
gives 256, which is a good sign. Here is another representation without the black grid (which is also non-cyclic):
ImageAssemble[(Graphics[{#, Rectangle[]}] & /@ #) & /@ (solution/. {0 -> White, 1 -> Green, 2 -> Blue, 3 -> Red})]
![enter image description here][21]
Of course, everything actually lives on a torus:
imgtiles = ImageAssemble[(Graphics[{#, Rectangle[]}] & /@ #) & /@ (solution[[;; -2]][[All, ;; -2]] /. {0 -> White, 1 -> Green, 2 -> Blue, 3 -> Red})];
img = ImageResize[imgtiles, 775];
imgmatrix = Join[ImageData[img], ImageData[img]];
frames = Table[
ParametricPlot3D[{Cos[u] (3 + Cos[v]), Sin[u] (3 + Cos[v]), Sin[v]}, {u, 0, 2 \[Pi]}, {v, 0, 2 \[Pi]},
TextureCoordinateFunction -> ({ #4, #5} &), PlotStyle -> Directive[Specularity[White, 50], Texture[Image[imgmatrix[[g ;; g + 774, All, All]]]]],
Axes -> False, Lighting -> "Neutral", Mesh -> None, Boxed -> False, ImageSize -> 900], {g, 1, 775, 7}];
Do[Export["~/Desktop/DeBruijnTorus/frame" <> ToString[1000 + i] <> ".jpg", frames[[i]]], {i, 1, Length[frames]}]
![enter image description here][22]
Automatic graphics
----------
We can create another function for the visualisation:
deBruijnPlot[matrix_] := Module[{}, (MatrixPlot[# /. (Rule @@@ Transpose[{#, RandomColor[Length[#]]}] &@
DeleteDuplicates[Sort[Flatten[#]]])]) &@matrix ]
So we get:
deBruijnPlot[deBruijn2D[4, 2, 2]]
![enter image description here][23]
Conclusion
----------
DeBruijnSequences are very intriguing mathematical objects with many applications. Here is for example a [card trick based on the DeBruijnSequence][24]. They can help to sequence DNA and to know where you are on a plane if all you have is very local information.
The functions that I introduced in this post are not optimised at all. They are relatively slow, and you will have to respect certain rules for length and width. Also the size of the matrices increases very fast as the number of symbols, length and width increase. Some slightly larger systems than the ones shown in the post can be computed, however, and their patterns are intriguing:
deBruijnPlot[deBruijn2D[8, 3, 2]]
![enter image description here][25]
They are obviously a consequence of the algorithm that I have used.
It is also quite possible to extend the entire procedure to more than 2 dimensions, but that is for another day....
Cheers,
Marco
[1]: https://reference.wolfram.com/language/ref/FindTextualAnswer.html
[2]: http://reference.wolfram.com/language/ref/FindEquationalProof.html
[3]: https://reference.wolfram.com/language/ref/DeBruijnSequence.html
[4]: https://reference.wolfram.com/language/ref/DeBruijnGraph.html
[5]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2018-03-1222.12.22.png&userId=48754
[6]: https://en.wikipedia.org/wiki/Nicolaas_Govert_de_Bruijn
[7]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2018-03-1222.24.21.png&userId=48754
[8]: https://www.youtube.com/watch?v=85-PsYvWprA
[9]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2018-03-1222.40.55.png&userId=48754
[10]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2018-03-1222.45.52.png&userId=48754
[11]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2018-03-1222.48.29.png&userId=48754
[12]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2018-03-1222.49.06.png&userId=48754
[13]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2018-03-1222.58.32.png&userId=48754
[14]: https://www.youtube.com/watch?v=iPLQgXUiU14&vl=en-GB
[15]: http://www.datagenetics.com/blog/october22013/index.html
[16]: http://www.datagenetics.com/blog/october22013/index.html
[17]: https://www.sciencedirect.com/science/article/pii/0012365X88900957
[18]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2018-03-1223.14.28.png&userId=48754
[19]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2018-03-1223.16.32.png&userId=48754
[20]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2018-03-1223.21.52.png&userId=48754
[21]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2018-03-1223.25.54.png&userId=48754
[22]: http://community.wolfram.com//c/portal/getImageAttachment?filename=4943animated.gif&userId=48754
[23]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2018-03-1223.28.12.png&userId=48754
[24]: https://www.youtube.com/watch?v=EWG6e-yBL94
[25]: http://community.wolfram.com//c/portal/getImageAttachment?filename=Screenshot2018-03-1300.05.27.png&userId=48754Marco Thiel2018-03-13T00:07:14ZFor Pi Day: Volume=3.141 -- The Canonical Tetragonal Antiwedge Hexahedron
http://community.wolfram.com/groups/-/m/t/1301599
The weirdest of the seven hexahedra, the tetragonal antiwedge, is a self-dual polyhedron that has a volume of 3.141 in its canonical form. Here it is shown with its dual.
![The antiwedge][1]
Here's code for it.
verts={
{Root[-1+14 #1^2+25 #1^4-8 #1^6+#1^8&,1],1,Root[-1-14 #1^2+25 #1^4+8 #1^6+#1^8&,2]},{Root[-1+14 #1^2+25 #1^4-8 #1^6+#1^8&,2],1,-Root[-1-14 #1^2+25 #1^4+8 #1^6+#1^8&,2]},{-Root[-1+10 #1^2-31 #1^4+80 #1^6+#1^8&,2],-Root[1-8 #1-2 #1^2-8 #1^3+#1^4&,1],-Root[-1+6 #1^2-15 #1^4+8 #1^6+#1^8&,2]},{Root[-1+10 #1^2-31 #1^4+80 #1^6+#1^8&,2],-Root[1-8 #1-2 #1^2-8 #1^3+#1^4&,1],Root[-1+6 #1^2-15 #1^4+8 #1^6+#1^8&,2]},{Root[-1-2 #1^2+5 #1^4-4 #1^6+#1^8&,1],-1,Root[-1+2 #1^2+5 #1^4+4 #1^6+#1^8&,2]}, {Root[-1-2 #1^2+5 #1^4-4 #1^6+#1^8&,2],-1,-Root[-1+2 #1^2+5 #1^4+4 #1^6+#1^8&,2]}};
dualverts = {-1,-1,1}#&/@verts;
faces={{1,2,6,4},{1,5,3,2},{1,4,5},{2,3,6},{3,5,6},{4,6,5}};
Graphics3D[{Opacity[.6],EdgeForm[{Black, Thick}],
Polygon[verts[[#]]]&/@faces,Polygon[dualverts[[#]]]&/@faces,
Table[Style[Text[n,verts[[n]]],20],{n,1,6}],Red,Table[Style[Text[n,dualverts[[n]]],20],{n,1,6}]},
ImageSize-> {600,400}, ViewAngle-> Pi/12,ViewPoint-> {0,0,3},Boxed-> False, SphericalRegion-> True]
Volume[ConvexHullMesh[verts]]
In the canonical form, all faces are planar and all edges are tangent to the unit sphere. Combined with the dual, all edges are perpendicular with an intersection at distance 1 from the origin.
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=antiwedge.jpg&userId=21530Ed Pegg2018-03-13T23:52:57Z