Here my physicist approach to the problem: I consider a cloud/grid of test-particles which get attracted to a reference point by a force. In the following I assume attraction by gravity -- i.e. the force on the test-particle is in line with its distance vector to the reference point and the strength of this force is inverse proportional to the distance squared. For each particle I solve the equations of motion to get the deformation/deflection after a given time. Here a rough first version
getDeflection[x0_, a0_, tend_] := Module[{eqs, x, t, r, t1, d},
r = Norm[x0 - a0];
If[r < 0.01, Return[x0]];
t1 = tend;
d = NDSolveValue[{x''[t] == -1/x[t]^2, x'[0] == 0, x[0] == r,
WhenEvent[x[t] < 0.01, t1 = t; "StopIntegration"]},
x, {t, 0, tend}][t1];
x0 - (r - d)/r (x0 - a0)
]
drawCube[a0_, tend_] := Module[{dat, lines},
dat = Table[
getDeflection[{i, j, k}, a0, tend], {i, -3, 3, 1}, {j, -3, 3,
1}, {k, -3, 3, 1}];
lines =
Table[{Line[#] & /@ dat[[All, All, i]],
Line[#] & /@ dat[[All, i, All]], Line[#] & /@ dat[[All, All, i]],
Line[#] & /@ Transpose[dat][[All, All, i]],
Line[#] & /@ Transpose[dat][[All, i, All]],
Line[#] & /@ Transpose[dat][[All, All, i]]}, {i, 1, 7}];
Graphics3D[{lines, Sphere[a0, 1/4]}]
]
imgs = Table[drawCube[{Sin[x], Cos[x], 0}, 4], {x, 0, 2 \[Pi], \[Pi]/8}]
ListAnimate[imgs]
So this works reasonably well but the drawing of the wire-frame could be improved by adding intermediate points. Coloring on the lines of the wire-frame could be archived quite easily based on deformation -- especially if one adds a few intermediate points. One could parallelize the code (computations of the deflection of the points) to speed if up. The strength of the deformation can be adjusted by changing the maximum integration time tend or by changing the underlying interaction. Approximating or analytically solving for the deformation would speed this up quite a bit I suppose but I am too lazy to look into that right now.
EDIT:
I found some time today to improve on some aspects of the implementation: I added subdivision of lines, parallelisation and color. getDeflection remains unchanged and with the two new functions
generateCube[dat_, subdivision_ : 2] := Module[{lines},
lines =
Table[{Line[#] & /@ dat[[All, All, i]],
Line[#] & /@ dat[[All, i, All]], Line[#] & /@ dat[[All, All, i]],
Line[#] & /@ Transpose[dat][[All, All, i]],
Line[#] & /@ Transpose[dat][[All, i, All]],
Line[#] & /@ Transpose[dat][[All, All, i]]}, {i, 1, Length[dat]}];
lines =
lines /.
Line[x_List] :>
MapThread[Line[{#1, #2}] &, {x[[;; -2]], x[[2 ;;]]}];
lines /.
Line[{a_, b_}] :>
With[{ab = Subdivide[a, b, subdivision]},
MapThread[Line[{#1, #2}] &, {ab[[;; -2]], ab[[2 ;;]]}]]
]
deformCube[lines_, a0_, tend_, f_, opts___] := Module[{pts, linesNew},
pts = DeleteDuplicates[
Flatten[Flatten[lines] /. Line[{a_, b_}] :> {a, b}, 1]];
pts = ParallelTable[x -> getDeflection[x, a0, tend], {x, pts},
DistributedContexts -> All, Method -> "FinestGrained"];
linesNew =
lines /.
Line[{a_, b_}] :>
With[{an = a /. pts, bn = b /. pts}, {Thick,
ColorData["DarkRainbow"][f*(Norm[a - an] + Norm[b - bn])],
Line[{an, bn}]}];
Graphics3D[{{White, Sphere[a0, 0.1]}, linesNew}, opts]
]
One can generate an animation close to the reference with
Table[{i, j, k}, {i, Subdivide[-1, 1, 3]}, {j,
Subdivide[-1, 1, 3]}, {k, Subdivide[-1, 1, 3]}];
cube = generateCube[%, 10];
imgs = Table[
deformCube[cube, 2/3*{Sin[x], Cos[x], 0}, 0.3, 1.8, Boxed -> False,
Background -> Black, Lighting -> "Neutral",
ViewPoint -> {2, 2, 1}], {x, 0, 2 \[Pi], \[Pi]/8}];
ListAnimate[imgs]
It is still not terribly efficient with all those NDSolveValue calls but with ParallelTable generating those frames took about 30 seconds on my laptop.
