38

DynamicModule[{t = 0, d = 5, a = .08, base, distortion, pts, r, f, n = 10}, r[y_] := .08 y^4; f[x_] := -2 Pi Dynamic[t] + d x; (*f does not evaluate to a number but FE will take care of that later*) base = Array[List, n {3, 1}, {{0, Pi}, {0, 1}} ]; distortion = Array[ Function[{x, y}, r[y] {Cos @ f @ x, Sin @ f @ x}], n {3, 1}, {{0, Pi}, {0, 1}} ...


16

Here is a very crude first implementation (code at the bottom): (note that the updated version is called as `dragDropList[Dynamic@l) Some notes: The black box serves both as insertion marker and as spacer to move the other items out of the way - obviously, it will need some better styling I'm not sure what the best size for the insertion point is - one ...


12

Update 2 Per request, I extended this to handle arbitrary sizes and rotations. It was a huge hassle to figure out how to get the appropriate permutations for the individual rotations for arbitrary sized cubes, but it worked out. Here's what it looks like: r1 = RubiksCube["Size" -> 4]; r1@"Colors" = ColorData["Atoms"] /@ {6, 7, 8, 9, 11, 13, 18}; r1@"...


12

I made a similar animation once with plusses: I changed the shape of the plus to a square. Here is the code: \[CurlyPhi] = Tan[1/3.]; Clear[DrawPlus, MakeScene] DrawPlus[p : {x_, y_}, \[Theta]_] := Module[{line}, (*line=Polygon[{{1,1},{3,1},{3,-1},{1,-1},{1,-3},{-1,-3},{-1,-1},{-3,-\ 1},{-3,1},{-1,1},{-1,3},{1,3},{1,1}}];*) line = Polygon[{{3, 1}, {1, -...


11

This is, as J.M. pointed out, a trochoidal wave. I'm going to provide an implementation based on this. This is slightly different compared to what Kuba did. The advantage is that this parametrization makes it easy to decide the wavelength, wave height, propagation speed and more. It even lets you account for gravity to get realistic waves (trochoidal waves ...


11

This almost, but not quite, matches the requested figure. square = {{0, 0}, {1, 0}, {1, 1}, {0, 1}}; n = 5; redlattice = Flatten[Table[{x, y}, {y, -n + 1, n}, {x, -n + 1, n}], 1]; greenlattice = Flatten[Table[{x, y}, {y, -n + 1, n - 1}, {x, -n + 1, n - 1}], 1]; Manipulate[ redsquares = RotationTransform[θ + π/2, #]@square & /@ redlattice; temp = ...


11

s[x_, y_] := y/Sqrt[x^2 + y^2]; star = RegionPlot3D[ x^2 + y^2 <= (1 - 3 z^2) (3 + 1.3 (1 - 3 z^2) (5 s[x, y] - 20 s[x, y]^3 + 16 s[x, y]^5)) && Abs[z] <= 1, {x, -2.2, 2.2}, {y, -2, 2.4}, {z, -2, 2}, PlotPoints -> 80, PlotStyle -> Directive[Yellow], Mesh -> None, Axes -> False, Boxed -> False, ViewPoint -&...


11

Two things come to mind: Use Translate to create the cells instead of generating (very) long lists of graphics primitives. Use Animate instead of ListAnimate so that when you add more frames, there won't be any cost for that upfront. It will always only have one frame in memory. If it gets to the point where generating a frame is too slow to be done on the ...


10

Making the GIF I'm bored so let me GIF this up for you. I whipped out my trusty lasoo tool to make a no-background doge for you. The final result looks like this: Here's how we use a variant of that IFS to make the frames of that GIF. fadeFrame[sides_: 20, bottom_: 40] := ImageEffect[ ImageEffect[#, {"FadedFrame", sides, {Left, Right}}], {"...


10

You can use ParametricPlot3D to get smoother orbits: SeedRandom[1] n = 50; seeds = RandomReal[{-1, 1}, {n, 3}]; tbar = 10; Animate[ParametricPlot3D[Evaluate[func[seeds[[#]], t] & /@ Range[Length@seeds]], {t, 0, tmax}, BoxRatios -> 1, PlotStyle -> Arrowheads[Medium], ImageSize -> 400, PlotRange -> {{-60, 60}, {-1, 1}, {-...


10

Extending @ MelaGo answer...in spirit of OP...but needs improvement: square = {{0, 0}, {1, 0}, {1, 1}, {0, 1}}; f[j_, k_] := Table[{u, k}, {u, -j, j}]; top[n_] := Join @@ (f @@@ Table[{n - j, j}, {j, 0, n}]); bot[n_] := Join @@ (f @@@ Table[{n - j, -j}, {j, 1, n}]); full[n_] := Join[top[n], bot[n]]; funr[p_] := RegionCentroid[Polygon[RotationTransform[Pi/2,...


10

I once approached this. I never finished it so let me know if you face any issues: ResourceFunction["GitHubInstall"]["kubapod", "mgui"] << MGUI` And here is an example: DynamicModule[{ labels = Range[7] } , labels[[1]] = Style[1, "Section"] ; Grid[{ { "Default", "ContinuousAction", "", "ref"} , { MSorter[Dynamic@labels] , MSorter[...


9

Not exactly what was asked, but another way to visualize the flow, based on How can I create a fountain effect?: DynamicModule[ {x0, y0, z0, last = 0, lam = 1.5, n = 500, colors, replace}, last = Clock[Infinity]; {x0, y0, z0} = RandomReal[{-1, 1}, {3, n}]; colors = RandomColor[n]; Graphics3D[GraphicsComplex[ Dynamic@ With[{t = Clock[Infinity]}, ...


9

This is one way of doing it to get you started: ListAnimate@Table[ Plot[ Cos[x], {x, 0, xmax}, PlotRange -> {{0, 2 \[Pi]}, {-1, 1}} ], {xmax, 2 \[Pi]/20, 2 \[Pi], 2 \[Pi]/20} ]


9

I modified the SHuisman's code a bit. It turned out to be almost a complete match with the required animation. \[CurlyPhi] = Tan[1/3.]; Clear[DrawPlus, MakeScene] DrawPlus[p : {x_, y_}, \[Theta]_] := Module[{line}, line = Polygon[{{3, 1}, {1, -3}, {-3, -1}, {-1, 3}}]; line = GeometricTransformation[line, RotationMatrix[\[Theta]]]; ...


9

ClearAll[f1, f2] f1[t_] := Sin[t]; f2[t_] := Sin[3 t]; Animate[ParametricPlot3D[{{t, f1[t], 0}, {t, 0, f2[t]}, {t, 0, 0}}, {t, 0, tmax}, PlotStyle -> {Red, Green, Gray}, PlotRange -> {{0, 3 Pi}, {-1, 1}, {-1, 1}}, ViewPoint -> {2.5, -1.3, 2}], {tmax, .1, 3 Pi}] frames = Table[ParametricPlot3D[{{t, f1[t], 0}, {t, 0, f2[t]}, {t, 0, 0}}, {t,...


8

I would use Manipulate as it is just like Animate but more flexible. Manipulate[ Module[{t}, ParametricPlot3D[{Cos[Sqrt[2] t] (3 + Cos[t]), Sin[Sqrt[2] t] (3 + Cos[t]), Sin[t]}, {t, 0, maxTime}, ImageSize -> 300, PlotRange -> {{-4, 4}, {-4, 4}, {-1, 1}}, PlotStyle -> Red] ] , {{maxTime, 1, "time"}, 1, 50, 0.01, Appearance -&...


8

pts = {{0, 0}, {1, 0}, {1, 1}, {0, 1}}; ClearAll[p, nextpt, redsquares, greensquares] nextpt = AssociationThread[pts, RotateRight[pts]]; p[m_] := Tuples[{SparseArray[DiamondMatrix[m - 1]]["NonzeroPositions"] - m, pts}] redsquares[t_, m_] := Rotate[Rectangle[], t + Pi/2, #] & /@ DeleteDuplicates[Total /@ p[m]] greensquares[t_, m_] := Translate[...


8

Trying to do this with plots may end up being very difficult. I tend to use the plot as a base and then add ancillary graphics around it, e.g. with Show: With[{center = {-1.5, 0}, radius = 1}, Animate[ Show[ Plot[ Sin[omega + phi], {omega, 0, 2 Pi}, Ticks -> None, AspectRatio -> Automatic, AxesOrigin -> {0, 0}, PlotStyle -&...


7

I didn't bother generating the nested fractal still since I don't have the original image. But here's how to semi-eyeball an animation with the still provided by OP. Because of this, my GIF will lose noticeable quality as it zooms. First let's remove the watermark: doge = RemoveAlphaChannel[Import["https://i.stack.imgur.com/PGfAi.jpg"]]; mask = Dilation[...


7

ImageAlign should probably be at least part of the solution: img = Import["https://i.stack.imgur.com/pc6ul.png"]; {xdim, ydim} = ImageDimensions[img]; images = Flatten@ImagePartition[img, {xdim/4, ydim/4}]; aligned = ImageAlign[images]; ListAnimate[aligned] Here is an attempt to make it more robust and to prevent it from clipping parts of the figure off at ...


7

Animate[ListLinePlot[T2, Epilog -> {PointSize[Large], Red, Point @ T2[[t]]}], {t, 1, Length @ T2, 1}] Alternatively, Animate[ListLinePlot[T2, Mesh -> {{t}}, MeshFunctions -> {# &}, MeshStyle -> Directive[PointSize[Large], Red]], {t, T2[[All, 1]]}] same picture


6

If there are no restrictions on r, x, then the solution is eq = {x''[t] == -k*(x[t] - r[t]*Cos[theta]), r''[t] == -k*(r[t] - x[t]*Cos[theta])}; theta = Pi/4; k = 1; ic = {x[0] == 1, r[0] == 0, x'[0] == 0, r'[0] == 0}; sol = NDSolve[{eq, ic}, {x, r}, {t, 0, 20}] lst = Table[ Graphics[{{Line[{{-1, 0}, {1, 0}}], Line[{{-Cos[theta], -Sin[theta]},...


6

A real doge: His Serenity Leonardo Loredan, the 75th Doge of Venice, with due credit to Bellini and Chip Hurst: im = Import[ "https://upload.wikimedia.org/wikipedia/commons/6/6b/Giovanni_Bellini%2C_portrait_of_Doge_Leonardo_Loredan.jpg"]; doge0 = ImageTake[im, {140, 4226 - 500}]; ctr = {1893, 3345}; doge = ImageCompose[doge0, ImageResize[doge0, ...


6

What I’ve done in the past is something like anim = Table[f[t], {t, 0, 2Pi, 0.01}] and then Export[“anim.gif”, anim, ImageResolution -> 300, “DisplayDurations” -> listOfTimes], where listOfTimes is generated so that most frames have the same display duration, but the frames of interest have a much longer display duration.


6

tlist = Range[0, 2 Pi, 2 Pi/180]; pauseat = {Pi/2, 2 Pi/3, Pi, 7 Pi/6, 3 Pi/2}; pausepos = Nearest[tlist -> Automatic, #] & /@ pauseat; reps = 10; tlist2 = Flatten[MapAt[ConstantArray[#, reps] &, tlist, pausepos]]; You can use tlist2 in Animate iterator: Animate[f[t], {t, tlist2}, DisplayAllSteps -> True] or to generate a table of frames to ...


6

I need to help with animated plot of falling body: I get this nostalgic feeling that I've seen similar question before in this forum. But one possible way to do this, is to just write the solution of the ODE directly in Manipulate, and then adjust the solution based on sliders. Something like the following Manipulate[ Module[{sol, k0, m0, v0, g = 9.81},...


6

Mathematica is great for Physics and simulation. One way is to use Manipulate which makes things very easy Manipulate[ ParametricPlot3D[{r Cos[w t], r Sin[w t], v t}, {t, 0, maxTime}, PlotRange -> {{-10, 10}, {-10, 10}, {0, 100}}, PerformanceGoal -> "Quality", PlotStyle -> Red], {{r, 6, "r?"}, 0.01, 10, 0.01, Appearance -> "Labeled", ...


5

You call f and g with two arguments, but they are only defined for a single argument. After fixing several typos, this seems to work: f[x_, a_] := x^2 - a x + 20 + a; g[x_, b_] := -x^2 + b x + b; Manipulate[ Plot[Evaluate[{f[x, a], g[x, b]}], {x, 0, 15}], {a, 10, 15}, {b, 10, 15} ]


5

You can use NDSolveValue and Animate: ClearAll[x1, x2, y1, y2] ndsv = NDSolveValue[{x1'[t] == -x1[t] + x2[t], y1'[t] == -y1[t] + y2[t], x2'[t] == x1[t] - x2[t], y2'[t] == y1[t] - y2[t], x1[0] == -5, x2[0] == -7, y1[0] == -5, y2[0] == 7}, {x1, x2, y1, y2}, {t, 0, 20}, "ExtrapolationHandler" -> {Undefined &, "...


Only top voted, non community-wiki answers of a minimum length are eligible