14
$\begingroup$

What is a stable way of creating a set of points that are attracted to a single moving point? I have tried the following:

Manipulate[
 pts = Flatten[Table[{u, t}, {u, -#, #, .25}, {t, -#, #, .25}], 1] &[
   2];
 pl = VectorPlot[{-x, -y} + {Cos[2 Pi a], 
       Sin[2 Pi a]}, {x, -#, #}, {y, -#, #}, VectorPoints -> pts, 
     VectorStyle -> Opacity[1], 
     Epilog -> {Black, PointSize[Medium], Point[pts]}] &[5];
 pl1 = Quiet[
    Part[pl[[1, 1, 2, 1, 3]], Most /@ Position[pl, Arrowheads]]][[1, 
    All, 2, 2, 1, 2]];
 Graphics[{Point /@ pl1, Red, PointSize[.05], 
   Point[{Cos[2 Pi a], Sin[2 Pi a]}]}], {{a, 0}, 0, 2 Pi}]

enter image description here

Ultimate goal is this:

enter image description here

Here is a go in 3D, but is a mess:

Manipulate[
 pl = VectorPlot3D[{-x, -y, -z} + {Cos[2 Pi a], Sin[2 Pi a], 
       0}, {x, -#, #}, {y, -#, #}, {z, -#, #}] &[2];
 pl1 = Quiet[
    Part[pl[[1, 1, 2, 1, 3]], Most /@ Position[pl, Tube]]][[1, All, 3,
     2, 1, 1, 1, 2]];
 Graphics3D[{FaceForm[None], Polygon[#] & /@ Partition[pl1, 8, 1], 
   Red, PointSize[.05], Point[{Cos[2 Pi a], Sin[2 Pi a], 0}]}, 
  ImageSize -> 300], {{a, 0}, 0, 2 Pi}]
$\endgroup$
3
  • 1
    $\begingroup$ This is not a "space-time diagram." (cs.westminstercollege.edu/~ccline/courses/phys301/…) $\endgroup$ Aug 30, 2023 at 17:31
  • $\begingroup$ Just for curiosity's sake, here is the chatbot's take on the matter: chat.openai.com/share/b1d07fd5-b237-4ad2-9dac-ade7a5b66944 $\endgroup$
    – Jason B.
    Aug 30, 2023 at 18:50
  • $\begingroup$ Interesting answer by our soon to be AI overlords: I did the gravity part. The springs are a neat idea and could be added but would complicate the problem from a coding point of view quite a bit. Gravity alone seems to work well on its own for this — if one considers different snap shots and not really movement of the ball. $\endgroup$
    – N0va
    Aug 30, 2023 at 19:30

1 Answer 1

25
$\begingroup$

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]

Blockquote

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]

v2

It is still not terribly efficient with all those NDSolveValue calls but with ParallelTable generating those frames took about 30 seconds on my laptop.

$\endgroup$
2
  • 4
    $\begingroup$ Amazing! :).... $\endgroup$
    – martin
    Aug 30, 2023 at 19:12
  • $\begingroup$ @n0va this is really quite educational, thank you. Please let me know if you are interested in placing this in Staff Picks wolfr.am/StaffPicks You can contact me <[email protected]> $\endgroup$ Sep 15, 2023 at 16:24

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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