Representing a Stencil of a Finite Difference Operator with Mathematica's Graphics3D
Take it in steps:
Extract the coefficients and locations into an appropriate data structure.
Use that data structure to create the graphics.
By examining the FullForm
of the original expression, we can cobble a rule to find the key data: the coefficients $c$, $d$, and $-1$ and the offsets to the indexes. First, the expression itself:
s = Subscript;
exp = d s[u, i, j, k] +
c (s[u, i - 1, j, k] + s[u, i + 1, j, k] + s[u, i, j - 1, k] +
s[u, i, j + 1, k] + s[u, i, j, k - 1] + s[u, i, j, k + 1]) -
s[u, i - 1, j + 1, k] - s[u, i - 1, j - 1, k] - s[u, i - 1, j, k - 1] - s[u, i - 1, j, k + 1] -
s[u, i + 1, j + 1, k] - s[u, i + 1, j - 1, k] - s[u, i + 1, j, k - 1] - s[u, i + 1, j, k + 1] -
s[u, i, j + 1, k - 1] - s[u, i, j - 1, k - 1] -
s[u, i, j + 1, k + 1] - s[u, i, j - 1, k + 1]
Expand
pairs the coefficients with the subscripts and Cases
extracts the essential information:
data = Cases[Expand@exp, Times[c_, s[u, i_, j_, k_]] :> {c, i, j, k}];
data // MatrixForm
$$\left( \begin{array}{cccc} -1 & -1+i & -1+j & k \\ -1 & -1+i & j & -1+k \\ c & -1+i & j & k \\ \cdots \\ -1 & 1+i & 1+j & k \end{array} \right)$$
We are really interested in the offsets to the central index $(i,j,k)$, so one more step to extract them (via Replace
this time) will be helpful. After doing it, let's group the offsets by common coefficient using GatherBy
:
spec = GatherBy[{First@#,
Replace[Rest@#, {Plus[x_?NumberQ, i_] -> x, x_Symbol -> 0}, 1]} & /@ data, First]
To illustrate, here is what the first few elements of the first entry in spec
look like:
$$\left( \begin{array}{cc} -1 & \{-1,-1,0\} \\ -1 & \{-1,0,-1\} \\ -1 & \{-1,0,1\} \\ \cdots \\ -1 & \{1,1,0\} \end{array} \right)$$
(You might be happier just entering the data in this format, or something close to it, at the outset: it's easier than entering all those subscripts.)
Choose some colors:
colors = Array[Hue[# / Length@spec, .8, .8] &, Length@spec];
The rest is easy. Let's make sure to include some visual cues such as thin lines connecting the base point to its neighbors, for otherwise this will look only like a random jumble of balls.
Graphics3D[ {
Table[{Specularity[White, 10],
GrayLevel[0.7], Tube[{{0, 0, 0}, Last@#}, 0.025] & /@ spec[[i]],
colors[[i]], Sphere[Last@#, .2] & /@ spec[[i]]}, {i, 1, Length@spec}]},
Boxed -> False, Axes -> True, AxesLabel -> {"i", "j", "k"} ]
(I leave the creation of a color key as an exercise :-).)
Although you haven't exactly asked this, you might like to generate your graphic automatically by applying pattern matching on your difference operator. The basic idea is as below:
Clear[i, j, k];
op = Plus @@
MapThread[Subscript[u, i - #1, j - #2, k - #3] &,
RotateRight[{0, -1, 1, 0, 0, 0, 0}, #] & /@ {0, 2, 4}]
Giving $op = u_{i-1,j,k}+u_{i,j-1,k}+u_{i,j,k-1}+u_{i,j,k}+u_{i,j,k+1}+u_{i,j+1,k}+u_{i+1,j,k}$
Graphics3D[
Level[op /.
Subscript[_, i_, j_, k_] :> Sphere[{i, j, k}, .1] /. {i -> 0,
j -> 0, k -> 0}, {-3}] /. {s : Sphere[{0, 0, 0}, _] :>
Sequence[Red, s], s_Sphere :> Sequence[Blue, s]}, Axes -> True]
Disclaimer: I'm a fairly new and rather unsophisticated Mathematica user, so my code is probably crap and likely to break if you breathe on it too hard, but anyway, there you have it.
Not sure if this is what you're after. Anyway:
r = .1;
Graphics3D[{Specularity[White, 10],
Red, Sphere[{0, 0, 0}, r],
Blue, Sphere[{0, 0, 1}, r], Sphere[{1, 0, 0}, r], Sphere[{-1, 0, 0}, r],
Sphere[{0, -1, 0}, r], Sphere[{0, 0, -1}, r],
Green, Sphere[{1, 1, 0}, r], Sphere[{1, 0, 1}, r]}, Boxed -> False,
Axes -> True]