12
$\begingroup$

This must be a trivial thing, but I was not able to find a function for it in Mathematica. How do you efficiently create a grid with constant but specific resolution $r$ in all directions on the boundary of $[-1,1]^d$ in arbitrary $d$ dimensions? By that, I mean, for example, for $d=2$ and $r=1/2$ a list with all equidistant points on the edge of the square:

points={{-1, -1}, {-1, 0}, {-1, 1}, {0, -1}, {0, 1}, {1, -1}, {1, 0}, {1, 1}}

2d plot

in $d=3$ and $r=1/2$

points={
 {-1, -1, -1}, {-1, -1, 0}, {-1, -1, 1}, {-1, 0, -1}, {-1, 0, 0}, 
 {-1, 0, 1}, {-1, 1, -1}, {-1, 1, 0}, {-1, 1, 1}, {0, -1, -1}, 
 {0, -1, 0}, {0, -1, 1}, {0, 0, -1}, {0, 0, 1}, {0, 1, -1}, {0, 1, 0}, 
 {0, 1, 1}, {1, -1, -1}, {1, -1, 0}, {1, -1, 1}, {1, 0, -1}, {1, 0, 0}, 
 {1, 0, 1}, {1, 1, -1}, {1, 1, 0}, {1, 1, 1}}

3d plot

At the moment I am doing this for arbitrary dimension $d$ and specified resolution $r$ with Table as follows:

d = 3;
r = 1/2;
(*Create indices*)
ids = Array[id, d];
(*Prepare argument for Table*)
arg = {Permutations[ids], {ids[[1]], {-1, 1}}};
Do[
 AppendTo[arg, {ids[[i]], -1, 1, 2*r}]
 , {i, 2, Length@ids}
 ]
arg;
(*Generate points with Table*)
points = Sort@DeleteDuplicates@Flatten[Table @@ arg, d];
Length@points
(*Plot in 2D and 3D*)
If[d == 2, Graphics@Point@points]
If[d == 3, Graphics3D@Point@points]

but I just wanted to know, if there is already a built-in function or more efficient way to do this. Thanks!

$\endgroup$
8
$\begingroup$

Here's a pretty general solution. This generates the desired boundary lattice points in $[0,1]^d$; apply Rescale[] as needed:

makeGrid[d_Integer?Positive, n_Integer /; n > 1] := 
    Module[{sh = {{0}, {1}}, ins = ArrayPad[Subdivide[n], -1]},
           Do[sh = Insert[Transpose[Outer[Append, 
              CoordinateBoundsArray[ConstantArray[{0, 1}, k], Into[n]], {0, 1}, k]], 
              Unevaluated[Sequence @@ Flatten[Outer[Append, sh, ins, k], {{2}, {1}}]], 2],
              {k, d - 1}]; sh]

Examples:

{Graphics[{AbsolutePointSize[4], Point[Flatten[makeGrid[2, 8], 1]]}, Frame -> True], 
 Graphics3D[Sphere[Flatten[makeGrid[3, 5], 2], 0.01], Axes -> True]} // GraphicsRow

boundary grid points in 2D and 3D

$\endgroup$
9
$\begingroup$

Since version 10.1, there has been a built-in function CoordinateBoundsArray to do this kind of thing. It is readily adapted to your special case.

lattice[d_Integer?Positive, r_?NumericQ] :=
  Flatten[CoordinateBoundsArray[ConstantArray[{-1, 1}, d], r], d - 1]

