Community RSS Feed
http://community.wolfram.com
RSS Feed for Wolfram Community showing any discussions in tag Graphics and Visualization sorted by activeproblem to plot function (cannot get the plot of function)
http://community.wolfram.com/groups/-/m/t/1304256
f[b_] = ProbabilityDistribution[ b Exp[-bx] , {x, 0.01, \[Infinity]}, Assumptions -> b > 0];
Plot[PDF[f[1.5], x], {x, 0, 2}, PlotRange -> All]jawad hussain2018-03-18T17:20:09Z[✓] High resolution GeoElevationData ?
http://community.wolfram.com/groups/-/m/t/1188722
I'm trying to produce 3D models in the Wolfram Language of various mountains around the world. The GeoElevationData[] function does not have enough resolution for a good looking model at the scale of a mountain, so I'm searching for online data sets that have more resolution and can be imported into Wolfram. For mountains in the United States, the United States Geological Survey offers ArcGRID files that Wolfram can import. This has worked fabulously, producing models such as this:
![enter image description here][1]
(Can you tell what mountain it is?)
But when I try to find data for mountains outside the US, like Mt. Fuji or Mt. Everest, I get overwhelmed by the abundance of file formats that, as far as I can tell, won't work in Wolfram. I sense that there is a way to do this. Has anyone solved this problem before? I could sure use some help here.
Thanks in advance,
Mark Greenberg
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=ScreenShot2017-09-20at8.14.21AM.png&userId=788861Mark Greenberg2017-09-20T15:35:58ZParametricPlot3D doesn't work at all
http://community.wolfram.com/groups/-/m/t/1303304
Hey folks,
I recently installed Wolfram Mathematica on my laptop and I have just noticed that my program is completely incapable of producing three-dimensional parametric plots. I've tried looking for errors in my syntax but it didn't change a thing. I even ended up copying the example functions for parametricPlot3D and pasting them in my documents, but Mathematica only produced a blank cartesian coordinate system in two dimensions.
This is the line I used: ParametricPlot3D[{Sin[u], Cos[u], u/10}, {u, 0, 20}].. and Mathematica only produces blank two-dimensional coordinates.
Has anyone else experienced this problem? As I am fairily new to Mathematica it very well may be that I've committed a fundamental mistake but I sure can't seem to find one no matter how hard I try.
Anyway, I just wanted to show you my problem... If anyone knows a fix to this, make sure to let me know. Thank you in advance!Elia Schmidt2018-03-16T14:59:45Z[GIF] Caught (Voronoi cells of stereographically projected pattern)
http://community.wolfram.com/groups/-/m/t/1286395
![Voronoi cells of stereographically projected pattern][1]
**Caught**
Continuing with the stereographic projection theme. This time, I generated a bunch of points arranged in spirals on the sphere, like so:
![Points on the sphere][2]
Then I stereographically project the points to the plane and compute the Voronoi diagram of the resulting points. Throw in a rotation of the sphere and you get the above animation.
As for the code, first of all we need the stereographic projection map:
Stereo[p_] := p[[;; -2]]/(1 - p[[-1]])
Next, we need to define the points. It turned out that without throwing in some noise in the definition of the points, `VoronoiMesh[]` would occasionally fail, which is why I put in the `RandomVariate[]` business in both cylindrical coordinates:
pts = With[{n = 20},
Table[
CoordinateTransformData["Cylindrical" -> "Cartesian", "Mapping"]
[{Sqrt[1 - (z + #)^2], θ + RandomVariate[UniformDistribution[{-.00001, .00001}]]
+ (z + # + 2)/2 * π/2, z + #}
&[RandomVariate[UniformDistribution[{-.00001, .00001}]]]
],
{z, -.9, .9, 2/n}, {θ, 0, 2 π - 2 π/n, 2 π/n}]
];
Finally, then, here's the animation:
With[{cols = RGBColor /@ {"#F5841A", "#03002C"}},
Manipulate[
VoronoiMesh[
Stereo[RotationMatrix[θ, {1., 0, 0}].#] & /@ Flatten[pts, 1],
{{-4.1, 4.1}, {-4.1, 4.1}}, PlotTheme -> "Lines", PlotRange -> 4,
MeshCellStyle -> {{1, All} -> Directive[Thickness[.005], cols[[1]]]},
ImageSize -> 540, Background -> cols[[-1]]],
{θ, 0, π}
]
]
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=r11Lqrc.gif&userId=610054
[2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=5946Untitled-13.png&userId=610054Clayton Shonkwiler2018-02-16T21:10:29Z[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:05Z[✓] Override the default square aspect ratio of Contour or Plot3D images?
http://community.wolfram.com/groups/-/m/t/1303102
When one uses the default Plot3D command like:
Plot3D[Re[ufun[x, y]], {x, xlow, xhigh}, {y, ylow, yhigh},
ColorFunction -> "TemperatureMap"]
You get square (x,y) base plane plots. The actual aspect ratio is Aratio=(xhigh-xlow)/(yhigh-ylow). But when Aratio is say 10/1,
it would be nicer to have a rectangular shape base than the default Aratio=1 square one.
Do how to alter the above command to get a user controlled aspect ratio?
Thanks in advanceAnthony Kalinowski2018-03-15T19:56:43ZThe spherical Lloyd algorithm
http://community.wolfram.com/groups/-/m/t/1302146
![visualization of Lloyd relaxation with a Voronoi diagram][1]
[Lloyd's algorithm](https://en.wikipedia.org/wiki/Lloyd%27s_algorithm) is a method that repeatedly generates the Voronoi diagram of a given set of points, and then replaces each point with the centroid of its corresponding Voronoi cell. It is useful for evenly redistributing points around a rectangular region.
Code for the usual Euclidean version can be found in [this Mathematica Stack Exchange post](https://mathematica.stackexchange.com/a/97358).
In this post, I will be demonstrating the spherical version of Lloyd's algorithm.
The code has its roots in [a Wolfram Demonstration written by Maxim Rytin](http://demonstrations.wolfram.com/VoronoiDiagramOnASphere/) for rendering a spherical Voronoi diagram. I had modernized it in [this Mathematica Stack Exchange post](https://mathematica.stackexchange.com/a/142100), and then had the notion that this code could be extended to implement the spherical Lloyd algorithm.
First, we need a few auxiliary routines. Older versions of *Mathematica* had an unstable implementation of `VectorAngle[]`, so I wrote [a stable version](https://mathematica.stackexchange.com/a/97854):
vecang[v1_?VectorQ, v2_?VectorQ] := Module[{n1 = Norm[v1], n2 = Norm[v2]},
2 ArcTan[Norm[v1 n2 + n1 v2], Norm[v1 n2 - n1 v2]]]
(You should be able to replace this with `VectorAngle[]` from version 11.2 onwards.)
Next, I needed a faster version of `RotationMatrix[]` for rotating one vector into another, so I wrote [a routine for doing that](https://mathematica.stackexchange.com/a/167114), too:
vectorRotate[vv1_?VectorQ, vv2_?VectorQ] :=
Module[{v1 = Normalize[vv1], v2 = Normalize[vv2], c, d, d1, d2, t1, t2},
d = v1.v2;
If[TrueQ[Chop[1 + d] == 0],
c = UnitVector[3, First[Ordering[Abs[v1], 1]]];
t1 = c - v1; t2 = c - v2; d1 = t1.t1; d2 = t2.t2;
IdentityMatrix[3] - 2 (Outer[Times, t2, t2]/d2 -
2 t2.t1 Outer[Times, t2, t1]/(d2 d1) + Outer[Times, t1, t1]/d1),
c = Cross[v1, v2];
d IdentityMatrix[3] + Outer[Times, c, c]/(1 + d) - LeviCivitaTensor[3].c]]
These two are needed for computing the "spherical centroid" of a spherical polygon, as defined by [Buss and Fillmore](https://doi.org/10.1145/502122.502124):
(* exponential map for sphere *)
sphereExp[q_?VectorQ, p_?VectorQ] /; Length[q] == Length[p] + 1 :=
With[{n = Norm[p]}, vectorRotate[{0, 0, 1}, q].Append[p Sinc[n], Cos[n]]]
(* inverse of exponential map for sphere *)
sphereLog[q_?VectorQ, p_?VectorQ] /; Length[q] == Length[p] :=
Most[vectorRotate[q, {0, 0, 1}].p]/Sinc[vecang[p, q]]
SphericalPolygonCentroid[pts_?MatrixQ] := Module[{k = 0, n = Length[pts], cp, h, pr},
cp = Normalize[Total[pts]];
pr = Internal`EffectivePrecision[pts];
While[cp = sphereExp[cp, h = Sum[sphereLog[cp, p], {p, pts}]/n];
k++; Norm[h] > 10^(-pr/2) && k <= 30];
cp]
Before I show the algorithm, let us first generate some starting points that will be "relaxed" by Lloyd's algorithm:
BlockRandom[SeedRandom[1337, Method -> "MersenneTwister"];
points = {2 π #1, ArcCos[2 #2 - 1]} & @@@ RandomReal[1, {50, 2}]]
(* convert to Cartesian *)
sp = Function[{u, v}, {Cos[u] Sin[v], Sin[u] Sin[v], Cos[v]}] @@@ points;
The code that implements Lloyd's algorithm is now remarkably compact:
With[{maxit = 40, (* maximum iterations *)
tol = 0.002 (* distance tolerance *)},
fr = FixedPointList[Function[pts,
Block[{ch, polys, verts, vor},
ch = ConvexHullMesh[pts];
verts = MeshCoordinates[ch];
polys = First /@ MeshCells[ch, 2];
vor = Normalize[Cross[verts[[#2]] - verts[[#1]],
verts[[#3]] - verts[[#1]]]] & @@@ polys;
SphericalPolygonCentroid[vor[[#]]] & /@ ch["VertexFaceConnectivity"]]],
sp, maxit,
SameTest -> (Max[MapThread[vecang, {#1, #2}]] < tol &)]];
I used `FixedPointList[]` so that I can visualize the progress of the algorithm in what follows. One can just use `FixedPoint[]`, of course, if only the final result is wanted.
Now, we can visualize how the points move:
frames = Graphics3D[{{Opacity[.75], Sphere[]}, {Green, Sphere[#, 0.02]}}, Boxed -> False] & /@ fr;
ListAnimate[frames]
![progress of points being relaxed by the Lloyd algorithm][2]
---
One might instead want to see how the Voronoi cells themselves shift around as Lloyd's algorithm proceeds. Visualizing that will require a bit more work.
First, we need a way to render individual spherical polygons, corresponding to the cells of a spherical Voronoi diagram. In [this Mathematica Stack Exchange post](https://mathematica.stackexchange.com/a/154112), I gave routines for rendering a spherical polygon, which I reproduce here along with its auxiliary routines:
(* slerp for two points *)
slerp = Compile[{{q1, _Real, 1}, {q2, _Real, 1}, {f, _Real}},
Module[{n1 = Norm[q1], n2 = Norm[q2], omega, so},
omega = 2 ArcTan[Norm[q1 n2 + n1 q2], Norm[q1 n2 - n1 q2]];
If[Chop[so = Sin[omega]] == 0, q1, Sin[{1 - f, f} omega].{q1, q2}/so]]];
(* stripped down version of functions in
https://mathematica.stackexchange.com/a/10385 *)
sphericalLinearInterpolation[pts_?MatrixQ] := Module[{times},
times = Accumulate[Prepend[vecang @@@ Partition[pts, 2, 1, 1], 0]];
{Last[times], sphericalInterpolatingFunction[times, pts]}]
sphericalInterpolatingFunction[times_, vecs_][t_?NumericQ] :=
With[{k = GeometricFunctions`BinarySearch[times, t]},
slerp[vecs[[k]], vecs[[k + 1]], Rescale[t, times[[{k, k + 1}]], {0, 1}]]]
SphericalPolygon[pts_?MatrixQ, p_: 8] := SphericalPolygon[pts, {p, p}]
SphericalPolygon[pts_?MatrixQ, {p_, q_}] := Module[{ch, cp, en, pt, ql, sp, spl},
cp = SphericalPolygonCentroid[pts];
{en, sp} = sphericalLinearInterpolation[ArrayPad[pts, {{0, 1}}, "Periodic"]];
ch = Sin[π Range[p]/(2 p)]^2; (* rescaled Chebyshev points *)
spl = Most[First[Cases[ParametricPlot3D[sp[t], {t, 0, en}, PlotPoints -> q],
Line[l_] :> l, ∞]]];
ql = Length[spl];
pt = Prepend[Apply[Join, Outer[Normalize[#1.{cp, #2}] &,
Transpose[{Append[Reverse[Most[ch]], 0], ch}],
spl, 1]], cp];
GraphicsComplex[pt, {EdgeForm[],
Polygon[PadLeft[Partition[Range[ql] + 1, 2, 1], {Automatic, 3}, 1]
~Join~
Flatten[Apply[Join[Reverse[#1], #2] &,
Partition[Partition[Range[p ql] + 1, ql],
{2, 2}, {1, 1},
{{1, 1}, {-1, 1}}],
{2}], 1]]}, VertexNormals -> pt]]
Here is a routine for generating the spherical Voronoi diagram itself (cf. the Lloyd implementation given above):
sphericalVoronoi[pts_?MatrixQ] := Module[{ch, polys, verts, vor},
ch = ConvexHullMesh[pts];
verts = MeshCoordinates[ch];
polys = First /@ MeshCells[ch, 2];
vor = Normalize /@ (Cross[verts[[#2]] - verts[[#1]],
verts[[#3]] - verts[[#1]]] & @@@ polys);
{vor, ch["VertexFaceConnectivity"]}]
The following code will then generate the cartoon at the beginning of this post:
frames = Function[pts,
Graphics3D[{MapIndexed[{ColorData[99] @@ #2, SphericalPolygon[#1, 12]} &,
(Function[idx, #1[[idx]]] /@ #2) & @@ sphericalVoronoi[pts]],
{Green, Sphere[pts, 0.02]}},
Boxed -> False, Lighting -> "Neutral"]] /@ fr;
ListAnimate[frames]
[1]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sphlloydb.gif&userId=520181
[2]: http://community.wolfram.com//c/portal/getImageAttachment?filename=sphlloyda.gif&userId=520181J. M.2018-03-14T08:40:08ZArrowHead not at the end of a tube? (Mathematica V11.3)
http://community.wolfram.com/groups/-/m/t/1302365
With the 11.3 version the combination Arrow Tube give unexpected results : the arrow head is not positionned at the end of the tube as expected from documentation :
http://reference.wolfram.com/language/ref/Arrow.html
3rd example of the basics
Code example :
Graphics3D[{Red, Arrowheads[0.1],
Arrow[Tube[{{1, 1, -1}, {2, 2, 0}, {3, 3, -1}, {4, 4, 0}}, 0.05]]}]Dominique Massiot2018-03-14T17:17:07ZMathematica 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:57ZConway's structures
http://community.wolfram.com/groups/-/m/t/1301097
Recently I noticed here a thread about gliders:
http://community.wolfram.com/groups/-/m/t/1120326
I must say that I have virtually almost no idea about "cellular autmatons" ("automata"?), but it reminded me about a book I have read quite a time ago (1979?).
**Manfred Eigen, Ruthild Winkler: "Das Spiel, Naturgesetze steuern den> Zufall" ( ISBN 3-492-02331-2)**
Manfred Eigen is a Nobel-Prize -Winner of 1967 in Chemistry ( for his work about very fast chemical reactions).
In this book several biochemical models are mentioned, which, as it seems, can well be described by cellular automata.
It is mentioned, that a lot of patterns with remarkable behaviour are described by Martin Gardner in "Mathematical Games" , Scientific American, Oct. 1970 and Feb. 1971 (citations given in the aforementioned book).
As I said I am a newby about cellular automata, and so I decided to write a procedure (in Mma 7) which is able to display a "gun", that is a device which emits periodically a glider, and an "eater" , which destroys the arriving glider. See the notebook attached.
First an oscillator and a glider are constructed and displayed, then the gun and eater, and finally both together.
I haven't looked at the behaviour of the system when the the patterns are shifted, but that could be easily done because I have provided a code which allows for translations.
Have a look at it, any comments are welcome.Hans Dolhaine2018-03-13T00:19:34Z