lattice[2, 1]
{{-1, -1}, {-1, 0}, {-1, 1}, {0, -1}, {0, 0}, {0, 1}, {1, -1}, {1, 0}, {1, 1}}
lattice[3, 1]
{{-1, -1, -1}, {-1, -1, 0}, {-1, -1, 1}, {-1, 0, -1}, {-1, 0, 0}, {-1,0, 1}, 
 {-1, 1, -1}, {-1, 1, 0}, {-1, 1, 1}, {0, -1, -1}, {0, -1, 0}, {0, -1, 1}, 
 {0, 0, -1}, {0, 0, 0}, {0, 0, 1}, {0, 1, -1}, {0, 1,0}, {0, 1, 1}, 
 {1, -1, -1}, {1, -1, 0}, {1, -1, 1}, {1, 0, -1}, {1, 0, 0}, {1, 0, 1}, 
 {1, 1, -1}, {1, 1, 0}, {1, 1, 1}}
$\endgroup$
  • 2
    $\begingroup$ There is still a need to delete the points within the $r$-hypercube, however. $\endgroup$ – J. M. is away May 26 '16 at 15:22
  • 1
    $\begingroup$ @J.M. wrap it in Select[Flatten[CoordinateBoundsArray[ConstantArray[{-1, 1}, d], r], d - 1], Max@Abs@# == 1 &] as I did - it's worth noting that this is considerably faster than my implementation. $\endgroup$ – dr.blochwave May 26 '16 at 16:40
  • $\begingroup$ Presumably there is some sort of optimization going on under the hood. $\endgroup$ – dr.blochwave May 26 '16 at 16:42
  • $\begingroup$ @J.M. I should have stated that my answer is only meant to reproduce the points output the OP showed. $\endgroup$ – m_goldberg May 26 '16 at 23:09
5
$\begingroup$

You could try something like this:

generateGrid[dim_] := DeleteCases[Tuples[{-1, 0, 1}, dim], {0 ..}]

For the case of specifying a resolution as well, try:

generateGrid[dim_, r_] := Select[Tuples[Range[-1, 1, r], dim], Max@Abs[#] == 1 &]
Graphics3D@Point@generateGrid[3, 1/2]

grid

But it won't be very efficient for higher dimensions or fine resolution, due to the use of Tuples[], as mentioned in the comments. This alternative might be better in terms of memory than using Tuples[], although it's not any faster:

generateGrid2[dim_, r_] := Module[{coords, pt},
  coords = Range[-1, 1, r];
  Last@Reap@Do[
     pt = coords[[1 + IntegerDigits[i, Length@coords, dim]]];
     If[Max@Abs[pt] == 1, Sow[pt]], 
    {i, (Length@coords)^dim}]
  ]

You could always compile this to make it even faster, but of course the algorithm complexity remains the same:

generateGridCompile = Compile[{{dim, _Integer}, {r, _Real}},
   Module[{coords, pt, pts, len, i, n = 1},
    coords = Range[-1, 1, r];
    len = Length@coords;
    pts = Table[0., {i, len^dim - 1}, {j, dim}];
    Do[pt = coords[[1 + IntegerDigits[i, len, dim]]];
     If[Max[Abs[pt]] == 1, pts[[n]] = pt; n++];,
     {i, len^dim}];
    pts],
   CompilationTarget -> "C",
   RuntimeOptions -> "Speed"];

performance plot

$\endgroup$
  • 1
    $\begingroup$ ...or DeleteCases[Tuples[{-1, 0, 1}, 3], {0 ..}]. $\endgroup$ – J. M. is away May 26 '16 at 11:27
  • 2
    $\begingroup$ For finer grids and larger dimensions I would expect this to slow down as Tuples will be making many more elements than are required. Is this likely to be the case? I'd be interested to find a more efficient alternative. (Although I do admit Tuples was my first port of call!) $\endgroup$ – Quantum_Oli May 26 '16 at 11:41
  • $\begingroup$ Thanks. But what about the resolution to be specified? But I think this is my fault, I should have been more specific, sorry :D $\endgroup$ – Mauricio Fernández May 26 '16 at 11:54
  • $\begingroup$ @MauricioLobos I've added that, but as I mention you may run into problems with high dimensions or fine resolutions. $\endgroup$ – dr.blochwave May 26 '16 at 12:21

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.